339a494 · rowtype-yoga/purescript-native

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

More progress on error messages

commit339a4945a8b349b8c1ae0251b0f6e9474b060def authorPhil Freeman <paf31@cantab.net> dateSun 22 Feb 2015, 14:05 (12 years ago) parent38981e8

10 files changed+110−84

compare with golang

unifiedsplit

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

@@ -32,6 +32,7 @@ import Language.PureScript.Pretty

3232import Language.PureScript.Types

3333import Language.PureScript.Names

3434import Language.PureScript.Kinds

35+import Language.PureScript.TypeClassDictionaries

3536

3637-- |

3738-- A type of error messages

@@ -49,6 +50,7 @@ data ErrorMessage

4950 | UnknownTypeClass (Qualified ProperName)

5051 | UnknownValue (Qualified Ident)

5152 | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

53+ | UnknownTypeConstructor (Qualified ProperName)

5254 | ConflictingImport String ModuleName

5355 | ConflictingImports String ModuleName ModuleName

5456 | ConflictingTypeDecls ProperName

@@ -69,8 +71,23 @@ data ErrorMessage

6971 | PartiallyAppliedSynonym (Qualified ProperName)

7072 | NotYetDefined [Ident] ErrorMessage

7173 | EscapedSkolem (Maybe Expr)

74+ | UnspecifiedSkolemScope

75+ | TypesDoNotUnify Type Type

76+ | KindsDoNotUnify Kind Kind

77+ | ConstrainedTypeUnified Type Type

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

79+ | NoInstanceFound (Qualified ProperName) [Type]

80+ | DuplicateLabel String Expr

81+ | DuplicateValueDeclaration Ident

82+ | ArgListLengthsDiffer Ident

83+ | OverlappingArgNames Ident

84+ | MissingClassMember Ident

85+ | ErrorUnifyingTypes Type Type ErrorMessage

7286 | ErrorInExpression Expr ErrorMessage

7387 | ErrorInModule ModuleName ErrorMessage

88+ | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

89+ | ErrorInSubsumption Type Type ErrorMessage

90+ | ErrorCheckingKind Type ErrorMessage

7491 | PositionedError SourceSpan ErrorMessage

7592 deriving (Show)

7693

@@ -87,16 +104,18 @@ prettyPrintErrorMessage :: ErrorMessage -> String

87104prettyPrintErrorMessage InvalidDoBind = "Bind statement cannot be the last statement in a do block"

88105prettyPrintErrorMessage InvalidDoLet = "Let statement cannot be the last statement in a do block"

89106prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

107+prettyPrintErrorMessage UnspecifiedSkolemScope = "Skolem variable scope is unspecified"

90108prettyPrintErrorMessage OverlappingNamesInLet = "Overlapping names in let binding."

