Skip to content

Commit 9b529a0

Browse files
rhendricrhendric
committed
fixup! Support local type synonyms natively
Add warnings for various shadowing cases.
1 parent 24135e0 commit 9b529a0

File tree

18 files changed

+195
-94
lines changed

18 files changed

+195
-94
lines changed

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

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

502-
data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident
502+
data ScopedName = LocalName Name | ToplevelName Name
503503
deriving (Show, Eq, Ord)
504504

505-
inScope :: Ident -> S.Set ScopedIdent -> Bool
506-
inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s)
505+
inScope' :: (a -> Name) -> a -> S.Set ScopedName -> Bool
506+
inScope' ctor i s = (LocalName (ctor i) `S.member` s) || (ToplevelName (ctor i) `S.member` s)
507+
508+
inScope :: Ident -> S.Set ScopedName -> Bool
509+
inScope = inScope' IdentName
510+
511+
typeInScope :: ProperName 'TypeName -> S.Set ScopedName -> Bool
512+
typeInScope = inScope' TyName
507513

508514
everythingWithScope
509515
:: forall r
510516
. (Monoid r)
511-
=> (S.Set ScopedIdent -> Declaration -> r)
512-
-> (S.Set ScopedIdent -> Expr -> r)
513-
-> (S.Set ScopedIdent -> Binder -> r)
514-
-> (S.Set ScopedIdent -> CaseAlternative -> r)
515-
-> (S.Set ScopedIdent -> DoNotationElement -> r)
516-
-> ( S.Set ScopedIdent -> Declaration -> r
517-
, S.Set ScopedIdent -> Expr -> r
518-
, S.Set ScopedIdent -> Binder -> r
519-
, S.Set ScopedIdent -> CaseAlternative -> r
520-
, S.Set ScopedIdent -> DoNotationElement -> r
517+
=> (S.Set ScopedName -> Declaration -> r)
518+
-> (S.Set ScopedName -> Expr -> r)
519+
-> (S.Set ScopedName -> Binder -> r)
520+
-> (S.Set ScopedName -> CaseAlternative -> r)
521+
-> (S.Set ScopedName -> DoNotationElement -> r)
522+
-> ( S.Set ScopedName -> Declaration -> r
523+
, S.Set ScopedName -> Expr -> r
524+
, S.Set ScopedName -> Binder -> r
525+
, S.Set ScopedName -> CaseAlternative -> r
526+
, S.Set ScopedName -> DoNotationElement -> r
521527
)
522528
everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
523529
where
524-
f'' :: S.Set ScopedIdent -> Declaration -> r
530+
f'' :: S.Set ScopedName -> Declaration -> r
525531
f'' s a = f s a <> f' s a
526532

527-
f' :: S.Set ScopedIdent -> Declaration -> r
533+
f' :: S.Set ScopedName -> Declaration -> r
528534
f' s (DataBindingGroupDeclaration ds) =
529-
let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds))))
535+
let s' = S.union s (S.fromList (map ToplevelName (mapMaybe declName (NEL.toList ds))))
530536
in foldMap (f'' s') ds
531537
f' s (ValueDecl _ name _ bs val) =
532-
let s' = S.insert (ToplevelIdent name) s
538+
let s' = S.insert (ToplevelName (IdentName name)) s
533539
s'' = S.union s' (S.fromList (concatMap localBinderNames bs))
534540
in foldMap (h'' s') bs <> foldMap (l' s'') val
535541
f' s (BindingGroupDeclaration ds) =
536-
let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds)))
542+
let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelName (IdentName name)) ds)))
537543
in foldMap (\(_, _, val) -> g'' s' val) ds
538544
f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds
539545
f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
540546
f' _ _ = mempty
541547

542-
g'' :: S.Set ScopedIdent -> Expr -> r
548+
g'' :: S.Set ScopedName -> Expr -> r
543549
g'' s a = g s a <> g' s a
544550

545-
g' :: S.Set ScopedIdent -> Expr -> r
551+
g' :: S.Set ScopedName -> Expr -> r
546552
g' s (Literal _ l) = lit g'' s l
547553
g' s (UnaryMinus _ v1) = g'' s v1
548554
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
@@ -560,7 +566,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
560566
g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
561567
g' s (TypedValue _ v1 _) = g'' s v1
562568
g' s (Let _ ds v1) =
563-
let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
569+
let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
564570
in foldMap (f'' s') ds <> g'' s' v1
565571
g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es
566572
g' s (Ado _ es v1) =
@@ -569,46 +575,46 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
569575
g' s (PositionedValue _ _ v1) = g'' s v1
570576
g' _ _ = mempty
571577

572-
h'' :: S.Set ScopedIdent -> Binder -> r
578+
h'' :: S.Set ScopedName -> Binder -> r
573579
h'' s a = h s a <> h' s a
574580

575-
h' :: S.Set ScopedIdent -> Binder -> r
581+
h' :: S.Set ScopedName -> Binder -> r
576582
h' s (LiteralBinder _ l) = lit h'' s l
577583
h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
578584
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
579585
h' s (ParensInBinder b) = h'' s b
580-
h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1
586+
h' s (NamedBinder _ name b1) = h'' (S.insert (LocalName (IdentName name)) s) b1
581587
h' s (PositionedBinder _ _ b1) = h'' s b1
582588
h' s (TypedBinder _ b1) = h'' s b1
583589
h' _ _ = mempty
584590

585-
lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r
591+
lit :: (S.Set ScopedName -> a -> r) -> S.Set ScopedName -> Literal a -> r
586592
lit go s (ArrayLiteral as) = foldMap (go s) as
587593
lit go s (ObjectLiteral as) = foldMap (go s . snd) as
588594
lit _ _ _ = mempty
589595

590-
i'' :: S.Set ScopedIdent -> CaseAlternative -> r
596+
i'' :: S.Set ScopedName -> CaseAlternative -> r
591597
i'' s a = i s a <> i' s a
592598

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

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

601-
j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
607+
j' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r)
602608
j' s (DoNotationValue v) = (s, g'' s v)
603609
j' s (DoNotationBind b v) =
604610
let s' = S.union (S.fromList (localBinderNames b)) s
605611
in (s', h'' s b <> g'' s v)
606612
j' s (DoNotationLet ds) =
607-
let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
613+
let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
608614
in (s', foldMap (f'' s') ds)
609615
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
610616

611-
k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r)
617+
k' :: S.Set ScopedName -> Guard -> (S.Set ScopedName, r)
612618
k' s (ConditionGuard e) = (s, g'' s e)
613619
k' s (PatternGuard b e) =
614620
let s' = S.union (S.fromList (localBinderNames b)) s
@@ -619,12 +625,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
619625
let (s', r) = k' s grd
620626
in r <> l' s' (GuardedExpr gs e)
621627

622-
getDeclIdent :: Declaration -> Maybe Ident
623-
getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
624-
getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td)
625-
getDeclIdent _ = Nothing
626-
627-
localBinderNames = map LocalIdent . binderNames
628+
localBinderNames = map (LocalName . IdentName) . binderNames
628629

629630
accumTypes
630631
:: (Monoid r)

‎src/Language/PureScript/Errors.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -132,6 +132,7 @@ data SimpleErrorMessage
132132
| TransitiveExportError DeclarationRef [DeclarationRef]
133133
| TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
134134
| ShadowedName Ident
135+
| ShadowedTypeName (ProperName 'TypeName)
135136
| ShadowedTypeVar Text
136137
| UnusedTypeVar Text
137138
| WildcardInferredType SourceType Context
@@ -295,6 +296,7 @@ errorCode em = case unwrapErrorMessage em of
295296
TransitiveExportError{} -> "TransitiveExportError"
296297
TransitiveDctorExportError{} -> "TransitiveDctorExportError"
297298
ShadowedName{} -> "ShadowedName"
299+
ShadowedTypeName{} -> "ShadowedTypeName"
298300
ShadowedTypeVar{} -> "ShadowedTypeVar"
299301
UnusedTypeVar{} -> "UnusedTypeVar"
300302
WildcardInferredType{} -> "WildcardInferredType"
@@ -1033,6 +1035,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
10331035
]
10341036
renderSimpleErrorMessage (ShadowedName nm) =
10351037
line $ "Name " <> markCode (showIdent nm) <> " was shadowed."
1038+
renderSimpleErrorMessage (ShadowedTypeName nm) =
1039+
line $ "Type " <> markCode (runProperName nm) <> " was shadowed."
10361040
renderSimpleErrorMessage (ShadowedTypeVar tv) =
10371041
line $ "Type variable " <> markCode tv <> " was shadowed."
10381042
renderSimpleErrorMessage (UnusedTypeVar tv) =

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

‎src/Language/PureScript/Linter.hs‎

Lines changed: 12 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -12,11 +12,9 @@ import qualified Data.Set as S
1212
import Data.Text (Text)
1313

1414
import Language.PureScript.AST
15-
import Language.PureScript.Crash
1615
import Language.PureScript.Errors
1716
import Language.PureScript.Linter.Exhaustive as L
1817
import Language.PureScript.Linter.Imports as L
19-
import Language.PureScript.Names
2018
import Language.PureScript.Types
2119

2220
-- | Lint the PureScript AST.
@@ -25,15 +23,8 @@ import Language.PureScript.Types
2523
lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()
2624
lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
2725
where
28-
moduleNames :: S.Set ScopedIdent
29-
moduleNames = S.fromList (map ToplevelIdent (mapMaybe getDeclIdent ds))
30-
31-
getDeclIdent :: Declaration -> Maybe Ident
32-
getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
33-
getDeclIdent (ExternDeclaration _ ident _) = Just ident
34-
getDeclIdent (TypeInstanceDeclaration _ _ _ ident _ _ _ _) = Just ident
35-
getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet."
36-
getDeclIdent _ = Nothing
26+
moduleNames :: S.Set ScopedName
27+
moduleNames = S.fromList (map ToplevelName (mapMaybe declName ds))
3728

3829
lintDeclaration :: Declaration -> m ()
3930
lintDeclaration = tell . f
@@ -51,16 +42,16 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
5142
addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars ss s (tydeclType td))
5243
f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec
5344

