Skip to content

Commit 84242a5

Browse files
rhendricrhendric
committed
Support local type synonyms natively
1 parent ed9d6a9 commit 84242a5

File tree

64 files changed

+986
-103
lines changed

Some content is hidden

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

64 files changed

+986
-103
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.

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

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

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

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -236,6 +236,16 @@ convertLetBinding fileName = \case
236236
binding@(LetBindingPattern _ a _ b) -> do
237237
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
238238
AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b)
239+
binding@(LetBindingType _ (DataHead _ a vars) _ bd) -> do
240+
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
241+
AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd)
242+
binding@(LetBindingKindSignature _ _ (Labeled name _ ty)) -> do
243+
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
244+
AST.KindDeclaration ann AST.TypeSynonymSig (nameValue name) $ convertType fileName ty
245+
where
246+
goTypeVar = \case
247+
TypeVarKinded (Wrapped _ (Labeled (_, x) _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y)
248+
TypeVarName (_, x) -> (getIdent $ nameValue x, Nothing)
239249

240250
convertExpr :: forall a. String -> Expr a -> AST.Expr
241251
convertExpr fileName = go

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

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -460,6 +460,8 @@ letBinding :: { LetBinding () }
460460
| ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) }
461461
| ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }
462462
| binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }
463+
| typeHead '=' type {% checkNoWildcards $3 *> pure (LetBindingType () $1 $2 $3) }
464+
| 'type' properName '::' type {% checkNoWildcards $4 *> pure (LetBindingKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }
463465
464466
caseBranch :: { (Separated (Binder ()), Guarded ()) }
465467
: 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
@@ -305,6 +305,8 @@ letBindingRange = \case
305305
LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
306306
LetBindingName _ a -> valueBindingFieldsRange a
307307
LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
308+
LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
309+
LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)
308310

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

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

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

408410
data DoBlock a = DoBlock

‎src/Language/PureScript/Errors.hs‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1768,17 +1768,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
17681768
hintCategory ErrorCheckingKind{} = CheckHint
17691769
hintCategory ErrorSolvingConstraint{} = SolverHint
17701770
hintCategory PositionedError{} = PositionHint
1771-
hintCategory ErrorInDataConstructor{} = DeclarationHint
1772-
hintCategory ErrorInTypeConstructor{} = DeclarationHint
1773-
hintCategory ErrorInBindingGroup{} = DeclarationHint
1774-
hintCategory ErrorInDataBindingGroup{} = DeclarationHint
1775-
hintCategory ErrorInTypeSynonym{} = DeclarationHint
1776-
hintCategory ErrorInValueDeclaration{} = DeclarationHint
1777-
hintCategory ErrorInTypeDeclaration{} = DeclarationHint
1778-
hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint
1779-
hintCategory ErrorInKindDeclaration{} = DeclarationHint
1780-
hintCategory ErrorInRoleDeclaration{} = DeclarationHint
1781-
hintCategory ErrorInForeignImport{} = DeclarationHint
1771+
hintCategory ErrorInDataConstructor{} = TypeDeclarationHint
1772+
hintCategory ErrorInTypeConstructor{} = TypeDeclarationHint
1773+
hintCategory ErrorInDataBindingGroup{} = TypeDeclarationHint
1774+
hintCategory ErrorInTypeSynonym{} = TypeDeclarationHint
1775+
hintCategory ErrorInTypeDeclaration{} = TypeDeclarationHint
1776+
hintCategory ErrorInTypeClassDeclaration{} = TypeDeclarationHint
1777+
hintCategory ErrorInKindDeclaration{} = TypeDeclarationHint
1778+
hintCategory ErrorInRoleDeclaration{} = TypeDeclarationHint
1779+
hintCategory ErrorInBindingGroup{} = ValueDeclarationHint
1780+
hintCategory ErrorInValueDeclaration{} = ValueDeclarationHint
1781+
hintCategory ErrorInForeignImport{} = ValueDeclarationHint
17821782
hintCategory _ = OtherHint
17831783

