82a2649 · rowtype-yoga/purescript-native

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

Fix #1534

commit82a2649257ccafa1407bfe2f4e2aabbdae429a28 authorPhil Freeman <paf31@cantab.net> dateFri 23 Oct 2015, 16:12 (11 years ago) parent3794bda

3 files changed+19−21

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+4−4 src/Language/PureScript/Sugar/TypeDeclarations.hs+12−17 src/Language/PureScript/TypeChecker/Types.hs+3

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

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

142142 | ShadowedTypeVar String

143143 | UnusedTypeVar String

144144 | WildcardInferredType Type

145− | MissingTypeDeclaration Ident

145+ | MissingTypeDeclaration Ident Type

146146 | NotExhaustivePattern [[Binder]] Bool

147147 | OverlappingPattern [[Binder]] Bool

148148 | IncompleteExhaustivityCheck

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

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

667667 , indent $ typeAsBox ty

668668 ]

669− renderSimpleErrorMessage (MissingTypeDeclaration ident) =

669+ renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

671671 , 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:"

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

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

673+ , indent $ typeAsBox ty

674674 ]

675675 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

676676 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

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

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

4343 rethrow (addHint (ErrorInModule name)) $

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

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

4545 where

4646

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

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

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

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

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

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

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

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

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

5252 (_, 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)

5454 where

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

5656 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) ->

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

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

6060 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

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

62− desugarTypeDeclarations reqd (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)

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

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

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

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

7065 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

7267 where

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

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

7469 go other = return other

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

76− desugarTypeDeclarations _ [] = return []

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

71+ desugarTypeDeclarations [] = return []

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

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

5050import Control.Monad.State

5151import Control.Monad.Unify

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

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

5354

5455import Language.PureScript.AST

5556import Language.PureScript.Environment

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

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

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

9596 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))

9698 replace _ em = em

9799

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

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

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

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

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

144+ tell . errorMessage $ MissingTypeDeclaration ident ty

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

143146

144147-- |