@@ -19,7 +19,7 @@
1919module Language.PureScript.Errors where
2020
2121import Data.Either (lefts, rights)
22−import Data.List (intersperse, intercalate)
22+import Data.List (intercalate)
2323import Data.Monoid
2424import Data.Foldable (fold, foldMap)
2525
@@ -34,6 +34,8 @@ import Language.PureScript.Names
3434import Language.PureScript.Kinds
3535import Language.PureScript.TypeClassDictionaries
3636
37+import qualified Text.PrettyPrint.Boxes as Box
38+
3739-- |
3840-- A type of error messages
3941--
@@ -198,116 +200,6 @@ errorCode (ErrorInTypeSynonym _ e) = errorCode e
198200errorCode (ErrorInValueDeclaration _ e) = errorCode e
199201errorCode (ErrorInForeignImport _ e) = errorCode e
200202errorCode (PositionedError _ e) = errorCode e
201−
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
288−
289−-- |
290−-- Render a DictionaryValue fit for human consumption in error messages
291−--
292−prettyPrintDictionaryValue :: DictionaryValue -> String
293−prettyPrintDictionaryValue = unlines . indented 0
294− where
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
299−
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
311203
312204-- |
313205-- A stack trace for an error
@@ -321,37 +213,6 @@ instance UnificationError Type MultipleErrors where
321213instance UnificationError Kind MultipleErrors where
322214 occursCheckFailed = errorMessage . occursCheckFailed
323215
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
354−
355216-- |
356217-- Create an error set from a single error message
357218--
@@ -367,17 +228,264 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors
367228-- |
368229-- Pretty print a single error, simplifying if necessary
369230--
370−prettyPrintSingleError :: Bool -> ErrorMessage -> String
231+prettyPrintSingleError :: Bool -> ErrorMessage -> Box.Box
371232prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
233+ where
234+ -- |
235+ -- Pretty print an ErrorMessage
236+ --
237+ prettyPrintErrorMessage :: ErrorMessage -> Box.Box
238+ prettyPrintErrorMessage em =
239+ paras
240+ [ go em
241+ , line ("See " ++ wikiUri ++ " for more information, or to contribute content related to this error.")
242+ ]
243+ where
244+ wikiUri :: String
245+ wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
246+
247+ go :: ErrorMessage -> Box.Box
248+ go InvalidDoBind = line "Bind statement cannot be the last statement in a do block"
249+ go InvalidDoLet = line "Let statement cannot be the last statement in a do block"
250+ go CannotReorderOperators = line "Unable to reorder operators"
251+ go UnspecifiedSkolemScope = line "Skolem variable scope is unspecified"
252+ go OverlappingNamesInLet = line "Overlapping names in let binding."
253+ go (InfiniteType ty) = paras [ line "Infinite type detected: "
254+ , indent $ line $ prettyPrintType ty
255+ ]
256+ go (InfiniteKind ki) = paras [ line "Infinite kind detected: "
257+ , indent $ line $ prettyPrintKind ki
258+ ]
259+ go (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ show name
260+ go (OrphanTypeDeclaration nm) = line $ "Orphan type declaration for " ++ show nm
261+ go (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op
262+ go (RedefinedModule name) = line $ "Module " ++ show name ++ " has been defined multiple times"
263+ go (RedefinedIdent name) = line $ "Name " ++ show name ++ " has been defined multiple times"
264+ go (UnknownModule mn) = line $ "Unknown module " ++ show mn
265+ go (UnknownType name) = line $ "Unknown type " ++ show name
266+ go (UnknownTypeClass name) = line $ "Unknown type class " ++ show name
267+ go (UnknownValue name) = line $ "Unknown value " ++ show name
268+ go (UnknownTypeConstructor name) = line $ "Unknown type constructor " ++ show name
269+ go (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
270+ go (ConflictingImport nm mn) = line $ "Declaration " ++ nm ++ " conflicts with import " ++ show mn
271+ go (ConflictingImports nm m1 m2) = line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
272+ go (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ show nm
273+ go (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ show nm
274+ go (TypeConflictsWithClass nm) = line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
275+ go (CtorConflictsWithClass nm) = line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
276+ go (ClassConflictsWithType nm) = line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
277+ go (ClassConflictsWithCtor nm) = line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
278+ go (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm
279+ go (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm
280+ go (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm
281+ go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
282+ , indent $ go err
283+ ]
284+ go (CycleInTypeSynonym pn) = line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
285+ go (NameIsUndefined ident) = line $ show ident ++ " is undefined"
286+ go (NameNotInScope ident) = line $ show ident ++ " may not be defined in the current scope"
287+ go (UndefinedTypeVariable name) = line $ "Type variable " ++ show name ++ " is undefined"
288+ go (PartiallyAppliedSynonym name) = line $ "Partially applied type synonym " ++ show name
289+ go (EscapedSkolem binding) = paras $ [ line "Rigid/skolem type variable has escaped." ]
290+ <> foldMap (\expr -> [ line "Relevant expression: "
291+ , indent $ line $ prettyPrintValue expr
292+ ]) binding
293+ go (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type"
294+ , indent $ line $ prettyPrintType t1
295+ , line "with type"
296+ , indent $ line $ prettyPrintType t2
297+ ]
298+ go (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind"
299+ , indent $ line $ prettyPrintKind k1
300+ , line "with kind"
301+ , indent $ line $ prettyPrintKind k2
302+ ]
303+ go (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type"
304+ , indent $ line $ prettyPrintType t1
305+ , line "with type"
306+ , indent $ line $ prettyPrintType t2
307+ ]
308+ go (OverlappingInstances nm ts ds) = paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
309+ , paras $ map prettyPrintDictionaryValue ds
310+ ]
311+ go (NoInstanceFound nm ts) = line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
312+ go (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
313+ <> foldMap (\expr' -> [ line "Relevant expression: "
314+ , indent $ line $ prettyPrintValue expr'
315+ ]) expr
316+ go (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name
317+ go (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ show nm
318+ go (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ show ident
319+ go (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
320+ go (MissingClassMember ident) = line $ "Member " ++ show ident ++ " has not been implemented"
321+ go (ExpectedType kind) = line $ "Expected type of kind *, was " ++ prettyPrintKind kind
322+ go (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ show nm
323+ go SubsumptionCheckFailed = line $ "Unable to check type subsumption"
324+ go (ExprDoesNotHaveType expr ty) = paras [ line "Expression"
325+ , indent $ line $ prettyPrintValue expr
326+ , line "does not have type"
327+ , indent $ line $ prettyPrintType ty
328+ ]
329+ go (PropertyIsMissing prop row) = line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
330+ go (CannotApplyFunction fn arg) = paras [ line "Cannot apply function of type"
331+ , indent $ line $ prettyPrintType fn
332+ , line "to argument"
333+ , indent $ line $ prettyPrintValue arg
334+ ]
335+ go TypeSynonymInstance = line "Type synonym instances are disallowed"
336+ go InvalidNewtype = line "Newtypes must define a single constructor with a single argument"
337+ go (InvalidInstanceHead ty) = paras [ line "Invalid type in class instance head:"
338+ , indent $ line $ prettyPrintType ty
339+ ]
340+ go (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
341+ : map (line . prettyPrintExport) ys
342+ go (ErrorUnifyingTypes t1 t2 err) = paras [ line "Error unifying type "
343+ , indent $ line $ prettyPrintType t1
344+ , line "with type"
345+ , indent $ line $ prettyPrintType t2
346+ , go err
347+ ]
348+ go (ErrorInExpression expr err) = paras [ line "Error in expression:"
349+ , indent $ line $ prettyPrintValue expr
350+ , go err
351+ ]
352+ go (ErrorInModule mn err) = paras [ line $ "Error in module " ++ show mn ++ ":"
353+ , go err
354+ ]
355+ go (ErrorInSubsumption t1 t2 err) = paras [ line "Error checking that type "
356+ , indent $ line $ prettyPrintType t1
357+ , line "subsumes type"
358+ , indent $ line $ prettyPrintType t2
359+ , go err
360+ ]
361+ go (ErrorInInstance name ts err) = paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
362+ , go err
363+ ]
364+ go (ErrorCheckingKind ty err) = paras [ line "Error checking kind of type "
365+ , indent $ line $ prettyPrintType ty
366+ , go err
367+ ]
368+ go (ErrorInferringType expr err) = paras [ line "Error inferring type of value "
369+ , indent $ line $ prettyPrintValue expr
370+ , go err
371+ ]
372+ go (ErrorCheckingType expr ty err) = paras [ line "Error checking that value "
373+ , indent $ line $ prettyPrintValue expr
374+ , line "has type"
375+ , indent $ line $ prettyPrintType ty
376+ , go err
377+ ]
378+ go (ErrorInApplication f t a err) = paras [ line "Error applying function"
379+ , indent $ line $ prettyPrintValue f
380+ , line "of type"
381+ , indent $ line $ prettyPrintType t
382+ , line "to argument"
383+ , indent $ line $ prettyPrintValue a
384+ , go err
385+ ]
386+ go (ErrorInDataConstructor nm err) = paras [ line $ "Error in data constructor " ++ show nm ++ ":"
387+ , go err
388+ ]
389+ go (ErrorInTypeConstructor nm err) = paras [ line $ "Error in type constructor " ++ show nm ++ ":"
390+ , go err
391+ ]
392+ go (ErrorInBindingGroup nms err) = paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
393+ , go err
394+ ]
395+ go (ErrorInDataBindingGroup err) = paras [ line $ "Error in data binding group:"
396+ , go err
397+ ]
398+ go (ErrorInTypeSynonym name err) = paras [ line $ "Error in type synonym " ++ show name ++ ":"
399+ , go err
400+ ]
401+ go (ErrorInValueDeclaration n err) = paras [ line $ "Error in value declaration " ++ show n ++ ":"
402+ , go err
403+ ]
404+ go (ErrorInForeignImport nm err) = paras [ line $ "Error in foreign import " ++ show nm ++ ":"
405+ , go err
406+ ]
407+ go (PositionedError pos err) = paras [ line $ "Error at " ++ show pos ++ ":"
408+ , indent $ go err
409+ ]
410+
411+ line :: String -> Box.Box
412+ line = Box.text
413+
414+ paras :: [Box.Box] -> Box.Box
415+ paras = Box.vcat Box.left
416+
417+ indent :: Box.Box -> Box.Box
418+ indent = Box.moveRight 2
419+
420+ -- |
421+ -- Render a DictionaryValue fit for human consumption in error messages
422+ --
423+ prettyPrintDictionaryValue :: DictionaryValue -> Box.Box
424+ prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"
425+ prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)
426+ prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"
427+ , indent $ paras $ map prettyPrintDictionaryValue args
428+ ]
429+ prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
430+ , indent $ prettyPrintDictionaryValue sup
431+ ]
432+
433+ -- |
434+ -- Pretty print and export declaration
435+ --
436+ prettyPrintExport :: DeclarationRef -> String
437+ prettyPrintExport (TypeRef pn _) = show pn
438+ prettyPrintExport (ValueRef ident) = show ident
439+ prettyPrintExport (TypeClassRef pn) = show pn
440+ prettyPrintExport (TypeInstanceRef ident) = show ident
441+ prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
442+
443+ -- |
444+ -- Simplify an error message
445+ --
446+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
447+ simplifyErrorMessage = unwrap Nothing
448+ where
449+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
450+ unwrap pos (ErrorInExpression _ err) = unwrap pos err
451+ unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
452+ unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
453+ unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
454+ unwrap pos (ErrorInferringType _ err) = unwrap pos err
455+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
456+ unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
457+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
458+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
459+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
460+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
461+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
462+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
463+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
464+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
465+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
466+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
467+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err
468+ unwrap pos other = wrap pos other
469+
470+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
471+ wrap Nothing = id
472+ wrap (Just pos) = PositionedError pos
372473
373474-- |
374475-- Pretty print multiple errors
375476--
376477prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
377−prettyPrintMultipleErrors full (MultipleErrors [e]) =
478+prettyPrintMultipleErrors full (MultipleErrors [e]) = renderBox $
378479 prettyPrintSingleError full e
379−prettyPrintMultipleErrors full (MultipleErrors es) =
380− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es
480+prettyPrintMultipleErrors full (MultipleErrors es) = renderBox $
481+ Box.vcat Box.left [ Box.text "Multiple errors:"
482+ , Box.vsep 1 Box.left $ map (Box.moveRight 2 . prettyPrintSingleError full) es
483+ ]
484+
485+renderBox :: Box.Box -> String
486+renderBox = unlines . map trimEnd . lines . Box.render
487+ where
488+ trimEnd = reverse . dropWhile (== ' ') . reverse
381489
382490-- |
383491-- Interpret multiple errors in a monad supporting errors