17841784
prettyPrintPlainIdent :: Ident -> Text

‎src/Language/PureScript/Linter.hs‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHi
1919
import Language.PureScript.Linter.Exhaustive as L
2020
import Language.PureScript.Linter.Imports as L
2121
import Language.PureScript.Names (Ident(..), Qualified(..), QualifiedBy(..), getIdentName, runIdent)
22-
import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everythingWithContextOnTypes)
22+
import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everythingOnTypes, everythingWithContextOnTypes)
2323
import Language.PureScript.Constants.Libs qualified as C
2424

2525
-- | Lint the PureScript AST.
@@ -222,7 +222,7 @@ lintUnused (Module modSS _ mn modDecls exports) =
222222
in
223223
mconcat $ map go vs ++ map f alts
224224

225-
go (TypedValue _ v1 _) = go v1
225+
go (TypedValue _ v1 ty) = go v1 <> goType ty
226226
go (Do _ es) = doElts es Nothing
227227
go (Ado _ es v1) = doElts es (Just v1)
228228

@@ -240,6 +240,10 @@ lintUnused (Module modSS _ mn modDecls exports) =
240240
go AnonymousArgument = mempty
241241
go (Hole _) = mempty
242242

243+
goType :: SourceType -> (S.Set Name, MultipleErrors)
244+
goType = everythingOnTypes (<>) $ \case
245+
TypeConstructor _ (Qualified (BySourcePos _) t) -> (S.singleton $ TyName t, mempty)
246+
_ -> mempty
243247

244248
doElts :: [DoNotationElement] -> Maybe Expr -> (S.Set Name, MultipleErrors)
245249
doElts (DoNotationValue e : rest) v = go e <> doElts rest v
@@ -257,6 +261,7 @@ lintUnused (Module modSS _ mn modDecls exports) =
257261
declNames :: Declaration -> (S.Set (SourceSpan, Name), S.Set (SourceSpan, Name))
258262
declNames (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, IdentName ident))
259263
declNames (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans' binders, S.empty)
264+
declNames (TypeSynonymDeclaration (ss,_) ty _ _) = (S.singleton (ss, TyName ty), S.empty)
260265
declNames _ = (S.empty, S.empty)
261266

262267
onDecls :: [ Declaration ] -> (S.Set Name, MultipleErrors) -> (S.Set Name, MultipleErrors)
@@ -280,6 +285,8 @@ lintUnused (Module modSS _ mn modDecls exports) =
280285
removeAndWarn bindNewNames $ foldr1 (<>) $ map go allExprs
281286
-- let {x} = e -- no binding to check inside e
282287
underDecl (BoundValueDeclaration _ _ expr) = go expr
288+
-- let f :: t -- check t
289+
underDecl (TypeDeclaration TypeDeclarationData{..}) = goType tydeclType
283290
underDecl _ = (mempty, mempty)
284291

285292
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 Data.List.NonEmpty qualified as NEL
1617
import Data.Monoid qualified as Monoid ((<>))
@@ -75,10 +76,10 @@ prettyPrintValue d (Case values binders) =
7576
prettyPrintValue d (Let FromWhere ds val) =
7677
prettyPrintValue (d - 1) val //
7778
moveRight 2 (text "where" //
78-
vcat left (map (prettyPrintDeclaration (d - 1)) ds))
79+
vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds))
7980
prettyPrintValue d (Let FromLet ds val) =
8081
text "let" //
81-
moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //
82+
moveRight 2 (vcat left (mapMaybe (prettyPrintDeclaration' (d - 1)) ds)) //
8283
(text "in " <> prettyPrintValue (d - 1) val)
8384
prettyPrintValue d (Do m els) =
8485
textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
@@ -139,6 +140,12 @@ prettyPrintDeclaration d (BindingGroupDeclaration ds) =
139140
toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e]
140141
prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"
141142

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

190197
prettyPrintBinderAtom :: Binder -> Text

0 commit comments

Comments
 (0)