0888ada · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Warn on shadowed type var within a single type

commit0888adac0a000cc03b62a950f70cb1a1b53f1156 authorGary Burgess <gary.burgess@gmail.com> dateSun 13 Sep 2015, 13:18 (11 years ago) parente2385f4

3 files changed+44−9

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+5−1 src/Language/PureScript/Linter.hs+24−8 src/Language/PureScript/Types.hs+15

src/Language/PureScript/Errors.hs+5−1

@@ -140,6 +140,7 @@ data SimpleErrorMessage

140140 | InvalidInstanceHead Type

141141 | TransitiveExportError DeclarationRef [DeclarationRef]

142142 | ShadowedName Ident

143+ | ShadowedTypeVar String

143144 | WildcardInferredType Type

144145 | NotExhaustivePattern [[Binder]] Bool

145146 | OverlappingPattern [[Binder]] Bool

@@ -266,6 +267,7 @@ errorCode em = case unwrapErrorMessage em of

266267 InvalidInstanceHead{} -> "InvalidInstanceHead"

267268 TransitiveExportError{} -> "TransitiveExportError"

268269 ShadowedName{} -> "ShadowedName"

270+ ShadowedTypeVar{} -> "ShadowedTypeVar"

269271 WildcardInferredType{} -> "WildcardInferredType"

270272 NotExhaustivePattern{} -> "NotExhaustivePattern"

271273 OverlappingPattern{} -> "OverlappingPattern"

@@ -628,7 +630,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

628630 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

629631 : map (line . prettyPrintExport) ys

630632 goSimple (ShadowedName nm) =

631− line $ "Name '" ++ showIdent nm ++ "' was shadowed."

633+ line $ "Name '" ++ showIdent nm ++ "' was shadowed"

634+ goSimple (ShadowedTypeVar tv) =

635+ line $ "Type variable '" ++ tv ++ "' was shadowed"

632636 goSimple (ClassOperator className opName) =

633637 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

634638 , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

src/Language/PureScript/Linter.hs+24−8

@@ -33,6 +33,7 @@ import Control.Monad.Writer.Class

3333import Language.PureScript.AST

3434import Language.PureScript.Names

3535import Language.PureScript.Errors

36+import Language.PureScript.Types

3637import Language.PureScript.Linter.Exhaustive as L

3738

3839-- | Lint the PureScript AST.

@@ -59,7 +60,7 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_

5960

6061 f' :: Declaration -> MultipleErrors

6162 f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec)

62− f' dec = f dec

63+ f' dec = f dec <> checkShadowedTypeVars dec

6364

6465 in tell (f' d)

6566 where

@@ -75,17 +76,32 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_

7576 stepD s _ = (s, mempty)

7677

7778 stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)

78− stepE s (Abs (Left name) _) = bind s name

79+ stepE s (Abs (Left name) _) = bindName s name

7980 stepE s (Let ds' _) =

80− case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of

81+ case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of

8182 (s', es) -> (s', mconcat es)

8283 stepE s _ = (s, mempty)

8384

8485 stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)

85− stepB s (VarBinder name) = bind s name

86− stepB s (NamedBinder name _) = bind s name

86+ stepB s (VarBinder name) = bindName s name

87+ stepB s (NamedBinder name _) = bindName s name

8788 stepB s _ = (s, mempty)

8889

89− bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

90− bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))

91− | otherwise = (S.insert name s, mempty)

90+ bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

91+ bindName = bind ShadowedName

92+

93+ checkShadowedTypeVars :: Declaration -> MultipleErrors

94+ checkShadowedTypeVars d =

95+ let (f, _, _, _, _) = accumTypes go in f d

96+ where

97+ go :: Type -> MultipleErrors

98+ go = everythingWithContextOnTypes S.empty mempty mappend step

99+ step :: S.Set String -> Type -> (S.Set String, MultipleErrors)

100+ step s (ForAll tv _ _) = bindVar s tv

101+ step s _ = (s, mempty)

102+ bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)

103+ bindVar = bind ShadowedTypeVar

104+

105+ bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors)

106+ bind mkError s name | name `S.member` s = (s, errorMessage (mkError name))

107+ | otherwise = (S.insert name s, mempty)

src/Language/PureScript/Types.hs+15

@@ -312,3 +312,18 @@ everythingOnTypes (<>) f = go

312312 go t@(PrettyPrintObject t1) = f t <> go t1

313313 go t@(PrettyPrintForAll _ t1) = f t <> go t1

314314 go other = f other

315+

316+everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r

317+everythingWithContextOnTypes s0 r0 (<>) f = go' s0

318+ where

319+ go' s t = let (s', r) = f s t in r <> go s' t

320+ go s (TypeApp t1 t2) = go' s t1 <> go' s t2

321+ go s (SaturatedTypeSynonym _ tys) = foldl (<>) r0 (map (go' s) tys)

322+ go s (ForAll _ ty _) = go' s ty

323+ go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty

324+ go s (RCons _ ty rest) = go' s ty <> go' s rest

325+ go s (KindedType ty _) = go' s ty

326+ go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2

327+ go s (PrettyPrintObject t1) = go' s t1

328+ go s (PrettyPrintForAll _ t1) = go' s t1

329+ go _ _ = r0