Skip to content

Commit 24135e0

Browse files
rhendricrhendric
committed
Support local type synonyms natively
1 parent d5ce655 commit 24135e0

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

42 files changed

+664
-77
lines changed

‎lib/purescript-cst/src/Language/PureScript/CST/Convert.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -224,6 +224,16 @@ convertLetBinding fileName = \case
224224
binding@(LetBindingPattern _ a _ b) -> do
225225
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
226226
AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b)
227+
binding@(LetBindingType _ (DataHead _ a vars) _ bd) -> do
228+
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
229+
AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd)
230+
binding@(LetBindingKindSignature _ _ (Labeled name _ ty)) -> do
231+
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
232+
AST.KindDeclaration ann AST.TypeSynonymSig (nameValue name) $ convertType fileName ty
233+
where
234+
goTypeVar = \case
235+
TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y)
236+
TypeVarName x -> (getIdent $ nameValue x, Nothing)
227237

228238
convertExpr :: forall a. String -> Expr a -> AST.Expr
229239
convertExpr fileName = go

‎lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -164,6 +164,8 @@ flattenLetBinding = \case
164164
LetBindingSignature _ a -> flattenLabeled flattenName flattenType a
165165
LetBindingName _ a -> flattenValueBindingFields a
166166
LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c
167+
LetBindingType _ a b c -> flattenDataHead a <> pure b <> flattenType c
168+
LetBindingKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b
167169

168170
flattenWhere :: Where a -> DList SourceToken
169171
flattenWhere (Where a b) =

‎lib/purescript-cst/src/Language/PureScript/CST/Parser.y‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -457,6 +457,8 @@ letBinding :: { LetBinding () }
457457
| ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) }
458458
| ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }
459459
| binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }
460+
| typeHead '=' type {% checkNoWildcards $3 *> pure (LetBindingType () $1 $2 $3) }
461+
| 'type' properName '::' type {% checkNoWildcards $4 *> pure (LetBindingKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }
460462
461463
caseBranch :: { (Separated (Binder ()), Guarded ()) }
462464
: sep(binder1, ',') guardedCase { ($1, $2) }

‎lib/purescript-cst/src/Language/PureScript/CST/Positions.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -307,6 +307,8 @@ letBindingRange = \case
307307
LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
308308
LetBindingName _ a -> valueBindingFieldsRange a
309309
LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
310+
LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
311+
LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)
310312

311313
doStatementRange :: DoStatement a -> TokenRange
312314
doStatementRange = \case

‎lib/purescript-cst/src/Language/PureScript/CST/Types.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -402,6 +402,8 @@ data LetBinding a
402402
= LetBindingSignature a (Labeled (Name Ident) (Type a))
403403
| LetBindingName a (ValueBindingFields a)
404404
| LetBindingPattern a (Binder a) SourceToken (Where a)
405+
| LetBindingType a (DataHead a) SourceToken (Type a)
406+
| LetBindingKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))
405407
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
406408

407409
data DoBlock a = DoBlock

‎src/Language/PureScript/Pretty/Values.hs‎

Lines changed: 9 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import Prelude.Compat hiding ((<>))
1111

1212
import Control.Arrow (second)
1313

14-
import Data.Maybe (maybe)
14+
import Data.Maybe (mapMaybe, maybe)
1515
import Data.Text (Text)
1616
import qualified Data.List.NonEmpty as NEL
1717
import qualified Data.Monoid as Monoid ((<>))
@@ -77,10 +77,10 @@ prettyPrintValue d (Case values binders) =
7777
prettyPrintValue d (Let FromWhere ds val) =
7878
prettyPrintValue (d - 1) val //
7979
moveRight 2 (text "where" //
80-
vcat left (map (prettyPrintDeclaration (d - 1)) ds))
80+
vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds))
8181
prettyPrintValue d (Let FromLet ds val) =
8282
text "let" //
83-
moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //
83+
moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds)) //
8484
(text "in " <> prettyPrintValue (d - 1) val)
8585
prettyPrintValue d (Do m els) =
8686
textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
@@ -142,6 +142,11 @@ prettyPrintDeclaration d (BindingGroupDeclaration ds) =
142142
toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e]
143143
prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"
144144