54-
stepE :: S.Set ScopedIdent -> Expr -> MultipleErrors
45+
stepE :: S.Set ScopedName -> Expr -> MultipleErrors
5546
stepE s (Abs (VarBinder ss name) _) | name `inScope` s = errorMessage' ss (ShadowedName name)
5647
stepE s (Let _ ds' _) = foldMap go ds'
5748
where
58-
go d | Just i <- getDeclIdent d
59-
, inScope i s = errorMessage' (declSourceSpan d) (ShadowedName i)
49+
go d | Just n <- declName d
50+
, Just e <- getShadowWarning s n = errorMessage' (declSourceSpan d) e
6051
| otherwise = mempty
6152
stepE _ _ = mempty
6253

63-
stepB :: S.Set ScopedIdent -> Binder -> MultipleErrors
54+
stepB :: S.Set ScopedName -> Binder -> MultipleErrors
6455
stepB s (VarBinder ss name)
6556
| name `inScope` s
6657
= errorMessage' ss (ShadowedName name)
@@ -69,14 +60,18 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
6960
= errorMessage' ss (ShadowedName name)
7061
stepB _ _ = mempty
7162

72-
stepDo :: S.Set ScopedIdent -> DoNotationElement -> MultipleErrors
63+
stepDo :: S.Set ScopedName -> DoNotationElement -> MultipleErrors
7364
stepDo s (DoNotationLet ds') = foldMap go ds'
7465
where
7566
go d
76-
| Just i <- getDeclIdent d, i `inScope` s = errorMessage' (declSourceSpan d) (ShadowedName i)
67+
| Just n <- declName d, Just e <- getShadowWarning s n = errorMessage' (declSourceSpan d) e
7768
| otherwise = mempty
7869
stepDo _ _ = mempty
7970

71+
getShadowWarning s (IdentName i) | inScope i s = Just $ ShadowedName i
72+
getShadowWarning s (TyName t) | typeInScope t s = Just $ ShadowedTypeName t
73+
getShadowWarning _ _ = Nothing
74+
8075
checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors
8176
checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars (declSourceSpan d) s) in f d
8277

‎src/Language/PureScript/Sugar/BindingGroups.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -124,11 +124,11 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression
124124

125125
(_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def
126126

127-
usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident]
127+
usedNamesE :: S.Set ScopedName -> Expr -> [Ident]
128128
usedNamesE scope (Var _ (Qualified Nothing name))
129-
| LocalIdent name `S.notMember` scope = [name]
129+
| LocalName (IdentName name) `S.notMember` scope = [name]
130130
usedNamesE scope (Var _ (Qualified (Just moduleName') name))
131-
| moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name]
131+
| moduleName == moduleName' && ToplevelName (IdentName name) `S.notMember` scope = [name]
132132
usedNamesE _ _ = []
133133

134134
usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

0 commit comments

Comments
 (0)