91109prettyPrintErrorMessage (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty

92110prettyPrintErrorMessage (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki

93111prettyPrintErrorMessage (MultipleFixities name) = "Multiple fixity declarations for " ++ show name

94112prettyPrintErrorMessage (OrphanTypeDeclaration pn) = "Orphan type declaration for: " ++ show pn

95113prettyPrintErrorMessage (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"

96−prettyPrintErrorMessage (UnknownModule mn) = "Unknown module: " ++ show mn

97−prettyPrintErrorMessage (UnknownType name) = "Unknown type: " ++ show name

98−prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class: " ++ show name

99−prettyPrintErrorMessage (UnknownValue name) = "Unknown value: " ++ show name

114+prettyPrintErrorMessage (UnknownModule mn) = "Unknown module " ++ show mn

115+prettyPrintErrorMessage (UnknownType name) = "Unknown type " ++ show name

116+prettyPrintErrorMessage (UnknownTypeClass name) = "Unknown type class " ++ show name

117+prettyPrintErrorMessage (UnknownValue name) = "Unknown value " ++ show name

118+prettyPrintErrorMessage (UnknownTypeConstructor name) = "Unknown type constructor " ++ show name

100119prettyPrintErrorMessage (UnknownDataConstructor dc tc) = "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc

101120prettyPrintErrorMessage (ConflictingImport nm mn) = "Declaration " ++ nm ++ " conflicts with import " ++ show mn

102121prettyPrintErrorMessage (ConflictingImports nm m1 m2) = "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2

@@ -116,15 +135,49 @@ prettyPrintErrorMessage (NameNotInScope ident) = show ident ++ " may no

116135prettyPrintErrorMessage (UndefinedTypeVariable name) = "Type variable " ++ show name ++ " is undefined"

117136prettyPrintErrorMessage (PartiallyAppliedSynonym name) = "Partially applied type synonym " ++ show name

118137prettyPrintErrorMessage (EscapedSkolem binding) = "Rigid/skolem type variable " ++ foldMap (("bound by " ++) . prettyPrintValue) binding ++ " has escaped."

138+prettyPrintErrorMessage (TypesDoNotUnify t1 t2) = "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2

139+prettyPrintErrorMessage (KindsDoNotUnify k1 k2) = "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2

140+prettyPrintErrorMessage (ConstrainedTypeUnified t1 t2) = "Cannot unify constrained type " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2

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

142+ : map prettyPrintDictionaryValue ds)

143+prettyPrintErrorMessage (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

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

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

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

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

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

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

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

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

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

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

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

122156

157+-- |

158+-- Render a DictionaryValue fit for human consumption in error messages

159+--

160+prettyPrintDictionaryValue :: DictionaryValue -> String

161+prettyPrintDictionaryValue = unlines . indented 0

162+ where

163+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]

164+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]

165+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args

166+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup

167+

168+ spaces n = replicate n ' ' ++ "- "

169+

123170-- |

124171-- A stack trace for an error

125172--

126173newtype MultipleErrors = MultipleErrors

127174 { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

175+

176+instance UnificationError Type MultipleErrors where

177+ occursCheckFailed = errorMessage . occursCheckFailed

178+

179+instance UnificationError Kind MultipleErrors where

180+ occursCheckFailed = errorMessage . occursCheckFailed

128181

129182-- |

130183-- Simplify an error message

@@ -134,6 +187,10 @@ simplifyErrorMessage = unwrap Nothing

134187 where

135188 unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

136189 unwrap pos (ErrorInExpression _ err) = unwrap pos err

190+ 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)

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

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

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

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

139196 unwrap _ (PositionedError pos err) = unwrap (Just pos) err

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

@@ -46,7 +46,7 @@ isLeft (Right _) = False

4646--

4747desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

4848desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->

49− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

49+ rethrow (onErrorMessages (ErrorInModule name)) $

5050 Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

5151

5252desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

@@ -93,14 +93,14 @@ 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 (strMsg "Overlapping function argument names") $ length (nub args) == length args

96+ guardWith (errorMessage (OverlappingArgNames 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

100100 unless (all ((== length bs) . length . fst) tuples) $

101− throwError $ mkMultipleErrors ("Argument list lengths differ in declaration " ++ show ident) Nothing

101+ throwError . errorMessage $ ArgListLengthsDiffer ident

102102 unless (not (null bs) || isLeft result) $

103− throwError $ mkMultipleErrors ("Duplicate value declaration '" ++ show ident ++ "'") Nothing

103+ throwError . errorMessage $ DuplicateValueDeclaration ident

104104 caseDecl <- makeCaseDeclaration ident tuples

105105 return [caseDecl]

106106toDecls (PositionedDeclaration pos com d : ds) = do

src/Language/PureScript/Sugar/TypeClasses.hs+4−5

@@ -27,7 +27,6 @@ import Language.PureScript.Environment

2727import Language.PureScript.Errors

2828import Language.PureScript.Kinds

2929import Language.PureScript.Names

30−import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)

3130import Language.PureScript.Sugar.CaseDeclarations

3231import Control.Monad.Supply.Class

3332import Language.PureScript.Types

@@ -226,16 +225,16 @@ unit = TypeApp tyObject REmpty

226225

227226typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

228227typeInstanceDictionaryDeclaration name mn deps className tys decls =

229− rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do

228+ rethrow (onErrorMessages (ErrorInInstance className tys)) $ do

230229 m <- get

231230

232231 -- Lookup the type arguments and member types for the type class

233232 (TypeClassDeclaration _ args implies tyDecls) <-

234− maybe (throwError $ mkMultipleErrors ("Type class " ++ show className ++ " is undefined") Nothing) return $

233+ maybe (throwError . errorMessage $ UnknownTypeClass className) return $

235234 M.lookup (qualify mn className) m

236235

237236 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

238− x : _ -> throwError $ mkMultipleErrors ("Member '" ++ show x ++ "' has not been implemented") Nothing

237+ member : _ -> throwError . errorMessage $ MissingClassMember member

239238 [] -> do

240239

241240 let instanceTys = map memberToNameAndType tyDecls

@@ -272,7 +271,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

272271

273272 memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

274273 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

275− _ <- maybe (throwError $ mkMultipleErrors ("Type class does not define member '" ++ show ident ++ "'") Nothing) return $ lookup ident tys'

274+ _ <- maybe (throwError . errorMessage $ MissingClassMember ident) return $ lookup ident tys'

276275 return val

277276 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

278277 val <- memberToValue tys' d

src/Language/PureScript/TypeChecker/Entailment.hs+2−45

@@ -31,7 +31,6 @@ import Language.PureScript.AST

3131import Language.PureScript.Errors

3232import Language.PureScript.Environment

3333import Language.PureScript.Names

34−import Language.PureScript.Pretty

3534import Language.PureScript.TypeChecker.Monad

3635import Language.PureScript.TypeChecker.Synonyms

3736import Language.PureScript.TypeChecker.Unify

@@ -39,29 +38,6 @@ import Language.PureScript.TypeClassDictionaries

3938import Language.PureScript.Types

4039import qualified Language.PureScript.Constants as C

4140

42−-- |

43−-- A simplified representation of expressions which are used to represent type

44−-- class dictionaries at runtime, which can be compared for equality

45−--

46−data DictionaryValue

47− -- |

48− -- A dictionary which is brought into scope by a local constraint

49− --

50− = LocalDictionaryValue (Qualified Ident)

51− -- |

52− -- A dictionary which is brought into scope by an instance declaration

53− --

54− | GlobalDictionaryValue (Qualified Ident)

55− -- |

56− -- A dictionary which depends on other dictionaries

57− --

58− | DependentDictionaryValue (Qualified Ident) [DictionaryValue]

59− -- |

60− -- A subclass dictionary

61− --

62− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

63− deriving (Show, Ord, Eq)

64−

6541-- |

6642-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

6743-- return a type class dictionary reference.

@@ -140,16 +116,9 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

140116 checkOverlaps :: [DictionaryValue] -> Check Expr

141117 checkOverlaps dicts =

142118 case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of

143− (d1, d2) : _ -> throwError . strMsg $ unlines

144− [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."

145− , "For example:"

146− , prettyPrintDictionaryValue d1

147− , "and:"

148− , prettyPrintDictionaryValue d2

149− ]

119+ ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys (map fst ds)

150120 _ -> case chooseSimplestDictionaries dicts of

151− [] -> throwError . strMsg $

152− "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

121+ [] -> throwError . errorMessage $ NoInstanceFound className tys

153122 d : _ -> return $ dictionaryValueToValue d

154123 -- Choose the simplest DictionaryValues from a list of candidates

155124 -- The reason for this function is as follows:

@@ -180,18 +149,6 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

180149 overlapping SubclassDictionaryValue{} _ = False

181150 overlapping _ SubclassDictionaryValue{} = False

182151 overlapping _ _ = True

183− -- |

184− -- Render a DictionaryValue fit for human consumption in error messages

185− --

186− prettyPrintDictionaryValue :: DictionaryValue -> String

187− prettyPrintDictionaryValue = unlines . indented 0

188− where

189− indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]

190− indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]

191− indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args

192− indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup

193−

194− spaces n = replicate n ' ' ++ "- "

195152

196153 valUndefined :: Expr

197154 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

src/Language/PureScript/TypeChecker/Kinds.hs+5−6

@@ -38,7 +38,6 @@ import Language.PureScript.Environment

3838import Language.PureScript.Errors

3939import Language.PureScript.Kinds

4040import Language.PureScript.Names

41−import Language.PureScript.Pretty

4241import Language.PureScript.TypeChecker.Monad

4342import Language.PureScript.Types

4443

@@ -65,7 +64,7 @@ instance Unifiable Check Kind where

6564 FunKind k1 k2 =?= FunKind k3 k4 = do

6665 k1 =?= k3

6766 k2 =?= k4

68− k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

67+ k1 =?= k2 = UnifyT . lift . throwError . errorMessage $ KindsDoNotUnify k1 k2

6968

7069-- |

7170-- Infer the kind of a single type

@@ -78,7 +77,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty

7877--

7978kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

8079kindOfWithScopedVars ty =

81− rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $

80+ rethrow (onErrorMessages (ErrorCheckingKind ty)) $

8281 fmap tidyUp . liftUnify $ infer ty

8382 where

8483 tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

@@ -156,7 +155,7 @@ starIfUnknown k = k

