Skip to content

Commit 06a803a

Browse files
rhendricrhendric
committed
Support local type synonyms natively
1 parent 20d8441 commit 06a803a

File tree

62 files changed

+1012
-168
lines changed

Some content is hidden

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

62 files changed

+1012
-168
lines changed

‎CHANGELOG.d/feature_local-type-synonyms.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
* Support local type synonyms
2+
3+
This feature enables type synonyms to be defined in do, let, and where
4+
blocks, alongside value definitions.

‎lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -97,7 +97,8 @@ data HintCategory
9797
| CheckHint
9898
| PositionHint
9999
| SolverHint
100-
| DeclarationHint
100+
| TypeDeclarationHint
101+
| ValueDeclarationHint
101102
| OtherHint
102103
deriving (Show, Eq)
103104

‎lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs‎

Lines changed: 38 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -493,50 +493,56 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
493493
k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
494494
k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e
495495

496-
data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident
496+
data ScopedName = LocalName Name | ToplevelName Name
497497
deriving (Show, Eq, Ord)
498498

499-
inScope :: Ident -> S.Set ScopedIdent -> Bool
500-
inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s)
499+
inScope' :: (a -> Name) -> a -> S.Set ScopedName -> Bool
500+
inScope' ctor i s = (LocalName (ctor i) `S.member` s) || (ToplevelName (ctor i) `S.member` s)
501+
502+
inScope :: Ident -> S.Set ScopedName -> Bool
503+
inScope = inScope' IdentName
504+
505+
typeInScope :: ProperName 'TypeName -> S.Set ScopedName -> Bool
506+
typeInScope = inScope' TyName
501507

