@@ -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,44 +142,54 @@ data SimpleErrorMessage
143142 | ShadowedTypeVar String
144143 | UnusedTypeVar String
145144 | WildcardInferredType Type
145+ | MissingTypeDeclaration Ident
146146 | NotExhaustivePattern [[Binder]] Bool
147147 | OverlappingPattern [[Binder]] Bool
148+ | IncompleteExhaustivityCheck
148149 | ClassOperator ProperName Ident
149150 | MisleadingEmptyTypeImport ModuleName ProperName
150151 | ImportHidingModule ModuleName
151− deriving (Show)
152−
153−-- |
154−-- Wrapper of simpler errors
155−--
156−data ErrorMessage
157− = NotYetDefined [Ident] ErrorMessage
158− | ErrorUnifyingTypes Type Type ErrorMessage
159− | ErrorInExpression Expr ErrorMessage
160− | ErrorInModule ModuleName ErrorMessage
161− | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
162− | ErrorInSubsumption Type Type ErrorMessage
163− | ErrorCheckingType Expr Type ErrorMessage
164− | ErrorCheckingKind Type ErrorMessage
165− | ErrorInferringType Expr ErrorMessage
166− | ErrorInApplication Expr Type Expr ErrorMessage
167− | ErrorInDataConstructor ProperName ErrorMessage
168− | ErrorInTypeConstructor ProperName ErrorMessage
169− | ErrorInBindingGroup [Ident] ErrorMessage
170− | ErrorInDataBindingGroup ErrorMessage
171− | ErrorInTypeSynonym ProperName ErrorMessage
172− | ErrorInValueDeclaration Ident ErrorMessage
173− | ErrorInTypeDeclaration Ident ErrorMessage
174− | ErrorInForeignImport Ident ErrorMessage
175− | PositionedError SourceSpan ErrorMessage
176− | SimpleErrorWrapper SimpleErrorMessage
177− 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)
178187
179188instance UnificationError Type ErrorMessage where
180− occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
189+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t
181190
182191instance UnificationError Kind ErrorMessage where
183− occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
192+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k
184193
185194-- |
186195-- Get the error code for a particular error type
@@ -229,6 +238,7 @@ errorCode em = case unwrapErrorMessage em of
229238 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
230239 ClassConflictsWithType{} -> "ClassConflictsWithType"
231240 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
241+ DuplicateModuleName{} -> "DuplicateModuleName"
232242 DuplicateClassExport{} -> "DuplicateClassExport"
233243 DuplicateValueExport{} -> "DuplicateValueExport"
234244 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -272,8 +282,10 @@ errorCode em = case unwrapErrorMessage em of
272282 ShadowedTypeVar{} -> "ShadowedTypeVar"
273283 UnusedTypeVar{} -> "UnusedTypeVar"
274284 WildcardInferredType{} -> "WildcardInferredType"
285+ MissingTypeDeclaration{} -> "MissingTypeDeclaration"
275286 NotExhaustivePattern{} -> "NotExhaustivePattern"
276287 OverlappingPattern{} -> "OverlappingPattern"
288+ IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
277289 ClassOperator{} -> "ClassOperator"
278290 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"
279291 ImportHidingModule{} -> "ImportHidingModule"
@@ -298,7 +310,7 @@ nonEmpty = not . null . runMultipleErrors
298310-- Create an error set from a single simple error message
299311--
300312errorMessage :: SimpleErrorMessage -> MultipleErrors
301−errorMessage err = MultipleErrors [SimpleErrorWrapper err]
313+errorMessage err = MultipleErrors [ErrorMessage [] err]
302314
303315
304316-- |
@@ -307,12 +319,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]
307319singleError :: ErrorMessage -> MultipleErrors
308320singleError = MultipleErrors . pure
309321
310−-- |
311−-- Lift a function on ErrorMessage to a function on MultipleErrors
312−--
322+-- | Lift a function on ErrorMessage to a function on MultipleErrors
313323onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
314324onErrorMessages f = MultipleErrors . map f . runMultipleErrors
315325
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+
316330-- | The various types of things which might need to be relabelled in errors messages.
317331data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
318332
@@ -326,27 +340,7 @@ data Level = Error | Warning deriving Show
326340-- Extract nested error messages from wrapper errors
327341--
328342unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
329−unwrapErrorMessage em = case em of
330− (ErrorCheckingKind _ err) -> unwrapErrorMessage err
331− (ErrorCheckingType _ _ err) -> unwrapErrorMessage err
332− (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err
333− (ErrorInBindingGroup _ err) -> unwrapErrorMessage err
334− (ErrorInDataBindingGroup err) -> unwrapErrorMessage err
335− (ErrorInDataConstructor _ err) -> unwrapErrorMessage err
336− (ErrorInExpression _ err) -> unwrapErrorMessage err
337− (ErrorInForeignImport _ err) -> unwrapErrorMessage err
338− (ErrorInInstance _ _ err) -> unwrapErrorMessage err
339− (ErrorInModule _ err) -> unwrapErrorMessage err
340− (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err
341− (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err
342− (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err
343− (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err
344− (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err
345− (ErrorInferringType _ err) -> unwrapErrorMessage err
346− (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err
347− (NotYetDefined _ err) -> unwrapErrorMessage err
348− (PositionedError _ err) -> unwrapErrorMessage err
349− (SimpleErrorWrapper sem) -> sem
343+unwrapErrorMessage (ErrorMessage _ se) = se
350344
351345replaceUnknowns :: Type -> State UnknownMap Type
352346replaceUnknowns = everywhereOnTypesM replaceTypes
@@ -362,400 +356,406 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
362356 replaceTypes other = return other
363357
364358onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
365−onTypesInErrorMessageM f = g
359+onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
366360 where
367− gSimple (InfiniteType t) = InfiniteType <$> (f t)
368− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
369− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
370− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
371− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
372− 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
373367 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
374368 gSimple other = pure other
375− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
376− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
377− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
378− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
379− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
380− g (NotYetDefined x e) = NotYetDefined x <$> (g e)
381− g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
382− g (ErrorInModule x e) = ErrorInModule x <$> (g e)
383− g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
384− g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
385− g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
386− g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
387− g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
388− g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
389− g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
390− g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
391− g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e)
392− g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
393− g (PositionedError x e) = PositionedError x <$> (g e)
394− 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
395375
396376-- |
397377-- Pretty print a single error, simplifying if necessary
398378--
399379prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
400−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)
401381 where
402− -- |
382+
403383 -- Pretty print an ErrorMessage
404− --
405384 prettyPrintErrorMessage :: ErrorMessage -> Box.Box
406− prettyPrintErrorMessage em =
385+ prettyPrintErrorMessage (ErrorMessage hints simple) =
407386 paras $
408− go em:suggestions em ++
387+ map renderHint hints ++
388+ renderSimpleErrorMessage simple :
389+ suggestions simple ++
409390 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
410391 where
411392 wikiUri :: String
412393 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
413394
414− go :: ErrorMessage -> Box.Box
415− goSimple (CannotGetFileInfo path) =
395+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
396+ renderSimpleErrorMessage (CannotGetFileInfo path) =
416397 paras [ line "Unable to read file info: "
417398 , indent . line $ path
418399 ]
419− goSimple (CannotReadFile path) =
400+ renderSimpleErrorMessage (CannotReadFile path) =
420401 paras [ line "Unable to read file: "
421402 , indent . line $ path
422403 ]
423− goSimple (CannotWriteFile path) =
404+ renderSimpleErrorMessage (CannotWriteFile path) =
424405 paras [ line "Unable to write file: "
425406 , indent . line $ path
426407 ]
427− goSimple (ErrorParsingExterns err) =
408+ renderSimpleErrorMessage (ErrorParsingExterns err) =
428409 paras [ lineWithLevel "parsing externs files: "
429− , indent . prettyPrintParseError $ err
410+ , prettyPrintParseError err
430411 ]
431− goSimple (ErrorParsingFFIModule path) =
412+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =
432413 paras [ line "Unable to parse module from FFI file: "
433414 , indent . line $ path
434415 ]
435− goSimple (ErrorParsingModule err) =
416+ renderSimpleErrorMessage (ErrorParsingModule err) =
436417 paras [ line "Unable to parse module: "
437− , indent . prettyPrintParseError $ err
418+ , prettyPrintParseError err
438419 ]
439− goSimple (MissingFFIModule mn) =
420+ renderSimpleErrorMessage (MissingFFIModule mn) =
440421 line $ "Missing FFI implementations for module " ++ runModuleName mn
441− goSimple (UnnecessaryFFIModule mn path) =
422+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
442423 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
443424 , indent . line $ path
444425 ]
445− goSimple (MultipleFFIModules mn paths) =
446− paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " ]
447− ++ map (indent . line) paths
448− 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) =
449431 paras [ line "Externs file is invalid: "
450432 , indent . line $ path
451433 ]
452− goSimple InvalidDoBind =
434+ renderSimpleErrorMessage InvalidDoBind =
453435 line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."
454− goSimple InvalidDoLet =
436+ renderSimpleErrorMessage InvalidDoLet =
455437 line "Let statement cannot be the last statement in a do block. The last statement must be an expression."
456− goSimple CannotReorderOperators =
438+ renderSimpleErrorMessage CannotReorderOperators =
457439 line "Unable to reorder operators"
458− goSimple UnspecifiedSkolemScope =
440+ renderSimpleErrorMessage UnspecifiedSkolemScope =
459441 line "Skolem variable scope is unspecified"
460− goSimple OverlappingNamesInLet =
442+ renderSimpleErrorMessage OverlappingNamesInLet =
461443 line "Overlapping names in let binding."
462− goSimple (InfiniteType ty) =
444+ renderSimpleErrorMessage (InfiniteType ty) =
463445 paras [ line "An infinite type was inferred for an expression: "
464− , indent $ line $ prettyPrintType ty
446+ , indent $ typeAsBox ty
465447 ]
466− goSimple (InfiniteKind ki) =
448+ renderSimpleErrorMessage (InfiniteKind ki) =
467449 paras [ line "An infinite kind was inferred for a type: "
468− , indent $ line $ prettyPrintKind ki
450+ , indent $ kindAsBox ki
469451 ]
470− goSimple (MultipleFixities name) =
452+ renderSimpleErrorMessage (MultipleFixities name) =
471453 line $ "Multiple fixity declarations for " ++ showIdent name
472− goSimple (OrphanTypeDeclaration nm) =
454+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
473455 line $ "Orphan type declaration for " ++ showIdent nm
474− goSimple (OrphanFixityDeclaration op) =
456+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =
475457 line $ "Orphan fixity declaration for " ++ show op
476− goSimple (RedefinedModule name filenames) =
477− paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
478− : map (indent . line . displaySourceSpan) filenames
479− 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) =
480463 line $ "Name " ++ showIdent name ++ " has been defined multiple times"
481− goSimple (UnknownModule mn) =
464+ renderSimpleErrorMessage (UnknownModule mn) =
482465 line $ "Unknown module " ++ runModuleName mn
483− goSimple (UnknownType name) =
466+ renderSimpleErrorMessage (UnknownType name) =
484467 line $ "Unknown type " ++ showQualified runProperName name
485− goSimple (UnknownTypeClass name) =
468+ renderSimpleErrorMessage (UnknownTypeClass name) =
486469 line $ "Unknown type class " ++ showQualified runProperName name
487− goSimple (UnknownValue name) =
470+ renderSimpleErrorMessage (UnknownValue name) =
488471 line $ "Unknown value " ++ showQualified showIdent name
489− goSimple (UnknownTypeConstructor name) =
472+ renderSimpleErrorMessage (UnknownTypeConstructor name) =
490473 line $ "Unknown type constructor " ++ showQualified runProperName name
491− goSimple (UnknownDataConstructor dc tc) =
474+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =
492475 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
493− goSimple (UnknownImportType mn name) =
476+ renderSimpleErrorMessage (UnknownImportType mn name) =
494477 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name
495− goSimple (UnknownExportType name) =
478+ renderSimpleErrorMessage (UnknownExportType name) =
496479 line $ "Cannot export unknown type " ++ runProperName name
497− goSimple (UnknownImportTypeClass mn name) =
480+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
498481 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name
499− goSimple (UnknownExportTypeClass name) =
482+ renderSimpleErrorMessage (UnknownExportTypeClass name) =
500483 line $ "Cannot export unknown type class " ++ runProperName name
501− goSimple (UnknownImportValue mn name) =
484+ renderSimpleErrorMessage (UnknownImportValue mn name) =
502485 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name
503− goSimple (UnknownExportValue name) =
486+ renderSimpleErrorMessage (UnknownExportValue name) =
504487 line $ "Cannot export unknown value " ++ showIdent name
505− goSimple (UnknownExportModule name) =
488+ renderSimpleErrorMessage (UnknownExportModule name) =
506489 line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"
507− goSimple (UnknownImportDataConstructor mn tcon dcon) =
490+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
508491 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
509− goSimple (UnknownExportDataConstructor tcon dcon) =
492+ renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
510493 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"
511− goSimple (ConflictingImport nm mn) =
494+ renderSimpleErrorMessage (ConflictingImport nm mn) =
512495 line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn
513− goSimple (ConflictingImports nm m1 m2) =
496+ renderSimpleErrorMessage (ConflictingImports nm m1 m2) =
514497 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
515− goSimple (ConflictingTypeDecls nm) =
498+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =
516499 line $ "Conflicting type declarations for " ++ runProperName nm
517− goSimple (ConflictingCtorDecls nm) =
500+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =
518501 line $ "Conflicting data constructor declarations for " ++ runProperName nm
519− goSimple (TypeConflictsWithClass nm) =
502+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =
520503 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
521− goSimple (CtorConflictsWithClass nm) =
504+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =
522505 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
523− goSimple (ClassConflictsWithType nm) =
506+ renderSimpleErrorMessage (ClassConflictsWithType nm) =
524507 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
525− goSimple (ClassConflictsWithCtor nm) =
508+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
526509 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
527− goSimple (DuplicateClassExport nm) =
510+ renderSimpleErrorMessage (DuplicateModuleName mn) =
511+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
512+ renderSimpleErrorMessage (DuplicateClassExport nm) =
528513 line $ "Duplicate export declaration for type class " ++ runProperName nm
529− goSimple (DuplicateValueExport nm) =
514+ renderSimpleErrorMessage (DuplicateValueExport nm) =
530515 line $ "Duplicate export declaration for value " ++ showIdent nm
531− goSimple (CycleInDeclaration nm) =
516+ renderSimpleErrorMessage (CycleInDeclaration nm) =
532517 line $ "Cycle in declaration of " ++ showIdent nm
533− goSimple (CycleInModules mns) =
518+ renderSimpleErrorMessage (CycleInModules mns) =
534519 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)
535− goSimple (CycleInTypeSynonym pn) =
520+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =
536521 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn
537− goSimple (NameIsUndefined ident) =
522+ renderSimpleErrorMessage (NameIsUndefined ident) =
538523 line $ showIdent ident ++ " is undefined"
539− goSimple (NameNotInScope ident) =
524+ renderSimpleErrorMessage (NameNotInScope ident) =
540525 line $ showIdent ident ++ " may not be defined in the current scope"
541− goSimple (UndefinedTypeVariable name) =
526+ renderSimpleErrorMessage (UndefinedTypeVariable name) =
542527 line $ "Type variable " ++ runProperName name ++ " is undefined"
543− goSimple (PartiallyAppliedSynonym name) =
528+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
544529 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name
545530 , line "Type synonyms must be applied to all of their type arguments."
546531 ]
547− goSimple (EscapedSkolem binding) =
532+ renderSimpleErrorMessage (EscapedSkolem binding) =
548533 paras $ [ line "A type variable has escaped its scope." ]
549534 <> foldMap (\expr -> [ line "Relevant expression: "
550− , indent $ line $ prettyPrintValue expr
535+ , indent $ prettyPrintValue expr
551536 ]) binding
552− goSimple (TypesDoNotUnify t1 t2)
537+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
553538 = paras [ line "Cannot unify type"
554− , indent $ line $ prettyPrintType t1
539+ , indent $ typeAsBox t1
555540 , line "with type"
556− , indent $ line $ prettyPrintType t2
541+ , indent $ typeAsBox t2
557542 ]
558− goSimple (KindsDoNotUnify k1 k2) =
543+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
559544 paras [ line "Cannot unify kind"
560− , indent $ line $ prettyPrintKind k1
545+ , indent $ kindAsBox k1
561546 , line "with kind"
562− , indent $ line $ prettyPrintKind k2
547+ , indent $ kindAsBox k2
563548 ]
564− goSimple (ConstrainedTypeUnified t1 t2) =
549+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
565550 paras [ line "Cannot unify constrained type"
566− , indent $ line $ prettyPrintType t1
551+ , indent $ typeAsBox t1
567552 , line "with type"
568− , indent $ line $ prettyPrintType t2
569− ]
570− goSimple (OverlappingInstances nm ts (d : ds)) =
571− 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:"
572561 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
573562 ]
574− goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"
575− goSimple (NoInstanceFound nm ts) =
576− line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
577− goSimple (PossiblyInfiniteInstance nm ts) =
578− line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."
579− goSimple (CannotDerive nm ts) =
580− line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)
581− 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) =
582584 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
583− goSimple (DuplicateLabel l expr) =
585+ renderSimpleErrorMessage (DuplicateLabel l expr) =
584586 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
585587 <> foldMap (\expr' -> [ line "Relevant expression: "
586− , indent $ line $ prettyPrintValue expr'
588+ , indent $ prettyPrintValue expr'
587589 ]) expr
588− goSimple (DuplicateTypeArgument name) =
590+ renderSimpleErrorMessage (DuplicateTypeArgument name) =
589591 line $ "Duplicate type argument " ++ show name
590− goSimple (DuplicateValueDeclaration nm) =
592+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
591593 line $ "Duplicate value declaration for " ++ showIdent nm
592− goSimple (ArgListLengthsDiffer ident) =
594+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
593595 line $ "Argument list lengths differ in declaration " ++ showIdent ident
594− goSimple (OverlappingArgNames ident) =
596+ renderSimpleErrorMessage (OverlappingArgNames ident) =
595597 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident
596− goSimple (MissingClassMember ident) =
598+ renderSimpleErrorMessage (MissingClassMember ident) =
597599 line $ "Member " ++ showIdent ident ++ " has not been implemented"
598− goSimple (ExtraneousClassMember ident) =
600+ renderSimpleErrorMessage (ExtraneousClassMember ident) =
599601 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"
600− goSimple (ExpectedType ty kind) =
602+ renderSimpleErrorMessage (ExpectedType ty kind) =
601603 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
602− , 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 $ kindAsBox kind
608+ , line "instead."
603609 ]
604− goSimple (IncorrectConstructorArity nm) =
610+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =
605611 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm
606− goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"
607− goSimple (ExprDoesNotHaveType expr ty) =
612+ renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"
613+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
608614 paras [ line "Expression"
609− , indent $ line $ prettyPrintValue expr
615+ , indent $ prettyPrintValue expr
610616 , line "does not have type"
611− , indent $ line $ prettyPrintType ty
617+ , indent $ typeAsBox ty
612618 ]
613− goSimple (PropertyIsMissing prop row) =
614− line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
615− 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) =
616625 paras [ line "Cannot apply function of type"
617− , indent $ line $ prettyPrintType fn
626+ , indent $ typeAsBox fn
618627 , line "to argument"
619− , indent $ line $ prettyPrintValue arg
628+ , indent $ prettyPrintValue arg
620629 ]
621− goSimple TypeSynonymInstance =
630+ renderSimpleErrorMessage TypeSynonymInstance =
622631 line "Type synonym instances are disallowed"
623− goSimple (OrphanInstance nm cnm ts) =
624− 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."
625638 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
626639 , line "Consider moving the instance, if possible, or using a newtype wrapper."
627640 ]
628− goSimple InvalidNewtype =
641+ renderSimpleErrorMessage InvalidNewtype =
629642 line "Newtypes must define a single constructor with a single argument"
630− goSimple (InvalidInstanceHead ty) =
643+ renderSimpleErrorMessage (InvalidInstanceHead ty) =
631644 paras [ line "Invalid type in class instance head:"
632− , indent $ line $ prettyPrintType ty
645+ , indent $ typeAsBox ty
633646 ]
634− goSimple (TransitiveExportError x ys) =
647+ renderSimpleErrorMessage (TransitiveExportError x ys) =
635648 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
636649 : map (line . prettyPrintExport) ys
637− goSimple (ShadowedName nm) =
650+ renderSimpleErrorMessage (ShadowedName nm) =
638651 line $ "Name '" ++ showIdent nm ++ "' was shadowed"
639− goSimple (ShadowedTypeVar tv) =
652+ renderSimpleErrorMessage (ShadowedTypeVar tv) =
640653 line $ "Type variable '" ++ tv ++ "' was shadowed"
641− goSimple (UnusedTypeVar tv) =
654+ renderSimpleErrorMessage (UnusedTypeVar tv) =
642655 line $ "Type variable '" ++ tv ++ "' was declared but not used"
643− goSimple (ClassOperator className opName) =
656+ renderSimpleErrorMessage (ClassOperator className opName) =
644657 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."
645− , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
646− , 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"
647660 ]
648− goSimple (MisleadingEmptyTypeImport mn name) =
661+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
649662 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"
650− goSimple (ImportHidingModule name) =
663+ renderSimpleErrorMessage (ImportHidingModule name) =
651664 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"
652− goSimple (WildcardInferredType ty) =
653− line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
654− 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) =
655676 paras $ [ line "A case expression could not be determined to cover all inputs."
656677 , line "The following additional cases are required to cover all inputs:\n"
657678 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
658679 ] ++
659680 [ line "..." | not b ]
660− goSimple (OverlappingPattern bs b) =
681+ renderSimpleErrorMessage (OverlappingPattern bs b) =
661682 paras $ [ line "A case expression contains unreachable cases:\n"
662683 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
663684 ] ++
664685 [ line "..." | not b ]
665− go (NotYetDefined names err) =
666− paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
667− , indent $ go err
686+ renderSimpleErrorMessage IncompleteExhaustivityCheck =
687+ paras [ line "An exhaustivity check was abandoned due to too many possible cases."
688+ , line "You may want to decomposing your data types into smaller types."
668689 ]
669− 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) =
670695 paras [ lineWithLevel "unifying type "
671− , indent $ line $ prettyPrintType t1
696+ , indent $ typeAsBox t1
672697 , line "with type"
673− , indent $ line $ prettyPrintType t2
674− , go err
698+ , indent $ typeAsBox t2
675699 ]
676− go (ErrorInExpression expr err) =
700+ renderHint (ErrorInExpression expr) =
677701 paras [ lineWithLevel "in expression:"
678− , indent $ line $ prettyPrintValue expr
679− , go err
702+ , indent $ prettyPrintValue expr
680703 ]
681− go (ErrorInModule mn err) =
704+ renderHint (ErrorInModule mn) =
682705 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
683− , go err
684706 ]
685− go (ErrorInSubsumption t1 t2 err) =
707+ renderHint (ErrorInSubsumption t1 t2) =
686708 paras [ lineWithLevel "checking that type "
687− , indent $ line $ prettyPrintType t1
709+ , indent $ typeAsBox t1
688710 , line "subsumes type"
689− , indent $ line $ prettyPrintType t2
690− , go err
711+ , indent $ typeAsBox t2
691712 ]
692− go (ErrorInInstance name ts err) =
693− paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
694− , 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+ ]
695718 ]
696− go (ErrorCheckingKind ty err) =
719+ renderHint (ErrorCheckingKind ty) =
697720 paras [ lineWithLevel "checking kind of type "
698− , indent $ line $ prettyPrintType ty
699− , go err
721+ , indent $ typeAsBox ty
700722 ]
701− go (ErrorInferringType expr err) =
723+ renderHint (ErrorInferringType expr) =
702724 paras [ lineWithLevel "inferring type of value "
703− , indent $ line $ prettyPrintValue expr
704− , go err
725+ , indent $ prettyPrintValue expr
705726 ]
706− go (ErrorCheckingType expr ty err) =
727+ renderHint (ErrorCheckingType expr ty) =
707728 paras [ lineWithLevel "checking that value "
708− , indent $ line $ prettyPrintValue expr
729+ , indent $ prettyPrintValue expr
709730 , line "has type"
710− , indent $ line $ prettyPrintType ty
711− , go err
731+ , indent $ typeAsBox ty
712732 ]
713− go (ErrorInApplication f t a err) =
733+ renderHint (ErrorInApplication f t a) =
714734 paras [ lineWithLevel "applying function"
715− , indent $ line $ prettyPrintValue f
735+ , indent $ prettyPrintValue f
716736 , line "of type"
717− , indent $ line $ prettyPrintType t
737+ , indent $ typeAsBox t
718738 , line "to argument"
719− , indent $ line $ prettyPrintValue a
720− , go err
721− ]
722− go (ErrorInDataConstructor nm err) =
723− paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
724− , go err
725− ]
726− go (ErrorInTypeConstructor nm err) =
727− paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
728− , go err
729− ]
730− go (ErrorInBindingGroup nms err) =
731− paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
732− , go err
733− ]
734− go (ErrorInDataBindingGroup err) =
735− paras [ lineWithLevel $ "in data binding group:"
736− , go err
737− ]
738− go (ErrorInTypeSynonym name err) =
739− paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
740− , go err
741− ]
742− go (ErrorInValueDeclaration n err) =
743− paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
744− , go err
745− ]
746− go (ErrorInTypeDeclaration n err) =
747− paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
748− , go err
749− ]
750− go (ErrorInForeignImport nm err) =
751− paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
752− , go err
753− ]
754− go (PositionedError srcSpan err) =
755− paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
756− , indent $ go err
757− ]
758− 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 ++ ":"
759759
760760 lineWithLevel :: String -> Box.Box
761761 lineWithLevel text = line $ show level ++ " " ++ text
@@ -765,23 +765,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
765765 Error -> "error"
766766 Warning -> "warning"
767767
768− suggestions :: ErrorMessage -> [Box.Box]
769− suggestions = suggestions' . unwrapErrorMessage
770− where
771− 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 ++ ":"
772770 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"
773771 ]
774− suggestions' (TypesDoNotUnify t1 t2)
775− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
776− | otherwise = []
777− 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 _ = []
778776
779777 paras :: [Box.Box] -> Box.Box
780778 paras = Box.vcat Box.left
781779
782− -- |
783780 -- Pretty print and export declaration
784− --
785781 prettyPrintExport :: DeclarationRef -> String
786782 prettyPrintExport (TypeRef pn _) = runProperName pn
787783 prettyPrintExport (ValueRef ident) = showIdent ident
@@ -790,38 +786,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
790786 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
791787 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
792788
793− -- |
794− -- Simplify an error message
795− --
796− simplifyErrorMessage :: ErrorMessage -> ErrorMessage
797− 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
798796 where
799− unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
800− unwrap pos (ErrorInExpression _ err) = unwrap pos err
801− unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
802− unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
803− unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
804− unwrap pos (ErrorInferringType _ err) = unwrap pos err
805− unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
806− unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
807− unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
808− unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
809− unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
810− unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
811− unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
812− unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
813− unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
814− unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
815− unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err)
816− unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
817− unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
818− unwrap _ (PositionedError pos err) = unwrap (Just pos) err
819− unwrap pos other = wrap pos other
820−
821− wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
822− wrap Nothing = id
823− wrap (Just pos) = PositionedError pos
797+ isPositionHint :: HintCategory -> Bool
798+ isPositionHint PositionHint = True
799+ isPositionHint OtherHint = True
800+ isPositionHint _ = False
824801
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
825827
826828-- |
827829-- Pretty print multiple errors
@@ -837,11 +839,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu
837839
838840-- | Pretty print warnings as a Box
839841prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
840−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
841843
842844-- | Pretty print errors as a Box
843845prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
844−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
845847
846848prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
847849prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
@@ -851,15 +853,16 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
851853 , result
852854 ]
853855prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
854− result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
855− return $
856− Box.vcat Box.left [ Box.text intro
857− , Box.vsep 1 Box.left result
858− ]
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+ ]
859862
860863-- | Pretty print a Parsec ParseError as a Box
861864prettyPrintParseError :: P.ParseError -> Box.Box
862−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
863866
864867-- |
865868-- Pretty print ParseError detail messages.
@@ -872,9 +875,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
872875 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
873876
874877 where
875− (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
876− (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
877− (expect,messages) = span ((Expect "") ==) msgs2
878+ (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs
879+ (unExpect,msgs2) = span (UnExpect "" ==) msgs1
880+ (expect,messages) = span (Expect "" ==) msgs2
878881
879882 showExpect = showMany msgExpecting expect
880883 showUnExpect = showMany msgUnExpected unExpect
@@ -905,8 +908,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
905908
906909 clean = nub . filter (not . null)
907910
911+-- | Indent to the right, and pad on top and bottom.
908912indent :: Box.Box -> Box.Box
909−indent = Box.moveRight 2
913+indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2
910914
911915line :: String -> Box.Box
912916line = Box.text
@@ -922,7 +926,7 @@ renderBox = unlines . map trimEnd . lines . Box.render
922926interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
923927interpretMultipleErrorsAndWarnings (err, ws) = do
924928 tell ws
925− either throwError return $ err
929+ either throwError return err
926930
927931-- |
928932-- Rethrow an error with a more detailed error message in the case of failure
@@ -946,8 +950,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple
946950warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
947951
948952withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
949−withPosition _ (PositionedError pos err) = withPosition pos err
950−withPosition pos err = PositionedError pos err
953+withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se
951954
952955-- |
953956-- Collect errors in in parallel