03fc48b · rowtype-yoga/purescript-native

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

Typechecker error messages

commit03fc48b94634c6c40dc4d16035a8a82a500361ed authorPhil Freeman <paf31@cantab.net> dateSun 22 Feb 2015, 15:53 (12 years ago) parent339a494

4 files changed+48−38

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+24−4 src/Language/PureScript/Sugar/CaseDeclarations.hs+1−1 src/Language/PureScript/TypeChecker/Rows.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+22−32

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

@@ -77,17 +77,26 @@ data ErrorMessage

7777 | ConstrainedTypeUnified Type Type

7878 | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]

7979 | NoInstanceFound (Qualified ProperName) [Type]

80− | DuplicateLabel String Expr

80+ | DuplicateLabel String (Maybe Expr)

8181 | DuplicateValueDeclaration Ident

8282 | ArgListLengthsDiffer Ident

83− | OverlappingArgNames Ident

83+ | OverlappingArgNames (Maybe Ident)

8484 | MissingClassMember Ident

85+ | ExpectedType Kind

86+ | IncorrectConstructorArity (Qualified ProperName)

87+ | SubsumptionCheckFailed

88+ | ExprDoesNotHaveType Expr Type

89+ | PropertyIsMissing String Type

8590 | ErrorUnifyingTypes Type Type ErrorMessage

91+ | CannotApplyFunction Type Expr

8692 | ErrorInExpression Expr ErrorMessage

8793 | ErrorInModule ModuleName ErrorMessage

8894 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

8995 | ErrorInSubsumption Type Type ErrorMessage

96+ | ErrorCheckingType Expr Type ErrorMessage

9097 | ErrorCheckingKind Type ErrorMessage

98+ | ErrorInferringType Expr ErrorMessage

99+ | ErrorInApplication Expr Type Expr ErrorMessage

91100 | PositionedError SourceSpan ErrorMessage

92101 deriving (Show)

93102

@@ -141,17 +150,26 @@ prettyPrintErrorMessage (ConstrainedTypeUnified t1 t2) = "Cannot unify constrai