156155-- Infer a kind for a type

157156--

158157infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

159−infer ty = rethrow (mkCompileError "Error inferring type of value" (Just (TypeError ty)) `combineErrors`) $ infer' ty

158+infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty

160159

161160infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

162161infer' (ForAll ident ty _) = do

@@ -189,10 +188,10 @@ infer' other = (, []) <$> go other

189188 go (Skolem v _ _) = do

190189 Just moduleName <- checkCurrentModule <$> get

191190 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

192− go c@(TypeConstructor v) = do

191+ go (TypeConstructor v) = do

193192 env <- liftCheck getEnv

194193 case M.lookup v (types env) of

195− Nothing -> UnifyT . lift . throwError $ mkMultipleErrors "Unknown type constructor" (Just (TypeError c))

194+ Nothing -> UnifyT . lift . throwError . errorMessage $ UnknownTypeConstructor v

196195 Just (kind, _) -> return kind

197196 go (TypeApp t1 t2) = do

198197 k0 <- fresh

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 $ mkMultipleErrors ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)

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

5757 Nothing -> return ()

5858 checkDups _ = return ()

5959

src/Language/PureScript/TypeChecker/Skolems.hs+1−2

@@ -31,7 +31,6 @@ import Control.Monad.Unify

3131

3232import Language.PureScript.AST

3333import Language.PureScript.Errors

34−import Language.PureScript.Pretty

3534import Language.PureScript.TypeChecker.Monad

3635import Language.PureScript.Types

3736

@@ -112,4 +111,4 @@ skolemEscapeCheck root@TypedValue{} =

112111 where

113112 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

114113 go' _ = mempty

115−skolemEscapeCheck val = error "Untyped value passed to skolemEscapeCheck"

114+skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck"

src/Language/PureScript/TypeChecker/Subsumption.hs+2−9