502508
everythingWithScope
503509
:: forall r
504510
. (Monoid r)
505-
=> (S.Set ScopedIdent -> Declaration -> r)
506-
-> (S.Set ScopedIdent -> Expr -> r)
507-
-> (S.Set ScopedIdent -> Binder -> r)
508-
-> (S.Set ScopedIdent -> CaseAlternative -> r)
509-
-> (S.Set ScopedIdent -> DoNotationElement -> r)
510-
-> ( S.Set ScopedIdent -> Declaration -> r
511-
, S.Set ScopedIdent -> Expr -> r
512-
, S.Set ScopedIdent -> Binder -> r
513-
, S.Set ScopedIdent -> CaseAlternative -> r
514-
, S.Set ScopedIdent -> DoNotationElement -> r
511+
=> (S.Set ScopedName -> Declaration -> r)
512+
-> (S.Set ScopedName -> Expr -> r)
513+
-> (S.Set ScopedName -> Binder -> r)
514+
-> (S.Set ScopedName -> CaseAlternative -> r)
515+
-> (S.Set ScopedName -> DoNotationElement -> r)
516+
-> ( S.Set ScopedName -> Declaration -> r
517+
, S.Set ScopedName -> Expr -> r
518+
, S.Set ScopedName -> Binder -> r
519+
, S.Set ScopedName -> CaseAlternative -> r
520+
, S.Set ScopedName -> DoNotationElement -> r
515521
)
516522
everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
517523
where
518-
f'' :: S.Set ScopedIdent -> Declaration -> r
524+
f'' :: S.Set ScopedName -> Declaration -> r
519525
f'' s a = f s a <> f' s a
520526

521-
f' :: S.Set ScopedIdent -> Declaration -> r
527+
f' :: S.Set ScopedName -> Declaration -> r
522528
f' s (DataBindingGroupDeclaration ds) =
523-
let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds))))
529+
let s' = S.union s (S.fromList (map ToplevelName (mapMaybe declName (NEL.toList ds))))
524530
in foldMap (f'' s') ds
525531
f' s (ValueDecl _ name _ bs val) =
526-
let s' = S.insert (ToplevelIdent name) s
532+
let s' = S.insert (ToplevelName (IdentName name)) s
527533
s'' = S.union s' (S.fromList (concatMap localBinderNames bs))
528534
in foldMap (h'' s') bs <> foldMap (l' s'') val
529535
f' s (BindingGroupDeclaration ds) =
530-
let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds)))
536+
let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelName (IdentName name)) ds)))
531537
in foldMap (\(_, _, val) -> g'' s' val) ds
532538
f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds
533539
f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
534540
f' _ _ = mempty
535541

536-
g'' :: S.Set ScopedIdent -> Expr -> r
542+
g'' :: S.Set ScopedName -> Expr -> r
537543
g'' s a = g s a <> g' s a
538544

539-
g' :: S.Set ScopedIdent -> Expr -> r
545+
g' :: S.Set ScopedName -> Expr -> r
540546
g' s (Literal _ l) = lit g'' s l
541547
g' s (UnaryMinus _ v1) = g'' s v1
542548
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
@@ -553,7 +559,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
553559
g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
554560
g' s (TypedValue _ v1 _) = g'' s v1
555561
g' s (Let _ ds v1) =
556-
let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
562+
let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
557563
in foldMap (f'' s') ds <> g'' s' v1
558564
g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es
559565
g' s (Ado _ es v1) =
@@ -562,46 +568,46 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
562568
g' s (PositionedValue _ _ v1) = g'' s v1
563569
g' _ _ = mempty
564570

565-
h'' :: S.Set ScopedIdent -> Binder -> r
571+
h'' :: S.Set ScopedName -> Binder -> r
566572
h'' s a = h s a <> h' s a
567573

568-
h' :: S.Set ScopedIdent -> Binder -> r
574+
h' :: S.Set ScopedName -> Binder -> r
569575
h' s (LiteralBinder _ l) = lit h'' s l
570576
h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
571577
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
572578
h' s (ParensInBinder b) = h'' s b
573-
h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1
579+
h' s (NamedBinder _ name b1) = h'' (S.insert (LocalName (IdentName name)) s) b1
574580
h' s (PositionedBinder _ _ b1) = h'' s b1
575581
h' s (TypedBinder _ b1) = h'' s b1
576582
h' _ _ = mempty
577583

578-
lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r
584+
lit :: (S.Set ScopedName -> a -> r) -> S.Set ScopedName -> Literal a -> r
579585
lit go s (ArrayLiteral as) = foldMap (go s) as
580586
lit go s (ObjectLiteral as) = foldMap (go s . snd) as
581587
lit _ _ _ = mempty
582588

583-
i'' :: S.Set ScopedIdent -> CaseAlternative -> r
589+
i'' :: S.Set ScopedName -> CaseAlternative -> r
584590
i'' s a = i s a <> i' s a
585591

586-
i' :: S.Set ScopedIdent -> CaseAlternative -> r
592+
i' :: S.Set ScopedName -> CaseAlternative -> r
587593
i' s (CaseAlternative bs gs) =
588594
let s' = S.union s (S.fromList (concatMap localBinderNames bs))
589595
in foldMap (h'' s) bs <> foldMap (l' s') gs
590596

591-
j'' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
597+
j'' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r)
592598
j'' s a = let (s', r) = j' s a in (s', j s a <> r)
593599

594-
j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
600+
j' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r)
595601
j' s (DoNotationValue v) = (s, g'' s v)
596602
j' s (DoNotationBind b v) =
597603
let s' = S.union (S.fromList (localBinderNames b)) s
598604
in (s', h'' s b <> g'' s v)
599605
j' s (DoNotationLet ds) =
600-
let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
606+
let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
601607
in (s', foldMap (f'' s') ds)
602608
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
603609

604-
k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r)
610+
k' :: S.Set ScopedName -> Guard -> (S.Set ScopedName, r)
605611
k' s (ConditionGuard e) = (s, g'' s e)
606612
k' s (PatternGuard b e) =
607613
let s' = S.union (S.fromList (localBinderNames b)) s
@@ -612,12 +618,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
612618
let (s', r) = k' s grd
613619
in r <> l' s' (GuardedExpr gs e)
614620

615-
getDeclIdent :: Declaration -> Maybe Ident
616-
getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
617-
getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td)
618-
getDeclIdent _ = Nothing
619-
620-
localBinderNames = map LocalIdent . binderNames
621+
localBinderNames = map (LocalName . IdentName) . binderNames
621622

622623
accumTypes
623624
:: (Monoid r)

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

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

230240
convertExpr :: forall a. String -> Expr a -> AST.Expr
231241
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
@@ -163,6 +163,8 @@ flattenLetBinding = \case
163163
LetBindingSignature _ a -> flattenLabeled flattenName flattenType a
164164
LetBindingName _ a -> flattenValueBindingFields a
165165
LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c
166+
LetBindingType _ a b c -> flattenDataHead a <> pure b <> flattenType c
167+
LetBindingKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b
166168

167169
flattenWhere :: Where a -> DList SourceToken
168170
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
@@ -446,6 +446,8 @@ letBinding :: { LetBinding () }
446446
| ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) }
447447
| ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }
448448
| binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }
449+
| typeHead '=' type {% checkNoWildcards $3 *> pure (LetBindingType () $1 $2 $3) }
450+
| 'type' properName '::' type {% checkNoWildcards $4 *> pure (LetBindingKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }
449451
450452
caseBranch :: { (Separated (Binder ()), Guarded ()) }
451453
: 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
@@ -302,6 +302,8 @@ letBindingRange = \case
302302
LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
303303
LetBindingName _ a -> valueBindingFieldsRange a
304304
LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
305+
LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
306+
LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)
305307

306308
doStatementRange :: DoStatement a -> TokenRange
307309
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
@@ -399,6 +399,8 @@ data LetBinding a
399399
= LetBindingSignature a (Labeled (Name Ident) (Type a))
400400
| LetBindingName a (ValueBindingFields a)
401401
| LetBindingPattern a (Binder a) SourceToken (Where a)
402+
| LetBindingType a (DataHead a) SourceToken (Type a)
403+
| LetBindingKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))
402404
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
403405

