Skip to content

Commit 4f80996

Browse files
rhendricrhendric
committed
Support local type synonyms natively
1 parent 53dc28e commit 4f80996

64 files changed

Lines changed: 978 additions & 95 deletions

File tree

Some content is hidden

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

‎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.

‎src/Language/PureScript/AST/Declarations.hs‎

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

‎src/Language/PureScript/CST/Convert.hs‎

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

234244
convertExpr :: forall a. String -> Expr a -> AST.Expr
235245
convertExpr fileName = go

‎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) =

‎src/Language/PureScript/CST/Parser.y‎

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

‎src/Language/PureScript/CST/Positions.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -304,6 +304,8 @@ letBindingRange = \case
304304
LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
305305
LetBindingName _ a -> valueBindingFieldsRange a
306306
LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
307+
LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
308+
LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)
307309

308310
doStatementRange :: DoStatement a -> TokenRange
309311
doStatementRange = \case

‎src/Language/PureScript/CST/Types.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -400,6 +400,8 @@ data LetBinding a
400400
= LetBindingSignature a (Labeled (Name Ident) (Type a))
401401
| LetBindingName a (ValueBindingFields a)
402402
| LetBindingPattern a (Binder a) SourceToken (Where a)
403+
| LetBindingType a (DataHead a) SourceToken (Type a)
404+
| LetBindingKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))
403405
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
404406

405407
data DoBlock a = DoBlock

‎src/Language/PureScript/Errors.hs‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1724,17 +1724,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
17241724
hintCategory ErrorCheckingKind{} = CheckHint
17251725
hintCategory ErrorSolvingConstraint{} = SolverHint
17261726
hintCategory PositionedError{} = PositionHint
1727-
hintCategory ErrorInDataConstructor{} = DeclarationHint
1728-
hintCategory ErrorInTypeConstructor{} = DeclarationHint
1729-
hintCategory ErrorInBindingGroup{} = DeclarationHint
1730-
hintCategory ErrorInDataBindingGroup{} = DeclarationHint
1731-
hintCategory ErrorInTypeSynonym{} = DeclarationHint
1732-
hintCategory ErrorInValueDeclaration{} = DeclarationHint
1733-
hintCategory ErrorInTypeDeclaration{} = DeclarationHint
1734-
hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint
1735-
hintCategory ErrorInKindDeclaration{} = DeclarationHint
1736-
hintCategory ErrorInRoleDeclaration{} = DeclarationHint
1737-
hintCategory ErrorInForeignImport{} = DeclarationHint
1727+
hintCategory ErrorInDataConstructor{} = TypeDeclarationHint
1728+
hintCategory ErrorInTypeConstructor{} = TypeDeclarationHint
1729+
hintCategory ErrorInDataBindingGroup{} = TypeDeclarationHint
1730+
hintCategory ErrorInTypeSynonym{} = TypeDeclarationHint
1731+
hintCategory ErrorInTypeDeclaration{} = TypeDeclarationHint
1732+
hintCategory ErrorInTypeClassDeclaration{} = TypeDeclarationHint
1733+
hintCategory ErrorInKindDeclaration{} = TypeDeclarationHint
1734+
hintCategory ErrorInRoleDeclaration{} = TypeDeclarationHint
1735+
hintCategory ErrorInBindingGroup{} = ValueDeclarationHint
1736+
hintCategory ErrorInValueDeclaration{} = ValueDeclarationHint
1737+
hintCategory ErrorInForeignImport{} = ValueDeclarationHint
17381738
hintCategory _ = OtherHint
17391739

17401740
prettyPrintPlainIdent :: Ident -> Text

‎src/Language/PureScript/Linter.hs‎

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -219,7 +219,7 @@ lintUnused (Module modSS _ mn modDecls exports) =
219219
in
220220
mconcat $ map go vs ++ map f alts
221221

222-
go (TypedValue _ v1 _) = go v1
222+
go (TypedValue _ v1 ty) = go v1 <> goType ty
223223
go (Do _ es) = doElts es Nothing
224224
go (Ado _ es v1) = doElts es (Just v1)
225225

