8000 fixme: Support local type synonyms natively · purescript/purescript@4068600 · GitHub
[go: up one dir, main page]
Skip to content < 8000 span data-view-component="true" class="progress-pjax-loader Progress position-fixed width-full">

Commit 4068600

Browse files
rhendricrhendric
committed
fixme: Support local type synonyms natively
1 parent fe57d49 commit 4068600

29 files changed

+402
-72
lines changed

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

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -224,6 +224,13 @@ 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+
where
231+
goTypeVar = \case
232+
TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y)
233+
TypeVarName x -> (getIdent $ nameValue x, Nothing)
227234

228235
convertExpr :: forall a. String -> Expr a -> AST.Expr
229236
convertExpr fileName = go

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -164,6 +164,7 @@ 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
167168

168169
flattenWhere :: Where a -> DList SourceToken
169170
flattenWhere (Where a b) =

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -457,6 +457,7 @@ 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) }
460461
461462
caseBranch :: { (Separated (Binder ()), Guarded ()) }
462463
: sep(binder1, ',') guardedCase { ($1, $2) }

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -307,6 +307,7 @@ 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)
310311

311312
doStatementRange :: DoStatement a -> TokenRange
312313
doStatementRange = \case

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -402,6 +402,7 @@ 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)
405406
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
406407

407408
data DoBlock a = DoBlock

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

Lines changed: 8 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,10 @@ 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' _ TypeSynonymDeclaration{} = Nothing
147+
prettyPrintDeclaration' d decl = Just $ prettyPrintDeclaration d decl
148+
145149
prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box
146150
prettyPrintCaseAlternative d _ | d < 0 = ellipsis
147151
prettyPrintCaseAlternative d (CaseAlternative binders result) =
@@ -187,7 +191,7 @@ prettyPrintDoNotationElement d (DoNotationBind binder val) =
187191
textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val
188192
prettyPrintDoNotationElement d (DoNotationLet ds) =
189193
text "let" //
190-
moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))
194+
moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds))
191195
prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el
192196

193197
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 & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -534,17 +534,6 @@ typeCheckAll moduleName _ = traverse go
534534
null $ intersect sss sssWildcards
535535
isLocalUnnamedWildcardError _ _ = False
536536

537-
-- |
538-
-- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
539-
-- extracted from the kind of the type constructor itself.
540-
--
541-
withKinds :: [(Text, Maybe SourceType)] -> SourceType -> [(Text, Maybe SourceType)]
542-
withKinds [] _ = []
543-
withKinds ss (ForAll _ _ _ k _) = withKinds ss k
544-
withKinds (s@(_, Just _):ss) (TypeApp _ (TypeApp _ tyFn _) k2) | eqType tyFn tyFunction = s : withKinds ss k2
545-
withKinds ((s, Nothing):ss) (TypeApp _ (TypeApp _ tyFn k1) k2) | eqType tyFn tyFunction = (s, Just k1) : withKinds ss k2
546-
withKinds _ _ = internalError "Invalid arguments to withKinds"
547-
548537
checkNewtype
549538
:: forall m
550539
. MonadError MultipleErrors m

‎src/Language/PureScript/TypeChecker/Kinds.hs

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -522,18 +522,18 @@ elaborateKind = \case
522522
ty ->
523523
throwError . errorMessage' (fst (getAnnForType ty)) $ UnsupportedTypeInKind ty
524524

525-
checkEscapedSkolems :: MonadError MultipleErrors m => SourceType -> m ()
526-
checkEscapedSkolems ty =
525+
checkEscapedSkolems :: (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName -> SourceType -> m ()
526+
checkEscapedSkolems moduleName ty = do
527+
env <- getEnv
528+
let typesInScope = E.types env
529+
go :: SourceType -> SourceType -> (SourceType, [(SourceSpan, Text, SourceType)])
530+
go ty' = \case
531+
Skolem ss name _ _ _ | M.notMember (Qualified (Just moduleName) (ProperName name)) typesInScope -> (ty', [(fst ss, name, ty')])
532+
_ -> (ty', [])
527533
traverse_ (throwError . toSkolemError)
528534
. everythingWithContextOnTypes ty [] (<>) go
529535
$ ty
530536
where
531-
go :: SourceType -> SourceType -> (SourceType, [(SourceSpan, Text, SourceType)])
532-
go ty' = \case
533-
Skolem ss name _ _ _ -> (ty', [(fst ss, name, ty')])
534-
ty''@(KindApp _ _ _) -> (ty'', [])
535-
_ -> (ty', [])
536-
537537
toSkolemError (ss, name, ty') =
538538
errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty'
539539

@@ -959,7 +959,7 @@ kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do
959959
unkBinders = unknownVarNames (usedTypeVariables synKind <> usedTypeVariables synBody) tyUnks
960960
genBody = replaceUnknownsWithVars unkBinders $ replaceTypeCtors synBody
961961
genSig = generalizeUnknownsWithVars unkBinders synKind
962-
checkEscapedSkolems genBody
962+
checkEscapedSkolems moduleName genBody
963963
checkTypeQuantification genBody
964964
checkVisibleTypeQuantification genSig
965965
pure (genBody, genSig)

0 commit comments

Comments
 (0)
0