@@ -15,7 +15,7 @@ import Data.Char (isSpace)
15import Data.Either (lefts, rights)
15import Data.Either (lefts, rights)
16import Data.Foldable (fold)
16import Data.Foldable (fold)
17import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
17import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
18−import Data.Maybe (maybeToList)
18+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
19import Data.Ord (comparing)
19import Data.Ord (comparing)
20import qualified Data.Map as M
20import qualified Data.Map as M
@@ -26,9 +26,12 @@ import Language.PureScript.Names
26import Language.PureScript.Pretty
26import Language.PureScript.Pretty
27import Language.PureScript.Traversals
27import Language.PureScript.Traversals
28import Language.PureScript.Types
28import Language.PureScript.Types
29+import Language.PureScript.Pretty.Common (endWith)
29import qualified Language.PureScript.Bundle as Bundle
30import qualified Language.PureScript.Bundle as Bundle
30import qualified Language.PureScript.Constants as C
31import qualified Language.PureScript.Constants as C
33+import qualified System.Console.ANSI as ANSI
32import qualified Text.Parsec as P
35import qualified Text.Parsec as P
33import qualified Text.Parsec.Error as PE
36import qualified Text.Parsec.Error as PE
34import qualified Text.PrettyPrint.Boxes as Box
37import qualified Text.PrettyPrint.Boxes as Box
@@ -62,17 +65,9 @@ data SimpleErrorMessage
62 | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
65 | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
63 | ScopeConflict Name [ModuleName]
66 | ScopeConflict Name [ModuleName]
64 | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
67 | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
65− | ConflictingTypeDecls (ProperName 'TypeName)
68+ | DeclConflict Name Name
66− | ConflictingCtorDecls (ProperName 'ConstructorName)
69+ | ExportConflict (Qualified Name) (Qualified Name)
67− | TypeConflictsWithClass (ProperName 'TypeName)
68− | CtorConflictsWithClass (ProperName 'ConstructorName)
69− | ClassConflictsWithType (ProperName 'ClassName)
70− | ClassConflictsWithCtor (ProperName 'ClassName)
71 | DuplicateModuleName ModuleName
70 | DuplicateModuleName ModuleName
72− | DuplicateClassExport (ProperName 'ClassName)
73− | DuplicateValueExport Ident
74− | DuplicateValueOpExport (OpName 'ValueOpName)
75− | DuplicateTypeOpExport (OpName 'TypeOpName)
76 | DuplicateTypeArgument String
71 | DuplicateTypeArgument String
77 | InvalidDoBind
72 | InvalidDoBind
78 | InvalidDoLet
73 | InvalidDoLet
@@ -231,17 +226,9 @@ errorCode em = case unwrapErrorMessage em of
231 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
226 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
232 ScopeConflict{} -> "ScopeConflict"
227 ScopeConflict{} -> "ScopeConflict"
233 ScopeShadowing{} -> "ScopeShadowing"
228 ScopeShadowing{} -> "ScopeShadowing"
234− ConflictingTypeDecls{} -> "ConflictingTypeDecls"
229+ DeclConflict{} -> "DeclConflict"
235− ConflictingCtorDecls{} -> "ConflictingCtorDecls"
230+ ExportConflict{} -> "ExportConflict"
236− TypeConflictsWithClass{} -> "TypeConflictsWithClass"
237− CtorConflictsWithClass{} -> "CtorConflictsWithClass"
238− ClassConflictsWithType{} -> "ClassConflictsWithType"
239− ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
240 DuplicateModuleName{} -> "DuplicateModuleName"
231 DuplicateModuleName{} -> "DuplicateModuleName"
241− DuplicateClassExport{} -> "DuplicateClassExport"
242− DuplicateValueExport{} -> "DuplicateValueExport"
243− DuplicateValueOpExport{} -> "DuplicateValueOpExport"
244− DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"
245 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
232 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
246 InvalidDoBind -> "InvalidDoBind"
233 InvalidDoBind -> "InvalidDoBind"
247 InvalidDoLet -> "InvalidDoLet"
234 InvalidDoLet -> "InvalidDoLet"
@@ -435,7 +422,7 @@ errorSuggestion err = case err of
436 importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
423 importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
437 importSuggestion mn refs qual =
424 importSuggestion mn refs qual =
438− "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual
425+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual
440 qstr :: Maybe ModuleName -> String
427 qstr :: Maybe ModuleName -> String
441 qstr (Just mn) = " as " ++ runModuleName mn
428 qstr (Just mn) = " as " ++ runModuleName mn
@@ -457,15 +444,65 @@ showSuggestion suggestion = case errorSuggestion suggestion of
457 Just (ErrorSuggestion x) -> x
444 Just (ErrorSuggestion x) -> x
447+ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String
448+ansiColor (intesity, color) =
449+ ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intesity color]
451+ansiColorReset :: String
453+ ANSI.setSGRCode [ANSI.Reset]
455+colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String
456+colorCode codeColor code = case codeColor of
458+ Just cc -> concat [ansiColor cc, code, ansiColorReset]
460+colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box
461+colorCodeBox codeColor b = case codeColor of
464+ | Box.rows b == 1 ->
465+ Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset
467+ | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards
468+ [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc
470+ , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset
474+-- | Default color intesity and color for code
475+defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color)
476+defaultCodeColor = (ANSI.Dull, ANSI.Yellow)
478+-- | `prettyPrintSingleError` Options
479+data PPEOptions = PPEOptions
480+ { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not
481+ , ppeFull :: Bool -- ^ Should write a full error message?
482+ , ppeLevel :: Level -- ^ Should this report an error or a warning?
483+ , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page?
486+-- | Default options for PPEOptions
487+defaultPPEOptions :: PPEOptions
488+defaultPPEOptions = PPEOptions
489+ { ppeCodeColor = Just defaultCodeColor
492+ , ppeShowWiki = True
461-- Pretty print a single error, simplifying if necessary
497-- Pretty print a single error, simplifying if necessary
463−prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box
499+prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
464−prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do
500+prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do
465 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
501 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
466 um <- get
502 um <- get
467 return (prettyPrintErrorMessage um em)
503 return (prettyPrintErrorMessage um em)
505+ (markCode, markCodeBox) = (colorCode &&& colorCodeBox) codeColor
470 -- Pretty print an ErrorMessage
507 -- Pretty print an ErrorMessage
471 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
508 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
@@ -474,9 +511,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
474 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
511 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
476 maybe [] (return . Box.moveDown 1) typeInformation ++
513 maybe [] (return . Box.moveDown 1) typeInformation ++
514+ [ Box.moveDown 1 $ paras
477− [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "
515+ [ line $ "See " ++ wikiUri e ++ " for more information, "
478− , line $ "or to contribute content related to this " ++ levelText ++ "."
516+ , line $ "or to contribute content related to this " ++ levelText ++ "."
480 | showWiki
518 | showWiki
@@ -491,11 +529,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
491 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box
529 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box
492 skolemInfo (name, s, ss) =
530 skolemInfo (name, s, ss) =
494− line (name ++ show s ++ " is a rigid type variable")
532+ line (markCode (name ++ show s) ++ " is a rigid type variable")
495 : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss
533 : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss
497 unknownInfo :: Int -> Box.Box
535 unknownInfo :: Int -> Box.Box
498− unknownInfo u = line $ "t" ++ show u ++ " is an unknown type"
536+ unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type"
500 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
538 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
501 renderSimpleErrorMessage (CannotGetFileInfo path) =
539 renderSimpleErrorMessage (CannotGetFileInfo path) =
@@ -520,29 +558,29 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
520 , prettyPrintParseError err
558 , prettyPrintParseError err
522 renderSimpleErrorMessage (MissingFFIModule mn) =
560 renderSimpleErrorMessage (MissingFFIModule mn) =
523− line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing."
561+ line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing."
524 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
562 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
525− paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": "
563+ paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": "
526 , indent . line $ path
564 , indent . line $ path
527− , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."
565+ , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary."
529 renderSimpleErrorMessage (MissingFFIImplementations mn idents) =
567 renderSimpleErrorMessage (MissingFFIImplementations mn idents) =
530− paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": "
568+ paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": "
531 , indent . paras $ map (line . runIdent) idents
569 , indent . paras $ map (line . runIdent) idents
533 renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =
571 renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =
534− paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "
572+ paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: "
535 , indent . paras $ map (line . runIdent) idents
573 , indent . paras $ map (line . runIdent) idents
537 renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =
575 renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =
538− paras [ line $ "In the FFI module for " ++ runModuleName mn ++ ":"
576+ paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":"
539 , indent . paras $
577 , indent . paras $
540− [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript."
578+ [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript."
541 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."
579 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."
544 renderSimpleErrorMessage (MultipleFFIModules mn paths) =
582 renderSimpleErrorMessage (MultipleFFIModules mn paths) =
545− paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "
583+ paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": "
546 , indent . paras $ map line paths
584 , indent . paras $ map line paths
548 renderSimpleErrorMessage InvalidDoBind =
586 renderSimpleErrorMessage InvalidDoBind =
@@ -553,94 +591,78 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
553 line "The same name was used more than once in a let binding."
591 line "The same name was used more than once in a let binding."
554 renderSimpleErrorMessage (InfiniteType ty) =
592 renderSimpleErrorMessage (InfiniteType ty) =
555 paras [ line "An infinite type was inferred for an expression: "
593 paras [ line "An infinite type was inferred for an expression: "
556− , indent $ typeAsBox ty
594+ , markCodeBox $ indent $ typeAsBox ty
558 renderSimpleErrorMessage (InfiniteKind ki) =
596 renderSimpleErrorMessage (InfiniteKind ki) =
559 paras [ line "An infinite kind was inferred for a type: "
597 paras [ line "An infinite kind was inferred for a type: "
560− , indent $ line $ prettyPrintKind ki
598+ , indent $ line $ markCode $ prettyPrintKind ki
562 renderSimpleErrorMessage (MultipleValueOpFixities op) =
600 renderSimpleErrorMessage (MultipleValueOpFixities op) =
563− line $ "There are multiple fixity/precedence declarations for operator " ++ showOp op
601+ line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op)
564 renderSimpleErrorMessage (MultipleTypeOpFixities op) =
602 renderSimpleErrorMessage (MultipleTypeOpFixities op) =
565− line $ "There are multiple fixity/precedence declarations for type operator " ++ showOp op
603+ line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)
566 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
604 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
567− line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition."
605+ line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."
568 renderSimpleErrorMessage (RedefinedModule name filenames) =
606 renderSimpleErrorMessage (RedefinedModule name filenames) =
569− paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:")
607+ paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:")
570 , indent . paras $ map (line . displaySourceSpan) filenames
608 , indent . paras $ map (line . displaySourceSpan) filenames
572 renderSimpleErrorMessage (RedefinedIdent name) =
610 renderSimpleErrorMessage (RedefinedIdent name) =
573− line $ "The value " ++ showIdent name ++ " has been defined multiple times"
611+ line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"
574 renderSimpleErrorMessage (UnknownName name) =
612 renderSimpleErrorMessage (UnknownName name) =
575 line $ "Unknown " ++ printName name
613 line $ "Unknown " ++ printName name
576 renderSimpleErrorMessage (UnknownImport mn name) =
614 renderSimpleErrorMessage (UnknownImport mn name) =
577− paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn
615+ paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn)
578 , line "It either does not exist or the module does not export it."
616 , line "It either does not exist or the module does not export it."
580 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
618 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
581− line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
619+ line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon)
582 renderSimpleErrorMessage (UnknownExport name) =
620 renderSimpleErrorMessage (UnknownExport name) =
583 line $ "Cannot export unknown " ++ printName (Qualified Nothing name)
621 line $ "Cannot export unknown " ++ printName (Qualified Nothing name)
584 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
622 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
585− line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."
623+ line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared."
586 renderSimpleErrorMessage (ScopeConflict nm ms) =
624 renderSimpleErrorMessage (ScopeConflict nm ms) =
587 paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:"
625 paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:"
588− , indent $ paras $ map (line . runModuleName) ms
626+ , indent $ paras $ map (line . markCode . runModuleName) ms
590 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =
628 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =
591 paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:"
629 paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:"
592− , indent $ paras $ map (line . ("import " ++) . runModuleName) ms
630+ , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms
593 , line $ "These will be ignored and the " ++ case exmn of
631 , line $ "These will be ignored and the " ++ case exmn of
594− Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used."
632+ Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."
595 Nothing -> "local declaration will be used."
633 Nothing -> "local declaration will be used."
597− renderSimpleErrorMessage (ConflictingTypeDecls nm) =
635+ renderSimpleErrorMessage (DeclConflict new existing) =
598− line $ "Conflicting type declarations for " ++ runProperName nm
636+ line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."
599− renderSimpleErrorMessage (ConflictingCtorDecls nm) =
600− line $ "Conflicting data constructor declarations for " ++ runProperName nm
601− renderSimpleErrorMessage (TypeConflictsWithClass nm) =
602− line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."
603− renderSimpleErrorMessage (CtorConflictsWithClass nm) =
604− line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."
605− renderSimpleErrorMessage (ClassConflictsWithType nm) =
637+ renderSimpleErrorMessage (ExportConflict new existing) =
606− line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name."
638+ line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing
607− renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
608− line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name."
609 renderSimpleErrorMessage (DuplicateModuleName mn) =
639 renderSimpleErrorMessage (DuplicateModuleName mn) =
610− line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
640+ line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."
611− renderSimpleErrorMessage (DuplicateClassExport nm) =
612− line $ "Duplicate export declaration for type class " ++ runProperName nm
613− renderSimpleErrorMessage (DuplicateValueExport nm) =
614− line $ "Duplicate export declaration for value " ++ showIdent nm
615− renderSimpleErrorMessage (DuplicateValueOpExport op) =
616− line $ "Duplicate export declaration for operator " ++ showOp op
617− renderSimpleErrorMessage (DuplicateTypeOpExport op) =
618− line $ "Duplicate export declaration for type operator " ++ showOp op
619 renderSimpleErrorMessage (CycleInDeclaration nm) =
641 renderSimpleErrorMessage (CycleInDeclaration nm) =
620− line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."
642+ line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."
621 renderSimpleErrorMessage (CycleInModules mns) =
643 renderSimpleErrorMessage (CycleInModules mns) =
622 paras [ line "There is a cycle in module dependencies in these modules: "
644 paras [ line "There is a cycle in module dependencies in these modules: "
623− , indent $ paras (map (line . runModuleName) mns)
645+ , indent $ paras (map (line . markCode . runModuleName) mns)
625 renderSimpleErrorMessage (CycleInTypeSynonym name) =
647 renderSimpleErrorMessage (CycleInTypeSynonym name) =
626 paras [ line $ case name of
648 paras [ line $ case name of
627− Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn
649+ Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn)
628 Nothing -> "A cycle appears in a set of type synonym definitions."
650 Nothing -> "A cycle appears in a set of type synonym definitions."
629 , line "Cycles are disallowed because they can lead to loops in the type checker."
651 , line "Cycles are disallowed because they can lead to loops in the type checker."
630 , line "Consider using a 'newtype' instead."
652 , line "Consider using a 'newtype' instead."
632 renderSimpleErrorMessage (NameIsUndefined ident) =
654 renderSimpleErrorMessage (NameIsUndefined ident) =
633− line $ "Value " ++ showIdent ident ++ " is undefined."
655+ line $ "Value " ++ markCode (showIdent ident) ++ " is undefined."
634 renderSimpleErrorMessage (UndefinedTypeVariable name) =
656 renderSimpleErrorMessage (UndefinedTypeVariable name) =
635− line $ "Type variable " ++ runProperName name ++ " is undefined."
657+ line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined."
636 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
658 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
637− paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied."
659+ paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied."
638 , line "Type synonyms must be applied to all of their type arguments."
660 , line "Type synonyms must be applied to all of their type arguments."
640 renderSimpleErrorMessage (EscapedSkolem binding) =
662 renderSimpleErrorMessage (EscapedSkolem binding) =
641 paras $ [ line "A type variable has escaped its scope." ]
663 paras $ [ line "A type variable has escaped its scope." ]
642 <> foldMap (\expr -> [ line "Relevant expression: "
664 <> foldMap (\expr -> [ line "Relevant expression: "
643− , indent $ prettyPrintValue valueDepth expr
665+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr
644 ]) binding
666 ]) binding
645 renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
667 renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
646 = let (sorted1, sorted2) = sortRows u1 u2
668 = let (sorted1, sorted2) = sortRows u1 u2
@@ -662,34 +684,39 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
662 , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)
684 , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)
664 in paras [ line "Could not match type"
686 in paras [ line "Could not match type"
665− , indent $ typeAsBox sorted1
687+ , markCodeBox $ indent $ typeAsBox sorted1
666 , line "with type"
688 , line "with type"
667− , indent $ typeAsBox sorted2
689+ , markCodeBox $ indent $ typeAsBox sorted2
670 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
692 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
671 paras [ line "Could not match kind"
693 paras [ line "Could not match kind"
672− , indent $ line $ prettyPrintKind k1
694+ , indent $ line $ markCode $ prettyPrintKind k1
673 , line "with kind"
695 , line "with kind"
674− , indent $ line $ prettyPrintKind k2
696+ , indent $ line $ markCode $ prettyPrintKind k2
676 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
698 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
677 paras [ line "Could not match constrained type"
699 paras [ line "Could not match constrained type"
678− , indent $ typeAsBox t1
700+ , markCodeBox $ indent $ typeAsBox t1
679 , line "with type"
701 , line "with type"
680− , indent $ typeAsBox t2
702+ , markCodeBox $ indent $ typeAsBox t2
682 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
704 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
683 paras [ line "Overlapping type class instances found for"
705 paras [ line "Overlapping type class instances found for"
706+ , markCodeBox $ indent $ Box.hsep 1 Box.left
684− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
707+ [ line (showQualified runProperName nm)
685− , Box.vcat Box.left (map typeAtomAsBox ts)
708+ , Box.vcat Box.left (map typeAtomAsBox ts)
687 , line "The following instances were found:"
710 , line "The following instances were found:"
688 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
711 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
689 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."
712 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."
690 , line "They may be disallowed completely in a future version of the compiler."
713 , line "They may be disallowed completely in a future version of the compiler."
692 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
715 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
716+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =
717+ paras [ line "A custom type error occurred while solving type class constraints:"
718+ , indent . paras . map line . lines $ message
693 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
720 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
695 (Just (PartialConstraintData bs b)))) =
722 (Just (PartialConstraintData bs b)))) =
@@ -697,15 +724,16 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
697 , line "The following additional cases are required to cover all inputs:\n"
724 , line "The following additional cases are required to cover all inputs:\n"
698 , indent $ paras $
725 , indent $ paras $
699 Box.hsep 1 Box.left
726 Box.hsep 1 Box.left
700− (map (paras . map line) (transpose bs))
727+ (map (paras . map (line . markCode)) (transpose bs))
701 : [line "..." | not b]
728 : [line "..." | not b]
702 , line "Alternatively, add a Partial constraint to the type of the enclosing value."
729 , line "Alternatively, add a Partial constraint to the type of the enclosing value."
704 renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) =
731 renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) =
705 paras [ line "No type class instance was found for"
732 paras [ line "No type class instance was found for"
733+ , markCodeBox $ indent $ Box.hsep 1 Box.left
706− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
734+ [ line (showQualified runProperName nm)
707− , Box.vcat Box.left (map typeAtomAsBox ts)
735+ , Box.vcat Box.left (map typeAtomAsBox ts)
709 , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."
737 , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."
710 | any containsUnknowns ts
738 | any containsUnknowns ts
@@ -718,125 +746,128 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
718 go _ = False
746 go _ = False
719 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
747 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
720 paras [ line "Type class instance for"
748 paras [ line "Type class instance for"
749+ , markCodeBox $ indent $ Box.hsep 1 Box.left
721− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
750+ [ line (showQualified runProperName nm)
722− , Box.vcat Box.left (map typeAtomAsBox ts)
751+ , Box.vcat Box.left (map typeAtomAsBox ts)
724 , line "is possibly infinite."
753 , line "is possibly infinite."
726 renderSimpleErrorMessage (CannotDerive nm ts) =
755 renderSimpleErrorMessage (CannotDerive nm ts) =
727 paras [ line "Cannot derive a type class instance for"
756 paras [ line "Cannot derive a type class instance for"
757+ , markCodeBox $ indent $ Box.hsep 1 Box.left
728− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
758+ [ line (showQualified runProperName nm)
729− , Box.vcat Box.left (map typeAtomAsBox ts)
759+ , Box.vcat Box.left (map typeAtomAsBox ts)
732 renderSimpleErrorMessage (CannotFindDerivingType nm) =
762 renderSimpleErrorMessage (CannotFindDerivingType nm) =
733− line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
763+ line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
734 renderSimpleErrorMessage (DuplicateLabel l expr) =
764 renderSimpleErrorMessage (DuplicateLabel l expr) =
735− paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ]
765+ paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ]
736 <> foldMap (\expr' -> [ line "Relevant expression: "
766 <> foldMap (\expr' -> [ line "Relevant expression: "
737− , indent $ prettyPrintValue valueDepth expr'
767+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr'
739 renderSimpleErrorMessage (DuplicateTypeArgument name) =
769 renderSimpleErrorMessage (DuplicateTypeArgument name) =
740− line $ "Type argument " ++ show name ++ " appears more than once."
770+ line $ "Type argument " ++ markCode name ++ " appears more than once."
741 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
771 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
742− line $ "Multiple value declarations exist for " ++ showIdent nm ++ "."
772+ line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "."
743 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
773 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
744− line $ "Argument list lengths differ in declaration " ++ showIdent ident
774+ line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident)
745 renderSimpleErrorMessage (OverlappingArgNames ident) =
775 renderSimpleErrorMessage (OverlappingArgNames ident) =
746 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident
776 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident
747 renderSimpleErrorMessage (MissingClassMember ident) =
777 renderSimpleErrorMessage (MissingClassMember ident) =
748− line $ "Type class member " ++ showIdent ident ++ " has not been implemented."
778+ line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented."
749 renderSimpleErrorMessage (ExtraneousClassMember ident className) =
779 renderSimpleErrorMessage (ExtraneousClassMember ident className) =
750− line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className
780+ line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className)
751 renderSimpleErrorMessage (ExpectedType ty kind) =
781 renderSimpleErrorMessage (ExpectedType ty kind) =
752− paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
782+ paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "."
753 , line "The error arises from the type"
783 , line "The error arises from the type"
754− , indent $ typeAsBox ty
784+ , markCodeBox $ indent $ typeAsBox ty
755 , line "having the kind"
785 , line "having the kind"
756− , indent $ line $ prettyPrintKind kind
786+ , indent $ line $ markCode $ prettyPrintKind kind
757 , line "instead."
787 , line "instead."
759 renderSimpleErrorMessage (IncorrectConstructorArity nm) =
789 renderSimpleErrorMessage (IncorrectConstructorArity nm) =
760− line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression."
790+ line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression."
761 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
791 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
762 paras [ line "Expression"
792 paras [ line "Expression"
763− , indent $ prettyPrintValue valueDepth expr
793+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr
764 , line "does not have type"
794 , line "does not have type"
765− , indent $ typeAsBox ty
795+ , markCodeBox $ indent $ typeAsBox ty
767 renderSimpleErrorMessage (PropertyIsMissing prop) =
797 renderSimpleErrorMessage (PropertyIsMissing prop) =
768− line $ "Type of expression lacks required label " ++ show prop ++ "."
798+ line $ "Type of expression lacks required label " ++ markCode prop ++ "."
769 renderSimpleErrorMessage (AdditionalProperty prop) =
799 renderSimpleErrorMessage (AdditionalProperty prop) =
770− line $ "Type of expression contains additional label " ++ show prop ++ "."
800+ line $ "Type of expression contains additional label " ++ markCode prop ++ "."
771 renderSimpleErrorMessage (CannotApplyFunction fn arg) =
801 renderSimpleErrorMessage (CannotApplyFunction fn arg) =
772 paras [ line "A function of type"
802 paras [ line "A function of type"
773− , indent $ typeAsBox fn
803+ , markCodeBox $ indent $ typeAsBox fn
774 , line "can not be applied to the argument"
804 , line "can not be applied to the argument"
775− , indent $ prettyPrintValue valueDepth arg
805+ , markCodeBox $ indent $ prettyPrintValue valueDepth arg
777 renderSimpleErrorMessage TypeSynonymInstance =
807 renderSimpleErrorMessage TypeSynonymInstance =
778 line "Type class instances for type synonyms are disallowed."
808 line "Type class instances for type synonyms are disallowed."
779 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
809 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
780− paras [ line $ "Type class instance " ++ showIdent nm ++ " for "
810+ paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for "
811+ , markCodeBox $ indent $ Box.hsep 1 Box.left
781− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)
812+ [ line (showQualified runProperName cnm)
782− , Box.vcat Box.left (map typeAtomAsBox ts)
813+ , Box.vcat Box.left (map typeAtomAsBox ts)
784 , line "is an orphan instance."
815 , line "is an orphan instance."
785 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
816 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
786 , line "Consider moving the instance, if possible, or using a newtype wrapper."
817 , line "Consider moving the instance, if possible, or using a newtype wrapper."
788 renderSimpleErrorMessage (InvalidNewtype name) =
819 renderSimpleErrorMessage (InvalidNewtype name) =
789− paras [ line $ "Newtype " ++ runProperName name ++ " is invalid."
820+ paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid."
790 , line "Newtypes must define a single constructor with a single argument."
821 , line "Newtypes must define a single constructor with a single argument."
792 renderSimpleErrorMessage (InvalidInstanceHead ty) =
823 renderSimpleErrorMessage (InvalidInstanceHead ty) =
793 paras [ line "Type class instance head is invalid due to use of type"
824 paras [ line "Type class instance head is invalid due to use of type"
794− , indent $ typeAsBox ty
825+ , markCodeBox $ indent $ typeAsBox ty
795 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."
826 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."
797 renderSimpleErrorMessage (TransitiveExportError x ys) =
828 renderSimpleErrorMessage (TransitiveExportError x ys) =
798− paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
829+ paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: "
799− , indent $ paras $ map (line . prettyPrintExport) ys
830+ , indent $ paras $ map (line . markCode . prettyPrintExport) ys
801 renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =
832 renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =
802− paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: "
833+ paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: "
803− , indent $ line $ runProperName ctor
834+ , indent $ line $ markCode $ runProperName ctor
805 renderSimpleErrorMessage (ShadowedName nm) =
836 renderSimpleErrorMessage (ShadowedName nm) =
806− line $ "Name '" ++ showIdent nm ++ "' was shadowed."
837+ line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed."
807 renderSimpleErrorMessage (ShadowedTypeVar tv) =
838 renderSimpleErrorMessage (ShadowedTypeVar tv) =
808− line $ "Type variable '" ++ tv ++ "' was shadowed."
839+ line $ "Type variable " ++ markCode tv ++ " was shadowed."
809 renderSimpleErrorMessage (UnusedTypeVar tv) =
840 renderSimpleErrorMessage (UnusedTypeVar tv) =
810− line $ "Type variable '" ++ tv ++ "' was declared but not used."
841+ line $ "Type variable " ++ markCode tv ++ " was declared but not used."
811 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
842 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
812− line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."
843+ line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors."
813 renderSimpleErrorMessage (ImportHidingModule name) =
844 renderSimpleErrorMessage (ImportHidingModule name) =
814− paras [ line "'hiding' imports cannot be used to hide modules."
845+ paras [ line "hiding imports cannot be used to hide modules."
815− , line $ "An attempt was made to hide the import of " ++ runModuleName name
846+ , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)
817 renderSimpleErrorMessage (WildcardInferredType ty) =
848 renderSimpleErrorMessage (WildcardInferredType ty) =
818 paras [ line "Wildcard type definition has the inferred type "
849 paras [ line "Wildcard type definition has the inferred type "
819− , indent $ typeAsBox ty
850+ , markCodeBox $ indent $ typeAsBox ty
821 renderSimpleErrorMessage (HoleInferredType name ty env) =
852 renderSimpleErrorMessage (HoleInferredType name ty env) =
822− paras $ [ line $ "Hole '" ++ name ++ "' has the inferred type "
853+ paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "
823− , indent $ typeAsBox ty
854+ , markCodeBox $ indent $ typeAsBox ty
824 ] ++ if null env then [] else envInfo
855 ] ++ if null env then [] else envInfo
826 envInfo :: [Box.Box]
857 envInfo :: [Box.Box]
827 envInfo = [ line "in the following context:"
858 envInfo = [ line "in the following context:"
828 , indent $ paras
859 , indent $ paras
829 [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
860 [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
830− , typeAsBox ty'
861+ , markCodeBox $ typeAsBox ty'
832 | (ident, ty') <- take 5 env
863 | (ident, ty') <- take 5 env
835 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =
866 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =
836− paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."
867+ paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."
837 , line "It is good practice to provide type declarations as a form of documentation."
868 , line "It is good practice to provide type declarations as a form of documentation."
838− , line $ "The inferred type of " ++ showIdent ident ++ " was:"
869+ , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"
839− , indent $ typeAsBox ty
870+ , markCodeBox $ indent $ typeAsBox ty
841 renderSimpleErrorMessage (OverlappingPattern bs b) =
872 renderSimpleErrorMessage (OverlappingPattern bs b) =
842 paras $ [ line "A case expression contains unreachable cases:\n"
873 paras $ [ line "A case expression contains unreachable cases:\n"
@@ -848,26 +879,26 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
848 , line "You may want to decompose your data types into smaller types."
879 , line "You may want to decompose your data types into smaller types."
850 renderSimpleErrorMessage (UnusedImport name) =
881 renderSimpleErrorMessage (UnusedImport name) =
851− line $ "The import of module " ++ runModuleName name ++ " is redundant"
882+ line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant"
853 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
884 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
854− paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"
885+ paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"
855 , indent $ paras $ map line names
886 , indent $ paras $ map line names
856 , line "It could be replaced with:"
887 , line "It could be replaced with:"
857− , indent $ line $ showSuggestion msg ]
888+ , indent $ line $ markCode $ showSuggestion msg ]
859 renderSimpleErrorMessage (UnusedDctorImport name) =
890 renderSimpleErrorMessage (UnusedDctorImport name) =
860− line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"
891+ line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used"
862 renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =
893 renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =
863− paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"
894+ paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:"
864− , indent $ paras $ map (line .runProperName) names ]
895+ , indent $ paras $ map (line . markCode . runProperName) names ]
866 renderSimpleErrorMessage (DuplicateSelectiveImport name) =
897 renderSimpleErrorMessage (DuplicateSelectiveImport name) =
867− line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists"
898+ line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"
869 renderSimpleErrorMessage (DuplicateImport name imp qual) =
900 renderSimpleErrorMessage (DuplicateImport name imp qual) =
870− line $ "Duplicate import of " ++ prettyPrintImport name imp qual
901+ line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual)
872 renderSimpleErrorMessage (DuplicateImportRef name) =
903 renderSimpleErrorMessage (DuplicateImportRef name) =
873 line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)
904 line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)
@@ -876,23 +907,23 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
876 line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)
907 line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)
878 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =
909 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =
879− paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."
910+ paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend."
880− , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]
911+ , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ]
882 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =
913 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =
883− paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."
914+ paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports."
884− , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"
915+ , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:"
885− , indent $ line $ showSuggestion msg
916+ , indent $ line $ markCode $ showSuggestion msg
888 renderSimpleErrorMessage msg@(ImplicitImport mn _) =
919 renderSimpleErrorMessage msg@(ImplicitImport mn _) =
889− paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "
920+ paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: "
890− , indent $ line $ showSuggestion msg
921+ , indent $ line $ markCode $ showSuggestion msg
893 renderSimpleErrorMessage msg@(HidingImport mn _) =
924 renderSimpleErrorMessage msg@(HidingImport mn _) =
894− paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "
925+ paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: "
895− , indent $ line $ showSuggestion msg
926+ , indent $ line $ markCode $ showSuggestion msg
898 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
929 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
@@ -905,7 +936,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
905 line "An anonymous function argument appears in an invalid context."
936 line "An anonymous function argument appears in an invalid context."
907 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
938 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
908− paras [ line $ "Operator " ++ showQualified showOp op ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "."
939+ paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "."
909 , line "Only aliases for data constructors may be used in patterns."
940 , line "Only aliases for data constructors may be used in patterns."
@@ -913,9 +944,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
913 line "The require-path option is deprecated and will be removed in PureScript 0.9."
944 line "The require-path option is deprecated and will be removed in PureScript 0.9."
915 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
946 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
916− paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "."
947+ paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "."
917− , line $ "The inferred type of " ++ showIdent ident ++ " was:"
948+ , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"
918− , indent $ typeAsBox ty
949+ , markCodeBox $ indent $ typeAsBox ty
919 , line "Try adding a type signature."
950 , line "Try adding a type signature."
@@ -923,42 +954,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
923 renderHint (ErrorUnifyingTypes t1 t2) detail =
954 renderHint (ErrorUnifyingTypes t1 t2) detail =
924 paras [ detail
955 paras [ detail
925 , Box.hsep 1 Box.top [ line "while trying to match type"
956 , Box.hsep 1 Box.top [ line "while trying to match type"
926− , typeAsBox t1
957+ , markCodeBox $ typeAsBox t1
928 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"
959 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"
929− , typeAsBox t2
960+ , markCodeBox $ typeAsBox t2
932 renderHint (ErrorInExpression expr) detail =
963 renderHint (ErrorInExpression expr) detail =
933 paras [ detail
964 paras [ detail
934 , Box.hsep 1 Box.top [ Box.text "in the expression"
965 , Box.hsep 1 Box.top [ Box.text "in the expression"
935− , prettyPrintValue valueDepth expr
966+ , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr
938 renderHint (ErrorInModule mn) detail =
969 renderHint (ErrorInModule mn) detail =
939− paras [ line $ "in module " ++ runModuleName mn
970+ paras [ line $ "in module " ++ markCode (runModuleName mn)
942 renderHint (ErrorInSubsumption t1 t2) detail =
973 renderHint (ErrorInSubsumption t1 t2) detail =
943 paras [ detail
974 paras [ detail
944 , Box.hsep 1 Box.top [ line "while checking that type"
975 , Box.hsep 1 Box.top [ line "while checking that type"
945− , typeAsBox t1
976+ , markCodeBox $ typeAsBox t1
947 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"
978 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"
948− , typeAsBox t2
979+ , markCodeBox $ typeAsBox t2
951 renderHint (ErrorInInstance nm ts) detail =
982 renderHint (ErrorInInstance nm ts) detail =
952 paras [ detail
983 paras [ detail
953− , Box.hsep 1 Box.top [ line "in type class instance"
984+ , line "in type class instance"
985+ , markCodeBox $ indent $ Box.hsep 1 Box.top
954− , line (showQualified runProperName nm)
986+ [ line $ showQualified runProperName nm
955− , Box.vcat Box.left (map typeAtomAsBox ts)
987+ , Box.vcat Box.left (map typeAtomAsBox ts)
958 renderHint (ErrorCheckingKind ty) detail =
990 renderHint (ErrorCheckingKind ty) detail =
959 paras [ detail
991 paras [ detail
960 , Box.hsep 1 Box.top [ line "while checking the kind of"
992 , Box.hsep 1 Box.top [ line "while checking the kind of"
961− , typeAsBox ty
993+ , markCodeBox $ typeAsBox ty
964 renderHint ErrorCheckingGuard detail =
996 renderHint ErrorCheckingGuard detail =
@@ -968,43 +1000,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
968 renderHint (ErrorInferringType expr) detail =
1000 renderHint (ErrorInferringType expr) detail =
969 paras [ detail
1001 paras [ detail
970 , Box.hsep 1 Box.top [ line "while inferring the type of"
1002 , Box.hsep 1 Box.top [ line "while inferring the type of"
971− , prettyPrintValue valueDepth expr
1003+ , markCodeBox $ prettyPrintValue valueDepth expr
974 renderHint (ErrorCheckingType expr ty) detail =
1006 renderHint (ErrorCheckingType expr ty) detail =
975 paras [ detail
1007 paras [ detail
976 , Box.hsep 1 Box.top [ line "while checking that expression"
1008 , Box.hsep 1 Box.top [ line "while checking that expression"
977− , prettyPrintValue valueDepth expr
1009+ , markCodeBox $ prettyPrintValue valueDepth expr
979 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"
1011 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"
980− , typeAsBox ty
1012+ , markCodeBox $ typeAsBox ty
983 renderHint (ErrorCheckingAccessor expr prop) detail =
1015 renderHint (ErrorCheckingAccessor expr prop) detail =
984 paras [ detail
1016 paras [ detail
985 , Box.hsep 1 Box.top [ line "while checking type of property accessor"
1017 , Box.hsep 1 Box.top [ line "while checking type of property accessor"
986− , prettyPrintValue valueDepth (Accessor prop expr)
1018+ , markCodeBox $ prettyPrintValue valueDepth (Accessor prop expr)
989 renderHint (ErrorInApplication f t a) detail =
1021 renderHint (ErrorInApplication f t a) detail =
990 paras [ detail
1022 paras [ detail
991 , Box.hsep 1 Box.top [ line "while applying a function"
1023 , Box.hsep 1 Box.top [ line "while applying a function"
992− , prettyPrintValue valueDepth f
1024+ , markCodeBox $ prettyPrintValue valueDepth f
994 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"
1026 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"
995− , typeAsBox t
1027+ , markCodeBox $ typeAsBox t
997 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"
1029 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"
998− , prettyPrintValue valueDepth a
1030+ , markCodeBox $ prettyPrintValue valueDepth a
1001 renderHint (ErrorInDataConstructor nm) detail =
1033 renderHint (ErrorInDataConstructor nm) detail =
1002 paras [ detail
1034 paras [ detail
1003− , line $ "in data constructor " ++ runProperName nm
1035+ , line $ "in data constructor " ++ markCode (runProperName nm)
1005 renderHint (ErrorInTypeConstructor nm) detail =
1037 renderHint (ErrorInTypeConstructor nm) detail =
1006 paras [ detail
1038 paras [ detail
1007− , line $ "in type constructor " ++ runProperName nm
1039+ , line $ "in type constructor " ++ markCode (runProperName nm)
1009 renderHint (ErrorInBindingGroup nms) detail =
1041 renderHint (ErrorInBindingGroup nms) detail =
1010 paras [ detail
1042 paras [ detail
@@ -1016,19 +1048,19 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1017 renderHint (ErrorInTypeSynonym name) detail =
1049 renderHint (ErrorInTypeSynonym name) detail =
1018 paras [ detail
1050 paras [ detail
1019− , line $ "in type synonym " ++ runProperName name
1051+ , line $ "in type synonym " ++ markCode (runProperName name)
1021 renderHint (ErrorInValueDeclaration n) detail =
1053 renderHint (ErrorInValueDeclaration n) detail =
1022 paras [ detail
1054 paras [ detail
1023− , line $ "in value declaration " ++ showIdent n
1055+ , line $ "in value declaration " ++ markCode (showIdent n)
1025 renderHint (ErrorInTypeDeclaration n) detail =
1057 renderHint (ErrorInTypeDeclaration n) detail =
1026 paras [ detail
1058 paras [ detail
1027− , line $ "in type declaration for " ++ showIdent n
1059+ , line $ "in type declaration for " ++ markCode (showIdent n)
1029 renderHint (ErrorInForeignImport nm) detail =
1061 renderHint (ErrorInForeignImport nm) detail =
1030 paras [ detail
1062 paras [ detail
1031− , line $ "in foreign import " ++ showIdent nm
1063+ , line $ "in foreign import " ++ markCode (showIdent nm)
1033 renderHint (PositionedError srcSpan) detail =
1065 renderHint (PositionedError srcSpan) detail =
1034 paras [ line $ "at " ++ displaySourceSpan srcSpan
1066 paras [ line $ "at " ++ displaySourceSpan srcSpan
@@ -1036,22 +1068,34 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1038 printName :: Qualified Name -> String
1070 printName :: Qualified Name -> String
1039− printName (Qualified mn (IdentName name)) =
1071+ printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)
1040− "value " ++ showQualified showIdent (Qualified mn name)
1072+
1041− printName (Qualified mn (ValOpName op)) =
1073+ nameType :: Name -> String
1042− "operator " ++ showQualified showOp (Qualified mn op)
1074+ nameType (IdentName _) = "value"
1043− printName (Qualified mn (TyName name)) =
1075+ nameType (ValOpName _) = "operator"
1044− "type " ++ showQualified runProperName (Qualified mn name)
1076+ nameType (TyName _) = "type"
1045− printName (Qualified mn (TyOpName op)) =
1077+ nameType (TyOpName _) = "type operator"
1046− "type operator " ++ showQualified showOp (Qualified mn op)
1078+ nameType (DctorName _) = "data constructor"
1047− printName (Qualified mn (DctorName name)) =
1079+ nameType (TyClassName _) = "type class"
1048− "data constructor " ++ showQualified runProperName (Qualified mn name)
1080+ nameType (ModName _) = "module"
1049− printName (Qualified mn (TyClassName name)) =
1081+
1050− "type class " ++ showQualified runProperName (Qualified mn name)
1082+ runName :: Qualified Name -> String
1051− printName (Qualified Nothing (ModName name)) =
1083+ runName (Qualified mn (IdentName name)) =
1084+ showQualified showIdent (Qualified mn name)
1085+ runName (Qualified mn (ValOpName op)) =
1086+ showQualified showOp (Qualified mn op)
1087+ runName (Qualified mn (TyName name)) =
1088+ showQualified runProperName (Qualified mn name)
1089+ runName (Qualified mn (TyOpName op)) =
1090+ showQualified showOp (Qualified mn op)
1091+ runName (Qualified mn (DctorName name)) =
1092+ showQualified runProperName (Qualified mn name)
1093+ runName (Qualified mn (TyClassName name)) =
1094+ showQualified runProperName (Qualified mn name)
1095+ runName (Qualified Nothing (ModName name)) =
1052− "module " ++ runModuleName name
1096+ runModuleName name
1053− printName (Qualified _ ModName{}) =
1097+ runName (Qualified _ ModName{}) =
1054− internalError "qualified ModName in printName"
1098+ internalError "qualified ModName in runName"
1056 valueDepth :: Int
1100 valueDepth :: Int
1057 valueDepth | full = 1000
1101 valueDepth | full = 1000
@@ -1119,57 +1163,72 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1119-- Pretty print and export declaration
1163-- Pretty print and export declaration
1120prettyPrintExport :: DeclarationRef -> String
1164prettyPrintExport :: DeclarationRef -> String
1121prettyPrintExport (TypeRef pn _) = runProperName pn
1165prettyPrintExport (TypeRef pn _) = runProperName pn
1122−prettyPrintExport ref = prettyPrintRef ref
1166+prettyPrintExport ref =
1168+ (internalError "prettyPrintRef returned Nothing in prettyPrintExport")
1169+ (prettyPrintRef ref)
1124prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
1171prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
1125prettyPrintImport mn idt qual =
1172prettyPrintImport mn idt qual =
1126 let i = case idt of
1173 let i = case idt of
1127 Implicit -> runModuleName mn
1174 Implicit -> runModuleName mn
1128− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
1175+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"
1129− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
1176+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"
1130 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
1177 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
1132−prettyPrintRef :: DeclarationRef -> String
1179+prettyPrintRef :: DeclarationRef -> Maybe String
1133−prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
1180+prettyPrintRef (TypeRef pn Nothing) =
1181+ Just $ runProperName pn ++ "(..)"
1134−prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
1182+prettyPrintRef (TypeRef pn (Just [])) =
1183+ Just $ runProperName pn
1184+prettyPrintRef (TypeRef pn (Just dctors)) =
1135−prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1185+ Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1136−prettyPrintRef (TypeOpRef op) = "type " ++ showOp op
1186+prettyPrintRef (TypeOpRef op) =
1187+ Just $ "type " ++ showOp op
1137−prettyPrintRef (ValueRef ident) = showIdent ident
1188+prettyPrintRef (ValueRef ident) =
1189+ Just $ showIdent ident
1138−prettyPrintRef (ValueOpRef op) = showOp op
1190+prettyPrintRef (ValueOpRef op) =
1139−prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
1192+prettyPrintRef (TypeClassRef pn) =
1193+ Just $ "class " ++ runProperName pn
1140−prettyPrintRef (TypeInstanceRef ident) = showIdent ident
1194+prettyPrintRef (TypeInstanceRef ident) =
1195+ Just $ showIdent ident
1141−prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
1196+prettyPrintRef (ModuleRef name) =
1197+ Just $ "module " ++ runModuleName name
1198+prettyPrintRef (ReExportRef _ _) =
1142−prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
1200+prettyPrintRef (PositionedDeclarationRef _ _ ref) =
1145-- Pretty print multiple errors
1204-- Pretty print multiple errors
1147−prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
1206+prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String
1148−prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full
1207+prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions
1151-- Pretty print multiple warnings
1210-- Pretty print multiple warnings
1153−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
1212+prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String
1154−prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full
1213+prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions
1156-- | Pretty print warnings as a Box
1215-- | Pretty print warnings as a Box
1157−prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]
1216+prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
1158−prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning"
1217+prettyPrintMultipleWarningsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Warning }) "Warning found:" "Warning"
1160-- | Pretty print errors as a Box
1219-- | Pretty print errors as a Box
1161−prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]
1220+prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
1162−prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"
1221+prettyPrintMultipleErrorsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Error }) "Error found:" "Error"
1164−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]
1223+prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box]
1165−prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
1224+prettyPrintMultipleErrorsWith ppeOptions intro _ (MultipleErrors [e]) =
1166− let result = prettyPrintSingleError full level True e
1225+ let result = prettyPrintSingleError ppeOptions e
1167 in [ Box.vcat Box.left [ Box.text intro
1226 in [ Box.vcat Box.left [ Box.text intro
1168 , result
1227 , result
1171−prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =
1230+prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) =
1172− let result = map (prettyPrintSingleError full level True) es
1231+ let result = map (prettyPrintSingleError ppeOptions) es
1173 in concat $ zipWith withIntro [1 :: Int ..] result
1232 in concat $ zipWith withIntro [1 :: Int ..] result
1175 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
1234 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")