82a2649 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #1534

82a2649Phil 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+12−17

@@ -41,16 +41,16 @@ import Language.PureScript.Traversals

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

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

43 rethrow (addHint (ErrorInModule name)) $

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

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

45 where

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

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

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

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

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

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

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

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

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

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

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

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

54 where

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

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

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

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

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

60 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

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

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

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

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

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

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

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

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

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

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

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

72 where

67 where

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

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

74 go other = return other

69 go other = return other

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

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

76− desugarTypeDeclarations _ [] = return []

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