8000 Local type synonyms by rhendric · Pull Request #3897 · purescript/purescript · GitHub
[go: up one dir, main page]
Skip to content

Local type synonyms #3897

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 2 commits into
base: master
Choose a base branch
from
Draft

Local type synonyms #3897

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
ed9d6a9
Generalize scopes, errors from Ident to Name
rhendric Dec 8, 2022
84242a5
Support local type synonyms natively
rhendric Dec 8, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 4 additions & 0 deletions CHANGELOG.d/feature_local-type-synonyms.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
* Support local type synonyms

This feature enables type synonyms to be defined in do, let, and where
blocks, alongside value definitions.
3 changes: 2 additions & 1 deletion src/Language/PureScript/AST/Declarations.hs
8000
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -99,7 +99,8 @@ data HintCategory
| CheckHint
| PositionHint
| SolverHint
| DeclarationHint
| TypeDeclarationHint
| ValueDeclarationHint
| OtherHint
deriving (Show, Eq)

Expand Down
76 changes: 37 additions & 39 deletions src/Language/PureScript/AST/Traversals.hs
View file
Open in desktop
< 8000 /tr>
Original file line number Diff line number Diff line change
Expand Up @@ -18,9 +18,9 @@ import Data.Map qualified as M
import Data.Set qualified as S

import Language.PureScript.AST.Binders (Binder(..), binderNames)
import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), mapTypeInstanceBody, traverseTypeInstanceBody)
import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), declName, mapTypeInstanceBody, traverseTypeInstanceBody)
import Language.PureScript.AST.Literals (Literal(..))
import Language.PureScript.Names (pattern ByNullSourcePos, Ident)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Name(..))
import Language.PureScript.Traversals (sndM, sndM', thirdM)
import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
import Language.PureScript.Types (Constraint(..), SourceType, mapConstraintArgs)
Expand Down Expand Up @@ -538,50 +538,53 @@ everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0,
k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e

data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident
data ScopedName = LocalName Name | ToplevelName Name
deriving (Show, Eq, Ord)

inScope :: Ident -> S.Set ScopedIdent -> Bool
inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s)
inScope' :: Name -> S.Set ScopedName -> Bool
inScope' n s = (LocalName n `S.member` s) || (ToplevelName n `S.member` s)

inScope :: Ident -> S.Set ScopedName -> Bool
inScope = inScope' . IdentName