145+
prettyPrintDeclaration' :: Int -> Declaration -> Maybe Box
146+
prettyPrintDeclaration' _ KindDeclaration{} = Nothing
147+
prettyPrintDeclaration' _ TypeSynonymDeclaration{} = Nothing
148+
prettyPrintDeclaration' d decl = Just $ prettyPrintDeclaration d decl
149+
145150
prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box
146151
prettyPrintCaseAlternative d _ | d < 0 = ellipsis
147152
prettyPrintCaseAlternative d (CaseAlternative binders result) =
@@ -187,7 +192,7 @@ prettyPrintDoNotationElement d (DoNotationBind binder val) =
187192
textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val
188193
prettyPrintDoNotationElement d (DoNotationLet ds) =
189194
text "let" //
190-
moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))
195+
moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds))
191196
prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el
192197

193198
prettyPrintBinderAtom :: Binder -> Text

‎src/Language/PureScript/Sugar/BindingGroups.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -155,6 +155,7 @@ usedTypeNames moduleName = go
155155

156156
usedNames :: SourceType -> [ProperName 'TypeName]
157157
usedNames (ConstrainedType _ con _) = usedConstraint con
158+
usedNames (TypeConstructor _ (Qualified Nothing name)) = [name]
158159
usedNames (TypeConstructor _ (Qualified (Just moduleName') name))
159160
| moduleName == moduleName' = [name]
160161
usedNames _ = []

‎src/Language/PureScript/Sugar/Names.hs‎

Lines changed: 55 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ import Control.Monad.Error.Class (MonadError(..))
1919
import Control.Monad.State.Lazy
2020
import Control.Monad.Writer (MonadWriter(..))
2121

22-
import Data.Maybe (fromMaybe, mapMaybe)
22+
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
2323
import qualified Data.Map as M
2424
import qualified Data.Set as S
2525

@@ -35,6 +35,11 @@ import Language.PureScript.Sugar.Names.Imports
3535
import Language.PureScript.Traversals
3636
import Language.PureScript.Types
3737

38+
data BoundNames = BoundNames
39+
{ boundValues :: [Ident]
40+
, boundTypes :: [ProperName 'TypeName]
41+
}
42+
3843
-- |
3944
-- Replaces all local names with qualified names within a list of modules. The
4045
-- modules should be topologically sorted beforehand.
@@ -187,57 +192,57 @@ renameInModule imports (Module modSS coms mn decls exps) =
187192

188193
(go, _, _, _, _) =
189194
everywhereWithContextOnValuesM
190-
(modSS, [])
195+
(modSS, BoundNames [] [])
191196
(\(_, bound) d -> (\(bound', d') -> ((declSourceSpan d', bound'), d')) <$> updateDecl bound d)
192197
updateValue
193198
updateBinder
194199
updateCase
195200
defS
196201

197202
updateDecl
198-
:: [Ident]
203+
:: BoundNames
199204
-> Declaration
200-
-> m ([Ident], Declaration)
205+
-> m (BoundNames, Declaration)
201206
updateDecl bound (DataDeclaration sa dtype name args dctors) =
202207
fmap (bound,) $
203208
DataDeclaration sa dtype name
204-
<$> updateTypeArguments args
205-
<*> traverse (traverseDataCtorFields (traverse (sndM updateTypesEverywhere))) dctors
209+
<$> updateTypeArguments bound args
210+
<*> traverse (traverseDataCtorFields (traverse (sndM (updateTypesEverywhere bound)))) dctors
206211
updateDecl bound (TypeSynonymDeclaration sa name ps ty) =
207-
fmap (bound,) $
212+
fmap (bound{ boundTypes = name : boundTypes bound },) $
208213
TypeSynonymDeclaration sa name
209-
<$> updateTypeArguments ps
210-
<*> updateTypesEverywhere ty
214+
<$> updateTypeArguments bound ps
215+
<*> updateTypesEverywhere bound ty
211216
updateDecl bound (TypeClassDeclaration sa@(ss, _) className args implies deps ds) =
212217
fmap (bound,) $
213218
TypeClassDeclaration sa className
214-
<$> updateTypeArguments args
215-
<*> updateConstraints ss implies
219+
<$> updateTypeArguments bound args
220+
<*> updateConstraints bound ss implies
216221
<*> pure deps
217222
<*> pure ds
218223
updateDecl bound (TypeInstanceDeclaration sa@(ss, _) ch idx name cs cn ts ds) =
219224
fmap (bound,) $
220225
TypeInstanceDeclaration sa ch idx name
221-
<$> updateConstraints ss cs
226+
<$> updateConstraints bound ss cs
222227
<*> updateClassName cn ss
223-
<*> traverse updateTypesEverywhere ts
228+
<*> traverse (updateTypesEverywhere bound) ts
224229
<*> pure ds
225230
updateDecl bound (KindDeclaration sa kindFor name ty) =
226231
fmap (bound,) $
227232
KindDeclaration sa kindFor name
228-
<$> updateTypesEverywhere ty
233+
<$> updateTypesEverywhere bound ty
229234
updateDecl bound (TypeDeclaration (TypeDeclarationData sa name ty)) =
230235
fmap (bound,) $
231236
TypeDeclaration . TypeDeclarationData sa name
232-
<$> updateTypesEverywhere ty
237+
<$> updateTypesEverywhere bound ty
233238
updateDecl bound (ExternDeclaration sa name ty) =
234-
fmap (name : bound,) $
239+
fmap (bound{ boundValues = name : boundValues bound },) $
235240
ExternDeclaration sa name
236-
<$> updateTypesEverywhere ty
241+
<$> updateTypesEverywhere bound ty
237242
updateDecl bound (ExternDataDeclaration sa name ki) =
238243
fmap (bound,) $
239244
ExternDataDeclaration sa name
240-
<$> updateTypesEverywhere ki
245+
<$> updateTypesEverywhere bound ki
241246
updateDecl bound (TypeFixityDeclaration sa@(ss, _) fixity alias op) =
242247
fmap (bound,) $
243248
TypeFixityDeclaration sa fixity
@@ -257,52 +262,53 @@ renameInModule imports (Module modSS coms mn decls exps) =
257262
return (b, d)
258263

259264
updateValue
260-
:: (SourceSpan, [Ident])
265+
:: (SourceSpan, BoundNames)
261266
-> Expr
262-
-> m ((SourceSpan, [Ident]), Expr)
267+
-> m ((SourceSpan, BoundNames), Expr)
263268
updateValue (_, bound) v@(PositionedValue pos' _ _) =
264269
return ((pos', bound), v)
265270
updateValue (pos, bound) (Abs (VarBinder ss arg) val') =
266-
return ((pos, arg : bound), Abs (VarBinder ss arg) val')
271+
return ((pos, bound{ boundValues = arg : boundValues bound }), Abs (VarBinder ss arg) val')
267272
updateValue (pos, bound) (Let w ds val') = do
268273
let args = mapMaybe letBoundVariable ds
274+
let syns = mapMaybe letBoundTypeSynonym ds
269275
unless (length (ordNub args) == length args) .
270276
throwError . errorMessage' pos $ OverlappingNamesInLet
271-
return ((pos, args ++ bound), Let w ds val')
272-
updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` bound =
277+
return ((pos, bound{ boundValues = args ++ boundValues bound, boundTypes = syns ++ boundTypes bound }), Let w ds val')
278+
updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` boundValues bound =
273279
(,) (ss, bound) <$> (Var ss <$> updateValueName name' ss)
274280
updateValue (_, bound) (Var ss name'@(Qualified (Just _) _)) =
275281
(,) (ss, bound) <$> (Var ss <$> updateValueName name' ss)
276282
updateValue (_, bound) (Op ss op) =
277283
(,) (ss, bound) <$> (Op ss <$> updateValueOpName op ss)
278284
updateValue (_, bound) (Constructor ss name) =
279285
(,) (ss, bound) <$> (Constructor ss <$> updateDataConstructorName name ss)
280-
updateValue s (TypedValue check val ty) =
281-
(,) s <$> (TypedValue check val <$> updateTypesEverywhere ty)
286+
updateValue s@(_, bound) (TypedValue check val ty) =
287+
(,) s <$> (TypedValue check val <$> updateTypesEverywhere bound ty)
282288
updateValue s v = return (s, v)
283289

284290
updateBinder
285-
:: (SourceSpan, [Ident])
291+
:: (SourceSpan, BoundNames)
286292
-> Binder
287-
-> m ((SourceSpan, [Ident]), Binder)
293+
-> m ((SourceSpan, BoundNames), Binder)
288294
updateBinder (_, bound) v@(PositionedBinder pos _ _) =
289295
return ((pos, bound), v)
290296
updateBinder (_, bound) (ConstructorBinder ss name b) =
291297
(,) (ss, bound) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b)
292298
updateBinder (_, bound) (OpBinder ss op) =
293299
(,) (ss, bound) <$> (OpBinder ss <$> updateValueOpName op ss)
294-
updateBinder s (TypedBinder t b) = do
295-
t' <- updateTypesEverywhere t
300+
updateBinder s@(_, bound) (TypedBinder t b) = do
301+
t' <- updateTypesEverywhere bound t
296302
return (s, TypedBinder t' b)
297303
updateBinder s v =
298304
return (s, v)
299305

300306
updateCase
301-
:: (SourceSpan, [Ident])
307+
:: (SourceSpan, BoundNames)
302308
-> CaseAlternative
303-
-> m ((SourceSpan, [Ident]), CaseAlternative)
309+
-> m ((SourceSpan, BoundNames), CaseAlternative)
304310
updateCase (pos, bound) c@(CaseAlternative bs gs) =
305-
return ((pos, concatMap binderNames bs ++ updateGuard gs ++ bound), c)
311+
return ((pos, bound{ boundValues = concatMap binderNames bs ++ updateGuard gs ++ boundValues bound }), c)
306312
where
307313
updateGuard :: [GuardedExpr] -> [Ident]
308314
updateGuard [] = []
@@ -315,29 +321,37 @@ renameInModule imports (Module modSS coms mn decls exps) =
315321
letBoundVariable :: Declaration -> Maybe Ident
316322
letBoundVariable = fmap valdeclIdent . getValueDeclaration
317323

324+
letBoundTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)
325+
letBoundTypeSynonym (TypeSynonymDeclaration _ name _ _) = Just name
326+
letBoundTypeSynonym _ = Nothing
327+
318328
updateTypeArguments
319329
:: (Traversable f, Traversable g)
320-
=> f (a, g SourceType) -> m (f (a, g SourceType))
321-
updateTypeArguments = traverse (sndM (traverse updateTypesEverywhere))
330+
=> BoundNames -> f (a, g SourceType) -> m (f (a, g SourceType))
331+
updateTypeArguments bound = traverse (sndM (traverse (updateTypesEverywhere bound)))
322332

323-
updateTypesEverywhere :: SourceType -> m SourceType
324-
updateTypesEverywhere = everywhereOnTypesM updateType
333+
updateTypesEverywhere :: BoundNames -> SourceType -> m SourceType
334+
updateTypesEverywhere bound = everywhereOnTypesM updateType
325335
where
326336
updateType :: SourceType -> m SourceType
327337
updateType (TypeOp ann@(ss, _) name) = TypeOp ann <$> updateTypeOpName name ss
328-
updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateTypeName name ss
338+
updateType (TypeConstructor ann@(ss, _) qname@(Qualified mn' name)) =
339+
TypeConstructor ann <$>
340+
if isNothing mn' && name `elem` boundTypes bound
341+
then return qname
342+
else updateTypeName qname ss
329343
updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t
330344
updateType t = return t
331345
updateInConstraint :: SourceConstraint -> m SourceConstraint
332346
updateInConstraint (Constraint ann@(ss, _) name ks ts info) =
333347
Constraint ann <$> updateClassName name ss <*> pure ks <*> pure ts <*> pure info
334348

335-
updateConstraints :: SourceSpan -> [SourceConstraint] -> m [SourceConstraint]
336-
updateConstraints pos = traverse $ \(Constraint ann name ks ts info) ->
349+
updateConstraints :: BoundNames -> SourceSpan -> [SourceConstraint] -> m [SourceConstraint]
350+
updateConstraints bound pos = traverse $ \(Constraint ann name ks ts info) ->
337351
Constraint ann
338352
<$> updateClassName name pos
339-
<*> traverse updateTypesEverywhere ks
340-
<*> traverse updateTypesEverywhere ts
353+
<*> traverse (updateTypesEverywhere bound) ks
354+
<*> traverse (updateTypesEverywhere bound) ts
341355
<*> pure info
342356

343357
updateTypeName

‎src/Language/PureScript/TypeChecker.hs‎

Lines changed: 0 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -201,16 +201,6 @@ addTypeClassDictionaries mn entries =
201201
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }
202202
where insertState st = M.insertWith (M.unionWith (M.unionWith (<>))) mn entries (typeClassDictionaries . checkEnv $ st)
203203

204-
checkDuplicateTypeArguments
205-
:: (MonadState CheckState m, MonadError MultipleErrors m)
206-
=> [Text]
207-
-> m ()
208-
checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
209-
throwError . errorMessage $ DuplicateTypeArgument dup
210-
where
211-
firstDup :: Maybe Text
212-
firstDup = listToMaybe $ args \\ ordNub args
213-
214204
checkTypeClassInstance
215205
:: (MonadState CheckState m, MonadError MultipleErrors m)
216206
=> TypeClassData

0 commit comments

Comments
 (0)