827d2ca · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1464 from purescript/typevar-warnings

827d2caGary Burgess11 years ago

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

compare with golang

unifiedsplit

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

140 | InvalidInstanceHead Type

141 | TransitiveExportError DeclarationRef [DeclarationRef]

142 | ShadowedName Ident

143+ | ShadowedTypeVar String

144+ | UnusedTypeVar String

143 | WildcardInferredType Type

145 | WildcardInferredType Type

144 | NotExhaustivePattern [[Binder]] Bool

146 | NotExhaustivePattern [[Binder]] Bool

145 | OverlappingPattern [[Binder]] Bool

147 | OverlappingPattern [[Binder]] Bool

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

168 | ErrorInDataBindingGroup ErrorMessage

170 | ErrorInDataBindingGroup ErrorMessage

169 | ErrorInTypeSynonym ProperName ErrorMessage

171 | ErrorInTypeSynonym ProperName ErrorMessage

170 | ErrorInValueDeclaration Ident ErrorMessage

172 | ErrorInValueDeclaration Ident ErrorMessage

173+ | ErrorInTypeDeclaration Ident ErrorMessage

171 | ErrorInForeignImport Ident ErrorMessage

174 | ErrorInForeignImport Ident ErrorMessage

172 | PositionedError SourceSpan ErrorMessage

175 | PositionedError SourceSpan ErrorMessage

173 | SimpleErrorWrapper SimpleErrorMessage

176 | SimpleErrorWrapper SimpleErrorMessage

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

266 InvalidInstanceHead{} -> "InvalidInstanceHead"

269 InvalidInstanceHead{} -> "InvalidInstanceHead"

267 TransitiveExportError{} -> "TransitiveExportError"

270 TransitiveExportError{} -> "TransitiveExportError"

268 ShadowedName{} -> "ShadowedName"

271 ShadowedName{} -> "ShadowedName"

272+ ShadowedTypeVar{} -> "ShadowedTypeVar"

273+ UnusedTypeVar{} -> "UnusedTypeVar"

269 WildcardInferredType{} -> "WildcardInferredType"

274 WildcardInferredType{} -> "WildcardInferredType"

270 NotExhaustivePattern{} -> "NotExhaustivePattern"

275 NotExhaustivePattern{} -> "NotExhaustivePattern"

271 OverlappingPattern{} -> "OverlappingPattern"

276 OverlappingPattern{} -> "OverlappingPattern"

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

336 (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err

341 (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err

337 (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err

342 (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err

338 (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err

343 (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err

344+ (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err

339 (ErrorInferringType _ err) -> unwrapErrorMessage err

345 (ErrorInferringType _ err) -> unwrapErrorMessage err

340 (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err

346 (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err

341 (NotYetDefined _ err) -> unwrapErrorMessage err

347 (NotYetDefined _ err) -> unwrapErrorMessage err

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

629 : map (line . prettyPrintExport) ys

636 : map (line . prettyPrintExport) ys

630 goSimple (ShadowedName nm) =

637 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"

632 goSimple (ClassOperator className opName) =

643 goSimple (ClassOperator className opName) =

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

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

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

645 , 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

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

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

733 , go err

744 , go err

734 ]

745 ]

746+ go (ErrorInTypeDeclaration n err) =

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

748+ , go err

749+ ]

735 go (ErrorInForeignImport nm err) =

750 go (ErrorInForeignImport nm err) =

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

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

737 , go err

752 , go err

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

797 unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)

812 unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

22−import Data.List (mapAccumL, nub)

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

23import Data.Maybe (mapMaybe)

24import Data.Monoid

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

33import Language.PureScript.AST

34import Language.PureScript.Names

35import Language.PureScript.Errors

36+import Language.PureScript.Types

36import Language.PureScript.Linter.Exhaustive as L

37import Language.PureScript.Linter.Exhaustive as L

38-- | Lint the PureScript AST.

39-- | Lint the PureScript AST.

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

60 f' :: Declaration -> MultipleErrors

61 f' :: Declaration -> MultipleErrors

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

62 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

64 in tell (f' d)

67 in tell (f' d)

65 where

68 where

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

75 stepD s _ = (s, mempty)

78 stepD s _ = (s, mempty)

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

80 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

79 stepE s (Let ds' _) =

82 stepE s (Let ds' _) =

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

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

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

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

82 stepE s _ = (s, mempty)

85 stepE s _ = (s, mempty)

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

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

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

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

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

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

87 stepB s _ = (s, mempty)

90 stepB s _ = (s, mempty)

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

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)

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

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

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

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

src/Language/PureScript/Types.hs+15

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

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

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

314 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