0f5cf75 · rowtype-yoga/purescript-native

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

on golang help sign in

Warnings for missing top-level type declarations, fix #1333

0f5cf75Phil Freeman11 years ago

src/Language/PureScript/Errors.hs+8

compare with golang

unifiedsplit

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

141 | ShadowedTypeVar String

142 | UnusedTypeVar String

143 | WildcardInferredType Type

144+ | MissingTypeDeclaration Ident

144 | NotExhaustivePattern [[Binder]] Bool

145 | NotExhaustivePattern [[Binder]] Bool

145 | OverlappingPattern [[Binder]] Bool

146 | OverlappingPattern [[Binder]] Bool

146 | IncompleteExhaustivityCheck

147 | IncompleteExhaustivityCheck

@@ -279,6 +280,7 @@ errorCode em = case unwrapErrorMessage em of

279 ShadowedTypeVar{} -> "ShadowedTypeVar"

280 ShadowedTypeVar{} -> "ShadowedTypeVar"

280 UnusedTypeVar{} -> "UnusedTypeVar"

281 UnusedTypeVar{} -> "UnusedTypeVar"

281 WildcardInferredType{} -> "WildcardInferredType"

282 WildcardInferredType{} -> "WildcardInferredType"

283+ MissingTypeDeclaration{} -> "MissingTypeDeclaration"

282 NotExhaustivePattern{} -> "NotExhaustivePattern"

284 NotExhaustivePattern{} -> "NotExhaustivePattern"

283 OverlappingPattern{} -> "OverlappingPattern"

285 OverlappingPattern{} -> "OverlappingPattern"

284 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

286 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

@@ -660,6 +662,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

660 paras [ line "The wildcard type definition has the inferred type "

662 paras [ line "The wildcard type definition has the inferred type "

661 , indent $ typeAsBox ty

663 , indent $ typeAsBox ty

662 ]

664 ]

665+ renderSimpleErrorMessage (MissingTypeDeclaration ident) =

666+ paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

667+ , line "It is good practice to provide type declarations as a form of documentation."

668+ , line "Consider using a type wildcard to display the inferred type:"

669+ , indent $ line $ showIdent ident ++ " :: _"

670+ ]

663 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

671 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

664 paras $ [ line "A case expression could not be determined to cover all inputs."

672 paras $ [ line "A case expression could not be determined to cover all inputs."

665 , line "The following additional cases are required to cover all inputs:\n"

673 , line "The following additional cases are required to cover all inputs:\n"

src/Language/PureScript/Sugar/TypeDeclarations.hs+33−30

@@ -15,10 +15,10 @@

15-----------------------------------------------------------------------------

17{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE ScopedTypeVariables #-}

18{-# LANGUAGE CPP #-}

19{-# LANGUAGE CPP #-}

20module Language.PureScript.Sugar.TypeDeclarations (

21module Language.PureScript.Sugar.TypeDeclarations (

21− desugarTypeDeclarations,

22 desugarTypeDeclarationsModule

23) where

@@ -27,6 +27,7 @@ import Control.Applicative

27#endif

28import Control.Monad (forM)

29import Control.Monad.Error.Class (MonadError(..))

30+import Control.Monad.Writer.Class (MonadWriter(tell))

31import Language.PureScript.AST

32import Language.PureScript.AST

32import Language.PureScript.Names

33import Language.PureScript.Names

@@ -37,36 +38,38 @@ import Language.PureScript.Traversals

37-- |

38-- |

38-- Replace all top level type declarations in a module with type annotations

39-- Replace all top level type declarations in a module with type annotations

39--

40--

40−desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

41+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

41desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

42desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

42 rethrow (addHint (ErrorInModule name)) $

43 rethrow (addHint (ErrorInModule name)) $

43 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

44 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

44−

45−-- |

46−-- Replace all top level type declarations with type annotations

47−--

48−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

49−desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

50− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

51− return (PositionedDeclaration pos com d' : ds')

52−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

53− (_, nameKind, val) <- fromValueDeclaration d

54− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

55 where

45 where

46+

47+ desugarTypeDeclarations :: [Declaration] -> m [Declaration]

48+ desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

50+ return (PositionedDeclaration pos com d' : ds')

51+ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

52+ (_, nameKind, val) <- fromValueDeclaration d

53+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

54+ where

56− fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)

55+ fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

57− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

56+ fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

58− fromValueDeclaration (PositionedDeclaration pos com d') = do

57+ fromValueDeclaration (PositionedDeclaration pos com d') = do

59− (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

58+ (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

60− return (ident, nameKind, PositionedValue pos com val)

59+ return (ident, nameKind, PositionedValue pos com val)

61− fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

60+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

62−desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

61+ desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

63−desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

62+ desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

63+ case val of

64+ Right TypedValue{} -> return ()

65+ Left _ -> error "desugarTypeDeclarations: cases were not desugared"

66+ _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

64− let (_, f, _) = everywhereOnValuesTopDownM return go return

67+ let (_, f, _) = everywhereOnValuesTopDownM return go return

65− f' (Left gs) = Left <$> mapM (pairM return f) gs

68+ f' (Left gs) = Left <$> mapM (pairM return f) gs

66− f' (Right v) = Right <$> f v

69+ f' (Right v) = Right <$> f v

67− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

70+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

68− where

71+ where

69− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

72+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

70− go other = return other

73+ go other = return other

71−desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

74+ desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

72−desugarTypeDeclarations [] = return []

75+ desugarTypeDeclarations [] = return []