0e6bfae · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1555 from purescript/1534

0e6bfaePhil Freeman11 years ago

src/Language/PureScript/Errors.hs+4−4

compare with golang

unifiedsplit

@@ -142,7 +142,7 @@ data SimpleErrorMessage

142 | ShadowedTypeVar String

143 | UnusedTypeVar String

144 | WildcardInferredType Type

145− | MissingTypeDeclaration Ident

145+ | MissingTypeDeclaration Ident Type

146 | NotExhaustivePattern [[Binder]] Bool

147 | OverlappingPattern [[Binder]] Bool

148 | IncompleteExhaustivityCheck

@@ -666,11 +666,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

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

667 , indent $ typeAsBox ty

668 ]

669− renderSimpleErrorMessage (MissingTypeDeclaration ident) =

669+ renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

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

672− , line "Consider using a type wildcard to display the inferred type:"

672+ , line $ "The inferred type of " ++ showIdent ident ++ " was:"

673− , indent $ line $ showIdent ident ++ " :: _"

673+ , indent $ typeAsBox ty

674 ]

675 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

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

src/Language/PureScript/Sugar/TypeDeclarations.hs+14−20

@@ -25,9 +25,8 @@ module Language.PureScript.Sugar.TypeDeclarations (

25#if __GLASGOW_HASKELL__ < 710

26import Control.Applicative

27#endif

28−import Control.Monad (forM, when)

28+import Control.Monad (forM)

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

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

32import Language.PureScript.AST

31import Language.PureScript.AST

33import Language.PureScript.Names

32import Language.PureScript.Names

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

38-- |

37-- |

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

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

40--

39--

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

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

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

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

43 rethrow (addHint (ErrorInModule name)) $

42 rethrow (addHint (ErrorInModule name)) $

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

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

45 where

44 where

47− desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]

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

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

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

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

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

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

49 return (PositionedDeclaration pos com d' : ds')

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

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

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

51 (_, nameKind, val) <- fromValueDeclaration d

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

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

54 where

53 where

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

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

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

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

@@ -58,19 +57,14 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

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

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

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

58 return (ident, nameKind, PositionedValue pos com val)

60 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

59 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

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

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

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

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

63− -- At the top level, match a type signature or emit a warning.

64− when reqd $ case val of

65− Right TypedValue{} -> return ()

66− Left _ -> error "desugarTypeDeclarations: cases were not desugared"

67− _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

68 let (_, f, _) = everywhereOnValuesTopDownM return go return

62 let (_, f, _) = everywhereOnValuesTopDownM return go return

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

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

70 f' (Right v) = Right <$> f v

64 f' (Right v) = Right <$> f v

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

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

72 where

66 where

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

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

74 go other = return other

68 go other = return other

75− desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds

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

76− desugarTypeDeclarations _ [] = return []

70+ desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker/Types.hs+3

@@ -50,6 +50,7 @@ import Control.Monad

50import Control.Monad.State

51import Control.Monad.Unify

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

53+import Control.Monad.Writer.Class (tell)

54import Language.PureScript.AST

55import Language.PureScript.AST

55import Language.PureScript.Environment

56import Language.PureScript.Environment

@@ -93,6 +94,7 @@ typesOf moduleName vals = do

93 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

94 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

94 -- Replace all the wildcards types with their inferred types

95 -- Replace all the wildcards types with their inferred types

95 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

96 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

97+ replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty))

96 replace _ em = em

98 replace _ em = em

98type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

100type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

@@ -139,6 +141,7 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do

139 -- Infer the type with the new names in scope

141 -- Infer the type with the new names in scope

140 TypedValue _ val' ty <- bindNames dict $ infer val

142 TypedValue _ val' ty <- bindNames dict $ infer val

141 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

143 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

144+ tell . errorMessage $ MissingTypeDeclaration ident ty

142 return (ident, (TypedValue True val' ty, ty))

145 return (ident, (TypedValue True val' ty, ty))

143

146

144-- |

147-- |