@@ -20,10 +20,11 @@
2020module Language.PureScript.Errors where
2121
2222import Data.Either (lefts, rights)
23−import Data.List (intercalate, transpose, nub)
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
@@ -53,9 +54,7 @@ import qualified Text.Parsec as P
5354import qualified Text.Parsec.Error as PE
5455import Text.Parsec.Error (Message(..))
5556
56−-- |
57−-- A type of error messages
58−--
57+-- | A type of error messages
5958data SimpleErrorMessage
6059 = ErrorParsingExterns P.ParseError
6160 | ErrorParsingFFIModule FilePath
@@ -148,39 +147,47 @@ data SimpleErrorMessage
148147 | ClassOperator ProperName Ident
149148 | MisleadingEmptyTypeImport ModuleName ProperName
150149 | 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)
150+ deriving Show
151+
152+-- | Error message hints, providing more detailed information about failure.
153+data ErrorMessageHint
154+ = NotYetDefined [Ident]
155+ | ErrorUnifyingTypes Type Type
156+ | ErrorInExpression Expr
157+ | ErrorInModule ModuleName
158+ | ErrorInInstance (Qualified ProperName) [Type]
159+ | ErrorInSubsumption Type Type
160+ | ErrorCheckingType Expr Type
161+ | ErrorCheckingKind Type
162+ | ErrorInferringType Expr
163+ | ErrorInApplication Expr Type Expr
164+ | ErrorInDataConstructor ProperName
165+ | ErrorInTypeConstructor ProperName
166+ | ErrorInBindingGroup [Ident]
167+ | ErrorInDataBindingGroup
168+ | ErrorInTypeSynonym ProperName
169+ | ErrorInValueDeclaration Ident
170+ | ErrorInTypeDeclaration Ident
171+ | ErrorInForeignImport Ident
172+ | PositionedError SourceSpan
173+ deriving Show
174+
175+-- | Categories of hints
176+data HintCategory
177+ = ExprHint
178+ | KindHint
179+ | CheckHint
180+ | PositionHint
181+ | OtherHint
182+ deriving (Show, Eq)
183+
184+data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
178185
179186instance UnificationError Type ErrorMessage where
180− occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
187+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t
181188
182189instance UnificationError Kind ErrorMessage where
183− occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
190+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k
184191
185192-- |
186193-- Get the error code for a particular error type
@@ -299,7 +306,7 @@ nonEmpty = not . null . runMultipleErrors
299306-- Create an error set from a single simple error message
300307--
301308errorMessage :: SimpleErrorMessage -> MultipleErrors
302−errorMessage err = MultipleErrors [SimpleErrorWrapper err]
309+errorMessage err = MultipleErrors [ErrorMessage [] err]
303310
304311
305312-- |
@@ -308,12 +315,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]
308315singleError :: ErrorMessage -> MultipleErrors
309316singleError = MultipleErrors . pure
310317
311−-- |
312−-- Lift a function on ErrorMessage to a function on MultipleErrors
313−--
318+-- | Lift a function on ErrorMessage to a function on MultipleErrors
314319onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
315320onErrorMessages f = MultipleErrors . map f . runMultipleErrors
316321
322+-- | Add a hint to an error message
323+addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
324+addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
325+
317326-- | The various types of things which might need to be relabelled in errors messages.
318327data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
319328
@@ -327,27 +336,7 @@ data Level = Error | Warning deriving Show
327336-- Extract nested error messages from wrapper errors
328337--
329338unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
330−unwrapErrorMessage em = case em of
331− (ErrorCheckingKind _ err) -> unwrapErrorMessage err
332− (ErrorCheckingType _ _ err) -> unwrapErrorMessage err
333− (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err
334− (ErrorInBindingGroup _ err) -> unwrapErrorMessage err
335− (ErrorInDataBindingGroup err) -> unwrapErrorMessage err
336− (ErrorInDataConstructor _ err) -> unwrapErrorMessage err
337− (ErrorInExpression _ err) -> unwrapErrorMessage err
338− (ErrorInForeignImport _ err) -> unwrapErrorMessage err
339− (ErrorInInstance _ _ err) -> unwrapErrorMessage err
340− (ErrorInModule _ err) -> unwrapErrorMessage err
341− (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err
342− (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err
343− (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err
344− (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err
345− (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err
346− (ErrorInferringType _ err) -> unwrapErrorMessage err
347− (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err
348− (NotYetDefined _ err) -> unwrapErrorMessage err
349− (PositionedError _ err) -> unwrapErrorMessage err
350− (SimpleErrorWrapper sem) -> sem
339+unwrapErrorMessage (ErrorMessage _ se) = se
351340
352341replaceUnknowns :: Type -> State UnknownMap Type
353342replaceUnknowns = everywhereOnTypesM replaceTypes
@@ -363,7 +352,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
363352 replaceTypes other = return other
364353
365354onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
366−onTypesInErrorMessageM f = g
355+onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
367356 where
368357 gSimple (InfiniteType t) = InfiniteType <$> f t
369358 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
@@ -373,204 +362,191 @@ onTypesInErrorMessageM f = g
373362 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
374363 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
375364 gSimple other = pure other
376− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> f t1 <*> f t2 <*> g em
377− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> f t1 <*> f t2 <*> g e
378− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> f t <*> g em
379− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> f t <*> g em
380− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> f t1 <*> pure e2 <*> g em
381− g (NotYetDefined x e) = NotYetDefined x <$> g e
382− g (ErrorInExpression x e) = ErrorInExpression x <$> g e
383− g (ErrorInModule x e) = ErrorInModule x <$> g e
384− g (ErrorInInstance x y e) = ErrorInInstance x y <$> g e
385− g (ErrorInferringType x e) = ErrorInferringType x <$> g e
386− g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> g e
387− g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> g e
388− g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> g e
389− g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> g e
390− g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> g e
391− g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> g e
392− g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> g e
393− g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> g e
394− g (PositionedError x e) = PositionedError x <$> g e
395− g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem
365+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
366+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
367+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
368+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
369+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
370+ gHint other = pure other
396371
397372-- |
398373-- Pretty print a single error, simplifying if necessary
399374--
400375prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
401−prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
376+prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
402377 where
403− -- |
378+
404379 -- Pretty print an ErrorMessage
405− --
406380 prettyPrintErrorMessage :: ErrorMessage -> Box.Box
407− prettyPrintErrorMessage em =
381+ prettyPrintErrorMessage (ErrorMessage hints simple) =
408382 paras $
409− go em:suggestions em ++
383+ map renderHint hints ++
384+ renderSimpleErrorMessage simple :
385+ suggestions simple ++
410386 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
411387 where
412388 wikiUri :: String
413389 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
414390
415− go :: ErrorMessage -> Box.Box
416− goSimple (CannotGetFileInfo path) =
391+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
392+ renderSimpleErrorMessage (CannotGetFileInfo path) =
417393 paras [ line "Unable to read file info: "
418394 , indent . line $ path
419395 ]
420− goSimple (CannotReadFile path) =
396+ renderSimpleErrorMessage (CannotReadFile path) =
421397 paras [ line "Unable to read file: "
422398 , indent . line $ path
423399 ]
424− goSimple (CannotWriteFile path) =
400+ renderSimpleErrorMessage (CannotWriteFile path) =
425401 paras [ line "Unable to write file: "
426402 , indent . line $ path
427403 ]
428− goSimple (ErrorParsingExterns err) =
404+ renderSimpleErrorMessage (ErrorParsingExterns err) =
429405 paras [ lineWithLevel "parsing externs files: "
430406 , prettyPrintParseError err
431407 ]
432− goSimple (ErrorParsingFFIModule path) =
408+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =
433409 paras [ line "Unable to parse module from FFI file: "
434410 , indent . line $ path
435411 ]
436− goSimple (ErrorParsingModule err) =
412+ renderSimpleErrorMessage (ErrorParsingModule err) =
437413 paras [ line "Unable to parse module: "
438414 , prettyPrintParseError err
439415 ]
440− goSimple (MissingFFIModule mn) =
416+ renderSimpleErrorMessage (MissingFFIModule mn) =
441417 line $ "Missing FFI implementations for module " ++ runModuleName mn
442− goSimple (UnnecessaryFFIModule mn path) =
418+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
443419 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
444420 , indent . line $ path
445421 ]
446− goSimple (MultipleFFIModules mn paths) =
422+ renderSimpleErrorMessage (MultipleFFIModules mn paths) =
447423 paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
448424 , indent . paras $ map line paths
449425 ]
450− goSimple (InvalidExternsFile path) =
426+ renderSimpleErrorMessage (InvalidExternsFile path) =
451427 paras [ line "Externs file is invalid: "
452428 , indent . line $ path
453429 ]
454− goSimple InvalidDoBind =
430+ renderSimpleErrorMessage InvalidDoBind =
455431 line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."
456− goSimple InvalidDoLet =
432+ renderSimpleErrorMessage InvalidDoLet =
457433 line "Let statement cannot be the last statement in a do block. The last statement must be an expression."
458− goSimple CannotReorderOperators =
434+ renderSimpleErrorMessage CannotReorderOperators =
459435 line "Unable to reorder operators"
460− goSimple UnspecifiedSkolemScope =
436+ renderSimpleErrorMessage UnspecifiedSkolemScope =
461437 line "Skolem variable scope is unspecified"
462− goSimple OverlappingNamesInLet =
438+ renderSimpleErrorMessage OverlappingNamesInLet =
463439 line "Overlapping names in let binding."
464− goSimple (InfiniteType ty) =
440+ renderSimpleErrorMessage (InfiniteType ty) =
465441 paras [ line "An infinite type was inferred for an expression: "
466442 , indent $ typeAsBox ty
467443 ]
468− goSimple (InfiniteKind ki) =
444+ renderSimpleErrorMessage (InfiniteKind ki) =
469445 paras [ line "An infinite kind was inferred for a type: "
470446 , indent $ kindAsBox ki
471447 ]
472− goSimple (MultipleFixities name) =
448+ renderSimpleErrorMessage (MultipleFixities name) =
473449 line $ "Multiple fixity declarations for " ++ showIdent name
474− goSimple (OrphanTypeDeclaration nm) =
450+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
475451 line $ "Orphan type declaration for " ++ showIdent nm
476− goSimple (OrphanFixityDeclaration op) =
452+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =
477453 line $ "Orphan fixity declaration for " ++ show op
478− goSimple (RedefinedModule name filenames) =
454+ renderSimpleErrorMessage (RedefinedModule name filenames) =
479455 paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
480456 , indent . paras $ map (line . displaySourceSpan) filenames
481457 ]
482− goSimple (RedefinedIdent name) =
458+ renderSimpleErrorMessage (RedefinedIdent name) =
483459 line $ "Name " ++ showIdent name ++ " has been defined multiple times"
484− goSimple (UnknownModule mn) =
460+ renderSimpleErrorMessage (UnknownModule mn) =
485461 line $ "Unknown module " ++ runModuleName mn
486− goSimple (UnknownType name) =
462+ renderSimpleErrorMessage (UnknownType name) =
487463 line $ "Unknown type " ++ showQualified runProperName name
488− goSimple (UnknownTypeClass name) =
464+ renderSimpleErrorMessage (UnknownTypeClass name) =
489465 line $ "Unknown type class " ++ showQualified runProperName name
490− goSimple (UnknownValue name) =
466+ renderSimpleErrorMessage (UnknownValue name) =
491467 line $ "Unknown value " ++ showQualified showIdent name
492− goSimple (UnknownTypeConstructor name) =
468+ renderSimpleErrorMessage (UnknownTypeConstructor name) =
493469 line $ "Unknown type constructor " ++ showQualified runProperName name
494− goSimple (UnknownDataConstructor dc tc) =
470+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =
495471 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
496− goSimple (UnknownImportType mn name) =
472+ renderSimpleErrorMessage (UnknownImportType mn name) =
497473 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name
498− goSimple (UnknownExportType name) =
474+ renderSimpleErrorMessage (UnknownExportType name) =
499475 line $ "Cannot export unknown type " ++ runProperName name
500− goSimple (UnknownImportTypeClass mn name) =
476+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
501477 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name
502− goSimple (UnknownExportTypeClass name) =
478+ renderSimpleErrorMessage (UnknownExportTypeClass name) =
503479 line $ "Cannot export unknown type class " ++ runProperName name
504− goSimple (UnknownImportValue mn name) =
480+ renderSimpleErrorMessage (UnknownImportValue mn name) =
505481 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name
506− goSimple (UnknownExportValue name) =
482+ renderSimpleErrorMessage (UnknownExportValue name) =
507483 line $ "Cannot export unknown value " ++ showIdent name
508− goSimple (UnknownExportModule name) =
484+ renderSimpleErrorMessage (UnknownExportModule name) =
509485 line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"
510− goSimple (UnknownImportDataConstructor mn tcon dcon) =
486+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
511487 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
512− goSimple (UnknownExportDataConstructor tcon dcon) =
488+ renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
513489 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"
514− goSimple (ConflictingImport nm mn) =
490+ renderSimpleErrorMessage (ConflictingImport nm mn) =
515491 line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn
516− goSimple (ConflictingImports nm m1 m2) =
492+ renderSimpleErrorMessage (ConflictingImports nm m1 m2) =
517493 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
518− goSimple (ConflictingTypeDecls nm) =
494+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =
519495 line $ "Conflicting type declarations for " ++ runProperName nm
520− goSimple (ConflictingCtorDecls nm) =
496+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =
521497 line $ "Conflicting data constructor declarations for " ++ runProperName nm
522− goSimple (TypeConflictsWithClass nm) =
498+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =
523499 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
524− goSimple (CtorConflictsWithClass nm) =
500+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =
525501 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
526− goSimple (ClassConflictsWithType nm) =
502+ renderSimpleErrorMessage (ClassConflictsWithType nm) =
527503 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
528− goSimple (ClassConflictsWithCtor nm) =
504+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
529505 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
530− goSimple (DuplicateClassExport nm) =
506+ renderSimpleErrorMessage (DuplicateClassExport nm) =
531507 line $ "Duplicate export declaration for type class " ++ runProperName nm
532− goSimple (DuplicateValueExport nm) =
508+ renderSimpleErrorMessage (DuplicateValueExport nm) =
533509 line $ "Duplicate export declaration for value " ++ showIdent nm
534− goSimple (CycleInDeclaration nm) =
510+ renderSimpleErrorMessage (CycleInDeclaration nm) =
535511 line $ "Cycle in declaration of " ++ showIdent nm
536− goSimple (CycleInModules mns) =
512+ renderSimpleErrorMessage (CycleInModules mns) =
537513 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)
538− goSimple (CycleInTypeSynonym pn) =
514+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =
539515 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn
540− goSimple (NameIsUndefined ident) =
516+ renderSimpleErrorMessage (NameIsUndefined ident) =
541517 line $ showIdent ident ++ " is undefined"
542− goSimple (NameNotInScope ident) =
518+ renderSimpleErrorMessage (NameNotInScope ident) =
543519 line $ showIdent ident ++ " may not be defined in the current scope"
544− goSimple (UndefinedTypeVariable name) =
520+ renderSimpleErrorMessage (UndefinedTypeVariable name) =
545521 line $ "Type variable " ++ runProperName name ++ " is undefined"
546− goSimple (PartiallyAppliedSynonym name) =
522+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
547523 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name
548524 , line "Type synonyms must be applied to all of their type arguments."
549525 ]
550− goSimple (EscapedSkolem binding) =
526+ renderSimpleErrorMessage (EscapedSkolem binding) =
551527 paras $ [ line "A type variable has escaped its scope." ]
552528 <> foldMap (\expr -> [ line "Relevant expression: "
553529 , indent $ prettyPrintValue expr
554530 ]) binding
555− goSimple (TypesDoNotUnify t1 t2)
531+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
556532 = paras [ line "Cannot unify type"
557533 , indent $ typeAsBox t1
558534 , line "with type"
559535 , indent $ typeAsBox t2
560536 ]
561− goSimple (KindsDoNotUnify k1 k2) =
537+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
562538 paras [ line "Cannot unify kind"
563539 , indent $ kindAsBox k1
564540 , line "with kind"
565541 , indent $ kindAsBox k2
566542 ]
567− goSimple (ConstrainedTypeUnified t1 t2) =
543+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
568544 paras [ line "Cannot unify constrained type"
569545 , indent $ typeAsBox t1
570546 , line "with type"
571547 , indent $ typeAsBox t2
572548 ]
573− goSimple (OverlappingInstances nm ts (d : ds)) =
549+ renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
574550 paras [ line "Overlapping instances found for"
575551 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
576552 , Box.vcat Box.left (map typeAtomAsBox ts)
@@ -578,46 +554,46 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
578554 , line "The following instances were found:"
579555 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
580556 ]
581− goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"
582− goSimple (NoInstanceFound nm ts) =
557+ renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"
558+ renderSimpleErrorMessage (NoInstanceFound nm ts) =
583559 paras [ line "No instance found for"
584560 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
585561 , Box.vcat Box.left (map typeAtomAsBox ts)
586562 ]
587563 ]
588− goSimple (PossiblyInfiniteInstance nm ts) =
564+ renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
589565 paras [ line "Instance for"
590566 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
591567 , Box.vcat Box.left (map typeAtomAsBox ts)
592568 ]
593569 , line "is possibly infinite."
594570 ]
595− goSimple (CannotDerive nm ts) =
571+ renderSimpleErrorMessage (CannotDerive nm ts) =
596572 paras [ line "Cannot derive an instance for"
597573 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
598574 , Box.vcat Box.left (map typeAtomAsBox ts)
599575 ]
600576 ]
601− goSimple (CannotFindDerivingType nm) =
577+ renderSimpleErrorMessage (CannotFindDerivingType nm) =
602578 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
603− goSimple (DuplicateLabel l expr) =
579+ renderSimpleErrorMessage (DuplicateLabel l expr) =
604580 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
605581 <> foldMap (\expr' -> [ line "Relevant expression: "
606582 , indent $ prettyPrintValue expr'
607583 ]) expr
608− goSimple (DuplicateTypeArgument name) =
584+ renderSimpleErrorMessage (DuplicateTypeArgument name) =
609585 line $ "Duplicate type argument " ++ show name
610− goSimple (DuplicateValueDeclaration nm) =
586+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
611587 line $ "Duplicate value declaration for " ++ showIdent nm
612− goSimple (ArgListLengthsDiffer ident) =
588+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
613589 line $ "Argument list lengths differ in declaration " ++ showIdent ident
614− goSimple (OverlappingArgNames ident) =
590+ renderSimpleErrorMessage (OverlappingArgNames ident) =
615591 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident
616− goSimple (MissingClassMember ident) =
592+ renderSimpleErrorMessage (MissingClassMember ident) =
617593 line $ "Member " ++ showIdent ident ++ " has not been implemented"
618− goSimple (ExtraneousClassMember ident) =
594+ renderSimpleErrorMessage (ExtraneousClassMember ident) =
619595 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"
620− goSimple (ExpectedType ty kind) =
596+ renderSimpleErrorMessage (ExpectedType ty kind) =
621597 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
622598 , line "The error arises from the type"
623599 , indent $ typeAsBox ty
@@ -625,29 +601,29 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
625601 , indent $ kindAsBox kind
626602 , line "instead."
627603 ]
628− goSimple (IncorrectConstructorArity nm) =
604+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =
629605 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm
630− goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"
631− goSimple (ExprDoesNotHaveType expr ty) =
606+ renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"
607+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
632608 paras [ line "Expression"
633609 , indent $ prettyPrintValue expr
634610 , line "does not have type"
635611 , indent $ typeAsBox ty
636612 ]
637− goSimple (PropertyIsMissing prop row) =
613+ renderSimpleErrorMessage (PropertyIsMissing prop row) =
638614 paras [ line "Row"
639615 , indent $ prettyPrintRowWith '(' ')' row
640616 , line $ "lacks required property " ++ show prop
641617 ]
642− goSimple (CannotApplyFunction fn arg) =
618+ renderSimpleErrorMessage (CannotApplyFunction fn arg) =
643619 paras [ line "Cannot apply function of type"
644620 , indent $ typeAsBox fn
645621 , line "to argument"
646622 , indent $ prettyPrintValue arg
647623 ]
648− goSimple TypeSynonymInstance =
624+ renderSimpleErrorMessage TypeSynonymInstance =
649625 line "Type synonym instances are disallowed"
650− goSimple (OrphanInstance nm cnm ts) =
626+ renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
651627 paras [ line $ "Instance " ++ showIdent nm ++ " for "
652628 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)
653629 , Box.vcat Box.left (map typeAtomAsBox ts)
@@ -656,146 +632,118 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
656632 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
657633 , line "Consider moving the instance, if possible, or using a newtype wrapper."
658634 ]
659− goSimple InvalidNewtype =
635+ renderSimpleErrorMessage InvalidNewtype =
660636 line "Newtypes must define a single constructor with a single argument"
661− goSimple (InvalidInstanceHead ty) =
637+ renderSimpleErrorMessage (InvalidInstanceHead ty) =
662638 paras [ line "Invalid type in class instance head:"
663639 , indent $ typeAsBox ty
664640 ]
665− goSimple (TransitiveExportError x ys) =
641+ renderSimpleErrorMessage (TransitiveExportError x ys) =
666642 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
667643 : map (line . prettyPrintExport) ys
668− goSimple (ShadowedName nm) =
644+ renderSimpleErrorMessage (ShadowedName nm) =
669645 line $ "Name '" ++ showIdent nm ++ "' was shadowed"
670− goSimple (ShadowedTypeVar tv) =
646+ renderSimpleErrorMessage (ShadowedTypeVar tv) =
671647 line $ "Type variable '" ++ tv ++ "' was shadowed"
672− goSimple (UnusedTypeVar tv) =
648+ renderSimpleErrorMessage (UnusedTypeVar tv) =
673649 line $ "Type variable '" ++ tv ++ "' was declared but not used"
674− goSimple (ClassOperator className opName) =
650+ renderSimpleErrorMessage (ClassOperator className opName) =
675651 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."
676652 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
677653 , indent . line $ showIdent opName ++ " = someMember"
678654 ]
679− goSimple (MisleadingEmptyTypeImport mn name) =
655+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
680656 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"
681− goSimple (ImportHidingModule name) =
657+ renderSimpleErrorMessage (ImportHidingModule name) =
682658 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"
683− goSimple (WildcardInferredType ty) =
659+ renderSimpleErrorMessage (WildcardInferredType ty) =
684660 paras [ line "The wildcard type definition has the inferred type "
685661 , indent $ typeAsBox ty
686662 ]
687− goSimple (NotExhaustivePattern bs b) =
663+ renderSimpleErrorMessage (NotExhaustivePattern bs b) =
688664 paras $ [ line "A case expression could not be determined to cover all inputs."
689665 , line "The following additional cases are required to cover all inputs:\n"
690666 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
691667 ] ++
692668 [ line "..." | not b ]
693− goSimple (OverlappingPattern bs b) =
669+ renderSimpleErrorMessage (OverlappingPattern bs b) =
694670 paras $ [ line "A case expression contains unreachable cases:\n"
695671 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
696672 ] ++
697673 [ line "..." | not b ]
698− goSimple IncompleteExhaustivityCheck =
674+ renderSimpleErrorMessage IncompleteExhaustivityCheck =
699675 paras [ line "An exhaustivity check was abandoned due to too many possible cases."
700676 , line "You may want to decomposing your data types into smaller types."
701677 ]
702− go (NotYetDefined names err) =
703− paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
704− , go err
705− ]
706− go (ErrorUnifyingTypes t1 t2 err) =
678+
679+ renderHint :: ErrorMessageHint -> Box.Box
680+ renderHint (NotYetDefined names) =
681+ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
682+ renderHint (ErrorUnifyingTypes t1 t2) =
707683 paras [ lineWithLevel "unifying type "
708684 , indent $ typeAsBox t1
709685 , line "with type"
710686 , indent $ typeAsBox t2
711− , go err
712687 ]
713− go (ErrorInExpression expr err) =
688+ renderHint (ErrorInExpression expr) =
714689 paras [ lineWithLevel "in expression:"
715690 , indent $ prettyPrintValue expr
716− , go err
717691 ]
718− go (ErrorInModule mn err) =
692+ renderHint (ErrorInModule mn) =
719693 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
720− , go err
721694 ]
722− go (ErrorInSubsumption t1 t2 err) =
695+ renderHint (ErrorInSubsumption t1 t2) =
723696 paras [ lineWithLevel "checking that type "
724697 , indent $ typeAsBox t1
725698 , line "subsumes type"
726699 , indent $ typeAsBox t2
727− , go err
728700 ]
729− go (ErrorInInstance nm ts err) =
701+ renderHint (ErrorInInstance nm ts) =
730702 paras [ lineWithLevel "in type class instance"
731703 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
732704 , Box.vcat Box.left (map typeAtomAsBox ts)
733705 ]
734− , go err
735706 ]
736− go (ErrorCheckingKind ty err) =
707+ renderHint (ErrorCheckingKind ty) =
737708 paras [ lineWithLevel "checking kind of type "
738709 , indent $ typeAsBox ty
739− , go err
740710 ]
741− go (ErrorInferringType expr err) =
711+ renderHint (ErrorInferringType expr) =
742712 paras [ lineWithLevel "inferring type of value "
743713 , indent $ prettyPrintValue expr
744− , go err
745714 ]
746− go (ErrorCheckingType expr ty err) =
715+ renderHint (ErrorCheckingType expr ty) =
747716 paras [ lineWithLevel "checking that value "
748717 , indent $ prettyPrintValue expr
749718 , line "has type"
750719 , indent $ typeAsBox ty
751− , go err
752720 ]
753− go (ErrorInApplication f t a err) =
721+ renderHint (ErrorInApplication f t a) =
754722 paras [ lineWithLevel "applying function"
755723 , indent $ prettyPrintValue f
756724 , line "of type"
757725 , indent $ typeAsBox t
758726 , line "to argument"
759727 , indent $ prettyPrintValue a
760− , go err
761− ]
762− go (ErrorInDataConstructor nm err) =
763− paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
764− , go err
765− ]
766− go (ErrorInTypeConstructor nm err) =
767− paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
768− , go err
769728 ]
770− go (ErrorInBindingGroup nms err) =
771− paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
772− , go err
773− ]
774− go (ErrorInDataBindingGroup err) =
775− paras [ lineWithLevel "in data binding group:"
776− , go err
777− ]
778− go (ErrorInTypeSynonym name err) =
779− paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
780− , go err
781− ]
782− go (ErrorInValueDeclaration n err) =
783− paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
784− , go err
785− ]
786− go (ErrorInTypeDeclaration n err) =
787− paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
788− , go err
789− ]
790− go (ErrorInForeignImport nm err) =
791− paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
792− , go err
793− ]
794− go (PositionedError srcSpan err) =
795− paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
796− , go err
797− ]
798− go (SimpleErrorWrapper sem) = goSimple sem
729+ renderHint (ErrorInDataConstructor nm) =
730+ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
731+ renderHint (ErrorInTypeConstructor nm) =
732+ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
733+ renderHint (ErrorInBindingGroup nms) =
734+ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
735+ renderHint ErrorInDataBindingGroup =
736+ lineWithLevel "in data binding group:"
737+ renderHint (ErrorInTypeSynonym name) =
738+ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
739+ renderHint (ErrorInValueDeclaration n) =
740+ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
741+ renderHint (ErrorInTypeDeclaration n) =
742+ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
743+ renderHint (ErrorInForeignImport nm) =
744+ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
745+ renderHint (PositionedError srcSpan) =
746+ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
799747
800748 lineWithLevel :: String -> Box.Box
801749 lineWithLevel text = line $ show level ++ " " ++ text
@@ -805,23 +753,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
805753 Error -> "error"
806754 Warning -> "warning"
807755
808− suggestions :: ErrorMessage -> [Box.Box]
809− suggestions = suggestions' . unwrapErrorMessage
810− where
811− suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
756+ suggestions :: SimpleErrorMessage -> [Box.Box]
757+ suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
812758 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"
813759 ]
814− suggestions' (TypesDoNotUnify t1 t2)
815− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
816− | otherwise = []
817− suggestions' _ = []
760+ suggestions (TypesDoNotUnify t1 t2)
761+ | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
762+ | otherwise = []
763+ suggestions _ = []
818764
819765 paras :: [Box.Box] -> Box.Box
820766 paras = Box.vcat Box.left
821767
822− -- |
823768 -- Pretty print and export declaration
824− --
825769 prettyPrintExport :: DeclarationRef -> String
826770 prettyPrintExport (TypeRef pn _) = runProperName pn
827771 prettyPrintExport (ValueRef ident) = showIdent ident
@@ -830,38 +774,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
830774 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
831775 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
832776
833− -- |
834− -- Simplify an error message
835− --
836− simplifyErrorMessage :: ErrorMessage -> ErrorMessage
837− simplifyErrorMessage = unwrap Nothing
777+ -- Hints get added at the front, so we need to reverse them before rendering
778+ reverseHints :: ErrorMessage -> ErrorMessage
779+ reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple
780+
781+ -- | Put positional hints at the front of the list
782+ positionHintsFirst :: ErrorMessage -> ErrorMessage
783+ positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple
838784 where
839− unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
840− unwrap pos (ErrorInExpression _ err) = unwrap pos err
841− unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
842− unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
843− unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
844− unwrap pos (ErrorInferringType _ err) = unwrap pos err
845− unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
846− unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
847− unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
848− unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
849− unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
850− unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
851− unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
852− unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
853− unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
854− unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
855− unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err)
856− unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
857− unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
858− unwrap _ (PositionedError pos err) = unwrap (Just pos) err
859− unwrap pos other = wrap pos other
860−
861− wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
862− wrap Nothing = id
863− wrap (Just pos) = PositionedError pos
785+ isPositionHint :: HintCategory -> Bool
786+ isPositionHint PositionHint = True
787+ isPositionHint OtherHint = True
788+ isPositionHint _ = False
864789
790+ -- | Simplify an error message
791+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
792+ simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple
793+ where
794+ -- Take the last instance of each "hint category"
795+ simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
796+ simplifyHints = reverse . nubBy categoriesEqual . reverse
797+
798+ -- Don't remove hints in the "other" category
799+ categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
800+ categoriesEqual x y =
801+ case (hintCategory x, hintCategory y) of
802+ (OtherHint, _) -> False
803+ (_, OtherHint) -> False
804+ (c1, c2) -> c1 == c2
805+
806+ hintCategory :: ErrorMessageHint -> HintCategory
807+ hintCategory ErrorCheckingType{} = ExprHint
808+ hintCategory ErrorInferringType{} = ExprHint
809+ hintCategory ErrorInExpression{} = ExprHint
810+ hintCategory ErrorUnifyingTypes{} = CheckHint
811+ hintCategory ErrorInSubsumption{} = CheckHint
812+ hintCategory ErrorInApplication{} = CheckHint
813+ hintCategory PositionedError{} = PositionHint
814+ hintCategory _ = OtherHint
865815
866816-- |
867817-- Pretty print multiple errors
@@ -988,8 +938,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple
988938warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
989939
990940withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
991−withPosition _ (PositionedError pos err) = withPosition pos err
992−withPosition pos err = PositionedError pos err
941+withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se
993942
994943-- |
995944-- Collect errors in in parallel