339a494 · rowtype-yoga/purescript-native

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

on golang help sign in

More progress on error messages

339a494Phil Freeman12 years ago

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

compare with golang

unifiedsplit

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

32import Language.PureScript.Types

33import Language.PureScript.Names

34import Language.PureScript.Kinds

35+import Language.PureScript.TypeClassDictionaries

36-- |

37-- |

37-- A type of error messages

38-- A type of error messages

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

49 | UnknownTypeClass (Qualified ProperName)

50 | UnknownTypeClass (Qualified ProperName)

50 | UnknownValue (Qualified Ident)

51 | UnknownValue (Qualified Ident)

51 | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

52 | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

53+ | UnknownTypeConstructor (Qualified ProperName)

52 | ConflictingImport String ModuleName

54 | ConflictingImport String ModuleName

53 | ConflictingImports String ModuleName ModuleName

55 | ConflictingImports String ModuleName ModuleName

54 | ConflictingTypeDecls ProperName

56 | ConflictingTypeDecls ProperName

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

69 | PartiallyAppliedSynonym (Qualified ProperName)

71 | PartiallyAppliedSynonym (Qualified ProperName)

70 | NotYetDefined [Ident] ErrorMessage

72 | NotYetDefined [Ident] ErrorMessage

71 | EscapedSkolem (Maybe Expr)

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

72 | ErrorInExpression Expr ErrorMessage

86 | ErrorInExpression Expr ErrorMessage

73 | ErrorInModule ModuleName ErrorMessage

87 | ErrorInModule ModuleName ErrorMessage

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

89+ | ErrorInSubsumption Type Type ErrorMessage

90+ | ErrorCheckingKind Type ErrorMessage

74 | PositionedError SourceSpan ErrorMessage

91 | PositionedError SourceSpan ErrorMessage

75 deriving (Show)

92 deriving (Show)

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

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

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

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

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

89prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

106prettyPrintErrorMessage CannotReorderOperators = "Unable to reorder operators"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

122

156

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+

123-- |

170-- |

124-- A stack trace for an error

171-- A stack trace for an error

125--

172--

126newtype MultipleErrors = MultipleErrors

173newtype MultipleErrors = MultipleErrors

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