everythingWithScope
:: forall r
. (Monoid r)
=> (S.Set ScopedIdent -> Declaration -> r)
-> (S.Set ScopedIdent -> Expr -> r)
-> (S.Set ScopedIdent -> Binder -> r)
-> (S.Set ScopedIdent -> CaseAlternative -> r)
-> (S.Set ScopedIdent -> DoNotationElement -> r)
-> ( S.Set ScopedIdent -> Declaration -> r
, S.Set ScopedIdent -> Expr -> r
, S.Set ScopedIdent -> Binder -> r
, S.Set ScopedIdent -> CaseAlternative -> r
, S.Set ScopedIdent -> DoNotationElement -> r
=> (S.Set ScopedName -> Declaration -> r)
-> (S.Set ScopedName -> Expr -> r)
-> (S.Set ScopedName -> Binder -> r)
-> (S.Set ScopedName -> CaseAlternative -> r)
-> (S.Set ScopedName -> DoNotationElement -> r)
-> ( S.Set ScopedName -> Declaration -> r
, S.Set ScopedName -> Expr -> r
, S.Set ScopedName -> Binder -> r
, S.Set ScopedName -> CaseAlternative -> r
, S.Set ScopedName -> DoNotationElement -> r
)
everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
where
f'' :: S.Set ScopedIdent -> Declaration -> r
f'' :: S.Set ScopedName -> Declaration -> r
f'' s a = f s a <> f' s a

f' :: S.Set ScopedIdent -> Declaration -> r
f' :: S.Set ScopedName -> Declaration -> r
f' s (DataBindingGroupDeclaration ds) =
let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds))))
let s' = S.union s (S.fromList (map ToplevelName (mapMaybe declName (NEL.toList ds))))
in foldMap (f'' s') ds
f' s (ValueDecl _ name _ bs val) =
let s' = S.insert (ToplevelIdent name) s
let s' = S.insert (ToplevelName (IdentName name)) s
s'' = S.union s' (S.fromList (concatMap localBinderNames bs))
in foldMap (h'' s') bs <> foldMap (l' s'') val
f' s (BindingGroupDeclaration ds) =
let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds)))
let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelName (IdentName name)) ds)))
in foldMap (\(_, _, val) -> g'' s' val) ds
f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds
f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
f' _ _ = mempty

g'' :: S.Set ScopedIdent -> Expr -> r
g'' :: S.Set ScopedName -> Expr -> r
g'' s a = g s a <> g' s a

g' :: S.Set ScopedIdent -> Expr -> r
g' :: S.Set ScopedName -> Expr -> r
g' s (Literal _ l) = lit g'' s l
g' s (UnaryMinus _ v1) = g'' s v1
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
Expand All @@ -599,7 +602,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
g' s (TypedValue _ v1 _) = g'' s v1
g' s (Let _ ds v1) =
let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
in foldMap (f'' s') ds <> g'' s' v1
g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es
g' s (Ado _ es v1) =
Expand All @@ -608,46 +611,46 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' s (PositionedValue _ _ v1) = g'' s v1
g' _ _ = mempty

h'' :: S.Set ScopedIdent -> Binder -> r
h'' :: S.Set ScopedName -> Binder -> r
h'' s a = h s a <> h' s a

h' :: S.Set ScopedIdent -> Binder -> r
h' :: S.Set ScopedName -> Binder -> r
h' s (LiteralBinder _ l) = lit h'' s l
h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
h' s (ParensInBinder b) = h'' s b
h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1
h' s (NamedBinder _ name b1) = h'' (S.insert (LocalName (IdentName name)) s) b1
h' s (PositionedBinder _ _ b1) = h'' s b1
h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = mempty

lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r
lit :: (S.Set ScopedName -> a -> r) -> S.Set ScopedName -> Literal a -> r
lit go s (ArrayLiteral as) = foldMap (go s) as
lit go s (ObjectLiteral as) = foldMap (go s . snd) as
lit _ _ _ = mempty

i'' :: S.Set ScopedIdent -> CaseAlternative -> r
i'' :: S.Set ScopedName -> CaseAlternative -> r
i'' s a = i s a <> i' s a

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

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

j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
j' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r)
j' s (DoNotationValue v) = (s, g'' s v)
j' s (DoNotationBind b v) =
let s' = S.union (S.fromList (localBinderNames b)) s
in (s', h'' s b <> g'' s v)
j' s (DoNotationLet ds) =
let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
in (s', foldMap (f'' s') ds)
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r)
k' :: S.Set ScopedName -> Guard -> (S.Set ScopedName, r)
k' s (ConditionGuard e) = (s, g'' s e)
k' s (PatternGuard b e) =
let s' = S.union (S.fromList (localBinderNames b)) s
Expand All @@ -658,12 +661,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
let (s', r) = k' s grd
in r <> l' s' (GuardedExpr gs e)

getDeclIdent :: Declaration -> Maybe Ident
getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td)
getDeclIdent _ = Nothing

localBinderNames = map LocalIdent . binderNames
localBinderNames = map (LocalName . IdentName) . binderNames

accumTypes
:: (Monoid r)
Expand Down
10 changes: 10 additions & 0 deletions src/Language/PureScript/CST/Convert.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -236,6 +236,16 @@ convertLetBinding fileName = \case
binding@(LetBindingPattern _ a _ b) -> do
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b)
binding@(LetBindingType _ (DataHead _ a vars) _ bd) -> do
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd)
binding@(LetBindingKindSignature _ _ (Labeled name _ ty)) -> do
let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
AST.KindDeclaration ann AST.TypeSynonymSig (nameValue name) $ convertType fileName ty
where
goTypeVar = \case
TypeVarKinded (Wrapped _ (Labeled (_, x) _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y)
TypeVarName (_, x) -> (getIdent $ nameValue x, Nothing)

convertExpr :: forall a. String -> Expr a -> AST.Expr
convertExpr fileName = go
Expand Down
2 changes: 2 additions & 0 deletions src/Language/PureScript/CST/Flatten.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -164,6 +164,8 @@ flattenLetBinding = \case
LetBindingSignature _ a -> flattenLabeled flattenName flattenType a
LetBindingName _ a -> flattenValueBindingFields a
LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c
LetBindingType _ a b c -> flattenDataHead a <> pure b <> flattenType c
LetBindingKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b

flattenWhere :: Where a -> DList SourceToken
flattenWhere (Where a b) =
Expand Down
2 changes: 2 additions & 0 deletions src/Language/PureScript/CST/Parser.y
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -460,6 +460,8 @@ letBinding :: { LetBinding () }
| ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) }
| ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }
| binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }
| typeHead '=' type {% checkNoWildcards $3 *> pure (LetBindingType () $1 $2 $3) }
| 'type' properName '::' type {% checkNoWildcards $4 *> pure (LetBindingKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }

caseBranch :: { (Separated (Binder ()), Guarded ()) }
: sep(binder1, ',') guardedCase { ($1, $2) }
Expand Down
2 changes: 2 additions & 0 deletions src/Language/PureScript/CST/Positions.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -305,6 +305,8 @@ letBindingRange = \case
LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
LetBindingName _ a -> valueBindingFieldsRange a
LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)

doStatementRange :: DoStatement a -> TokenRange
doStatementRange = \case
Expand Down
2 changes: 2 additions & 0 deletions src/Language/PureScript/CST/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -403,6 +403,8 @@ data LetBinding a
= LetBindingSignature a (Labeled (Name Ident) (Type a))
| LetBindingName a (ValueBindingFields a)
| LetBindingPattern a (Binder a) SourceToken (Where a)
| LetBindingType a (DataHead a) SourceToken (Type a)
| LetBindingKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)