@@ -237,6 +237,10 @@ lintUnused (Module modSS _ mn modDecls exports) =
237237
go AnonymousArgument = mempty
238238
go (Hole _) = mempty
239239

240+
goType :: SourceType -> (S.Set Name, MultipleErrors)
241+
goType = everythingOnTypes (<>) $ \case
242+
TypeConstructor _ (Qualified (BySourcePos _) t) -> (S.singleton $ TyName t, mempty)
243+
_ -> mempty
240244

241245
doElts :: [DoNotationElement] -> Maybe Expr -> (S.Set Name, MultipleErrors)
242246
doElts (DoNotationValue e : rest) v = go e <> doElts rest v
@@ -254,6 +258,7 @@ lintUnused (Module modSS _ mn modDecls exports) =
254258
declNames :: Declaration -> (S.Set (SourceSpan, Name), S.Set (SourceSpan, Name))
255259
declNames (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, IdentName ident))
256260
declNames (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans' binders, S.empty)
261+
declNames (TypeSynonymDeclaration (ss,_) ty _ _) = (S.singleton (ss, TyName ty), S.empty)
257262
declNames _ = (S.empty, S.empty)
258263

259264
onDecls :: [ Declaration ] -> (S.Set Name, MultipleErrors) -> (S.Set Name, MultipleErrors)
@@ -277,6 +282,8 @@ lintUnused (Module modSS _ mn modDecls exports) =
277282
removeAndWarn bindNewNames $ foldr1 (<>) $ map go allExprs
278283
-- let {x} = e -- no binding to check inside e
279284
underDecl (BoundValueDeclaration _ _ expr) = go expr
285+
-- let f :: t -- check t
286+
underDecl (TypeDeclaration TypeDeclarationData{..}) = goType tydeclType
280287
underDecl _ = (mempty, mempty)
281288

282289
unguard (GuardedExpr guards expr) = map unguard' guards ++ [expr]

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

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Prelude hiding ((<>))
1111

1212
import Control.Arrow (second)
1313

14+
import Data.Maybe (mapMaybe)
1415
import Data.Text (Text)
1516
import qualified Data.List.NonEmpty as NEL
1617
import qualified Data.Monoid as Monoid ((<>))
@@ -74,10 +75,10 @@ prettyPrintValue d (Case values binders) =
7475
prettyPrintValue d (Let FromWhere ds val) =
7576
prettyPrintValue (d - 1) val //
7677
moveRight 2 (text "where" //
77-
vcat left (map (prettyPrintDeclaration (d - 1)) ds))
78+
vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds))
7879
prettyPrintValue d (Let FromLet ds val) =
7980
text "let" //
80-
moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //
81+
moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds)) //
8182
(text "in " <> prettyPrintValue (d - 1) val)
8283
prettyPrintValue d (Do m els) =
8384
textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
@@ -138,6 +139,12 @@ prettyPrintDeclaration d (BindingGroupDeclaration ds) =
138139
toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e]
139140
prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"
140141

142+
prettyPrintDeclaration' :: Int -> Declaration -> Maybe Box
143+
prettyPrintDeclaration' d = \case
144+
KindDeclaration{} -> Nothing
145+
TypeSynonymDeclaration{} -> Nothing
146+
decl -> Just $ prettyPrintDeclaration d decl
147+
141148
prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box
142149
prettyPrintCaseAlternative d _ | d < 0 = ellipsis
143150
prettyPrintCaseAlternative d (CaseAlternative binders result) =
@@ -183,7 +190,7 @@ prettyPrintDoNotationElement d (DoNotationBind binder val) =
183190
textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val
184191
prettyPrintDoNotationElement d (DoNotationLet ds) =
185192
text "let" //
186-
moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))
193+
moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds))
187194
prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el
188195

189196
prettyPrintBinderAtom :: Binder -> Text

0 commit comments

Comments
 (0)