03fc48b · rowtype-yoga/purescript-native

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

on golang help sign in

Typechecker error messages

03fc48bPhil Freeman12 years ago

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

compare with golang

unifiedsplit

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

77 | ConstrainedTypeUnified Type Type

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

79 | NoInstanceFound (Qualified ProperName) [Type]

80− | DuplicateLabel String Expr

80+ | DuplicateLabel String (Maybe Expr)

81 | DuplicateValueDeclaration Ident

82 | ArgListLengthsDiffer Ident

83− | OverlappingArgNames Ident

83+ | OverlappingArgNames (Maybe Ident)

84 | MissingClassMember Ident

85+ | ExpectedType Kind

86+ | IncorrectConstructorArity (Qualified ProperName)

87+ | SubsumptionCheckFailed

88+ | ExprDoesNotHaveType Expr Type

89+ | PropertyIsMissing String Type

85 | ErrorUnifyingTypes Type Type ErrorMessage

90 | ErrorUnifyingTypes Type Type ErrorMessage

91+ | CannotApplyFunction Type Expr

86 | ErrorInExpression Expr ErrorMessage

92 | ErrorInExpression Expr ErrorMessage

87 | ErrorInModule ModuleName ErrorMessage

93 | ErrorInModule ModuleName ErrorMessage

88 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

94 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

89 | ErrorInSubsumption Type Type ErrorMessage

95 | ErrorInSubsumption Type Type ErrorMessage

96+ | ErrorCheckingType Expr Type ErrorMessage

90 | ErrorCheckingKind Type ErrorMessage

97 | ErrorCheckingKind Type ErrorMessage

98+ | ErrorInferringType Expr ErrorMessage

99+ | ErrorInApplication Expr Type Expr ErrorMessage

91 | PositionedError SourceSpan ErrorMessage

100 | PositionedError SourceSpan ErrorMessage

92 deriving (Show)

101 deriving (Show)

102

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

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

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

142 : map prettyPrintDictionaryValue ds)

151 : map prettyPrintDictionaryValue ds)

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

152prettyPrintErrorMessage (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

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

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

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

155prettyPrintErrorMessage (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

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

157prettyPrintErrorMessage (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

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

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

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

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

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

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

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

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

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

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

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

169prettyPrintErrorMessage (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

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

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

156

174

157-- |

175-- |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

215 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

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

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

95 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

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

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

99 let tuples = map toTuple ds

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

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

53 checkDups r@RCons{} =

54 let (ls, _) = rowToList r in

55 case firstDup . sort . map fst $ ls of

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

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

57 Nothing -> return ()

58 checkDups _ = return ()

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

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

39import Data.List

40import Data.Maybe (fromMaybe)

41import qualified Data.Map as M

42−import Data.String (IsString)

44import Control.Applicative

43import Control.Applicative

45import Control.Monad.Except

44import Control.Monad.Except

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

51import Language.PureScript.Errors

50import Language.PureScript.Errors

52import Language.PureScript.Kinds

51import Language.PureScript.Kinds

53import Language.PureScript.Names

52import Language.PureScript.Names

54−import Language.PureScript.Pretty

55import Language.PureScript.Traversals

53import Language.PureScript.Traversals

56import Language.PureScript.TypeChecker.Entailment

54import Language.PureScript.TypeChecker.Entailment

57import Language.PureScript.TypeChecker.Kinds

55import Language.PureScript.TypeChecker.Kinds

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

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

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

185--

183--

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

184checkTypeKind :: 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

188

186

189-- |

187-- |

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

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

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

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

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

208--

206--

209infer :: Expr -> UnifyT Type Check Expr

207infer :: 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

211

209

212-- |

210-- |

213-- Infer a type for a value

211-- Infer a type for a value

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

269infer' v@(Constructor c) = do

267infer' v@(Constructor c) = do

270 env <- getEnv

268 env <- getEnv

271 case M.lookup c (dataConstructors env) of

269 case M.lookup c (dataConstructors env) of

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

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

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

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

274 return $ TypedValue True v' ty'

272 return $ TypedValue True v' ty'

275infer' (Case vals binders) = do

273infer' (Case vals binders) = do

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

365 return M.empty

363 return M.empty

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

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

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

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

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

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

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

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

370inferBinder val (ObjectBinder props) = do

368inferBinder val (ObjectBinder props) = do

371 row <- fresh

369 row <- fresh

372 rest <- fresh

370 rest <- fresh

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

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

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

405checkBinders _ _ [] = return []

403checkBinders _ _ [] = return []

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

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

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

405+ guardWith (errorMessage $ OverlappingArgNames Nothing) $

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

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

409 Just moduleName <- checkCurrentModule <$> get

407 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

428--

426--

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

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

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

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

431− where

432− errorMessage =

433− "Error checking type of term " ++

434− prettyPrintValue val ++

435− " against type " ++

436− prettyPrintType ty

437

429

438-- |

430-- |

439-- Check the type of a value

431-- Check the type of a value

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

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

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

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

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

492 case v' of

484 case v' of

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

485+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

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

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

495check' (SuperClassDictionary className tys) _ = do

487check' (SuperClassDictionary className tys) _ = do

496 {-

488 {-

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

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

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

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

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

515 case val' of

507 case val' of

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

508+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

517 Just val'' -> do

509 Just val'' -> do

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

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

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

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

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

551check' (Constructor c) ty = do

543check' (Constructor c) ty = do

552 env <- getEnv

544 env <- getEnv

553 case M.lookup c (dataConstructors env) of

545 case M.lookup c (dataConstructors env) of

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

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

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

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

556 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

548 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

557 _ <- subsumes Nothing repl ty

549 _ <- subsumes Nothing repl ty

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

568 return $ TypedValue True val' kt

560 return $ TypedValue True val' kt

569check' (PositionedValue pos _ val) ty =

561check' (PositionedValue pos _ val) ty =

570 rethrowWithPosition pos $ check' val ty

562 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

572

564

573containsTypeSynonyms :: Type -> Bool

565containsTypeSynonyms :: Type -> Bool

574containsTypeSynonyms = everythingOnTypes (||) go where

566containsTypeSynonyms = everythingOnTypes (||) go where

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

589 return []

581 return []

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

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

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

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

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

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

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

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

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

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

595 case lookup p ts of

587 case lookup p ts of

596 Nothing -> do

588 Nothing -> do

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

603 v' <- check v ty

595 v' <- check v ty

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

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

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

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

607

599

608-- |

600-- |

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

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

610--

602--

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

603checkFunctionApplication :: 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

613 subst <- unifyCurrentSubstitution <$> UnifyT get

605 subst <- unifyCurrentSubstitution <$> UnifyT get

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

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

615− where

616− errorMessage = "Error applying function of type "

617− ++ prettyPrintType fnTy

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

619

607

620-- |

608-- |

621-- Check the type of a function application

609-- Check the type of a function application

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

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

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

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

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

653 return (fnTy, App fn dict)

641 return (fnTy, App fn dict)

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

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

655− ++ prettyPrintType fnTy

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

657

643

658-- |

644-- |

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

645-- 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

673-- |

659-- |

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

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

675--

661--

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

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

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

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