data DoBlock a = DoBlock
Expand Down
34 changes: 17 additions & 17 deletions src/Language/PureScript/Errors.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -81,7 +81,7 @@ data SimpleErrorMessage
| OrphanKindDeclaration (ProperName 'TypeName)
| OrphanRoleDeclaration (ProperName 'TypeName)
| RedefinedIdent Ident
| OverlappingNamesInLet Ident
| OverlappingNamesInLet Name
| UnknownName (Qualified Name)
| UnknownImport ModuleName Name
| UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
Expand Down Expand Up @@ -143,10 +143,10 @@ data SimpleErrorMessage
| TransitiveExportError DeclarationRef [DeclarationRef]
| TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName]
| HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName))
| ShadowedName Ident
| ShadowedName Name
| ShadowedTypeVar Text
| UnusedTypeVar Text
| UnusedName Ident
| UnusedName Name
| UnusedDeclaration Ident
| WildcardInferredType SourceType Context
| HoleInferredType Text SourceType Context (Maybe TypeSearch)
Expand Down Expand Up @@ -744,7 +744,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
renderSimpleErrorMessage InvalidDoLet =
line "The last statement in a 'do' block must be an expression, but this block ends with a let binding."
renderSimpleErrorMessage (OverlappingNamesInLet name) =
line $ "The name " <> markCode (showIdent name) <> " was defined multiple times in a binding group"
line $ "The " <> printName (Qualified ByNullSourcePos name) <> " was defined multiple times in a binding group"
renderSimpleErrorMessage (InfiniteType ty) =
paras [ line "An infinite type was inferred for an expression: "
, markCodeBox $ indent $ prettyType ty
Expand Down Expand Up @@ -1122,11 +1122,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
, line "Such instance allows to match and construct values of this type, effectively making the constructors public."
]
renderSimpleErrorMessage (ShadowedName nm) =
line $ "Name " <> markCode (showIdent nm) <> " was shadowed."
line $ "The " <> printName (Qualified ByNullSourcePos nm) <> " was shadowed."
renderSimpleErrorMessage (ShadowedTypeVar tv) =
line $ "Type variable " <> markCode tv <> " was shadowed."
renderSimpleErrorMessage (UnusedName nm) =
line $ "Name " <> markCode (showIdent nm) <> " was introduced but not used."
line $ "The " <> printName (Qualified ByNullSourcePos nm) <> " was introduced but not used."
renderSimpleErrorMessage (UnusedDeclaration nm) =
line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported."
renderSimpleErrorMessage (UnusedTypeVar tv) =
Expand Down Expand Up @@ -1768,17 +1768,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
hintCategory ErrorCheckingKind{} = CheckHint
hintCategory ErrorSolvingConstraint{} = SolverHint
hintCategory PositionedError{} = PositionHint
hintCategory ErrorInDataConstructor{} = DeclarationHint
hintCategory ErrorInTypeConstructor{} = DeclarationHint
hintCategory ErrorInBindingGroup{} = DeclarationHint
hintCategory ErrorInDataBindingGroup{} = DeclarationHint
hintCategory ErrorInTypeSynonym{} = DeclarationHint
hintCategory ErrorInValueDeclaration{} = DeclarationHint
hintCategory ErrorInTypeDeclaration{} = DeclarationHint
hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint
hintCategory ErrorInKindDeclaration{} = DeclarationHint
hintCategory ErrorInRoleDeclaration{} = DeclarationHint
hintCategory ErrorInForeignImport{} = DeclarationHint
hintCategory ErrorInDataConstructor{} = TypeDeclarationHint
hintCategory ErrorInTypeConstructor{} = TypeDeclarationHint
hintCategory ErrorInDataBindingGroup{} = TypeDeclarationHint
hintCategory ErrorInTypeSynonym{} = TypeDeclarationHint
hintCategory ErrorInTypeDeclaration{} = TypeDeclarationHint
hintCategory ErrorInTypeClassDeclaration{} = TypeDeclarationHint
hintCategory ErrorInKindDeclaration{} = TypeDeclarationHint
hintCategory ErrorInRoleDeclaration{} = TypeDeclarationHint
hintCategory ErrorInBindingGroup{} = ValueDeclarationHint
hintCategory ErrorInValueDeclaration{} = ValueDeclarationHint
hintCategory ErrorInForeignImport{} = ValueDeclarationHint
hintCategory _ = OtherHint

prettyPrintPlainIdent :: Ident -> Text
Expand Down
2 changes: 1 addition & 1 deletion src/Language/PureScript/Ide/Usage.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -141,7 +141,7 @@ applySearch module_ search =
P.Var sp i
| Just ideValue <- preview _IdeDeclValue (P.disqualify search)
, P.isQualified search
|| not (P.LocalIdent (_ideValueIdent ideValue) `Set.member` scope) ->
|| not (P.LocalName (P.IdentName $ _ideValueIdent ideValue) `Set.member` scope) ->
[sp | map P.runIdent i == map identifierFromIdeDeclaration search]
P.Constructor sp name
| Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search ->
Expand Down
Loading
0