141150prettyPrintErrorMessage (OverlappingInstances nm ts ds) = unlines (("Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintType ts) ++ ":")

142151 : map prettyPrintDictionaryValue ds)

143152prettyPrintErrorMessage (NoInstanceFound nm ts) = "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

144−prettyPrintErrorMessage (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row. Relevant expression: " ++ prettyPrintValue expr

153+prettyPrintErrorMessage (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row." ++ foldMap ((" Relevant expression: " ++) . prettyPrintValue) expr

145154prettyPrintErrorMessage (DuplicateValueDeclaration nm) = "Duplicate value declaration for " ++ show nm

146155prettyPrintErrorMessage (ArgListLengthsDiffer ident) = "Argument list lengths differ in declaration " ++ show ident

147−prettyPrintErrorMessage (OverlappingArgNames ident) = "Overlapping function argument names in declaration" ++ show ident

156+prettyPrintErrorMessage (OverlappingArgNames ident) = "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident

148157prettyPrintErrorMessage (MissingClassMember ident) = "Member " ++ show ident ++ " has not been implemented"

158+prettyPrintErrorMessage (ExpectedType kind) = "Expected type of kind *, was " ++ prettyPrintKind kind

159+prettyPrintErrorMessage (IncorrectConstructorArity nm) = "Wrong number of arguments to constructor " ++ show nm

160+prettyPrintErrorMessage SubsumptionCheckFailed = "Unable to check type subsumption"

161+prettyPrintErrorMessage (ExprDoesNotHaveType expr ty) = "Expression " ++ prettyPrintValue expr ++ " does not have type " ++ prettyPrintType ty

162+prettyPrintErrorMessage (PropertyIsMissing prop row) = "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop

163+prettyPrintErrorMessage (CannotApplyFunction fn arg) = "Cannot apply function of type " ++ prettyPrintType fn ++ " to argument " ++ prettyPrintValue arg

149164prettyPrintErrorMessage (ErrorUnifyingTypes t1 t2 err) = "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ prettyPrintErrorMessage err

150165prettyPrintErrorMessage (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err

151166prettyPrintErrorMessage (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ prettyPrintErrorMessage err

152167prettyPrintErrorMessage (ErrorInSubsumption t1 t2 err) = "Error checking that type " ++ prettyPrintType t1 ++ " subsumes type " ++ prettyPrintType t2 ++ ":\n" ++ prettyPrintErrorMessage err

153168prettyPrintErrorMessage (ErrorInInstance name ts err) = "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":\n" ++ prettyPrintErrorMessage err

154169prettyPrintErrorMessage (ErrorCheckingKind ty err) = "Error checking kind of type " ++ prettyPrintType ty ++ ":\n" ++ prettyPrintErrorMessage err

170+prettyPrintErrorMessage (ErrorInferringType expr err) = "Error inferring type of value " ++ prettyPrintValue expr ++ ":\n" ++ prettyPrintErrorMessage err

171+prettyPrintErrorMessage (ErrorCheckingType expr ty err) = "Error checking value " ++ prettyPrintValue expr ++ " has type " ++ prettyPrintType ty ++ ":\n" ++ prettyPrintErrorMessage err

172+prettyPrintErrorMessage (ErrorInApplication f t a err) = "Error applying function " ++ prettyPrintValue f ++ " of type " ++ prettyPrintType t ++ " to argument " ++ prettyPrintValue a ++ ":\n" ++ prettyPrintErrorMessage err

155173prettyPrintErrorMessage (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ prettyPrintErrorMessage err

156174

157175-- |

@@ -190,6 +208,8 @@ simplifyErrorMessage = unwrap Nothing

190208 unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)

191209 unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)

192210 unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err

211+ unwrap pos (ErrorInferringType _ err) = unwrap pos err

212+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err

193213 unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)

194214 unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)

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

src/Language/PureScript/Sugar/CaseDeclarations.hs+1−1

@@ -93,7 +93,7 @@ toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m

9393toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

9494 let args = map (\(VarBinder arg) -> arg) bs

9595 body = foldr (Abs . Left) val args

96− guardWith (errorMessage (OverlappingArgNames ident)) $ length (nub args) == length args

96+ guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args

9797 return [ValueDeclaration ident nameKind [] (Right body)]

9898toDecls ds@(ValueDeclaration ident _ bs result : _) = do

9999 let tuples = map toTuple ds

src/Language/PureScript/TypeChecker/Rows.hs+1−1

@@ -53,7 +53,7 @@ checkDuplicateLabels =

5353 checkDups r@RCons{} =

5454 let (ls, _) = rowToList r in

5555 case firstDup . sort . map fst $ ls of

56− Just l -> throwError . errorMessage $ DuplicateLabel l val

56+ Just l -> throwError . errorMessage $ DuplicateLabel l (Just val)

5757 Nothing -> return ()

5858 checkDups _ = return ()

5959

src/Language/PureScript/TypeChecker/Types.hs+22−32

@@ -39,7 +39,6 @@ import Data.Either (lefts, rights)

3939import Data.List

4040import Data.Maybe (fromMaybe)

4141import qualified Data.Map as M

42−import Data.String (IsString)

4342

4443import Control.Applicative

4544import Control.Monad.Except

@@ -51,7 +50,6 @@ import Language.PureScript.Environment

5150import Language.PureScript.Errors

5251import Language.PureScript.Kinds

5352import Language.PureScript.Names

54−import Language.PureScript.Pretty

5553import Language.PureScript.Traversals

5654import Language.PureScript.TypeChecker.Entailment

5755import Language.PureScript.TypeChecker.Kinds

@@ -184,7 +182,7 @@ replaceTypeClassDictionaries mn =

184182-- Check the kind of a type, failing if it is not of kind *.

185183--

186184checkTypeKind :: Kind -> UnifyT t Check ()

187−checkTypeKind kind = guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

185+checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star

188186

189187-- |

190188-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

@@ -207,7 +205,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

207205-- Infer a type for a value, rethrowing any error to provide a more useful error message

208206--

209207infer :: Expr -> UnifyT Type Check Expr

210−infer val = rethrow (mkCompileError "Error inferring type of value" (Just (ExprError val)) `combineErrors`) $ infer' val

208+infer val = rethrow (onErrorMessages (ErrorInferringType val)) $ infer' val

211209

212210-- |

213211-- Infer a type for a value

@@ -269,7 +267,7 @@ infer' (Var var) = do

269267infer' v@(Constructor c) = do

270268 env <- getEnv

271269 case M.lookup c (dataConstructors env) of

272− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

270+ Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

273271 Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

274272 return $ TypedValue True v' ty'

275273infer' (Case vals binders) = do

@@ -365,8 +363,8 @@ inferBinder val (ConstructorBinder ctor binders) = do

365363 return M.empty

366364 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

367365 M.union <$> inferBinder obj binder <*> go binders' ret

368− go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor

369− _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"

366+ go _ _ = throwError . errorMessage $ IncorrectConstructorArity ctor

367+ _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing

370368inferBinder val (ObjectBinder props) = do

371369 row <- fresh

372370 rest <- fresh

@@ -404,7 +402,7 @@ inferBinder val (PositionedBinder pos _ binder) =

404402checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]

405403checkBinders _ _ [] = return []

406404checkBinders nvals ret (CaseAlternative binders result : bs) = do

407− guardWith (strMsg "Overlapping binders in case statement") $

405+ guardWith (errorMessage $ OverlappingArgNames Nothing) $

408406 let ns = concatMap binderNames binders in length (nub ns) == length ns

409407 Just moduleName <- checkCurrentModule <$> get

410408 m1 <- M.unions <$> zipWithM inferBinder nvals binders

@@ -427,13 +425,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

427425-- Check the type of a value, rethrowing errors to provide a better error message

428426--

429427check :: Expr -> Type -> UnifyT Type Check Expr

430−check val ty = rethrow (mkCompileError errorMessage (Just (ExprError val)) `combineErrors`) $ check' val ty

431− where

432− errorMessage =

433− "Error checking type of term " ++

434− prettyPrintValue val ++

435− " against type " ++

436− prettyPrintType ty

428+check val ty = rethrow (onErrorMessages (ErrorCheckingType val ty)) $ check' val ty

437429

438430-- |

439431-- Check the type of a value

@@ -490,7 +482,7 @@ check' v@(Var var) ty = do

490482 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

491483 v' <- subsumes (Just v) repl ty'

492484 case v' of

493− Nothing -> throwError . strMsg $ "Unable to check type subsumption"

485+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

494486 Just v'' -> return $ TypedValue True v'' ty'

495487check' (SuperClassDictionary className tys) _ = do

496488 {-

@@ -513,7 +505,7 @@ check' (TypedValue checkType val ty1) ty2 = do

513505 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

514506 val' <- subsumes (Just val) ty1' ty2'

515507 case val' of

516− Nothing -> throwError . strMsg $ "Unable to check type subsumption"

508+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

517509 Just val'' -> do

518510 val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''

519511 return $ TypedValue checkType (TypedValue True val''' ty1') ty2'

@@ -551,7 +543,7 @@ check' (Accessor prop val) ty = do

551543check' (Constructor c) ty = do

552544 env <- getEnv

553545 case M.lookup c (dataConstructors env) of

554− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

546+ Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

555547 Just (_, _, ty1, _) -> do

556548 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

557549 _ <- subsumes Nothing repl ty

@@ -568,7 +560,7 @@ check' val kt@(KindedType ty kind) = do

568560 return $ TypedValue True val' kt

569561check' (PositionedValue pos _ val) ty =

570562 rethrowWithPosition pos $ check' val ty

571−check' val ty = throwError $ mkMultipleErrors ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

563+check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty

572564

573565containsTypeSynonyms :: Type -> Bool

574566containsTypeSynonyms = everythingOnTypes (||) go where

@@ -589,8 +581,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

589581 return []

590582 go [] [] Skolem{} | lax = return []

591583 go [] ((p, _): _) _ | lax = return []

592− | otherwise = throwError $ mkMultipleErrors ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))

593− go ((p,_):_) [] REmpty = throwError $ mkMultipleErrors ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))

584+ | otherwise = throwError . errorMessage $ PropertyIsMissing p row

585+ go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row

594586 go ((p,v):ps') ts r =

595587 case lookup p ts of

596588 Nothing -> do

@@ -603,19 +595,15 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

603595 v' <- check v ty

604596 ps'' <- go ps' (delete (p, ty) ts) r

605597 return $ (p, v') : ps''

606− go _ _ _ = throwError $ mkMultipleErrors ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))

598+ go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)

607599

608600-- |

609601-- Check the type of a function application, rethrowing errors to provide a better error message

610602--

611603checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

612−checkFunctionApplication fn fnTy arg ret = rethrow (mkCompileError errorMessage (Just (ExprError fn)) `combineErrors`) $ do

604+checkFunctionApplication fn fnTy arg ret = rethrow (onErrorMessages (ErrorInApplication fn fnTy arg)) $ do

613605 subst <- unifyCurrentSubstitution <$> UnifyT get

614606 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

615− where

616− errorMessage = "Error applying function of type "

617− ++ prettyPrintType fnTy

618− ++ " to argument " ++ prettyPrintValue arg

619607

620608-- |

621609-- Check the type of a function application

@@ -651,9 +639,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

651639 checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret

652640checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =

653641 return (fnTy, App fn dict)

654−checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "

655− ++ prettyPrintType fnTy

656− ++ " to argument " ++ prettyPrintValue arg

642+checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg

657643

658644-- |

659645-- Compute the meet of two types, i.e. the most general type which both types subsume.

@@ -673,5 +659,9 @@ meet e1 e2 t1 t2 = do

673659-- |

674660-- Ensure a set of property names and value does not contain duplicate labels

675661--

676−ensureNoDuplicateProperties :: (IsString e, MonadError e m) => [(String, Expr)] -> m ()

677−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

662+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()

663+ensureNoDuplicateProperties ps =

664+ let ls = map fst ps in

665+ case ls \\ nub ls of

666+ l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing

667+ _ -> return ()