@@ -20,10 +20,11 @@
20module Language.PureScript.Errors where
20module Language.PureScript.Errors where
22import Data.Either (lefts, rights)
22import Data.Either (lefts, rights)
23−import Data.List (intercalate, transpose)
23+import Data.List (intercalate, transpose, nub, nubBy, partition)
24import Data.Function (on)
24import Data.Function (on)
25#if __GLASGOW_HASKELL__ < 710
25#if __GLASGOW_HASKELL__ < 710
26import Data.Foldable (fold, foldMap)
26import Data.Foldable (fold, foldMap)
27+import Data.Traversable (traverse)
28import Data.Foldable (fold)
29import Data.Foldable (fold)
@@ -52,11 +53,8 @@ import qualified Text.PrettyPrint.Boxes as Box
52import qualified Text.Parsec as P
53import qualified Text.Parsec as P
53import qualified Text.Parsec.Error as PE
54import qualified Text.Parsec.Error as PE
54import Text.Parsec.Error (Message(..))
55import Text.Parsec.Error (Message(..))
55−import Data.List (nub)
58−-- A type of error messages
57+-- | A type of error messages
60data SimpleErrorMessage
58data SimpleErrorMessage
61 = ErrorParsingExterns P.ParseError
59 = ErrorParsingExterns P.ParseError
62 | ErrorParsingFFIModule FilePath
60 | ErrorParsingFFIModule FilePath
@@ -100,6 +98,7 @@ data SimpleErrorMessage
100 | CtorConflictsWithClass ProperName
98 | CtorConflictsWithClass ProperName
101 | ClassConflictsWithType ProperName
99 | ClassConflictsWithType ProperName
102 | ClassConflictsWithCtor ProperName
100 | ClassConflictsWithCtor ProperName
101+ | DuplicateModuleName ModuleName
103 | DuplicateClassExport ProperName
102 | DuplicateClassExport ProperName
104 | DuplicateValueExport Ident
103 | DuplicateValueExport Ident
105 | DuplicateTypeArgument String
104 | DuplicateTypeArgument String
@@ -143,45 +142,54 @@ data SimpleErrorMessage
143 | ShadowedTypeVar String
142 | ShadowedTypeVar String
144 | UnusedTypeVar String
143 | UnusedTypeVar String
145 | WildcardInferredType Type
144 | WildcardInferredType Type
145+ | MissingTypeDeclaration Ident
146 | NotExhaustivePattern [[Binder]] Bool
146 | NotExhaustivePattern [[Binder]] Bool
147 | OverlappingPattern [[Binder]] Bool
147 | OverlappingPattern [[Binder]] Bool
148 | IncompleteExhaustivityCheck
148 | IncompleteExhaustivityCheck
149 | ClassOperator ProperName Ident
149 | ClassOperator ProperName Ident
150 | MisleadingEmptyTypeImport ModuleName ProperName
150 | MisleadingEmptyTypeImport ModuleName ProperName
151 | ImportHidingModule ModuleName
151 | ImportHidingModule ModuleName
152− deriving (Show)
152+ deriving Show
154−-- |
154+-- | Error message hints, providing more detailed information about failure.
155−-- Wrapper of simpler errors
155+data ErrorMessageHint
158− = NotYetDefined [Ident] ErrorMessage
156+ = NotYetDefined [Ident]
159− | ErrorUnifyingTypes Type Type ErrorMessage
157+ | ErrorUnifyingTypes Type Type
160− | ErrorInExpression Expr ErrorMessage
158+ | ErrorInExpression Expr
161− | ErrorInModule ModuleName ErrorMessage
159+ | ErrorInModule ModuleName
162− | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
160+ | ErrorInInstance (Qualified ProperName) [Type]
163− | ErrorInSubsumption Type Type ErrorMessage
161+ | ErrorInSubsumption Type Type
164− | ErrorCheckingType Expr Type ErrorMessage
162+ | ErrorCheckingType Expr Type
165− | ErrorCheckingKind Type ErrorMessage
163+ | ErrorCheckingKind Type
166− | ErrorInferringType Expr ErrorMessage
164+ | ErrorInferringType Expr
167− | ErrorInApplication Expr Type Expr ErrorMessage
165+ | ErrorInApplication Expr Type Expr
168− | ErrorInDataConstructor ProperName ErrorMessage
166+ | ErrorInDataConstructor ProperName
169− | ErrorInTypeConstructor ProperName ErrorMessage
167+ | ErrorInTypeConstructor ProperName
170− | ErrorInBindingGroup [Ident] ErrorMessage
168+ | ErrorInBindingGroup [Ident]
171− | ErrorInDataBindingGroup ErrorMessage
169+ | ErrorInDataBindingGroup
172− | ErrorInTypeSynonym ProperName ErrorMessage
170+ | ErrorInTypeSynonym ProperName
173− | ErrorInValueDeclaration Ident ErrorMessage
171+ | ErrorInValueDeclaration Ident
174− | ErrorInTypeDeclaration Ident ErrorMessage
172+ | ErrorInTypeDeclaration Ident
175− | ErrorInForeignImport Ident ErrorMessage
173+ | ErrorInForeignImport Ident
176− | PositionedError SourceSpan ErrorMessage
174+ | PositionedError SourceSpan
177− | SimpleErrorWrapper SimpleErrorMessage
175+ deriving Show
177+-- | Categories of hints
186+data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
180instance UnificationError Type ErrorMessage where
188instance UnificationError Type ErrorMessage where
181− occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
189+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t
183instance UnificationError Kind ErrorMessage where
191instance UnificationError Kind ErrorMessage where
184− occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
192+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k
187-- Get the error code for a particular error type
195-- Get the error code for a particular error type
@@ -230,6 +238,7 @@ errorCode em = case unwrapErrorMessage em of
230 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
238 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
231 ClassConflictsWithType{} -> "ClassConflictsWithType"
239 ClassConflictsWithType{} -> "ClassConflictsWithType"
232 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
240 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
241+ DuplicateModuleName{} -> "DuplicateModuleName"
233 DuplicateClassExport{} -> "DuplicateClassExport"
242 DuplicateClassExport{} -> "DuplicateClassExport"
234 DuplicateValueExport{} -> "DuplicateValueExport"
243 DuplicateValueExport{} -> "DuplicateValueExport"
235 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
244 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -273,6 +282,7 @@ errorCode em = case unwrapErrorMessage em of
273 ShadowedTypeVar{} -> "ShadowedTypeVar"
282 ShadowedTypeVar{} -> "ShadowedTypeVar"
274 UnusedTypeVar{} -> "UnusedTypeVar"
283 UnusedTypeVar{} -> "UnusedTypeVar"
275 WildcardInferredType{} -> "WildcardInferredType"
284 WildcardInferredType{} -> "WildcardInferredType"
285+ MissingTypeDeclaration{} -> "MissingTypeDeclaration"
276 NotExhaustivePattern{} -> "NotExhaustivePattern"
286 NotExhaustivePattern{} -> "NotExhaustivePattern"
277 OverlappingPattern{} -> "OverlappingPattern"
287 OverlappingPattern{} -> "OverlappingPattern"
278 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
288 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
@@ -300,7 +310,7 @@ nonEmpty = not . null . runMultipleErrors
300-- Create an error set from a single simple error message
310-- Create an error set from a single simple error message
302errorMessage :: SimpleErrorMessage -> MultipleErrors
312errorMessage :: SimpleErrorMessage -> MultipleErrors
303−errorMessage err = MultipleErrors [SimpleErrorWrapper err]
313+errorMessage err = MultipleErrors [ErrorMessage [] err]
@@ -309,12 +319,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]
309singleError :: ErrorMessage -> MultipleErrors
319singleError :: ErrorMessage -> MultipleErrors
310singleError = MultipleErrors . pure
320singleError = MultipleErrors . pure
313−-- Lift a function on ErrorMessage to a function on MultipleErrors
322+-- | Lift a function on ErrorMessage to a function on MultipleErrors
315onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
323onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
316onErrorMessages f = MultipleErrors . map f . runMultipleErrors
324onErrorMessages f = MultipleErrors . map f . runMultipleErrors
326+-- | Add a hint to an error message
327+addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
328+addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
318-- | The various types of things which might need to be relabelled in errors messages.
330-- | The various types of things which might need to be relabelled in errors messages.
319data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
331data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
@@ -328,27 +340,7 @@ data Level = Error | Warning deriving Show
328-- Extract nested error messages from wrapper errors
340-- Extract nested error messages from wrapper errors
330unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
342unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
331−unwrapErrorMessage em = case em of
343+unwrapErrorMessage (ErrorMessage _ se) = se
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
353replaceUnknowns :: Type -> State UnknownMap Type
345replaceUnknowns :: Type -> State UnknownMap Type
354replaceUnknowns = everywhereOnTypesM replaceTypes
346replaceUnknowns = everywhereOnTypesM replaceTypes
@@ -364,404 +356,406 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
364 replaceTypes other = return other
356 replaceTypes other = return other
366onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
358onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
367−onTypesInErrorMessageM f = g
359+onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
369− gSimple (InfiniteType t) = InfiniteType <$> (f t)
361+ gSimple (InfiniteType t) = InfiniteType <$> f t
370− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
362+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
371− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
363+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
372− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
364+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
373− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
365+ gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t
374− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
366+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
375 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
367 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
376 gSimple other = pure other
368 gSimple other = pure other
377− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
369+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
378− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
370+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
379− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
371+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
380− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
372+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
381− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
373+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
382− g (NotYetDefined x e) = NotYetDefined x <$> (g e)
374+ gHint other = pure other
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
399-- Pretty print a single error, simplifying if necessary
377-- Pretty print a single error, simplifying if necessary
401prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
379prettyPrintSingleError :: 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)
405 -- Pretty print an ErrorMessage
383 -- Pretty print an ErrorMessage
407 prettyPrintErrorMessage :: ErrorMessage -> Box.Box
384 prettyPrintErrorMessage :: ErrorMessage -> Box.Box
408− prettyPrintErrorMessage em =
385+ prettyPrintErrorMessage (ErrorMessage hints simple) =
387+ map renderHint hints ++
388+ renderSimpleErrorMessage simple :
410− go em:suggestions em ++
389+ suggestions simple ++
411 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
390 [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
413 wikiUri :: String
392 wikiUri :: String
414 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
393 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
416− go :: ErrorMessage -> Box.Box
395+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
417− goSimple (CannotGetFileInfo path) =
396+ renderSimpleErrorMessage (CannotGetFileInfo path) =
418 paras [ line "Unable to read file info: "
397 paras [ line "Unable to read file info: "
419 , indent . line $ path
398 , indent . line $ path
421− goSimple (CannotReadFile path) =
400+ renderSimpleErrorMessage (CannotReadFile path) =
422 paras [ line "Unable to read file: "
401 paras [ line "Unable to read file: "
423 , indent . line $ path
402 , indent . line $ path
425− goSimple (CannotWriteFile path) =
404+ renderSimpleErrorMessage (CannotWriteFile path) =
426 paras [ line "Unable to write file: "
405 paras [ line "Unable to write file: "
427 , indent . line $ path
406 , indent . line $ path
429− goSimple (ErrorParsingExterns err) =
408+ renderSimpleErrorMessage (ErrorParsingExterns err) =
430 paras [ lineWithLevel "parsing externs files: "
409 paras [ lineWithLevel "parsing externs files: "
431− , indent . prettyPrintParseError $ err
410+ , prettyPrintParseError err
433− goSimple (ErrorParsingFFIModule path) =
412+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =
434 paras [ line "Unable to parse module from FFI file: "
413 paras [ line "Unable to parse module from FFI file: "
435 , indent . line $ path
414 , indent . line $ path
437− goSimple (ErrorParsingModule err) =
416+ renderSimpleErrorMessage (ErrorParsingModule err) =
438 paras [ line "Unable to parse module: "
417 paras [ line "Unable to parse module: "
439− , indent . prettyPrintParseError $ err
418+ , prettyPrintParseError err
441− goSimple (MissingFFIModule mn) =
420+ renderSimpleErrorMessage (MissingFFIModule mn) =
442 line $ "Missing FFI implementations for module " ++ runModuleName mn
421 line $ "Missing FFI implementations for module " ++ runModuleName mn
443− goSimple (UnnecessaryFFIModule mn path) =
422+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
444 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
423 paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
445 , indent . line $ path
424 , indent . line $ path
447− goSimple (MultipleFFIModules mn paths) =
426+ renderSimpleErrorMessage (MultipleFFIModules mn paths) =
448− paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " ]
427+ paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
449− ++ map (indent . line) paths
428+ , indent . paras $ map line paths
450− goSimple (InvalidExternsFile path) =
430+ renderSimpleErrorMessage (InvalidExternsFile path) =
451 paras [ line "Externs file is invalid: "
431 paras [ line "Externs file is invalid: "
452 , indent . line $ path
432 , indent . line $ path
454− goSimple InvalidDoBind =
434+ renderSimpleErrorMessage InvalidDoBind =
455 line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."
435 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 =
457 line "Let statement cannot be the last statement in a do block. The last statement must be an expression."
437 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 =
459 line "Unable to reorder operators"
439 line "Unable to reorder operators"
460− goSimple UnspecifiedSkolemScope =
440+ renderSimpleErrorMessage UnspecifiedSkolemScope =
461 line "Skolem variable scope is unspecified"
441 line "Skolem variable scope is unspecified"
462− goSimple OverlappingNamesInLet =
442+ renderSimpleErrorMessage OverlappingNamesInLet =
463 line "Overlapping names in let binding."
443 line "Overlapping names in let binding."
464− goSimple (InfiniteType ty) =
444+ renderSimpleErrorMessage (InfiniteType ty) =
465 paras [ line "An infinite type was inferred for an expression: "
445 paras [ line "An infinite type was inferred for an expression: "
466− , indent $ line $ prettyPrintType ty
446+ , indent $ typeAsBox ty
468− goSimple (InfiniteKind ki) =
448+ renderSimpleErrorMessage (InfiniteKind ki) =
469 paras [ line "An infinite kind was inferred for a type: "
449 paras [ line "An infinite kind was inferred for a type: "
470 , indent $ line $ prettyPrintKind ki
450 , indent $ line $ prettyPrintKind ki
472− goSimple (MultipleFixities name) =
452+ renderSimpleErrorMessage (MultipleFixities name) =
473 line $ "Multiple fixity declarations for " ++ showIdent name
453 line $ "Multiple fixity declarations for " ++ showIdent name
474− goSimple (OrphanTypeDeclaration nm) =
454+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
475 line $ "Orphan type declaration for " ++ showIdent nm
455 line $ "Orphan type declaration for " ++ showIdent nm
476− goSimple (OrphanFixityDeclaration op) =
456+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =
477 line $ "Orphan fixity declaration for " ++ show op
457 line $ "Orphan fixity declaration for " ++ show op
478− goSimple (RedefinedModule name filenames) =
458+ renderSimpleErrorMessage (RedefinedModule name filenames) =
479− paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
459+ paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
480− : map (indent . line . displaySourceSpan) filenames
460+ , indent . paras $ map (line . displaySourceSpan) filenames
481− goSimple (RedefinedIdent name) =
462+ renderSimpleErrorMessage (RedefinedIdent name) =
482 line $ "Name " ++ showIdent name ++ " has been defined multiple times"
463 line $ "Name " ++ showIdent name ++ " has been defined multiple times"
483− goSimple (UnknownModule mn) =
464+ renderSimpleErrorMessage (UnknownModule mn) =
484 line $ "Unknown module " ++ runModuleName mn
465 line $ "Unknown module " ++ runModuleName mn
485− goSimple (UnknownType name) =
466+ renderSimpleErrorMessage (UnknownType name) =
486 line $ "Unknown type " ++ showQualified runProperName name
467 line $ "Unknown type " ++ showQualified runProperName name
487− goSimple (UnknownTypeClass name) =
468+ renderSimpleErrorMessage (UnknownTypeClass name) =
488 line $ "Unknown type class " ++ showQualified runProperName name
469 line $ "Unknown type class " ++ showQualified runProperName name
489− goSimple (UnknownValue name) =
470+ renderSimpleErrorMessage (UnknownValue name) =
490 line $ "Unknown value " ++ showQualified showIdent name
471 line $ "Unknown value " ++ showQualified showIdent name
491− goSimple (UnknownTypeConstructor name) =
472+ renderSimpleErrorMessage (UnknownTypeConstructor name) =
492 line $ "Unknown type constructor " ++ showQualified runProperName name
473 line $ "Unknown type constructor " ++ showQualified runProperName name
493− goSimple (UnknownDataConstructor dc tc) =
474+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =
494 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
475 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
495− goSimple (UnknownImportType mn name) =
476+ renderSimpleErrorMessage (UnknownImportType mn name) =
496 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name
477 line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name
497− goSimple (UnknownExportType name) =
478+ renderSimpleErrorMessage (UnknownExportType name) =
498 line $ "Cannot export unknown type " ++ runProperName name
479 line $ "Cannot export unknown type " ++ runProperName name
499− goSimple (UnknownImportTypeClass mn name) =
480+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
500 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name
481 line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name
501− goSimple (UnknownExportTypeClass name) =
482+ renderSimpleErrorMessage (UnknownExportTypeClass name) =
502 line $ "Cannot export unknown type class " ++ runProperName name
483 line $ "Cannot export unknown type class " ++ runProperName name
503− goSimple (UnknownImportValue mn name) =
484+ renderSimpleErrorMessage (UnknownImportValue mn name) =
504 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name
485 line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name
505− goSimple (UnknownExportValue name) =
486+ renderSimpleErrorMessage (UnknownExportValue name) =
506 line $ "Cannot export unknown value " ++ showIdent name
487 line $ "Cannot export unknown value " ++ showIdent name
507− goSimple (UnknownExportModule name) =
488+ renderSimpleErrorMessage (UnknownExportModule name) =
508 line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"
489 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) =
510 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
491 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) =
512 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"
493 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) =
514 line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn
495 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) =
516 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
497 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
517− goSimple (ConflictingTypeDecls nm) =
498+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =
518 line $ "Conflicting type declarations for " ++ runProperName nm
499 line $ "Conflicting type declarations for " ++ runProperName nm
519− goSimple (ConflictingCtorDecls nm) =
500+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =
520 line $ "Conflicting data constructor declarations for " ++ runProperName nm
501 line $ "Conflicting data constructor declarations for " ++ runProperName nm
521− goSimple (TypeConflictsWithClass nm) =
502+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =
522 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
503 line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
523− goSimple (CtorConflictsWithClass nm) =
504+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =
524 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
505 line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
525− goSimple (ClassConflictsWithType nm) =
506+ renderSimpleErrorMessage (ClassConflictsWithType nm) =
526 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
507 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
527− goSimple (ClassConflictsWithCtor nm) =
508+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
528 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
509 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
510+ renderSimpleErrorMessage (DuplicateModuleName mn) =
511+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
529− goSimple (DuplicateClassExport nm) =
512+ renderSimpleErrorMessage (DuplicateClassExport nm) =
530 line $ "Duplicate export declaration for type class " ++ runProperName nm
513 line $ "Duplicate export declaration for type class " ++ runProperName nm
531− goSimple (DuplicateValueExport nm) =
514+ renderSimpleErrorMessage (DuplicateValueExport nm) =
532 line $ "Duplicate export declaration for value " ++ showIdent nm
515 line $ "Duplicate export declaration for value " ++ showIdent nm
533− goSimple (CycleInDeclaration nm) =
516+ renderSimpleErrorMessage (CycleInDeclaration nm) =
534 line $ "Cycle in declaration of " ++ showIdent nm
517 line $ "Cycle in declaration of " ++ showIdent nm
535− goSimple (CycleInModules mns) =
518+ renderSimpleErrorMessage (CycleInModules mns) =
536 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)
519 line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)
537− goSimple (CycleInTypeSynonym pn) =
520+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =
538 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn
521 line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn
539− goSimple (NameIsUndefined ident) =
522+ renderSimpleErrorMessage (NameIsUndefined ident) =
540 line $ showIdent ident ++ " is undefined"
523 line $ showIdent ident ++ " is undefined"
541− goSimple (NameNotInScope ident) =
524+ renderSimpleErrorMessage (NameNotInScope ident) =
542 line $ showIdent ident ++ " may not be defined in the current scope"
525 line $ showIdent ident ++ " may not be defined in the current scope"
543− goSimple (UndefinedTypeVariable name) =
526+ renderSimpleErrorMessage (UndefinedTypeVariable name) =
544 line $ "Type variable " ++ runProperName name ++ " is undefined"
527 line $ "Type variable " ++ runProperName name ++ " is undefined"
545− goSimple (PartiallyAppliedSynonym name) =
528+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
546 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name
529 paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name
547 , line "Type synonyms must be applied to all of their type arguments."
530 , line "Type synonyms must be applied to all of their type arguments."
549− goSimple (EscapedSkolem binding) =
532+ renderSimpleErrorMessage (EscapedSkolem binding) =
550 paras $ [ line "A type variable has escaped its scope." ]
533 paras $ [ line "A type variable has escaped its scope." ]
551 <> foldMap (\expr -> [ line "Relevant expression: "
534 <> foldMap (\expr -> [ line "Relevant expression: "
552− , indent $ line $ prettyPrintValue expr
535+ , indent $ prettyPrintValue expr
553 ]) binding
536 ]) binding
554− goSimple (TypesDoNotUnify t1 t2)
537+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
555 = paras [ line "Cannot unify type"
538 = paras [ line "Cannot unify type"
556− , indent $ line $ prettyPrintType t1
539+ , indent $ typeAsBox t1
557 , line "with type"
540 , line "with type"
558− , indent $ line $ prettyPrintType t2
541+ , indent $ typeAsBox t2
560− goSimple (KindsDoNotUnify k1 k2) =
543+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
561 paras [ line "Cannot unify kind"
544 paras [ line "Cannot unify kind"
562 , indent $ line $ prettyPrintKind k1
545 , indent $ line $ prettyPrintKind k1
563 , line "with kind"
546 , line "with kind"
564 , indent $ line $ prettyPrintKind k2
547 , indent $ line $ prettyPrintKind k2
566− goSimple (ConstrainedTypeUnified t1 t2) =
549+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
567 paras [ line "Cannot unify constrained type"
550 paras [ line "Cannot unify constrained type"
568− , indent $ line $ prettyPrintType t1
551+ , indent $ typeAsBox t1
569 , line "with type"
552 , line "with type"
570− , indent $ line $ prettyPrintType t2
553+ , indent $ typeAsBox t2
572− goSimple (OverlappingInstances nm ts (d : ds)) =
555+ renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
573− paras [ line $ "Overlapping instances found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
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)
560+ , line "The following instances were found:"
574 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
561 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
576− goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"
563+ renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"
577− goSimple (NoInstanceFound nm ts) =
564+ renderSimpleErrorMessage (NoInstanceFound nm ts) =
578− line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom 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)
579− goSimple (PossiblyInfiniteInstance nm ts) =
570+ renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
580− line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."
571+ paras [ line "Instance for"
572+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
573+ , Box.vcat Box.left (map typeAtomAsBox ts)
575+ , line "is possibly infinite."
581− goSimple (CannotDerive nm ts) =
577+ renderSimpleErrorMessage (CannotDerive nm ts) =
582− line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom 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)
583− goSimple (CannotFindDerivingType nm) =
583+ renderSimpleErrorMessage (CannotFindDerivingType nm) =
584 line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
584 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) =
586 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
586 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
587 <> foldMap (\expr' -> [ line "Relevant expression: "
587 <> foldMap (\expr' -> [ line "Relevant expression: "
588− , indent $ line $ prettyPrintValue expr'
588+ , indent $ prettyPrintValue expr'
590− goSimple (DuplicateTypeArgument name) =
590+ renderSimpleErrorMessage (DuplicateTypeArgument name) =
591 line $ "Duplicate type argument " ++ show name
591 line $ "Duplicate type argument " ++ show name
592− goSimple (DuplicateValueDeclaration nm) =
592+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
593 line $ "Duplicate value declaration for " ++ showIdent nm
593 line $ "Duplicate value declaration for " ++ showIdent nm
594− goSimple (ArgListLengthsDiffer ident) =
594+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
595 line $ "Argument list lengths differ in declaration " ++ showIdent ident
595 line $ "Argument list lengths differ in declaration " ++ showIdent ident
596− goSimple (OverlappingArgNames ident) =
596+ renderSimpleErrorMessage (OverlappingArgNames ident) =
597 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident
597 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident
598− goSimple (MissingClassMember ident) =
598+ renderSimpleErrorMessage (MissingClassMember ident) =
599 line $ "Member " ++ showIdent ident ++ " has not been implemented"
599 line $ "Member " ++ showIdent ident ++ " has not been implemented"
600− goSimple (ExtraneousClassMember ident) =
600+ renderSimpleErrorMessage (ExtraneousClassMember ident) =
601 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"
601 line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"
602− goSimple (ExpectedType ty kind) =
602+ renderSimpleErrorMessage (ExpectedType ty kind) =
603 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
603 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
606− goSimple (IncorrectConstructorArity nm) =
610+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =
607 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm
611 line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm
608− goSimple SubsumptionCheckFailed = line "Unable to check type subsumption"
612+ renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"
609− goSimple (ExprDoesNotHaveType expr ty) =
613+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
610 paras [ line "Expression"
614 paras [ line "Expression"
611− , indent $ line $ prettyPrintValue expr
615+ , indent $ prettyPrintValue expr
612 , line "does not have type"
616 , line "does not have type"
613− , indent $ line $ prettyPrintType ty
617+ , indent $ typeAsBox ty
615− goSimple (PropertyIsMissing prop row) =
619+ renderSimpleErrorMessage (PropertyIsMissing prop row) =
621+ , indent $ prettyPrintRowWith '(' ')' row
616− line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
622+ , line $ "lacks required property " ++ show prop
617− goSimple (CannotApplyFunction fn arg) =
624+ renderSimpleErrorMessage (CannotApplyFunction fn arg) =
618 paras [ line "Cannot apply function of type"
625 paras [ line "Cannot apply function of type"
619− , indent $ line $ prettyPrintType fn
626+ , indent $ typeAsBox fn
620 , line "to argument"
627 , line "to argument"
621− , indent $ line $ prettyPrintValue arg
628+ , indent $ prettyPrintValue arg
623− goSimple TypeSynonymInstance =
630+ renderSimpleErrorMessage TypeSynonymInstance =
624 line "Type synonym instances are disallowed"
631 line "Type synonym instances are disallowed"
625− goSimple (OrphanInstance nm cnm ts) =
632+ renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
626− paras [ line $ "Instance " ++ showIdent nm ++ " for " ++ showQualified runProperName cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance."
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)
637+ , line "is an orphan instance."
627 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
638 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
628 , line "Consider moving the instance, if possible, or using a newtype wrapper."
639 , line "Consider moving the instance, if possible, or using a newtype wrapper."
630− goSimple InvalidNewtype =
641+ renderSimpleErrorMessage InvalidNewtype =
631 line "Newtypes must define a single constructor with a single argument"
642 line "Newtypes must define a single constructor with a single argument"
632− goSimple (InvalidInstanceHead ty) =
643+ renderSimpleErrorMessage (InvalidInstanceHead ty) =
633 paras [ line "Invalid type in class instance head:"
644 paras [ line "Invalid type in class instance head:"
634− , indent $ line $ prettyPrintType ty
645+ , indent $ typeAsBox ty
636− goSimple (TransitiveExportError x ys) =
647+ renderSimpleErrorMessage (TransitiveExportError x ys) =
637 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
648 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
638 : map (line . prettyPrintExport) ys
649 : map (line . prettyPrintExport) ys
639− goSimple (ShadowedName nm) =
650+ renderSimpleErrorMessage (ShadowedName nm) =
640 line $ "Name '" ++ showIdent nm ++ "' was shadowed"
651 line $ "Name '" ++ showIdent nm ++ "' was shadowed"
641− goSimple (ShadowedTypeVar tv) =
652+ renderSimpleErrorMessage (ShadowedTypeVar tv) =
642 line $ "Type variable '" ++ tv ++ "' was shadowed"
653 line $ "Type variable '" ++ tv ++ "' was shadowed"
643− goSimple (UnusedTypeVar tv) =
654+ renderSimpleErrorMessage (UnusedTypeVar tv) =
644 line $ "Type variable '" ++ tv ++ "' was declared but not used"
655 line $ "Type variable '" ++ tv ++ "' was declared but not used"
645− goSimple (ClassOperator className opName) =
656+ renderSimpleErrorMessage (ClassOperator className opName) =
646 paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."
657 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:"
658+ , 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"
659+ , indent . line $ showIdent opName ++ " = someMember"
650− goSimple (MisleadingEmptyTypeImport mn name) =
661+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
651 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"
662 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) =
653 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"
664 line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"
654− goSimple (WildcardInferredType ty) =
665+ renderSimpleErrorMessage (WildcardInferredType ty) =
655− line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
666+ paras [ line "The wildcard type definition has the inferred type "
667+ , indent $ typeAsBox ty
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 ++ " :: _"
656− goSimple (NotExhaustivePattern bs b) =
675+ renderSimpleErrorMessage (NotExhaustivePattern bs b) =
657 paras $ [ line "A case expression could not be determined to cover all inputs."
676 paras $ [ line "A case expression could not be determined to cover all inputs."
658 , line "The following additional cases are required to cover all inputs:\n"
677 , line "The following additional cases are required to cover all inputs:\n"
659 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
678 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
661 [ line "..." | not b ]
680 [ line "..." | not b ]
662− goSimple (OverlappingPattern bs b) =
681+ renderSimpleErrorMessage (OverlappingPattern bs b) =
663 paras $ [ line "A case expression contains unreachable cases:\n"
682 paras $ [ line "A case expression contains unreachable cases:\n"
664 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
683 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
666 [ line "..." | not b ]
685 [ line "..." | not b ]
667− goSimple IncompleteExhaustivityCheck =
686+ renderSimpleErrorMessage IncompleteExhaustivityCheck =
668 paras [ line "An exhaustivity check was abandoned due to too many possible cases."
687 paras [ line "An exhaustivity check was abandoned due to too many possible cases."
669 , line "You may want to decomposing your data types into smaller types."
688 , line "You may want to decomposing your data types into smaller types."
691+ renderHint :: ErrorMessageHint -> Box.Box
671− go (NotYetDefined names err) =
692+ renderHint (NotYetDefined names) =
672− paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
693+ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
675− go (ErrorUnifyingTypes t1 t2 err) =
694+ renderHint (ErrorUnifyingTypes t1 t2) =
676 paras [ lineWithLevel "unifying type "
695 paras [ lineWithLevel "unifying type "
677− , indent $ line $ prettyPrintType t1
696+ , indent $ typeAsBox t1
678 , line "with type"
697 , line "with type"
679− , indent $ line $ prettyPrintType t2
698+ , indent $ typeAsBox t2
682− go (ErrorInExpression expr err) =
700+ renderHint (ErrorInExpression expr) =
683 paras [ lineWithLevel "in expression:"
701 paras [ lineWithLevel "in expression:"
684− , indent $ line $ prettyPrintValue expr
702+ , indent $ prettyPrintValue expr
687− go (ErrorInModule mn err) =
704+ renderHint (ErrorInModule mn) =
688 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
705 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
691− go (ErrorInSubsumption t1 t2 err) =
707+ renderHint (ErrorInSubsumption t1 t2) =
692 paras [ lineWithLevel "checking that type "
708 paras [ lineWithLevel "checking that type "
693− , indent $ line $ prettyPrintType t1
709+ , indent $ typeAsBox t1
694 , line "subsumes type"
710 , line "subsumes type"
695− , indent $ line $ prettyPrintType t2
711+ , indent $ typeAsBox t2
698− go (ErrorInInstance name ts err) =
713+ renderHint (ErrorInInstance nm ts) =
699− paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
714+ paras [ lineWithLevel "in type class instance"
700− , go err
715+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
716+ , Box.vcat Box.left (map typeAtomAsBox ts)
702− go (ErrorCheckingKind ty err) =
719+ renderHint (ErrorCheckingKind ty) =
703 paras [ lineWithLevel "checking kind of type "
720 paras [ lineWithLevel "checking kind of type "
704− , indent $ line $ prettyPrintType ty
721+ , indent $ typeAsBox ty
707− go (ErrorInferringType expr err) =
723+ renderHint (ErrorInferringType expr) =
708 paras [ lineWithLevel "inferring type of value "
724 paras [ lineWithLevel "inferring type of value "
709− , indent $ line $ prettyPrintValue expr
725+ , indent $ prettyPrintValue expr
712− go (ErrorCheckingType expr ty err) =
727+ renderHint (ErrorCheckingType expr ty) =
713 paras [ lineWithLevel "checking that value "
728 paras [ lineWithLevel "checking that value "
714− , indent $ line $ prettyPrintValue expr
729+ , indent $ prettyPrintValue expr
715 , line "has type"
730 , line "has type"
716− , indent $ line $ prettyPrintType ty
731+ , indent $ typeAsBox ty
719− go (ErrorInApplication f t a err) =
733+ renderHint (ErrorInApplication f t a) =
720 paras [ lineWithLevel "applying function"
734 paras [ lineWithLevel "applying function"
721− , indent $ line $ prettyPrintValue f
735+ , indent $ prettyPrintValue f
722 , line "of type"
736 , line "of type"
723− , indent $ line $ prettyPrintType t
737+ , indent $ typeAsBox t
724 , line "to argument"
738 , line "to argument"
725− , indent $ line $ prettyPrintValue a
739+ , indent $ prettyPrintValue a
728− go (ErrorInDataConstructor nm err) =
741+ renderHint (ErrorInDataConstructor nm) =
729− paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
742+ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
732− go (ErrorInTypeConstructor nm err) =
743+ renderHint (ErrorInTypeConstructor nm) =
733− paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
744+ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
736− go (ErrorInBindingGroup nms err) =
745+ renderHint (ErrorInBindingGroup nms) =
737− paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
746+ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
740− go (ErrorInDataBindingGroup err) =
747+ renderHint ErrorInDataBindingGroup =
741− paras [ lineWithLevel $ "in data binding group:"
748+ lineWithLevel "in data binding group:"
744− go (ErrorInTypeSynonym name err) =
749+ renderHint (ErrorInTypeSynonym name) =
745− paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
750+ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
748− go (ErrorInValueDeclaration n err) =
751+ renderHint (ErrorInValueDeclaration n) =
749− paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
752+ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
752− go (ErrorInTypeDeclaration n err) =
753+ renderHint (ErrorInTypeDeclaration n) =
753− paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
754+ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
756− go (ErrorInForeignImport nm err) =
755+ renderHint (ErrorInForeignImport nm) =
757− paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
756+ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
760− go (PositionedError srcSpan err) =
757+ renderHint (PositionedError srcSpan) =
761− paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
758+ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
764− go (SimpleErrorWrapper sem) = goSimple sem
766 lineWithLevel :: String -> Box.Box
760 lineWithLevel :: String -> Box.Box
767 lineWithLevel text = line $ show level ++ " " ++ text
761 lineWithLevel text = line $ show level ++ " " ++ text
@@ -771,23 +765,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
771 Error -> "error"
765 Error -> "error"
772 Warning -> "warning"
766 Warning -> "warning"
774− suggestions :: ErrorMessage -> [Box.Box]
768+ suggestions :: SimpleErrorMessage -> [Box.Box]
775− suggestions = suggestions' . unwrapErrorMessage
777− suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
769+ suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
778 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"
770 , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"
780− suggestions' (TypesDoNotUnify t1 t2)
772+ suggestions (TypesDoNotUnify t1 t2)
781− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
773+ | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
782− | otherwise = []
774+ | otherwise = []
783− suggestions' _ = []
775+ suggestions _ = []
785 paras :: [Box.Box] -> Box.Box
777 paras :: [Box.Box] -> Box.Box
786 paras = Box.vcat Box.left
778 paras = Box.vcat Box.left
789 -- Pretty print and export declaration
780 -- Pretty print and export declaration
791 prettyPrintExport :: DeclarationRef -> String
781 prettyPrintExport :: DeclarationRef -> String
792 prettyPrintExport (TypeRef pn _) = runProperName pn
782 prettyPrintExport (TypeRef pn _) = runProperName pn
793 prettyPrintExport (ValueRef ident) = showIdent ident
783 prettyPrintExport (ValueRef ident) = showIdent ident
@@ -796,38 +786,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
796 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
786 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
797 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
787 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
799− -- |
789+ -- Hints get added at the front, so we need to reverse them before rendering
800− -- Simplify an error message
790+ reverseHints :: ErrorMessage -> ErrorMessage
801− --
791+ reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple
793+ -- | Put positional hints at the front of the list
802− simplifyErrorMessage :: ErrorMessage -> ErrorMessage
794+ positionHintsFirst :: ErrorMessage -> ErrorMessage
803− simplifyErrorMessage = unwrap Nothing
795+ positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple
805− unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
797+ isPositionHint :: HintCategory -> Bool
806− unwrap pos (ErrorInExpression _ err) = unwrap pos err
798+ isPositionHint PositionHint = True
807− unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
799+ isPositionHint OtherHint = True
808− unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
800+ isPositionHint _ = False
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
827− wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
829− wrap (Just pos) = PositionedError pos
802+ -- | Simplify an error message
803+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
804+ simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple
806+ -- Take the last instance of each "hint category"
807+ simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
808+ simplifyHints = reverse . nubBy categoriesEqual . reverse
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
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
833-- Pretty print multiple errors
829-- Pretty print multiple errors
@@ -843,11 +839,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu
844-- | Pretty print warnings as a Box
840-- | Pretty print warnings as a Box
845prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
841prettyPrintMultipleWarningsBox :: 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
848-- | Pretty print errors as a Box
844-- | Pretty print errors as a Box
849prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
845prettyPrintMultipleErrorsBox :: 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
852prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
848prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
853prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
849prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
@@ -857,15 +853,16 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
859prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
855prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
860− result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
856+ result <- forM es $ prettyPrintSingleError full level
861− return $
857+ return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
862− Box.vcat Box.left [ Box.text intro
858+ where
863− , Box.vsep 1 Box.left result
859+ withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
860+ , Box.moveRight 2 err
866-- | Pretty print a Parsec ParseError as a Box
863-- | Pretty print a Parsec ParseError as a Box
867prettyPrintParseError :: P.ParseError -> Box.Box
864prettyPrintParseError :: 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
871-- Pretty print ParseError detail messages.
868-- Pretty print ParseError detail messages.
@@ -878,9 +875,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
878 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
875 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
881− (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
878+ (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs
882− (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
879+ (unExpect,msgs2) = span (UnExpect "" ==) msgs1
883− (expect,messages) = span ((Expect "") ==) msgs2
880+ (expect,messages) = span (Expect "" ==) msgs2
885 showExpect = showMany msgExpecting expect
882 showExpect = showMany msgExpecting expect
886 showUnExpect = showMany msgUnExpected unExpect
883 showUnExpect = showMany msgUnExpected unExpect
@@ -911,8 +908,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
912 clean = nub . filter (not . null)
909 clean = nub . filter (not . null)
911+-- | Indent to the right, and pad on top and bottom.
914indent :: Box.Box -> Box.Box
912indent :: Box.Box -> Box.Box
915−indent = Box.moveRight 2
913+indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2
917line :: String -> Box.Box
915line :: String -> Box.Box
918line = Box.text
916line = Box.text
@@ -928,7 +926,7 @@ renderBox = unlines . map trimEnd . lines . Box.render
928interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
926interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
929interpretMultipleErrorsAndWarnings (err, ws) = do
927interpretMultipleErrorsAndWarnings (err, ws) = do
931− either throwError return $ err
929+ either throwError return err
934-- Rethrow an error with a more detailed error message in the case of failure
932-- Rethrow an error with a more detailed error message in the case of failure
@@ -952,8 +950,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple
952warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
950warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
954withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
952withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
955−withPosition _ (PositionedError pos err) = withPosition pos err
953+withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se
956−withPosition pos err = PositionedError pos err
959-- Collect errors in in parallel
956-- Collect errors in in parallel