174 { 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

128

181

129-- |

182-- |

130-- Simplify an error message

183-- Simplify an error message

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

134 where

187 where

135 unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

188 unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

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

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

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

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

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

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

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

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

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

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

46--

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

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

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

49+ rethrow (onErrorMessages (ErrorInModule name)) $

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

52desugarAbs :: (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

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

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

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

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

101+ throwError . errorMessage $ ArgListLengthsDiffer ident

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

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

103+ throwError . errorMessage $ DuplicateValueDeclaration ident

104 caseDecl <- makeCaseDeclaration ident tuples

105 return [caseDecl]

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

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

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

27import Language.PureScript.Errors

28import Language.PureScript.Kinds

29import Language.PureScript.Names

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

31import Language.PureScript.Sugar.CaseDeclarations

30import Language.PureScript.Sugar.CaseDeclarations

32import Control.Monad.Supply.Class

31import Control.Monad.Supply.Class

33import Language.PureScript.Types

32import Language.PureScript.Types

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

226

225

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

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

228typeInstanceDictionaryDeclaration name mn deps className tys decls =

227typeInstanceDictionaryDeclaration 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

230 m <- get

229 m <- get

231

230

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

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

233 (TypeClassDeclaration _ args implies tyDecls) <-

232 (TypeClassDeclaration _ args implies tyDecls) <-

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

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

235 M.lookup (qualify mn className) m

234 M.lookup (qualify mn className) m

236

235

237 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

236 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

239 [] -> do

238 [] -> do

240

239

241 let instanceTys = map memberToNameAndType tyDecls

240 let instanceTys = map memberToNameAndType tyDecls

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

272

271

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

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

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

273 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'

276 return val

275 return val

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

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

278 val <- memberToValue tys' d

277 val <- memberToValue tys' d

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

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

31import Language.PureScript.Errors

32import Language.PureScript.Environment

33import Language.PureScript.Names

34−import Language.PureScript.Pretty

35import Language.PureScript.TypeChecker.Monad

34import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.TypeChecker.Synonyms

35import Language.PureScript.TypeChecker.Synonyms

37import Language.PureScript.TypeChecker.Unify

36import Language.PureScript.TypeChecker.Unify

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

39import Language.PureScript.Types

38import Language.PureScript.Types

40import qualified Language.PureScript.Constants as C

39import qualified Language.PureScript.Constants as C

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−

65-- |

41-- |

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

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

67-- return a type class dictionary reference.

43-- return a type class dictionary reference.

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

140 checkOverlaps :: [DictionaryValue] -> Check Expr

116 checkOverlaps :: [DictionaryValue] -> Check Expr

141 checkOverlaps dicts =

117 checkOverlaps dicts =

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

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

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

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

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

145− , "For example:"

146− , prettyPrintDictionaryValue d1

147− , "and:"

148− , prettyPrintDictionaryValue d2

149− ]

150 _ -> case chooseSimplestDictionaries dicts of

120 _ -> case chooseSimplestDictionaries dicts of

151− [] -> throwError . strMsg $

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

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

153 d : _ -> return $ dictionaryValueToValue d

122 d : _ -> return $ dictionaryValueToValue d

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

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

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

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

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

180 overlapping SubclassDictionaryValue{} _ = False

149 overlapping SubclassDictionaryValue{} _ = False

181 overlapping _ SubclassDictionaryValue{} = False

150 overlapping _ SubclassDictionaryValue{} = False

182 overlapping _ _ = True

151 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 ' ' ++ "- "

195

152

196 valUndefined :: Expr

153 valUndefined :: Expr

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

154 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

38import Language.PureScript.Errors

39import Language.PureScript.Kinds

40import Language.PureScript.Names

41−import Language.PureScript.Pretty

42import Language.PureScript.TypeChecker.Monad

41import Language.PureScript.TypeChecker.Monad

43import Language.PureScript.Types

42import Language.PureScript.Types

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

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

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

66 k1 =?= k3

65 k1 =?= k3

67 k2 =?= k4

66 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

70-- |

69-- |

71-- Infer the kind of a single type

70-- Infer the kind of a single type

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

78--

77--

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

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

80kindOfWithScopedVars ty =

79kindOfWithScopedVars ty =

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

80+ rethrow (onErrorMessages (ErrorCheckingKind ty)) $

82 fmap tidyUp . liftUnify $ infer ty

81 fmap tidyUp . liftUnify $ infer ty

83 where

82 where

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

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

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

156-- Infer a kind for a type

155-- Infer a kind for a type

157--

156--

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

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

160

159

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

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

162infer' (ForAll ident ty _) = do

161infer' (ForAll ident ty _) = do

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

189 go (Skolem v _ _) = do

188 go (Skolem v _ _) = do

190 Just moduleName <- checkCurrentModule <$> get

189 Just moduleName <- checkCurrentModule <$> get

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

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

192− go c@(TypeConstructor v) = do

191+ go (TypeConstructor v) = do

193 env <- liftCheck getEnv

192 env <- liftCheck getEnv

194 case M.lookup v (types env) of

193 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

196 Just (kind, _) -> return kind

195 Just (kind, _) -> return kind

197 go (TypeApp t1 t2) = do

196 go (TypeApp t1 t2) = do

198 k0 <- fresh

197 k0 <- fresh

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

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

57 Nothing -> return ()

58 checkDups _ = return ()

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

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

32import Language.PureScript.AST

33import Language.PureScript.Errors

34−import Language.PureScript.Pretty

35import Language.PureScript.TypeChecker.Monad

34import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.Types

35import Language.PureScript.Types

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

112 where

111 where

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

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

114 go' _ = mempty

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

20import Data.List (sortBy)

21import Data.Ord (comparing)

23−import Control.Applicative

24import Control.Monad.Except

23import Control.Monad.Except

25import Control.Monad.Unify

24import Control.Monad.Unify

27import Language.PureScript.AST

26import Language.PureScript.AST

28import Language.PureScript.Environment

27import Language.PureScript.Environment

29import Language.PureScript.Errors

28import Language.PureScript.Errors

30−import Language.PureScript.Pretty

31import Language.PureScript.TypeChecker.Monad

29import Language.PureScript.TypeChecker.Monad

32import Language.PureScript.TypeChecker.Skolems

30import Language.PureScript.TypeChecker.Skolems

33import Language.PureScript.TypeChecker.Synonyms

31import Language.PureScript.TypeChecker.Synonyms

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

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

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

39--

37--

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

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

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

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

42− where

43− errorMessage = "Error checking that type "

44− ++ prettyPrintType ty1

45− ++ " subsumes type "

46− ++ prettyPrintType ty2

48-- |

41-- |

49-- Check whether one type subsumes another

42-- Check whether one type subsumes another

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

58 sko <- newSkolemConstant

51 sko <- newSkolemConstant

59 let sk = skolemize ident sko sco' ty2

52 let sk = skolemize ident sko sco' ty2

60 subsumes val ty1 sk

53 subsumes val ty1 sk

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

54+ Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope

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

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

63 _ <- subsumes Nothing arg2 arg1

56 _ <- subsumes Nothing arg2 arg1

64 _ <- subsumes Nothing ret1 ret2

57 _ <- subsumes Nothing ret1 ret2

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

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

35import Language.PureScript.Environment

36import Language.PureScript.Errors

37−import Language.PureScript.Pretty

38import Language.PureScript.TypeChecker.Monad

37import Language.PureScript.TypeChecker.Monad

39import Language.PureScript.TypeChecker.Skolems

38import Language.PureScript.TypeChecker.Skolems

40import Language.PureScript.TypeChecker.Synonyms

39import Language.PureScript.TypeChecker.Synonyms

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

60-- Unify two types, updating the current substitution

59-- Unify two types, updating the current substitution

61--

60--

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

61unifyTypes :: 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)) $

64 unifyTypes' t1 t2

63 unifyTypes' t1 t2

65 where

64 where

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

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

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

82 sko <- newSkolemConstant

81 sko <- newSkolemConstant

83 let sk = skolemize ident sko sc ty1

82 let sk = skolemize ident sko sc ty1

84 sk `unifyTypes` ty2

83 sk `unifyTypes` ty2

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

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

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

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

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

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

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

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

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

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

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

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

91 t3 `unifyTypes` t5

90 t3 `unifyTypes` t5

92 t4 `unifyTypes` t6

91 t4 `unifyTypes` t6

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

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

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

98 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

97 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

99 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

98 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

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

100 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

103

102

104-- |

103-- |

105-- Unify two rows, updating the current substitution

104-- Unify two rows, updating the current substitution

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

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

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

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

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

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

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

140

139

141-- |

140-- |

142-- Check that two types unify

141-- Check that two types unify

src/Language/PureScript/TypeClassDictionaries.hs+23

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

65 --

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

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+

68-- |

91-- |

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

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

70--

93--