@@ -20,14 +20,12 @@ module Language.PureScript.TypeChecker.Subsumption (

2020import Data.List (sortBy)

2121import Data.Ord (comparing)

2222

23−import Control.Applicative

2423import Control.Monad.Except

2524import Control.Monad.Unify

2625

2726import Language.PureScript.AST

2827import Language.PureScript.Environment

2928import Language.PureScript.Errors

30−import Language.PureScript.Pretty

3129import Language.PureScript.TypeChecker.Monad

3230import Language.PureScript.TypeChecker.Skolems

3331import Language.PureScript.TypeChecker.Synonyms

@@ -38,12 +36,7 @@ import Language.PureScript.Types

3836-- Check whether one type subsumes another, rethrowing errors to provide a better error message

3937--

4038subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

41−subsumes val ty1 ty2 = rethrow (mkCompileError errorMessage (ExprError <$> val) `combineErrors`) $ subsumes' val ty1 ty2

42− where

43− errorMessage = "Error checking that type "

44− ++ prettyPrintType ty1

45− ++ " subsumes type "

46− ++ prettyPrintType ty2

39+subsumes val ty1 ty2 = rethrow (onErrorMessages (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

4740

4841-- |

4942-- Check whether one type subsumes another

@@ -58,7 +51,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

5851 sko <- newSkolemConstant

5952 let sk = skolemize ident sko sco' ty2

6053 subsumes val ty1 sk

61− Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"

54+ Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope

6255subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

6356 _ <- subsumes Nothing arg2 arg1

6457 _ <- subsumes Nothing ret1 ret2

src/Language/PureScript/TypeChecker/Unify.hs+7−8

@@ -34,7 +34,6 @@ import Control.Monad.Unify

3434

3535import Language.PureScript.Environment

3636import Language.PureScript.Errors

37−import Language.PureScript.Pretty

3837import Language.PureScript.TypeChecker.Monad

3938import Language.PureScript.TypeChecker.Skolems

4039import Language.PureScript.TypeChecker.Synonyms

@@ -60,7 +59,7 @@ instance Unifiable Check Type where

6059-- Unify two types, updating the current substitution

6160--

6261unifyTypes :: Type -> Type -> UnifyT Type Check ()

63−unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing `combineErrors`) $

62+unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $

6463 unifyTypes' t1 t2

6564 where

6665 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

@@ -82,11 +81,11 @@ unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrin

8281 sko <- newSkolemConstant

8382 let sk = skolemize ident sko sc ty1

8483 sk `unifyTypes` ty2

85− unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"

84+ unifyTypes' ForAll{} _ = throwError . errorMessage $ UnspecifiedSkolemScope

8685 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

8786 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

88− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =

89− guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)

87+ unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

88+ guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2)

9089 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

9190 t3 `unifyTypes` t5

9291 t4 `unifyTypes` t6

@@ -97,9 +96,9 @@ unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrin

9796 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

9897 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

9998 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

100− unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."

99+ unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

101100 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

102− unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

101+ unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4

103102

104103-- |

105104-- Unify two rows, updating the current substitution

@@ -136,7 +135,7 @@ unifyRows r1 r2 =

136135 unifyRows' [] REmpty [] REmpty = return ()

137136 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

138137 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

139− unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"

138+ unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4))

140139

141140-- |

142141-- Check that two types unify

src/Language/PureScript/TypeClassDictionaries.hs+23

@@ -65,6 +65,29 @@ data TypeClassDictionaryType

6565 --

6666 | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

6767

68+-- |

69+-- A simplified representation of expressions which are used to represent type

70+-- class dictionaries at runtime, which can be compared for equality

71+--

72+data DictionaryValue

73+ -- |

74+ -- A dictionary which is brought into scope by a local constraint

75+ --

76+ = LocalDictionaryValue (Qualified Ident)

77+ -- |

78+ -- A dictionary which is brought into scope by an instance declaration

79+ --

80+ | GlobalDictionaryValue (Qualified Ident)

81+ -- |

82+ -- A dictionary which depends on other dictionaries

83+ --

84+ | DependentDictionaryValue (Qualified Ident) [DictionaryValue]

85+ -- |

86+ -- A subclass dictionary

87+ --

88+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

89+ deriving (Show, Ord, Eq)

90+

6891-- |

6992-- Find the original dictionary which a type class dictionary in scope refers to

7093--