827d2ca · rowtype-yoga/purescript-native

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

Merge pull request #1464 from purescript/typevar-warnings

Typevar warnings

commit827d2ca96cf352fa88499c05c6745d488bdb18cb authorGary Burgess <gary.burgess@gmail.com> dateMon 14 Sep 2015, 11:36 (11 years ago) parente2385f4 ab73d58

3 files changed+69−10

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+17−1 src/Language/PureScript/Linter.hs+37−9 src/Language/PureScript/Types.hs+15

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

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

140140 | InvalidInstanceHead Type

141141 | TransitiveExportError DeclarationRef [DeclarationRef]

142142 | ShadowedName Ident

143+ | ShadowedTypeVar String

144+ | UnusedTypeVar String

143145 | WildcardInferredType Type

144146 | NotExhaustivePattern [[Binder]] Bool

145147 | OverlappingPattern [[Binder]] Bool

@@ -168,6 +170,7 @@ data ErrorMessage

168170 | ErrorInDataBindingGroup ErrorMessage

169171 | ErrorInTypeSynonym ProperName ErrorMessage

170172 | ErrorInValueDeclaration Ident ErrorMessage

173+ | ErrorInTypeDeclaration Ident ErrorMessage

171174 | ErrorInForeignImport Ident ErrorMessage

172175 | PositionedError SourceSpan ErrorMessage

173176 | SimpleErrorWrapper SimpleErrorMessage

@@ -266,6 +269,8 @@ errorCode em = case unwrapErrorMessage em of

266269 InvalidInstanceHead{} -> "InvalidInstanceHead"

267270 TransitiveExportError{} -> "TransitiveExportError"

268271 ShadowedName{} -> "ShadowedName"

272+ ShadowedTypeVar{} -> "ShadowedTypeVar"

273+ UnusedTypeVar{} -> "UnusedTypeVar"

269274 WildcardInferredType{} -> "WildcardInferredType"

270275 NotExhaustivePattern{} -> "NotExhaustivePattern"

271276 OverlappingPattern{} -> "OverlappingPattern"

@@ -336,6 +341,7 @@ unwrapErrorMessage em = case em of

336341 (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err

337342 (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err

338343 (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err

344+ (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err

339345 (ErrorInferringType _ err) -> unwrapErrorMessage err

340346 (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err

341347 (NotYetDefined _ err) -> unwrapErrorMessage err

@@ -382,6 +388,7 @@ onTypesInErrorMessageM f = g

382388 g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)

383389 g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)

384390 g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)

391+ g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e)

385392 g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)

386393 g (PositionedError x e) = PositionedError x <$> (g e)

387394 g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem

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

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

629636 : map (line . prettyPrintExport) ys

630637 goSimple (ShadowedName nm) =

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

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

639+ goSimple (ShadowedTypeVar tv) =

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

641+ goSimple (UnusedTypeVar tv) =

642+ line $ "Type variable '" ++ tv ++ "' was declared but not used"

632643 goSimple (ClassOperator className opName) =

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

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

@@ -732,6 +743,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

732743 paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"

733744 , go err

734745 ]

746+ go (ErrorInTypeDeclaration n err) =

747+ paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"

748+ , go err

749+ ]

735750 go (ErrorInForeignImport nm err) =

736751 paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"

737752 , go err

@@ -797,6 +812,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

797812 unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)

798813 unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)

799814 unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)

815+ unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err)

800816 unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)

801817 unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)

802818 unwrap _ (PositionedError pos err) = unwrap (Just pos) err

src/Language/PureScript/Linter.hs+37−9

@@ -19,7 +19,7 @@

1919

2020module Language.PureScript.Linter (lint, module L) where

2121

22−import Data.List (mapAccumL, nub)

22+import Data.List (mapAccumL, nub, (\\))

2323import Data.Maybe (mapMaybe)

2424import Data.Monoid

2525

@@ -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,9 @@ 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@(ValueDeclaration name _ _ _) = onErrorMessages (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)

64+ f' (TypeDeclaration name ty) = onErrorMessages (ErrorInTypeDeclaration name) (checkTypeVars ty)

65+ f' dec = f dec <> checkTypeVarsInDecl dec

6366

6467 in tell (f' d)

6568 where

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

7578 stepD s _ = (s, mempty)

7679

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

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

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

7982 stepE s (Let ds' _) =

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

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

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

8285 stepE s _ = (s, mempty)

8386

8487 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

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

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

8790 stepB s _ = (s, mempty)

8891

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)

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

93+ bindName = bind ShadowedName

94+

95+ checkTypeVarsInDecl :: Declaration -> MultipleErrors

96+ checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d

97+

98+ checkTypeVars :: Type -> MultipleErrors

99+ checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty

100+ where

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

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

103+ step s _ = (s, mempty)

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

105+ bindVar = bind ShadowedTypeVar

106+ findUnused :: Type -> MultipleErrors

107+ findUnused ty' =

108+ let used = usedTypeVariables ty'

109+ declared = everythingOnTypes (++) go ty'

110+ unused = nub declared \\ nub used

111+ in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused

112+ where

113+ go :: Type -> [String]

114+ go (ForAll tv _ _) = [tv]

115+ go _ = []

116+

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

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

119+ | 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