404406
data DoBlock a = DoBlock

‎src/Language/PureScript/Errors.hs‎

Lines changed: 17 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -140,9 +140,10 @@ data SimpleErrorMessage
140140
| TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName]
141141
| HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName))
142142
| ShadowedName Ident
143+
| ShadowedTypeName (ProperName 'TypeName)
143144
| ShadowedTypeVar Text
144145
| UnusedTypeVar Text
145-
| UnusedName Ident
146+
| UnusedName Name
146147
| UnusedDeclaration Ident
147148
| WildcardInferredType SourceType Context
148149
| HoleInferredType Text SourceType Context (Maybe TypeSearch)
@@ -316,6 +317,7 @@ errorCode em = case unwrapErrorMessage em of
316317
ShadowedName{} -> "ShadowedName"
317318
UnusedName{} -> "UnusedName"
318319
UnusedDeclaration{} -> "UnusedDeclaration"
320+
ShadowedTypeName{} -> "ShadowedTypeName"
319321
ShadowedTypeVar{} -> "ShadowedTypeVar"
320322
UnusedTypeVar{} -> "UnusedTypeVar"
321323
WildcardInferredType{} -> "WildcardInferredType"
@@ -1084,10 +1086,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
10841086
]
10851087
renderSimpleErrorMessage (ShadowedName nm) =
10861088
line $ "Name " <> markCode (showIdent nm) <> " was shadowed."
1089+
renderSimpleErrorMessage (ShadowedTypeName nm) =
1090+
line $ "Type " <> markCode (runProperName nm) <> " was shadowed."
10871091
renderSimpleErrorMessage (ShadowedTypeVar tv) =
10881092
line $ "Type variable " <> markCode tv <> " was shadowed."
10891093
renderSimpleErrorMessage (UnusedName nm) =
1090-
line $ "Name " <> markCode (showIdent nm) <> " was introduced but not used."
1094+
line $ "Name " <> markCode (runName (Qualified Nothing nm)) <> " was introduced but not used."
10911095
renderSimpleErrorMessage (UnusedDeclaration nm) =
10921096
line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported."
10931097
renderSimpleErrorMessage (UnusedTypeVar tv) =
@@ -1702,17 +1706,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
17021706
hintCategory ErrorCheckingKind{} = CheckHint
17031707
hintCategory ErrorSolvingConstraint{} = SolverHint
17041708
hintCategory PositionedError{} = PositionHint
1705-
hintCategory ErrorInDataConstructor{} = DeclarationHint
1706-
hintCategory ErrorInTypeConstructor{} = DeclarationHint
1707-
hintCategory ErrorInBindingGroup{} = DeclarationHint
1708-
hintCategory ErrorInDataBindingGroup{} = DeclarationHint
1709-
hintCategory ErrorInTypeSynonym{} = DeclarationHint
1710-
hintCategory ErrorInValueDeclaration{} = DeclarationHint
1711-
hintCategory ErrorInTypeDeclaration{} = DeclarationHint
1712-
hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint
1713-
hintCategory ErrorInKindDeclaration{} = DeclarationHint
1714-
hintCategory ErrorInRoleDeclaration{} = DeclarationHint
1715-
hintCategory ErrorInForeignImport{} = DeclarationHint
1709+
hintCategory ErrorInDataConstructor{} = TypeDeclarationHint
1710+
hintCategory ErrorInTypeConstructor{} = TypeDeclarationHint
1711+
hintCategory ErrorInDataBindingGroup{} = TypeDeclarationHint
1712+
hintCategory ErrorInTypeSynonym{} = TypeDeclarationHint
1713+
hintCategory ErrorInTypeDeclaration{} = TypeDeclarationHint
1714+
hintCategory ErrorInTypeClassDeclaration{} = TypeDeclarationHint
1715+
hintCategory ErrorInKindDeclaration{} = TypeDeclarationHint
1716+
hintCategory ErrorInRoleDeclaration{} = TypeDeclarationHint
1717+
hintCategory ErrorInBindingGroup{} = ValueDeclarationHint
1718+
hintCategory ErrorInValueDeclaration{} = ValueDeclarationHint
1719+
hintCategory ErrorInForeignImport{} = ValueDeclarationHint
17161720
hintCategory _ = OtherHint
17171721

17181722
prettyPrintPlainIdent :: Ident -> Text

‎src/Language/PureScript/Ide/Usage.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,7 @@ applySearch module_ search =
141141
P.Var sp i
142142
| Just ideValue <- preview _IdeDeclValue (P.disqualify search)
143143
, P.isQualified search
144-
|| not (P.LocalIdent (_ideValueIdent ideValue) `Set.member` scope) ->
144+
|| not (P.LocalName (P.IdentName (_ideValueIdent ideValue)) `Set.member` scope) ->
145145
[sp | map P.runIdent i == map identifierFromIdeDeclaration search]
146146
P.Constructor sp name
147147
| Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search ->

0 commit comments

Comments
 (0)