@@ -20,10 +20,11 @@
2020module Language.PureScript.Errors where
2121
2222import Data.Either (lefts, rights)
23−import Data.List (intercalate, transpose)
23+import Data.List (intercalate, transpose, nub, nubBy, partition)
2424import Data.Function (on)
2525#if __GLASGOW_HASKELL__ < 710
2626import Data.Foldable (fold, foldMap)
27+import Data.Traversable (traverse)
2728#else
2829import Data.Foldable (fold)
2930#endif
@@ -52,11 +53,8 @@ import qualified Text.PrettyPrint.Boxes as Box
5253import qualified Text.Parsec as P
5354import qualified Text.Parsec.Error as PE
5455import Text.Parsec.Error (Message(..))
55−import Data.List (nub)
5656
57−-- |
58−-- A type of error messages
59−--
57+-- | A type of error messages
6058data SimpleErrorMessage
6159 = ErrorParsingExterns P.ParseError
6260 | ErrorParsingFFIModule FilePath
@@ -100,6 +98,7 @@ data SimpleErrorMessage
10098 | CtorConflictsWithClass ProperName
10199 | ClassConflictsWithType ProperName
102100 | ClassConflictsWithCtor ProperName
101+ | DuplicateModuleName ModuleName
103102 | DuplicateClassExport ProperName
104103 | DuplicateValueExport Ident
105104 | DuplicateTypeArgument String
@@ -143,45 +142,54 @@ data SimpleErrorMessage
143142 | ShadowedTypeVar String
144143 | UnusedTypeVar String
145144 | WildcardInferredType Type
145+ | MissingTypeDeclaration Ident
146146 | NotExhaustivePattern [[Binder]] Bool
147147 | OverlappingPattern [[Binder]] Bool
148148 | IncompleteExhaustivityCheck
149149 | ClassOperator ProperName Ident
150150 | MisleadingEmptyTypeImport ModuleName ProperName
151151 | ImportHidingModule ModuleName
152− deriving (Show)
153−
154−-- |
155−-- Wrapper of simpler errors
156−--
157−data ErrorMessage
158− = NotYetDefined [Ident] ErrorMessage
159− | ErrorUnifyingTypes Type Type ErrorMessage
160− | ErrorInExpression Expr ErrorMessage
161− | ErrorInModule ModuleName ErrorMessage
162− | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
163− | ErrorInSubsumption Type Type ErrorMessage
164− | ErrorCheckingType Expr Type ErrorMessage
165− | ErrorCheckingKind Type ErrorMessage
166− | ErrorInferringType Expr ErrorMessage
167− | ErrorInApplication Expr Type Expr ErrorMessage
168− | ErrorInDataConstructor ProperName ErrorMessage
169− | ErrorInTypeConstructor ProperName ErrorMessage
170− | ErrorInBindingGroup [Ident] ErrorMessage
171− | ErrorInDataBindingGroup ErrorMessage
172− | ErrorInTypeSynonym ProperName ErrorMessage
173− | ErrorInValueDeclaration Ident ErrorMessage
174− | ErrorInTypeDeclaration Ident ErrorMessage
175− | ErrorInForeignImport Ident ErrorMessage
176− | PositionedError SourceSpan ErrorMessage
177− | SimpleErrorWrapper SimpleErrorMessage
178− deriving (Show)
152+ deriving Show
153+
154+-- | Error message hints, providing more detailed information about failure.
155+data ErrorMessageHint
156+ = NotYetDefined [Ident]
157+ | ErrorUnifyingTypes Type Type
158+ | ErrorInExpression Expr
159+ | ErrorInModule ModuleName
160+ | ErrorInInstance (Qualified ProperName) [Type]
161+ | ErrorInSubsumption Type Type
162+ | ErrorCheckingType Expr Type
163+ | ErrorCheckingKind Type
164+ | ErrorInferringType Expr
165+ | ErrorInApplication Expr Type Expr
166+ | ErrorInDataConstructor ProperName
167+ | ErrorInTypeConstructor ProperName
168+ | ErrorInBindingGroup [Ident]
169+ | ErrorInDataBindingGroup
170+ | ErrorInTypeSynonym ProperName
171+ | ErrorInValueDeclaration Ident
172+ | ErrorInTypeDeclaration Ident
173+ | ErrorInForeignImport Ident
174+ | PositionedError SourceSpan
175+ deriving Show
176+
177+-- | Categories of hints
178+data HintCategory
179+ = ExprHint
180+ | KindHint
181+ | CheckHint
182+ | PositionHint
183+ | OtherHint
184+ deriving (Show, Eq)
185+
186+data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
179187
180188instance UnificationError Type ErrorMessage where
181− occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
189+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t
182190
183191instance UnificationError Kind ErrorMessage where
184− occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
192+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k
185193
186194-- |
187195-- Get the error code for a particular error type
@@ -230,6 +238,7 @@ errorCode em = case unwrapErrorMessage em of
230238 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
231239 ClassConflictsWithType{} -> "ClassConflictsWithType"
232240 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
241+ DuplicateModuleName{} -> "DuplicateModuleName"
233242 DuplicateClassExport{} -> "DuplicateClassExport"
234243 DuplicateValueExport{} -> "DuplicateValueExport"
235244 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -273,6 +282,7 @@ errorCode em = case unwrapErrorMessage em of
273282 ShadowedTypeVar{} -> "ShadowedTypeVar"
274283 UnusedTypeVar{} -> "UnusedTypeVar"
275284 WildcardInferredType{} -> "WildcardInferredType"
285+ MissingTypeDeclaration{} -> "MissingTypeDeclaration"
276286 NotExhaustivePattern{} -> "NotExhaustivePattern"
277287 OverlappingPattern{} -> "OverlappingPattern"
278288 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
@@ -300,7 +310,7 @@ nonEmpty = not . null . runMultipleErrors
300310-- Create an error set from a single simple error message
301311--
302312errorMessage :: SimpleErrorMessage -> MultipleErrors
303−errorMessage err = MultipleErrors [SimpleErrorWrapper err]
313+errorMessage err = MultipleErrors [ErrorMessage [] err]
304314
305315
306316-- |
@@ -309,12 +319,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]
309319singleError :: ErrorMessage -> MultipleErrors
310320singleError = MultipleErrors . pure
311321
312−-- |
313−-- Lift a function on ErrorMessage to a function on MultipleErrors
314−--
322+-- | Lift a function on ErrorMessage to a function on MultipleErrors
315323onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
316324onErrorMessages f = MultipleErrors . map f . runMultipleErrors
317325
326+-- | Add a hint to an error message
327+addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
328+addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
329+
318330-- | The various types of things which might need to be relabelled in errors messages.
319331data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
320332
@@ -328,27 +340,7 @@ data Level = Error | Warning deriving Show
328340-- Extract nested error messages from wrapper errors
329341--
330342unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
331−unwrapErrorMessage em = case em of
332− (ErrorCheckingKind _ err) -> unwrapErrorMessage err
333− (ErrorCheckingType _ _ err) -> unwrapErrorMessage err
334− (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err
335− (ErrorInBindingGroup _ err) -> unwrapErrorMessage err
336− (ErrorInDataBindingGroup err) -> unwrapErrorMessage err
337− (ErrorInDataConstructor _ err) -> unwrapErrorMessage err
338− (ErrorInExpression _ err) -> unwrapErrorMessage err
339− (ErrorInForeignImport _ err) -> unwrapErrorMessage err
340− (ErrorInInstance _ _ err) -> unwrapErrorMessage err
341− (ErrorInModule _ err) -> unwrapErrorMessage err
342− (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err
343− (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err
344− (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err
345− (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err
346− (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err
347− (ErrorInferringType _ err) -> unwrapErrorMessage err
348− (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err
349− (NotYetDefined _ err) -> unwrapErrorMessage err
350− (PositionedError _ err) -> unwrapErrorMessage err
351− (SimpleErrorWrapper sem) -> sem
343+unwrapErrorMessage (ErrorMessage _ se) = se
352344
353345replaceUnknowns :: Type -> State UnknownMap Type
354346replaceUnknowns = everywhereOnTypesM replaceTypes
@@ -364,404 +356,406 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
364356 replaceTypes other = return other
365357
366358onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
367−onTypesInErrorMessageM f = g
359+onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
368360 where
369− gSimple (InfiniteType t) = InfiniteType <$> (f t)
370− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
371− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
372− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
373− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
374− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
361+ gSimple (InfiniteType t) = InfiniteType <$> f t
362+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
363+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
364+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
365+ gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t
366+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
375367 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
376368 gSimple other = pure other
377− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
378− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
379− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
380− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
381− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
382− g (NotYetDefined x e) = NotYetDefined x <$> (g e)
383− g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
384− g (ErrorInModule x e) = ErrorInModule x <$> (g e)
385− g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
386− g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
387− g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
388− g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
389− g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
390− g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
391− g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
392− g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
393− g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e)
394− g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
395− g (PositionedError x e) = PositionedError x <$> (g e)
396− g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem
369+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
370+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
371+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
372+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
373+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
374+ gHint other = pure other
397375
398376-- |
399377-- Pretty print a single error, simplifying if necessary
400378--
401379prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
402−prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
380+prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
403381 where
404− -- |
382+
405383 -- Pretty print an ErrorMessage
406− --
407384 prettyPrintErrorMessage :: ErrorMessage -> Box.Box
408− prettyPrintErrorMessage em =
385+ prettyPrintErrorMessage (ErrorMessage hints simple) =
409386 paras $
410− go em:suggestions em ++
387+ map renderHint hints ++
388+ renderSimpleErrorMessage simple :
389+ suggestions simple ++
411390 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
412391 where
413392 wikiUri :: String
414393 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
415394
416− go :: ErrorMessage -> Box.Box
417− goSimple (CannotGetFileInfo path) =
395+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
396+ renderSimpleErrorMessage (CannotGetFileInfo path) =
418397 paras [ line "Unable to read file info: "
419398 , indent . line $ path
420399 ]
421− goSimple (CannotReadFile path) =
400+ renderSimpleErrorMessage (CannotReadFile path) =
422401 paras [ line "Unable to read file: "
423402 , indent . line $ path
424403 ]
425− goSimple (CannotWriteFile path) =
404+ renderSimpleErrorMessage (CannotWriteFile path) =
426405 paras [ line "Unable to write file: "
427406 , indent . line $ path
428407 ]
429− goSimple (ErrorParsingExterns err) =
408+ renderSimpleErrorMessage (ErrorParsingExterns err) =
430409 paras [ lineWithLevel "parsing externs files: "
431− , indent . prettyPrintParseError $ err
410+ , prettyPrintParseError err
432411 ]
433− goSimple (ErrorParsingFFIModule path) =
412+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =
434413 paras [ line "Unable to parse module from FFI file: "
435414 , indent . line $ path
436415 ]
437− goSimple (ErrorParsingModule err) =
416+ renderSimpleErrorMessage (ErrorParsingModule err) =
438417 paras [ line "Unable to parse module: "
439− , indent . prettyPrintParseError $ err
418+ , prettyPrintParseError err
440419 ]
441− goSimple (MissingFFIModule mn) =
420+ renderSimpleErrorMessage (MissingFFIModule mn) =
442421 line $ "Missing FFI implementations for module " ++ runModuleName mn
443− goSimple (UnnecessaryFFIModule mn path) =
422+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
444423 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
445424 , indent . line $ path
446425 ]
447− goSimple (MultipleFFIModules mn paths) =
448− paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " ]
449− ++ map (indent . line) paths
450− goSimple (InvalidExternsFile path) =
426+ renderSimpleErrorMessage (MultipleFFIModules mn paths) =
427+ paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
428+ , indent . paras $ map line paths
429+ ]
430+ renderSimpleErrorMessage (InvalidExternsFile path) =
451431 paras [ line "Externs file is invalid: "
452432 , indent . line $ path
453433 ]
454− goSimple InvalidDoBind =
434+ renderSimpleErrorMessage InvalidDoBind =
455435 line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."
456− goSimple InvalidDoLet =
436+ renderSimpleErrorMessage InvalidDoLet =
457437 line "Let statement cannot be the last statement in a do block. The last statement must be an expression."
458− goSimple CannotReorderOperators =
438+ renderSimpleErrorMessage CannotReorderOperators =
459439 line "Unable to reorder operators"
460− goSimple UnspecifiedSkolemScope =
440+ renderSimpleErrorMessage UnspecifiedSkolemScope =
461441 line "Skolem variable scope is unspecified"
462− goSimple OverlappingNamesInLet =
442+ renderSimpleErrorMessage OverlappingNamesInLet =
463443 line "Overlapping names in let binding."
464− goSimple (InfiniteType ty) =
444+ renderSimpleErrorMessage (InfiniteType ty) =
465445 paras [ line "An infinite type was inferred for an expression: "
466− , indent $ line $ prettyPrintType ty
446+ , indent $ typeAsBox ty
467447 ]
468− goSimple (InfiniteKind ki) =
448+ renderSimpleErrorMessage (InfiniteKind ki) =
469449 paras [ line "An infinite kind was inferred for a type: "
470450 , indent $ line $ prettyPrintKind ki
471451 ]
472− goSimple (MultipleFixities name) =
452+ renderSimpleErrorMessage (MultipleFixities name) =
473453 line $ "Multiple fixity declarations for " ++ showIdent name
474− goSimple (OrphanTypeDeclaration nm) =
454+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
475455 line $ "Orphan type declaration for " ++ showIdent nm
476− goSimple (OrphanFixityDeclaration op) =
456+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =
477457 line $ "Orphan fixity declaration for " ++ show op
478− goSimple (RedefinedModule name filenames) =
479− paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
480− : map (indent . line . displaySourceSpan) filenames
481− goSimple (RedefinedIdent name) =
458+ renderSimpleErrorMessage (RedefinedModule name filenames) =
459+ paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
460+ , indent . paras $ map (line . displaySourceSpan) filenames
461+ ]
462+ renderSimpleErrorMessage (RedefinedIdent name) =
482463 line $ "Name " ++ showIdent name ++ " has been defined multiple times"
483− goSimple (UnknownModule mn) =
464+ renderSimpleErrorMessage (UnknownModule mn) =
484465 line $ "Unknown module " ++ runModuleName mn
485− goSimple (UnknownType name) =
466+ renderSimpleErrorMessage (UnknownType name) =
486467 line $ "Unknown type " ++ showQualified runProperName name
487− goSimple (UnknownTypeClass name) =
468+ renderSimpleErrorMessage (UnknownTypeClass name) =
488469 line $ "Unknown type class " ++ showQualified runProperName name
489− goSimple (UnknownValue name) =
470+ renderSimpleErrorMessage (UnknownValue name) =
490471 line $ "Unknown value " ++ showQualified showIdent name
491− goSimple (UnknownTypeConstructor name) =
472+ renderSimpleErrorMessage (UnknownTypeConstructor name) =
492473 line $ "Unknown type constructor " ++ showQualified runProperName name
493− goSimple (UnknownDataConstructor dc tc) =
474+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =
494475 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
495− goSimple (UnknownImportType mn name) =
476+ renderSimpleErrorMessage (UnknownImportType mn name) =
496477 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name
497− goSimple (UnknownExportType name) =
478+ renderSimpleErrorMessage (UnknownExportType name) =
498479 line $ "Cannot export unknown type " ++ runProperName name
499− goSimple (UnknownImportTypeClass mn name) =
480+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
500481 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name
501− goSimple (UnknownExportTypeClass name) =
482+ renderSimpleErrorMessage (UnknownExportTypeClass name) =
502483 line $ "Cannot export unknown type class " ++ runProperName name
503− goSimple (UnknownImportValue mn name) =
484+ renderSimpleErrorMessage (UnknownImportValue mn name) =
504485 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name
505− goSimple (UnknownExportValue name) =
486+ renderSimpleErrorMessage (UnknownExportValue name) =
506487 line $ "Cannot export unknown value " ++ showIdent name
507− goSimple (UnknownExportModule name) =
488+ renderSimpleErrorMessage (UnknownExportModule name) =
508489 line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"
509− goSimple (UnknownImportDataConstructor mn tcon dcon) =
490+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
510491 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
511− goSimple (UnknownExportDataConstructor tcon dcon) =
492+ renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
512493 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"
513− goSimple (ConflictingImport nm mn) =
494+ renderSimpleErrorMessage (ConflictingImport nm mn) =
514495 line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn
515− goSimple (ConflictingImports nm m1 m2) =
496+ renderSimpleErrorMessage (ConflictingImports nm m1 m2) =
516497 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
517− goSimple (ConflictingTypeDecls nm) =
498+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =
518499 line $ "Conflicting type declarations for " ++ runProperName nm
519− goSimple (ConflictingCtorDecls nm) =
500+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =
520501 line $ "Conflicting data constructor declarations for " ++ runProperName nm
521− goSimple (TypeConflictsWithClass nm) =
502+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =
522503 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
523− goSimple (CtorConflictsWithClass nm) =
504+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =
524505 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
525− goSimple (ClassConflictsWithType nm) =
506+ renderSimpleErrorMessage (ClassConflictsWithType nm) =
526507 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
527− goSimple (ClassConflictsWithCtor nm) =
508+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
528509 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
529− goSimple (DuplicateClassExport nm) =
510+ renderSimpleErrorMessage (DuplicateModuleName mn) =
511+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
512+ renderSimpleErrorMessage (DuplicateClassExport nm) =
530513 line $ "Duplicate export declaration for type class " ++ runProperName nm
531− goSimple (DuplicateValueExport nm) =
514+ renderSimpleErrorMessage (DuplicateValueExport nm) =
532515 line $ "Duplicate export declaration for value " ++ showIdent nm
533− goSimple (CycleInDeclaration nm) =
516+ renderSimpleErrorMessage (CycleInDeclaration nm) =
534517 line $ "Cycle in declaration of " ++ showIdent nm
535− goSimple (CycleInModules mns) =
518+ renderSimpleErrorMessage (CycleInModules mns) =
536519 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)
537− goSimple (CycleInTypeSynonym pn) =
520+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =
538521 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn
539− goSimple (NameIsUndefined ident) =
522+ renderSimpleErrorMessage (NameIsUndefined ident) =
540523 line $ showIdent ident ++ " is undefined"
541− goSimple (NameNotInScope ident) =
524+ renderSimpleErrorMessage (NameNotInScope ident) =
542525 line $ showIdent ident ++ " may not be defined in the current scope"
543− goSimple (UndefinedTypeVariable name) =
526+ renderSimpleErrorMessage (UndefinedTypeVariable name) =
544527 line $ "Type variable " ++ runProperName name ++ " is undefined"
545− goSimple (PartiallyAppliedSynonym name) =
528+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
546529 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name
547530 , line "Type synonyms must be applied to all of their type arguments."
548531 ]
549− goSimple (EscapedSkolem binding) =
532+ renderSimpleErrorMessage (EscapedSkolem binding) =
550533 paras $ [ line "A type variable has escaped its scope." ]
551534 <> foldMap (\expr -> [ line "Relevant expression: "
552− , indent $ line $ prettyPrintValue expr
535+ , indent $ prettyPrintValue expr
553536 ]) binding
554− goSimple (TypesDoNotUnify t1 t2)
537+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
555538 = paras [ line "Cannot unify type"
556− , indent $ line $ prettyPrintType t1
539+ , indent $ typeAsBox t1
557540 , line "with type"
558− , indent $ line $ prettyPrintType t2
541+ , indent $ typeAsBox t2
559542 ]
560− goSimple (KindsDoNotUnify k1 k2) =
543+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
561544 paras [ line "Cannot unify kind"
562545 , indent $ line $ prettyPrintKind k1
563546 , line "with kind"
564547 , indent $ line $ prettyPrintKind k2
565548 ]
566− goSimple (ConstrainedTypeUnified t1 t2) =
549+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
567550 paras [ line "Cannot unify constrained type"
568− , indent $ line $ prettyPrintType t1
551+ , indent $ typeAsBox t1
569552 , line "with type"
570− , indent $ line $ prettyPrintType t2
571− ]
572− goSimple (OverlappingInstances nm ts (d : ds)) =
573− paras [ line $ "Overlapping instances found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
553+ , indent $ typeAsBox t2
554+ ]
555+ renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
556+ paras [ line "Overlapping instances found for"
557+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
558+ , Box.vcat Box.left (map typeAtomAsBox ts)
559+ ]
560+ , line "The following instances were found:"
574561 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
575562 ]
576− goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"
577− goSimple (NoInstanceFound nm ts) =
578− line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
579− goSimple (PossiblyInfiniteInstance nm ts) =
580− line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."
581− goSimple (CannotDerive nm ts) =
582− line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)
583− goSimple (CannotFindDerivingType nm) =
563+ renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"
564+ renderSimpleErrorMessage (NoInstanceFound nm ts) =
565+ paras [ line "No instance found for"
566+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
567+ , Box.vcat Box.left (map typeAtomAsBox ts)
568+ ]
569+ ]
570+ renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
571+ paras [ line "Instance for"
572+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
573+ , Box.vcat Box.left (map typeAtomAsBox ts)
574+ ]
575+ , line "is possibly infinite."
576+ ]
577+ renderSimpleErrorMessage (CannotDerive nm ts) =
578+ paras [ line "Cannot derive an instance for"
579+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
580+ , Box.vcat Box.left (map typeAtomAsBox ts)
581+ ]
582+ ]
583+ renderSimpleErrorMessage (CannotFindDerivingType nm) =
584584 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
585− goSimple (DuplicateLabel l expr) =
585+ renderSimpleErrorMessage (DuplicateLabel l expr) =
586586 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
587587 <> foldMap (\expr' -> [ line "Relevant expression: "
588− , indent $ line $ prettyPrintValue expr'
588+ , indent $ prettyPrintValue expr'
589589 ]) expr
590− goSimple (DuplicateTypeArgument name) =
590+ renderSimpleErrorMessage (DuplicateTypeArgument name) =
591591 line $ "Duplicate type argument " ++ show name
592− goSimple (DuplicateValueDeclaration nm) =
592+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
593593 line $ "Duplicate value declaration for " ++ showIdent nm
594− goSimple (ArgListLengthsDiffer ident) =
594+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
595595 line $ "Argument list lengths differ in declaration " ++ showIdent ident
596− goSimple (OverlappingArgNames ident) =
596+ renderSimpleErrorMessage (OverlappingArgNames ident) =
597597 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident
598− goSimple (MissingClassMember ident) =
598+ renderSimpleErrorMessage (MissingClassMember ident) =
599599 line $ "Member " ++ showIdent ident ++ " has not been implemented"
600− goSimple (ExtraneousClassMember ident) =
600+ renderSimpleErrorMessage (ExtraneousClassMember ident) =
601601 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"
602− goSimple (ExpectedType ty kind) =
602+ renderSimpleErrorMessage (ExpectedType ty kind) =
603603 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
604− , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead."
604+ , line "The error arises from the type"
605+ , indent $ typeAsBox ty
606+ , line "having the kind"
607+ , indent $ line $ prettyPrintKind kind
608+ , line "instead."
605609 ]
606− goSimple (IncorrectConstructorArity nm) =
610+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =
607611 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm
608− goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"
609− goSimple (ExprDoesNotHaveType expr ty) =
612+ renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"
613+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
610614 paras [ line "Expression"
611− , indent $ line $ prettyPrintValue expr
615+ , indent $ prettyPrintValue expr
612616 , line "does not have type"
613− , indent $ line $ prettyPrintType ty
617+ , indent $ typeAsBox ty
614618 ]
615− goSimple (PropertyIsMissing prop row) =
616− line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
617− goSimple (CannotApplyFunction fn arg) =
619+ renderSimpleErrorMessage (PropertyIsMissing prop row) =
620+ paras [ line "Row"
621+ , indent $ prettyPrintRowWith '(' ')' row
622+ , line $ "lacks required property " ++ show prop
623+ ]
624+ renderSimpleErrorMessage (CannotApplyFunction fn arg) =
618625 paras [ line "Cannot apply function of type"
619− , indent $ line $ prettyPrintType fn
626+ , indent $ typeAsBox fn
620627 , line "to argument"
621− , indent $ line $ prettyPrintValue arg
628+ , indent $ prettyPrintValue arg
622629 ]
623− goSimple TypeSynonymInstance =
630+ renderSimpleErrorMessage TypeSynonymInstance =
624631 line "Type synonym instances are disallowed"
625− goSimple (OrphanInstance nm cnm ts) =
626− paras [ line $ "Instance " ++ showIdent nm ++ " for " ++ showQualified runProperName cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance."
632+ renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
633+ paras [ line $ "Instance " ++ showIdent nm ++ " for "
634+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)
635+ , Box.vcat Box.left (map typeAtomAsBox ts)
636+ ]
637+ , line "is an orphan instance."
627638 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
628639 , line "Consider moving the instance, if possible, or using a newtype wrapper."
629640 ]
630− goSimple InvalidNewtype =
641+ renderSimpleErrorMessage InvalidNewtype =
631642 line "Newtypes must define a single constructor with a single argument"
632− goSimple (InvalidInstanceHead ty) =
643+ renderSimpleErrorMessage (InvalidInstanceHead ty) =
633644 paras [ line "Invalid type in class instance head:"
634− , indent $ line $ prettyPrintType ty
645+ , indent $ typeAsBox ty
635646 ]
636− goSimple (TransitiveExportError x ys) =
647+ renderSimpleErrorMessage (TransitiveExportError x ys) =
637648 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
638649 : map (line . prettyPrintExport) ys
639− goSimple (ShadowedName nm) =
650+ renderSimpleErrorMessage (ShadowedName nm) =
640651 line $ "Name '" ++ showIdent nm ++ "' was shadowed"
641− goSimple (ShadowedTypeVar tv) =
652+ renderSimpleErrorMessage (ShadowedTypeVar tv) =
642653 line $ "Type variable '" ++ tv ++ "' was shadowed"
643− goSimple (UnusedTypeVar tv) =
654+ renderSimpleErrorMessage (UnusedTypeVar tv) =
644655 line $ "Type variable '" ++ tv ++ "' was declared but not used"
645− goSimple (ClassOperator className opName) =
656+ renderSimpleErrorMessage (ClassOperator className opName) =
646657 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."
647− , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
648− , indent $ line $ showIdent opName ++ " = someMember"
658+ , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
659+ , indent . line $ showIdent opName ++ " = someMember"
649660 ]
650− goSimple (MisleadingEmptyTypeImport mn name) =
661+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
651662 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"
652− goSimple (ImportHidingModule name) =
663+ renderSimpleErrorMessage (ImportHidingModule name) =
653664 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"
654− goSimple (WildcardInferredType ty) =
655− line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
656− goSimple (NotExhaustivePattern bs b) =
665+ renderSimpleErrorMessage (WildcardInferredType ty) =
666+ paras [ line "The wildcard type definition has the inferred type "
667+ , indent $ typeAsBox ty
668+ ]
669+ renderSimpleErrorMessage (MissingTypeDeclaration ident) =
670+ paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."
671+ , line "It is good practice to provide type declarations as a form of documentation."
672+ , line "Consider using a type wildcard to display the inferred type:"
673+ , indent $ line $ showIdent ident ++ " :: _"
674+ ]
675+ renderSimpleErrorMessage (NotExhaustivePattern bs b) =
657676 paras $ [ line "A case expression could not be determined to cover all inputs."
658677 , line "The following additional cases are required to cover all inputs:\n"
659678 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
660679 ] ++
661680 [ line "..." | not b ]
662− goSimple (OverlappingPattern bs b) =
681+ renderSimpleErrorMessage (OverlappingPattern bs b) =
663682 paras $ [ line "A case expression contains unreachable cases:\n"
664683 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
665684 ] ++
666685 [ line "..." | not b ]
667− goSimple IncompleteExhaustivityCheck =
686+ renderSimpleErrorMessage IncompleteExhaustivityCheck =
668687 paras [ line "An exhaustivity check was abandoned due to too many possible cases."
669688 , line "You may want to decomposing your data types into smaller types."
670689 ]
671− go (NotYetDefined names err) =
672− paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
673− , indent $ go err
674− ]
675− go (ErrorUnifyingTypes t1 t2 err) =
690+
691+ renderHint :: ErrorMessageHint -> Box.Box
692+ renderHint (NotYetDefined names) =
693+ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
694+ renderHint (ErrorUnifyingTypes t1 t2) =
676695 paras [ lineWithLevel "unifying type "
677− , indent $ line $ prettyPrintType t1
696+ , indent $ typeAsBox t1
678697 , line "with type"
679− , indent $ line $ prettyPrintType t2
680− , go err
698+ , indent $ typeAsBox t2
681699 ]
682− go (ErrorInExpression expr err) =
700+ renderHint (ErrorInExpression expr) =
683701 paras [ lineWithLevel "in expression:"
684− , indent $ line $ prettyPrintValue expr
685− , go err
702+ , indent $ prettyPrintValue expr
686703 ]
687− go (ErrorInModule mn err) =
704+ renderHint (ErrorInModule mn) =
688705 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
689− , go err
690706 ]
691− go (ErrorInSubsumption t1 t2 err) =
707+ renderHint (ErrorInSubsumption t1 t2) =
692708 paras [ lineWithLevel "checking that type "
693− , indent $ line $ prettyPrintType t1
709+ , indent $ typeAsBox t1
694710 , line "subsumes type"
695− , indent $ line $ prettyPrintType t2
696− , go err
711+ , indent $ typeAsBox t2
697712 ]
698− go (ErrorInInstance name ts err) =
699− paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
700− , go err
713+ renderHint (ErrorInInstance nm ts) =
714+ paras [ lineWithLevel "in type class instance"
715+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
716+ , Box.vcat Box.left (map typeAtomAsBox ts)
717+ ]
701718 ]
702− go (ErrorCheckingKind ty err) =
719+ renderHint (ErrorCheckingKind ty) =
703720 paras [ lineWithLevel "checking kind of type "
704− , indent $ line $ prettyPrintType ty
705− , go err
721+ , indent $ typeAsBox ty
706722 ]
707− go (ErrorInferringType expr err) =
723+ renderHint (ErrorInferringType expr) =
708724 paras [ lineWithLevel "inferring type of value "
709− , indent $ line $ prettyPrintValue expr
710− , go err
725+ , indent $ prettyPrintValue expr
711726 ]
712− go (ErrorCheckingType expr ty err) =
727+ renderHint (ErrorCheckingType expr ty) =
713728 paras [ lineWithLevel "checking that value "
714− , indent $ line $ prettyPrintValue expr
729+ , indent $ prettyPrintValue expr
715730 , line "has type"
716− , indent $ line $ prettyPrintType ty
717− , go err
731+ , indent $ typeAsBox ty
718732 ]
719− go (ErrorInApplication f t a err) =
733+ renderHint (ErrorInApplication f t a) =
720734 paras [ lineWithLevel "applying function"
721− , indent $ line $ prettyPrintValue f
735+ , indent $ prettyPrintValue f
722736 , line "of type"
723− , indent $ line $ prettyPrintType t
737+ , indent $ typeAsBox t
724738 , line "to argument"
725− , indent $ line $ prettyPrintValue a
726− , go err
727− ]
728− go (ErrorInDataConstructor nm err) =
729− paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
730− , go err
731− ]
732− go (ErrorInTypeConstructor nm err) =
733− paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
734− , go err
735− ]
736− go (ErrorInBindingGroup nms err) =
737− paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
738− , go err
739− ]
740− go (ErrorInDataBindingGroup err) =
741− paras [ lineWithLevel $ "in data binding group:"
742− , go err
743− ]
744− go (ErrorInTypeSynonym name err) =
745− paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
746− , go err
747− ]
748− go (ErrorInValueDeclaration n err) =
749− paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
750− , go err
751− ]
752− go (ErrorInTypeDeclaration n err) =
753− paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
754− , go err
755− ]
756− go (ErrorInForeignImport nm err) =
757− paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
758− , go err
759− ]
760− go (PositionedError srcSpan err) =
761− paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
762− , indent $ go err
763− ]
764− go (SimpleErrorWrapper sem) = goSimple sem
739+ , indent $ prettyPrintValue a
740+ ]
741+ renderHint (ErrorInDataConstructor nm) =
742+ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
743+ renderHint (ErrorInTypeConstructor nm) =
744+ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
745+ renderHint (ErrorInBindingGroup nms) =
746+ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
747+ renderHint ErrorInDataBindingGroup =
748+ lineWithLevel "in data binding group:"
749+ renderHint (ErrorInTypeSynonym name) =
750+ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
751+ renderHint (ErrorInValueDeclaration n) =
752+ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
753+ renderHint (ErrorInTypeDeclaration n) =
754+ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
755+ renderHint (ErrorInForeignImport nm) =
756+ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
757+ renderHint (PositionedError srcSpan) =
758+ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
765759
766760 lineWithLevel :: String -> Box.Box
767761 lineWithLevel text = line $ show level ++ " " ++ text
@@ -771,23 +765,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
771765 Error -> "error"
772766 Warning -> "warning"
773767
774− suggestions :: ErrorMessage -> [Box.Box]
775− suggestions = suggestions' . unwrapErrorMessage
776− where
777− suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
768+ suggestions :: SimpleErrorMessage -> [Box.Box]
769+ suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
778770 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"
779771 ]
780− suggestions' (TypesDoNotUnify t1 t2)
781− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
782− | otherwise = []
783− suggestions' _ = []
772+ suggestions (TypesDoNotUnify t1 t2)
773+ | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
774+ | otherwise = []
775+ suggestions _ = []
784776
785777 paras :: [Box.Box] -> Box.Box
786778 paras = Box.vcat Box.left
787779
788− -- |
789780 -- Pretty print and export declaration
790− --
791781 prettyPrintExport :: DeclarationRef -> String
792782 prettyPrintExport (TypeRef pn _) = runProperName pn
793783 prettyPrintExport (ValueRef ident) = showIdent ident
@@ -796,38 +786,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
796786 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
797787 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
798788
799− -- |
800− -- Simplify an error message
801− --
802− simplifyErrorMessage :: ErrorMessage -> ErrorMessage
803− simplifyErrorMessage = unwrap Nothing
789+ -- Hints get added at the front, so we need to reverse them before rendering
790+ reverseHints :: ErrorMessage -> ErrorMessage
791+ reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple
792+
793+ -- | Put positional hints at the front of the list
794+ positionHintsFirst :: ErrorMessage -> ErrorMessage
795+ positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple
804796 where
805− unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
806− unwrap pos (ErrorInExpression _ err) = unwrap pos err
807− unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
808− unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
809− unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
810− unwrap pos (ErrorInferringType _ err) = unwrap pos err
811− unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
812− unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
813− unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
814− unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
815− unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
816− unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
817− unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
818− unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
819− unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
820− unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
821− unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err)
822− unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
823− unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
824− unwrap _ (PositionedError pos err) = unwrap (Just pos) err
825− unwrap pos other = wrap pos other
826−
827− wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
828− wrap Nothing = id
829− wrap (Just pos) = PositionedError pos
797+ isPositionHint :: HintCategory -> Bool
798+ isPositionHint PositionHint = True
799+ isPositionHint OtherHint = True
800+ isPositionHint _ = False
830801
802+ -- | Simplify an error message
803+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
804+ simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple
805+ where
806+ -- Take the last instance of each "hint category"
807+ simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
808+ simplifyHints = reverse . nubBy categoriesEqual . reverse
809+
810+ -- Don't remove hints in the "other" category
811+ categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
812+ categoriesEqual x y =
813+ case (hintCategory x, hintCategory y) of
814+ (OtherHint, _) -> False
815+ (_, OtherHint) -> False
816+ (c1, c2) -> c1 == c2
817+
818+ hintCategory :: ErrorMessageHint -> HintCategory
819+ hintCategory ErrorCheckingType{} = ExprHint
820+ hintCategory ErrorInferringType{} = ExprHint
821+ hintCategory ErrorInExpression{} = ExprHint
822+ hintCategory ErrorUnifyingTypes{} = CheckHint
823+ hintCategory ErrorInSubsumption{} = CheckHint
824+ hintCategory ErrorInApplication{} = CheckHint
825+ hintCategory PositionedError{} = PositionHint
826+ hintCategory _ = OtherHint
831827
832828-- |
833829-- Pretty print multiple errors
@@ -843,11 +839,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu
843839
844840-- | Pretty print warnings as a Box
845841prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
846−prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full
842+prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
847843
848844-- | Pretty print errors as a Box
849845prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
850−prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full
846+prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
851847
852848prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
853849prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
@@ -857,15 +853,16 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
857853 , result
858854 ]
859855prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
860− result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
861− return $
862− Box.vcat Box.left [ Box.text intro
863− , Box.vsep 1 Box.left result
864− ]
856+ result <- forM es $ prettyPrintSingleError full level
857+ return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
858+ where
859+ withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
860+ , Box.moveRight 2 err
861+ ]
865862
866863-- | Pretty print a Parsec ParseError as a Box
867864prettyPrintParseError :: P.ParseError -> Box.Box
868−prettyPrintParseError = (prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input") . PE.errorMessages
865+prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages
869866
870867-- |
871868-- Pretty print ParseError detail messages.
@@ -878,9 +875,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
878875 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
879876
880877 where
881− (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
882− (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
883− (expect,messages) = span ((Expect "") ==) msgs2
878+ (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs
879+ (unExpect,msgs2) = span (UnExpect "" ==) msgs1
880+ (expect,messages) = span (Expect "" ==) msgs2
884881
885882 showExpect = showMany msgExpecting expect
886883 showUnExpect = showMany msgUnExpected unExpect
@@ -911,8 +908,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
911908
912909 clean = nub . filter (not . null)
913910
911+-- | Indent to the right, and pad on top and bottom.
914912indent :: Box.Box -> Box.Box
915−indent = Box.moveRight 2
913+indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2
916914
917915line :: String -> Box.Box
918916line = Box.text
@@ -928,7 +926,7 @@ renderBox = unlines . map trimEnd . lines . Box.render
928926interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
929927interpretMultipleErrorsAndWarnings (err, ws) = do
930928 tell ws
931− either throwError return $ err
929+ either throwError return err
932930
933931-- |
934932-- Rethrow an error with a more detailed error message in the case of failure
@@ -952,8 +950,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple
952950warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
953951
954952withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
955−withPosition _ (PositionedError pos err) = withPosition pos err
956−withPosition pos err = PositionedError pos err
953+withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se
957954
958955-- |
959956-- Collect errors in in parallel