@@ -12,108 +12,378 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
1618
1719module Language.PureScript.Errors where
1820
1921import Data.Either (lefts, rights)
20−import Data.String (IsString(..))
2122import Data.List (intersperse, intercalate)
2223import Data.Monoid
24+import Data.Foldable (fold, foldMap)
2325
2426import Control.Monad.Except
27+import Control.Monad.Unify
2528import Control.Applicative ((<$>))
2629
2730import Language.PureScript.AST
2831import Language.PureScript.Pretty
2932import Language.PureScript.Types
33+import Language.PureScript.Names
34+import Language.PureScript.Kinds
35+import Language.PureScript.TypeClassDictionaries
3036
3137-- |
32−-- Type for sources of type checking errors
33−--
34−data ErrorSource
35− -- |
36− -- An error which originated at a Expr
37− --
38− = ExprError Expr
39− -- |
40− -- An error which originated at a Type
41− --
42− | TypeError Type deriving (Show)
43−
44−-- |
45−-- Compilation errors
46−--
47−data CompileError
48− = CompileError
49− { -- |
50− -- Error message
51− --
52− compileErrorMessage :: String
53− -- |
54− -- The value where the error occurred
55− --
56− , compileErrorValue :: Maybe ErrorSource
57− -- |
58− -- Optional source position information
59− --
60− , compileErrorPosition :: Maybe SourceSpan
61− }
38+-- A type of error messages
39+--
40+data ErrorMessage
41+ = InfiniteType Type
42+ | InfiniteKind Kind
43+ | CannotReorderOperators
44+ | MultipleFixities Ident
45+ | OrphanTypeDeclaration Ident
46+ | OrphanFixityDeclaration String
47+ | RedefinedModule ModuleName
48+ | RedefinedIdent Ident
49+ | OverlappingNamesInLet
50+ | UnknownModule ModuleName
51+ | UnknownType (Qualified ProperName)
52+ | UnknownTypeClass (Qualified ProperName)
53+ | UnknownValue (Qualified Ident)
54+ | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
55+ | UnknownTypeConstructor (Qualified ProperName)
56+ | ConflictingImport String ModuleName
57+ | ConflictingImports String ModuleName ModuleName
58+ | ConflictingTypeDecls ProperName
59+ | ConflictingCtorDecls ProperName
60+ | TypeConflictsWithClass ProperName
61+ | CtorConflictsWithClass ProperName
62+ | ClassConflictsWithType ProperName
63+ | ClassConflictsWithCtor ProperName
64+ | DuplicateClassExport ProperName
65+ | DuplicateValueExport Ident
66+ | DuplicateTypeArgument String
67+ | InvalidDoBind
68+ | InvalidDoLet
69+ | CycleInDeclaration Ident
70+ | CycleInTypeSynonym (Maybe ProperName)
71+ | NameIsUndefined Ident
72+ | NameNotInScope Ident
73+ | UndefinedTypeVariable ProperName
74+ | PartiallyAppliedSynonym (Qualified ProperName)
75+ | NotYetDefined [Ident] ErrorMessage
76+ | EscapedSkolem (Maybe Expr)
77+ | UnspecifiedSkolemScope
78+ | TypesDoNotUnify Type Type
79+ | KindsDoNotUnify Kind Kind
80+ | ConstrainedTypeUnified Type Type
81+ | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
82+ | NoInstanceFound (Qualified ProperName) [Type]
83+ | DuplicateLabel String (Maybe Expr)
84+ | DuplicateValueDeclaration Ident
85+ | ArgListLengthsDiffer Ident
86+ | OverlappingArgNames (Maybe Ident)
87+ | MissingClassMember Ident
88+ | ExpectedType Kind
89+ | IncorrectConstructorArity (Qualified ProperName)
90+ | SubsumptionCheckFailed
91+ | ExprDoesNotHaveType Expr Type
92+ | PropertyIsMissing String Type
93+ | ErrorUnifyingTypes Type Type ErrorMessage
94+ | CannotApplyFunction Type Expr
95+ | TypeSynonymInstance
96+ | InvalidNewtype
97+ | InvalidInstanceHead Type
98+ | TransitiveExportError DeclarationRef [DeclarationRef]
99+ | ErrorInExpression Expr ErrorMessage
100+ | ErrorInModule ModuleName ErrorMessage
101+ | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
102+ | ErrorInSubsumption Type Type ErrorMessage
103+ | ErrorCheckingType Expr Type ErrorMessage
104+ | ErrorCheckingKind Type ErrorMessage
105+ | ErrorInferringType Expr ErrorMessage
106+ | ErrorInApplication Expr Type Expr ErrorMessage
107+ | ErrorInDataConstructor ProperName ErrorMessage
108+ | ErrorInTypeConstructor ProperName ErrorMessage
109+ | ErrorInBindingGroup [Ident] ErrorMessage
110+ | ErrorInDataBindingGroup ErrorMessage
111+ | ErrorInTypeSynonym ProperName ErrorMessage
112+ | ErrorInValueDeclaration Ident ErrorMessage
113+ | ErrorInForeignImport Ident ErrorMessage
114+ | PositionedError SourceSpan ErrorMessage
62115 deriving (Show)
116+
117+instance UnificationError Type ErrorMessage where
118+ occursCheckFailed = InfiniteType
119+
120+instance UnificationError Kind ErrorMessage where
121+ occursCheckFailed = InfiniteKind
63122
64123-- |
65−-- A stack trace for an error
124+-- Get the error code for a particular error type
66125--
67−data ErrorStack
68− = ErrorStack { runErrorStack :: [CompileError] }
69− | MultipleErrors [ErrorStack] deriving (Show)
126+errorCode :: ErrorMessage -> String
127+errorCode (InfiniteType _) = "InfiniteType"
128+errorCode (InfiniteKind _) = "InfiniteKind"
129+errorCode CannotReorderOperators = "CannotReorderOperators"
130+errorCode (MultipleFixities _) = "MultipleFixities"
131+errorCode (OrphanTypeDeclaration _) = "OrphanTypeDeclaration"
132+errorCode (OrphanFixityDeclaration _) = "OrphanFixityDeclaration"
133+errorCode (RedefinedModule _) = "RedefinedModule"
134+errorCode (RedefinedIdent _) = "RedefinedIdent"
135+errorCode OverlappingNamesInLet = "OverlappingNamesInLet"
136+errorCode (UnknownModule _) = "UnknownModule"
137+errorCode (UnknownType _) = "UnknownType"
138+errorCode (UnknownTypeClass _) = "UnknownTypeClass"
139+errorCode (UnknownValue _) = "UnknownValue"
140+errorCode (UnknownDataConstructor _ _) = "UnknownDataConstructor"
141+errorCode (UnknownTypeConstructor _) = "UnknownTypeConstructor"
142+errorCode (ConflictingImport _ _) = "ConflictingImport"
143+errorCode (ConflictingImports _ _ _) = "ConflictingImports"
144+errorCode (ConflictingTypeDecls _) = "ConflictingTypeDecls"
145+errorCode (ConflictingCtorDecls _) = "ConflictingCtorDecls"
146+errorCode (TypeConflictsWithClass _) = "TypeConflictsWithClass"
147+errorCode (CtorConflictsWithClass _) = "CtorConflictsWithClass"
148+errorCode (ClassConflictsWithType _) = "ClassConflictsWithType"
149+errorCode (ClassConflictsWithCtor _) = "ClassConflictsWithCtor"
150+errorCode (DuplicateClassExport _) = "DuplicateClassExport"
151+errorCode (DuplicateValueExport _) = "DuplicateValueExport"
152+errorCode (DuplicateTypeArgument _) = "DuplicateTypeArgument"
153+errorCode InvalidDoBind = "InvalidDoBind"
154+errorCode InvalidDoLet = "InvalidDoLet"
155+errorCode (CycleInDeclaration _) = "CycleInDeclaration"
156+errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"
157+errorCode (NameIsUndefined _) = "NameIsUndefined"
158+errorCode (NameNotInScope _) = "NameNotInScope"
159+errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"
160+errorCode (PartiallyAppliedSynonym _) = "PartiallyAppliedSynonym"
161+errorCode (EscapedSkolem _) = "EscapedSkolem"
162+errorCode UnspecifiedSkolemScope = "UnspecifiedSkolemScope"
163+errorCode (TypesDoNotUnify _ _) = "TypesDoNotUnify"
164+errorCode (KindsDoNotUnify _ _) = "KindsDoNotUnify"
165+errorCode (ConstrainedTypeUnified _ _) = "ConstrainedTypeUnified"
166+errorCode (OverlappingInstances _ _ _) = "OverlappingInstances"
167+errorCode (NoInstanceFound _ _) = "NoInstanceFound"
168+errorCode (DuplicateLabel _ _) = "DuplicateLabel"
169+errorCode (DuplicateValueDeclaration _) = "DuplicateValueDeclaration"
170+errorCode (ArgListLengthsDiffer _) = "ArgListLengthsDiffer"
171+errorCode (OverlappingArgNames _) = "OverlappingArgNames"
172+errorCode (MissingClassMember _) = "MissingClassMember"
173+errorCode (ExpectedType _) = "ExpectedType"
174+errorCode (IncorrectConstructorArity _) = "IncorrectConstructorArity"
175+errorCode SubsumptionCheckFailed = "SubsumptionCheckFailed"
176+errorCode (ExprDoesNotHaveType _ _) = "ExprDoesNotHaveType"
177+errorCode (PropertyIsMissing _ _) = "PropertyIsMissing"
178+errorCode (ErrorUnifyingTypes _ _ _) = "ErrorUnifyingTypes"
179+errorCode (CannotApplyFunction _ _) = "CannotApplyFunction"
180+errorCode TypeSynonymInstance = "TypeSynonymInstance"
181+errorCode InvalidNewtype = "InvalidNewtype"
182+errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"
183+errorCode (TransitiveExportError _ _) = "TransitiveExportError"
184+errorCode (NotYetDefined _ e) = errorCode e
185+errorCode (ErrorInExpression _ e) = errorCode e
186+errorCode (ErrorInModule _ e) = errorCode e
187+errorCode (ErrorInInstance _ _ e) = errorCode e
188+errorCode (ErrorInSubsumption _ _ e) = errorCode e
189+errorCode (ErrorCheckingType _ _ e) = errorCode e
190+errorCode (ErrorCheckingKind _ e) = errorCode e
191+errorCode (ErrorInferringType _ e) = errorCode e
192+errorCode (ErrorInApplication _ _ _ e) = errorCode e
193+errorCode (ErrorInDataConstructor _ e) = errorCode e
194+errorCode (ErrorInTypeConstructor _ e) = errorCode e
195+errorCode (ErrorInBindingGroup _ e) = errorCode e
196+errorCode (ErrorInDataBindingGroup e) = errorCode e
197+errorCode (ErrorInTypeSynonym _ e) = errorCode e
198+errorCode (ErrorInValueDeclaration _ e) = errorCode e
199+errorCode (ErrorInForeignImport _ e) = errorCode e
200+errorCode (PositionedError _ e) = errorCode e
70201
71−-- TODO: Remove strMsg, the IsString instance, and unnecessary
72−-- OverloadedStrings pragmas. See #745
73−-- | Create an ErrorStack from a string
74−strMsg :: String -> ErrorStack
75−strMsg s = ErrorStack [CompileError s Nothing Nothing]
76−
77−instance IsString ErrorStack where
78− fromString = strMsg
202+-- |
203+-- Pretty print an ErrorMessage
204+--
205+prettyPrintErrorMessage :: ErrorMessage -> String
206+prettyPrintErrorMessage e =
207+ go e ++ "\n\nSee " ++ wikiUri ++ " for more information, or to contribute content related to this error."
208+ where
209+ wikiUri :: String
210+ wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
211+
212+ go :: ErrorMessage -> String
213+ go InvalidDoBind = "Bind statement cannot be the last statement in a do block"
214+ go InvalidDoLet = "Let statement cannot be the last statement in a do block"
215+ go CannotReorderOperators = "Unable to reorder operators"
216+ go UnspecifiedSkolemScope = "Skolem variable scope is unspecified"
217+ go OverlappingNamesInLet = "Overlapping names in let binding."
218+ go (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty
219+ go (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki
220+ go (MultipleFixities name) = "Multiple fixity declarations for " ++ show name
221+ go (OrphanTypeDeclaration nm) = "Orphan type declaration for " ++ show nm
222+ go (OrphanFixityDeclaration op) = "Orphan fixity declaration for " ++ show op
223+ go (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"
224+ go (RedefinedIdent name) = "Name " ++ show name ++ " has been defined multiple times"
225+ go (UnknownModule mn) = "Unknown module " ++ show mn
226+ go (UnknownType name) = "Unknown type " ++ show name
227+ go (UnknownTypeClass name) = "Unknown type class " ++ show name
228+ go (UnknownValue name) = "Unknown value " ++ show name
229+ go (UnknownTypeConstructor name) = "Unknown type constructor " ++ show name
230+ go (UnknownDataConstructor dc tc) = "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
231+ go (ConflictingImport nm mn) = "Declaration " ++ nm ++ " conflicts with import " ++ show mn
232+ go (ConflictingImports nm m1 m2) = "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
233+ go (ConflictingTypeDecls nm) = "Conflicting type declarations for " ++ show nm
234+ go (ConflictingCtorDecls nm) = "Conflicting data constructor declarations for " ++ show nm
235+ go (TypeConflictsWithClass nm) = "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
236+ go (CtorConflictsWithClass nm) = "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
237+ go (ClassConflictsWithType nm) = "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
238+ go (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
239+ go (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm
240+ go (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm
241+ go (CycleInDeclaration nm) = "Cycle in declaration of " ++ show nm
242+ go (NotYetDefined names err) = "The following are not yet defined here: " ++ unwords (map show names) ++ "\n" ++ go err
243+ go (CycleInTypeSynonym pn) = "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
244+ go (NameIsUndefined ident) = show ident ++ " is undefined"
245+ go (NameNotInScope ident) = show ident ++ " may not be defined in the current scope"
246+ go (UndefinedTypeVariable name) = "Type variable " ++ show name ++ " is undefined"
247+ go (PartiallyAppliedSynonym name) = "Partially applied type synonym " ++ show name
248+ go (EscapedSkolem binding) = "Rigid/skolem type variable " ++ foldMap (("bound by " ++) . prettyPrintValue) binding ++ " has escaped."
249+ go (TypesDoNotUnify t1 t2) = "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2
250+ go (KindsDoNotUnify k1 k2) = "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2
251+ go (ConstrainedTypeUnified t1 t2) = "Cannot unify constrained type " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2
252+ go (OverlappingInstances nm ts ds) = unlines ( ("Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintType ts) ++ ":")
253+ : map prettyPrintDictionaryValue ds)
254+ go (NoInstanceFound nm ts) = "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
255+ go (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row." ++ foldMap ((" Relevant expression: " ++) . prettyPrintValue) expr
256+ go (DuplicateTypeArgument name) = "Duplicate type argument " ++ show name
257+ go (DuplicateValueDeclaration nm) = "Duplicate value declaration for " ++ show nm
258+ go (ArgListLengthsDiffer ident) = "Argument list lengths differ in declaration " ++ show ident
259+ go (OverlappingArgNames ident) = "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
260+ go (MissingClassMember ident) = "Member " ++ show ident ++ " has not been implemented"
261+ go (ExpectedType kind) = "Expected type of kind *, was " ++ prettyPrintKind kind
262+ go (IncorrectConstructorArity nm) = "Wrong number of arguments to constructor " ++ show nm
263+ go SubsumptionCheckFailed = "Unable to check type subsumption"
264+ go (ExprDoesNotHaveType expr ty) = "Expression " ++ prettyPrintValue expr ++ " does not have type " ++ prettyPrintType ty
265+ go (PropertyIsMissing prop row) = "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
266+ go (CannotApplyFunction fn arg) = "Cannot apply function of type " ++ prettyPrintType fn ++ " to argument " ++ prettyPrintValue arg
267+ go TypeSynonymInstance = "Type synonym instances are disallowed"
268+ go InvalidNewtype = "Newtypes must define a single constructor with a single argument"
269+ go (InvalidInstanceHead ty) = "Invalid type " ++ prettyPrintType ty ++ " in class instance head"
270+ go (TransitiveExportError x ys) = "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " ++ intercalate ", " (map prettyPrintExport ys)
271+ go (ErrorUnifyingTypes t1 t2 err) = "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ go err
272+ go (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ go err
273+ go (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ go err
274+ go (ErrorInSubsumption t1 t2 err) = "Error checking that type " ++ prettyPrintType t1 ++ " subsumes type " ++ prettyPrintType t2 ++ ":\n" ++ go err
275+ go (ErrorInInstance name ts err) = "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":\n" ++ go err
276+ go (ErrorCheckingKind ty err) = "Error checking kind of type " ++ prettyPrintType ty ++ ":\n" ++ go err
277+ go (ErrorInferringType expr err) = "Error inferring type of value " ++ prettyPrintValue expr ++ ":\n" ++ go err
278+ go (ErrorCheckingType expr ty err) = "Error checking value " ++ prettyPrintValue expr ++ " has type " ++ prettyPrintType ty ++ ":\n" ++ go err
279+ go (ErrorInApplication f t a err) = "Error applying function " ++ prettyPrintValue f ++ " of type " ++ prettyPrintType t ++ " to argument " ++ prettyPrintValue a ++ ":\n" ++ go err
280+ go (ErrorInDataConstructor nm err) = "Error in data constructor " ++ show nm ++ ":\n" ++ go err
281+ go (ErrorInTypeConstructor nm err) = "Error in type constructor " ++ show nm ++ ":\n" ++ go err
282+ go (ErrorInBindingGroup nms err) = "Error in binding group " ++ intercalate ", " (map show nms) ++ ":\n" ++ go err
283+ go (ErrorInDataBindingGroup err) = "Error in data binding group:\n" ++ go err
284+ go (ErrorInTypeSynonym name err) = "Error in type synonym " ++ show name ++ ":\n" ++ go err
285+ go (ErrorInValueDeclaration n err) = "Error in value declaration " ++ show n ++ ":\n" ++ go err
286+ go (ErrorInForeignImport nm err) = "Error in foreign import " ++ show nm ++ ":\n" ++ go err
287+ go (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ go err
79288
80−prettyPrintErrorStack :: Bool -> ErrorStack -> String
81−prettyPrintErrorStack printFullStack (ErrorStack es) =
82− case mconcat $ map (Last . compileErrorPosition) es of
83− Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
84− _ -> prettyPrintErrorStack'
289+-- |
290+-- Render a DictionaryValue fit for human consumption in error messages
291+--
292+prettyPrintDictionaryValue :: DictionaryValue -> String
293+prettyPrintDictionaryValue = unlines . indented 0
85294 where
86− prettyPrintErrorStack' :: String
87− prettyPrintErrorStack'
88− | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
89− | otherwise =
90− let
91− es' = filter isErrorNonEmpty es
92− in case length es' of
93− 1 -> showError (head es')
94− _ -> showError (head es') ++ "\n" ++ showError (last es')
95−prettyPrintErrorStack printFullStack (MultipleErrors es) =
96− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
295+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
296+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
297+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
298+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
97299
98−stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
99−stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
300+ spaces n = replicate n ' ' ++ "- "
301+
302+-- |
303+-- Pretty print and export declaration
304+--
305+prettyPrintExport :: DeclarationRef -> String
306+prettyPrintExport (TypeRef pn _) = show pn
307+prettyPrintExport (ValueRef ident) = show ident
308+prettyPrintExport (TypeClassRef pn) = show pn
309+prettyPrintExport (TypeInstanceRef ident) = show ident
310+prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
311+
312+-- |
313+-- A stack trace for an error
314+--
315+newtype MultipleErrors = MultipleErrors
316+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
317+
318+instance UnificationError Type MultipleErrors where
319+ occursCheckFailed = errorMessage . occursCheckFailed
320+
321+instance UnificationError Kind MultipleErrors where
322+ occursCheckFailed = errorMessage . occursCheckFailed
100323
101−isErrorNonEmpty :: CompileError -> Bool
102−isErrorNonEmpty = not . null . compileErrorMessage
324+-- |
325+-- Simplify an error message
326+--
327+simplifyErrorMessage :: ErrorMessage -> ErrorMessage
328+simplifyErrorMessage = unwrap Nothing
329+ where
330+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
331+ unwrap pos (ErrorInExpression _ err) = unwrap pos err
332+ unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
333+ unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
334+ unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
335+ unwrap pos (ErrorInferringType _ err) = unwrap pos err
336+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
337+ unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
338+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
339+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
340+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
341+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
342+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
343+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
344+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
345+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
346+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
347+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
348+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err
349+ unwrap pos other = wrap pos other
350+
351+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
352+ wrap Nothing = id
353+ wrap (Just pos) = PositionedError pos
103354
104−showError :: CompileError -> String
105−showError (CompileError msg Nothing _) = msg
106−showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
107−showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
355+-- |
356+-- Create an error set from a single error message
357+--
358+errorMessage :: ErrorMessage -> MultipleErrors
359+errorMessage err = MultipleErrors [err]
108360
109−mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
110−mkErrorStack msg t = ErrorStack [mkCompileError msg t]
361+-- |
362+-- Lift a function on ErrorMessage to a function on MultipleErrors
363+--
364+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
365+onErrorMessages f = MultipleErrors . map f . runMultipleErrors
366+
367+-- |
368+-- Pretty print a single error, simplifying if necessary
369+--
370+prettyPrintSingleError :: Bool -> ErrorMessage -> String
371+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
111372
112−mkCompileError :: String -> Maybe ErrorSource -> CompileError
113−mkCompileError msg t = CompileError msg t Nothing
373+-- |
374+-- Pretty print multiple errors
375+--
376+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
377+prettyPrintMultipleErrors full (MultipleErrors [e]) =
378+ prettyPrintSingleError full e
379+prettyPrintMultipleErrors full (MultipleErrors es) =
380+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es
114381
115−positionError :: SourceSpan -> CompileError
116−positionError pos = CompileError "" Nothing (Just pos)
382+-- |
383+-- Interpret multiple errors in a monad supporting errors
384+--
385+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a
386+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return
117387
118388-- |
119389-- Rethrow an error with a more detailed error message in the case of failure
@@ -124,30 +394,23 @@ rethrow f = flip catchError $ \e -> throwError (f e)
124394-- |
125395-- Rethrow an error with source position information
126396--
127−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
128−rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
397+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
398+rethrowWithPosition pos = rethrow (onErrorMessages withPosition)
399+ where
400+ withPosition :: ErrorMessage -> ErrorMessage
401+ withPosition (PositionedError _ err) = withPosition err
402+ withPosition err = PositionedError pos err
129403
130404-- |
131405-- Collect errors in in parallel
132406--
133−parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
407+parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
134408parU xs f = forM xs (withError . f) >>= collectErrors
135409 where
136− withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
410+ withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
137411 withError u = catchError (Right <$> u) (return . Left)
138412
139− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
413+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
140414 collectErrors es = case lefts es of
141− [err] -> throwError err
142415 [] -> return $ rights es
143− errs -> throwError $ MultipleErrors errs
144−
145−-- |
146−-- Add an extra error string onto the top of each error stack in a list of possibly many errors
147−--
148−combineErrors :: CompileError -> ErrorStack -> ErrorStack
149−combineErrors ce err = go (ErrorStack [ce]) err
150− where
151− go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
152− go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]
153− go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]
416+ errs -> throwError $ fold errs