@@ -15,7 +15,7 @@ import Data.Char (isSpace)
1515import Data.Either (lefts, rights)
1616import Data.Foldable (fold)
1717import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
18−import Data.Maybe (maybeToList)
18+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
1919import Data.Ord (comparing)
2020import qualified Data.Map as M
2121
@@ -26,9 +26,12 @@ import Language.PureScript.Names
2626import Language.PureScript.Pretty
2727import Language.PureScript.Traversals
2828import Language.PureScript.Types
29+import Language.PureScript.Pretty.Common (endWith)
2930import qualified Language.PureScript.Bundle as Bundle
3031import qualified Language.PureScript.Constants as C
3132
33+import qualified System.Console.ANSI as ANSI
34+
3235import qualified Text.Parsec as P
3336import qualified Text.Parsec.Error as PE
3437import qualified Text.PrettyPrint.Boxes as Box
@@ -62,17 +65,9 @@ data SimpleErrorMessage
6265 | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
6366 | ScopeConflict Name [ModuleName]
6467 | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
65− | ConflictingTypeDecls (ProperName 'TypeName)
66− | ConflictingCtorDecls (ProperName 'ConstructorName)
67− | TypeConflictsWithClass (ProperName 'TypeName)
68− | CtorConflictsWithClass (ProperName 'ConstructorName)
69− | ClassConflictsWithType (ProperName 'ClassName)
70− | ClassConflictsWithCtor (ProperName 'ClassName)
68+ | DeclConflict Name Name
69+ | ExportConflict (Qualified Name) (Qualified Name)
7170 | DuplicateModuleName ModuleName
72− | DuplicateClassExport (ProperName 'ClassName)
73− | DuplicateValueExport Ident
74− | DuplicateValueOpExport (OpName 'ValueOpName)
75− | DuplicateTypeOpExport (OpName 'TypeOpName)
7671 | DuplicateTypeArgument String
7772 | InvalidDoBind
7873 | InvalidDoLet
@@ -231,17 +226,9 @@ errorCode em = case unwrapErrorMessage em of
231226 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
232227 ScopeConflict{} -> "ScopeConflict"
233228 ScopeShadowing{} -> "ScopeShadowing"
234− ConflictingTypeDecls{} -> "ConflictingTypeDecls"
235− ConflictingCtorDecls{} -> "ConflictingCtorDecls"
236− TypeConflictsWithClass{} -> "TypeConflictsWithClass"
237− CtorConflictsWithClass{} -> "CtorConflictsWithClass"
238− ClassConflictsWithType{} -> "ClassConflictsWithType"
239− ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
229+ DeclConflict{} -> "DeclConflict"
230+ ExportConflict{} -> "ExportConflict"
240231 DuplicateModuleName{} -> "DuplicateModuleName"
241− DuplicateClassExport{} -> "DuplicateClassExport"
242− DuplicateValueExport{} -> "DuplicateValueExport"
243− DuplicateValueOpExport{} -> "DuplicateValueOpExport"
244− DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"
245232 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
246233 InvalidDoBind -> "InvalidDoBind"
247234 InvalidDoLet -> "InvalidDoLet"
@@ -435,7 +422,7 @@ errorSuggestion err = case err of
435422
436423 importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
437424 importSuggestion mn refs qual =
438− "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual
425+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual
439426
440427 qstr :: Maybe ModuleName -> String
441428 qstr (Just mn) = " as " ++ runModuleName mn
@@ -457,15 +444,65 @@ showSuggestion suggestion = case errorSuggestion suggestion of
457444 Just (ErrorSuggestion x) -> x
458445 _ -> ""
459446
447+ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String
448+ansiColor (intesity, color) =
449+ ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intesity color]
450+
451+ansiColorReset :: String
452+ansiColorReset =
453+ ANSI.setSGRCode [ANSI.Reset]
454+
455+colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String
456+colorCode codeColor code = case codeColor of
457+ Nothing -> code
458+ Just cc -> concat [ansiColor cc, code, ansiColorReset]
459+
460+colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box
461+colorCodeBox codeColor b = case codeColor of
462+ Nothing -> b
463+ Just cc
464+ | Box.rows b == 1 ->
465+ Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset
466+
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
469+ , b
470+ , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset
471+ ]
472+
473+
474+-- | Default color intesity and color for code
475+defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color)
476+defaultCodeColor = (ANSI.Dull, ANSI.Yellow)
477+
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?
484+ }
485+
486+-- | Default options for PPEOptions
487+defaultPPEOptions :: PPEOptions
488+defaultPPEOptions = PPEOptions
489+ { ppeCodeColor = Just defaultCodeColor
490+ , ppeFull = False
491+ , ppeLevel = Error
492+ , ppeShowWiki = True
493+ }
494+
495+
460496-- |
461497-- Pretty print a single error, simplifying if necessary
462498--
463−prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box
464−prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do
499+prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
500+prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do
465501 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
466502 um <- get
467503 return (prettyPrintErrorMessage um em)
468504 where
505+ (markCode, markCodeBox) = (colorCode &&& colorCodeBox) codeColor
469506
470507 -- Pretty print an ErrorMessage
471508 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
@@ -474,9 +511,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
474511 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
475512 ] ++
476513 maybe [] (return . Box.moveDown 1) typeInformation ++
477− [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "
478− , line $ "or to contribute content related to this " ++ levelText ++ "."
479− ]
514+ [ Box.moveDown 1 $ paras
515+ [ line $ "See " ++ wikiUri e ++ " for more information, "
516+ , line $ "or to contribute content related to this " ++ levelText ++ "."
517+ ]
480518 | showWiki
481519 ]
482520 where
@@ -491,11 +529,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
491529 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box
492530 skolemInfo (name, s, ss) =
493531 paras $
494− line (name ++ show s ++ " is a rigid type variable")
532+ line (markCode (name ++ show s) ++ " is a rigid type variable")
495533 : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss
496534
497535 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"
499537
500538 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
501539 renderSimpleErrorMessage (CannotGetFileInfo path) =
@@ -520,29 +558,29 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
520558 , prettyPrintParseError err
521559 ]
522560 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."
524562 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) ++ ": "
526564 , 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."
528566 ]
529567 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) ++ ": "
531569 , indent . paras $ map (line . runIdent) idents
532570 ]
533571 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: "
535573 , indent . paras $ map (line . runIdent) idents
536574 ]
537575 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) ++ ":"
539577 , indent . paras $
540− [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript."
578+ [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript."
541579 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."
542580 ]
543581 ]
544582 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) ++ ": "
546584 , indent . paras $ map line paths
547585 ]
548586 renderSimpleErrorMessage InvalidDoBind =
@@ -553,94 +591,78 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
553591 line "The same name was used more than once in a let binding."
554592 renderSimpleErrorMessage (InfiniteType ty) =
555593 paras [ line "An infinite type was inferred for an expression: "
556− , indent $ typeAsBox ty
594+ , markCodeBox $ indent $ typeAsBox ty
557595 ]
558596 renderSimpleErrorMessage (InfiniteKind ki) =
559597 paras [ line "An infinite kind was inferred for a type: "
560− , indent $ line $ prettyPrintKind ki
598+ , indent $ line $ markCode $ prettyPrintKind ki
561599 ]
562600 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)
564602 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)
566604 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."
568606 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:")
570608 , indent . paras $ map (line . displaySourceSpan) filenames
571609 ]
572610 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"
574612 renderSimpleErrorMessage (UnknownName name) =
575613 line $ "Unknown " ++ printName name
576614 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)
578616 , line "It either does not exist or the module does not export it."
579617 ]
580618 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)
582620 renderSimpleErrorMessage (UnknownExport name) =
583621 line $ "Cannot export unknown " ++ printName (Qualified Nothing name)
584622 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."
586624 renderSimpleErrorMessage (ScopeConflict nm ms) =
587625 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
589627 ]
590628 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =
591629 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
593631 , 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."
595633 Nothing -> "local declaration will be used."
596634 ]
597− renderSimpleErrorMessage (ConflictingTypeDecls nm) =
598− line $ "Conflicting type declarations for " ++ runProperName nm
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) =
606− line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name."
607− renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
608− line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name."
635+ renderSimpleErrorMessage (DeclConflict new existing) =
636+ line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."
637+ renderSimpleErrorMessage (ExportConflict new existing) =
638+ line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing
609639 renderSimpleErrorMessage (DuplicateModuleName mn) =
610− line $ "Module " ++ 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
640+ line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."
619641 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."
621643 renderSimpleErrorMessage (CycleInModules mns) =
622644 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)
624646 ]
625647 renderSimpleErrorMessage (CycleInTypeSynonym name) =
626648 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)
628650 Nothing -> "A cycle appears in a set of type synonym definitions."
629651 , line "Cycles are disallowed because they can lead to loops in the type checker."
630652 , line "Consider using a 'newtype' instead."
631653 ]
632654 renderSimpleErrorMessage (NameIsUndefined ident) =
633− line $ "Value " ++ showIdent ident ++ " is undefined."
655+ line $ "Value " ++ markCode (showIdent ident) ++ " is undefined."
634656 renderSimpleErrorMessage (UndefinedTypeVariable name) =
635− line $ "Type variable " ++ runProperName name ++ " is undefined."
657+ line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined."
636658 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."
638660 , line "Type synonyms must be applied to all of their type arguments."
639661 ]
640662 renderSimpleErrorMessage (EscapedSkolem binding) =
641663 paras $ [ line "A type variable has escaped its scope." ]
642664 <> foldMap (\expr -> [ line "Relevant expression: "
643− , indent $ prettyPrintValue valueDepth expr
665+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr
644666 ]) binding
645667 renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
646668 = let (sorted1, sorted2) = sortRows u1 u2
@@ -662,34 +684,39 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
662684 , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)
663685 )
664686 in paras [ line "Could not match type"
665− , indent $ typeAsBox sorted1
687+ , markCodeBox $ indent $ typeAsBox sorted1
666688 , line "with type"
667− , indent $ typeAsBox sorted2
689+ , markCodeBox $ indent $ typeAsBox sorted2
668690 ]
669691
670692 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
671693 paras [ line "Could not match kind"
672− , indent $ line $ prettyPrintKind k1
694+ , indent $ line $ markCode $ prettyPrintKind k1
673695 , line "with kind"
674− , indent $ line $ prettyPrintKind k2
696+ , indent $ line $ markCode $ prettyPrintKind k2
675697 ]
676698 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
677699 paras [ line "Could not match constrained type"
678− , indent $ typeAsBox t1
700+ , markCodeBox $ indent $ typeAsBox t1
679701 , line "with type"
680− , indent $ typeAsBox t2
702+ , markCodeBox $ indent $ typeAsBox t2
681703 ]
682704 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
683705 paras [ line "Overlapping type class instances found for"
684− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
685− , Box.vcat Box.left (map typeAtomAsBox ts)
686− ]
706+ , markCodeBox $ indent $ Box.hsep 1 Box.left
707+ [ line (showQualified runProperName nm)
708+ , Box.vcat Box.left (map typeAtomAsBox ts)
709+ ]
687710 , line "The following instances were found:"
688711 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
689712 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."
690713 , line "They may be disallowed completely in a future version of the compiler."
691714 ]
692715 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
719+ ]
693720 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
694721 _
695722 (Just (PartialConstraintData bs b)))) =
@@ -697,15 +724,16 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
697724 , line "The following additional cases are required to cover all inputs:\n"
698725 , indent $ paras $
699726 Box.hsep 1 Box.left
700− (map (paras . map line) (transpose bs))
727+ (map (paras . map (line . markCode)) (transpose bs))
701728 : [line "..." | not b]
702729 , line "Alternatively, add a Partial constraint to the type of the enclosing value."
703730 ]
704731 renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) =
705732 paras [ line "No type class instance was found for"
706− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
707− , Box.vcat Box.left (map typeAtomAsBox ts)
708− ]
733+ , markCodeBox $ indent $ Box.hsep 1 Box.left
734+ [ line (showQualified runProperName nm)
735+ , Box.vcat Box.left (map typeAtomAsBox ts)
736+ ]
709737 , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."
710738 | any containsUnknowns ts
711739 ]
@@ -718,125 +746,128 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
718746 go _ = False
719747 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
720748 paras [ line "Type class instance for"
721− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
722− , Box.vcat Box.left (map typeAtomAsBox ts)
723− ]
749+ , markCodeBox $ indent $ Box.hsep 1 Box.left
750+ [ line (showQualified runProperName nm)
751+ , Box.vcat Box.left (map typeAtomAsBox ts)
752+ ]
724753 , line "is possibly infinite."
725754 ]
726755 renderSimpleErrorMessage (CannotDerive nm ts) =
727756 paras [ line "Cannot derive a type class instance for"
728− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
729− , Box.vcat Box.left (map typeAtomAsBox ts)
730− ]
757+ , markCodeBox $ indent $ Box.hsep 1 Box.left
758+ [ line (showQualified runProperName nm)
759+ , Box.vcat Box.left (map typeAtomAsBox ts)
760+ ]
731761 ]
732762 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."
734764 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." ]
736766 <> foldMap (\expr' -> [ line "Relevant expression: "
737− , indent $ prettyPrintValue valueDepth expr'
767+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr'
738768 ]) expr
739769 renderSimpleErrorMessage (DuplicateTypeArgument name) =
740− line $ "Type argument " ++ show name ++ " appears more than once."
770+ line $ "Type argument " ++ markCode name ++ " appears more than once."
741771 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
742− line $ "Multiple value declarations exist for " ++ showIdent nm ++ "."
772+ line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "."
743773 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
744− line $ "Argument list lengths differ in declaration " ++ showIdent ident
774+ line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident)
745775 renderSimpleErrorMessage (OverlappingArgNames ident) =
746776 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident
747777 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."
749779 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)
751781 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 "*" ++ "."
753783 , line "The error arises from the type"
754− , indent $ typeAsBox ty
784+ , markCodeBox $ indent $ typeAsBox ty
755785 , line "having the kind"
756− , indent $ line $ prettyPrintKind kind
786+ , indent $ line $ markCode $ prettyPrintKind kind
757787 , line "instead."
758788 ]
759789 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."
761791 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
762792 paras [ line "Expression"
763− , indent $ prettyPrintValue valueDepth expr
793+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr
764794 , line "does not have type"
765− , indent $ typeAsBox ty
795+ , markCodeBox $ indent $ typeAsBox ty
766796 ]
767797 renderSimpleErrorMessage (PropertyIsMissing prop) =
768− line $ "Type of expression lacks required label " ++ show prop ++ "."
798+ line $ "Type of expression lacks required label " ++ markCode prop ++ "."
769799 renderSimpleErrorMessage (AdditionalProperty prop) =
770− line $ "Type of expression contains additional label " ++ show prop ++ "."
800+ line $ "Type of expression contains additional label " ++ markCode prop ++ "."
771801 renderSimpleErrorMessage (CannotApplyFunction fn arg) =
772802 paras [ line "A function of type"
773− , indent $ typeAsBox fn
803+ , markCodeBox $ indent $ typeAsBox fn
774804 , line "can not be applied to the argument"
775− , indent $ prettyPrintValue valueDepth arg
805+ , markCodeBox $ indent $ prettyPrintValue valueDepth arg
776806 ]
777807 renderSimpleErrorMessage TypeSynonymInstance =
778808 line "Type class instances for type synonyms are disallowed."
779809 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
780− paras [ line $ "Type class instance " ++ showIdent nm ++ " for "
781− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)
782− , Box.vcat Box.left (map typeAtomAsBox ts)
783− ]
810+ paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for "
811+ , markCodeBox $ indent $ Box.hsep 1 Box.left
812+ [ line (showQualified runProperName cnm)
813+ , Box.vcat Box.left (map typeAtomAsBox ts)
814+ ]
784815 , line "is an orphan instance."
785816 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
786817 , line "Consider moving the instance, if possible, or using a newtype wrapper."
787818 ]
788819 renderSimpleErrorMessage (InvalidNewtype name) =
789− paras [ line $ "Newtype " ++ runProperName name ++ " is invalid."
820+ paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid."
790821 , line "Newtypes must define a single constructor with a single argument."
791822 ]
792823 renderSimpleErrorMessage (InvalidInstanceHead ty) =
793824 paras [ line "Type class instance head is invalid due to use of type"
794− , indent $ typeAsBox ty
825+ , markCodeBox $ indent $ typeAsBox ty
795826 , 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."
796827 ]
797828 renderSimpleErrorMessage (TransitiveExportError x ys) =
798− paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
799− , indent $ paras $ map (line . prettyPrintExport) ys
829+ paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: "
830+ , indent $ paras $ map (line . markCode . prettyPrintExport) ys
800831 ]
801832 renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =
802− paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: "
803− , indent $ line $ runProperName ctor
833+ paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: "
834+ , indent $ line $ markCode $ runProperName ctor
804835 ]
805836 renderSimpleErrorMessage (ShadowedName nm) =
806− line $ "Name '" ++ showIdent nm ++ "' was shadowed."
837+ line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed."
807838 renderSimpleErrorMessage (ShadowedTypeVar tv) =
808− line $ "Type variable '" ++ tv ++ "' was shadowed."
839+ line $ "Type variable " ++ markCode tv ++ " was shadowed."
809840 renderSimpleErrorMessage (UnusedTypeVar tv) =
810− line $ "Type variable '" ++ tv ++ "' was declared but not used."
841+ line $ "Type variable " ++ markCode tv ++ " was declared but not used."
811842 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."
813844 renderSimpleErrorMessage (ImportHidingModule name) =
814− paras [ line "'hiding' imports cannot be used to hide modules."
815− , line $ "An attempt was made to hide the import of " ++ runModuleName name
845+ paras [ line "hiding imports cannot be used to hide modules."
846+ , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)
816847 ]
817848 renderSimpleErrorMessage (WildcardInferredType ty) =
818849 paras [ line "Wildcard type definition has the inferred type "
819− , indent $ typeAsBox ty
850+ , markCodeBox $ indent $ typeAsBox ty
820851 ]
821852 renderSimpleErrorMessage (HoleInferredType name ty env) =
822− paras $ [ line $ "Hole '" ++ name ++ "' has the inferred type "
823− , indent $ typeAsBox ty
853+ paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "
854+ , markCodeBox $ indent $ typeAsBox ty
824855 ] ++ if null env then [] else envInfo
825856 where
826857 envInfo :: [Box.Box]
827858 envInfo = [ line "in the following context:"
828859 , indent $ paras
829860 [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
830− , typeAsBox ty'
861+ , markCodeBox $ typeAsBox ty'
831862 ]
832863 | (ident, ty') <- take 5 env
833864 ]
834865 ]
835866 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) ++ "."
837868 , line "It is good practice to provide type declarations as a form of documentation."
838− , line $ "The inferred type of " ++ showIdent ident ++ " was:"
839− , indent $ typeAsBox ty
869+ , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"
870+ , markCodeBox $ indent $ typeAsBox ty
840871 ]
841872 renderSimpleErrorMessage (OverlappingPattern bs b) =
842873 paras $ [ line "A case expression contains unreachable cases:\n"
@@ -848,26 +879,26 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
848879 , line "You may want to decompose your data types into smaller types."
849880 ]
850881 renderSimpleErrorMessage (UnusedImport name) =
851− line $ "The import of module " ++ runModuleName name ++ " is redundant"
882+ line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant"
852883
853884 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:"
855886 , indent $ paras $ map line names
856887 , line "It could be replaced with:"
857− , indent $ line $ showSuggestion msg ]
888+ , indent $ line $ markCode $ showSuggestion msg ]
858889
859890 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"
861892
862893 renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =
863− paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"
864− , indent $ paras $ map (line .runProperName) names ]
894+ paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:"
895+ , indent $ paras $ map (line . markCode . runProperName) names ]
865896
866897 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"
868899
869900 renderSimpleErrorMessage (DuplicateImport name imp qual) =
870− line $ "Duplicate import of " ++ prettyPrintImport name imp qual
901+ line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual)
871902
872903 renderSimpleErrorMessage (DuplicateImportRef name) =
873904 line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)
@@ -876,23 +907,23 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
876907 line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)
877908
878909 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =
879− paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."
880− , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]
910+ paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend."
911+ , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ]
881912
882913 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =
883− paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."
884− , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"
885− , indent $ line $ showSuggestion msg
914+ paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports."
915+ , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:"
916+ , indent $ line $ markCode $ showSuggestion msg
886917 ]
887918
888919 renderSimpleErrorMessage msg@(ImplicitImport mn _) =
889− paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "
890− , indent $ line $ showSuggestion msg
920+ paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: "
921+ , indent $ line $ markCode $ showSuggestion msg
891922 ]
892923
893924 renderSimpleErrorMessage msg@(HidingImport mn _) =
894− paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "
895− , indent $ line $ showSuggestion msg
925+ paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: "
926+ , indent $ line $ markCode $ showSuggestion msg
896927 ]
897928
898929 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
@@ -905,7 +936,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
905936 line "An anonymous function argument appears in an invalid context."
906937
907938 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 ++ "."
909940 , line "Only aliases for data constructors may be used in patterns."
910941 ]
911942
@@ -913,9 +944,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
913944 line "The require-path option is deprecated and will be removed in PureScript 0.9."
914945
915946 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
916− paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "."
917− , line $ "The inferred type of " ++ showIdent ident ++ " was:"
918− , indent $ typeAsBox ty
947+ paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "."
948+ , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"
949+ , markCodeBox $ indent $ typeAsBox ty
919950 , line "Try adding a type signature."
920951 ]
921952
@@ -923,42 +954,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
923954 renderHint (ErrorUnifyingTypes t1 t2) detail =
924955 paras [ detail
925956 , Box.hsep 1 Box.top [ line "while trying to match type"
926− , typeAsBox t1
957+ , markCodeBox $ typeAsBox t1
927958 ]
928959 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"
929− , typeAsBox t2
960+ , markCodeBox $ typeAsBox t2
930961 ]
931962 ]
932963 renderHint (ErrorInExpression expr) detail =
933964 paras [ detail
934965 , Box.hsep 1 Box.top [ Box.text "in the expression"
935− , prettyPrintValue valueDepth expr
966+ , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr
936967 ]
937968 ]
938969 renderHint (ErrorInModule mn) detail =
939− paras [ line $ "in module " ++ runModuleName mn
970+ paras [ line $ "in module " ++ markCode (runModuleName mn)
940971 , detail
941972 ]
942973 renderHint (ErrorInSubsumption t1 t2) detail =
943974 paras [ detail
944975 , Box.hsep 1 Box.top [ line "while checking that type"
945− , typeAsBox t1
976+ , markCodeBox $ typeAsBox t1
946977 ]
947978 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"
948− , typeAsBox t2
979+ , markCodeBox $ typeAsBox t2
949980 ]
950981 ]
951982 renderHint (ErrorInInstance nm ts) detail =
952983 paras [ detail
953− , Box.hsep 1 Box.top [ line "in type class instance"
954− , line (showQualified runProperName nm)
955− , Box.vcat Box.left (map typeAtomAsBox ts)
956− ]
984+ , line "in type class instance"
985+ , markCodeBox $ indent $ Box.hsep 1 Box.top
986+ [ line $ showQualified runProperName nm
987+ , Box.vcat Box.left (map typeAtomAsBox ts)
988+ ]
957989 ]
958990 renderHint (ErrorCheckingKind ty) detail =
959991 paras [ detail
960992 , Box.hsep 1 Box.top [ line "while checking the kind of"
961− , typeAsBox ty
993+ , markCodeBox $ typeAsBox ty
962994 ]
963995 ]
964996 renderHint ErrorCheckingGuard detail =
@@ -968,43 +1000,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
9681000 renderHint (ErrorInferringType expr) detail =
9691001 paras [ detail
9701002 , Box.hsep 1 Box.top [ line "while inferring the type of"
971− , prettyPrintValue valueDepth expr
1003+ , markCodeBox $ prettyPrintValue valueDepth expr
9721004 ]
9731005 ]
9741006 renderHint (ErrorCheckingType expr ty) detail =
9751007 paras [ detail
9761008 , Box.hsep 1 Box.top [ line "while checking that expression"
977− , prettyPrintValue valueDepth expr
1009+ , markCodeBox $ prettyPrintValue valueDepth expr
9781010 ]
9791011 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"
980− , typeAsBox ty
1012+ , markCodeBox $ typeAsBox ty
9811013 ]
9821014 ]
9831015 renderHint (ErrorCheckingAccessor expr prop) detail =
9841016 paras [ detail
9851017 , 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)
9871019 ]
9881020 ]
9891021 renderHint (ErrorInApplication f t a) detail =
9901022 paras [ detail
9911023 , Box.hsep 1 Box.top [ line "while applying a function"
992− , prettyPrintValue valueDepth f
1024+ , markCodeBox $ prettyPrintValue valueDepth f
9931025 ]
9941026 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"
995− , typeAsBox t
1027+ , markCodeBox $ typeAsBox t
9961028 ]
9971029 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"
998− , prettyPrintValue valueDepth a
1030+ , markCodeBox $ prettyPrintValue valueDepth a
9991031 ]
10001032 ]
10011033 renderHint (ErrorInDataConstructor nm) detail =
10021034 paras [ detail
1003− , line $ "in data constructor " ++ runProperName nm
1035+ , line $ "in data constructor " ++ markCode (runProperName nm)
10041036 ]
10051037 renderHint (ErrorInTypeConstructor nm) detail =
10061038 paras [ detail
1007− , line $ "in type constructor " ++ runProperName nm
1039+ , line $ "in type constructor " ++ markCode (runProperName nm)
10081040 ]
10091041 renderHint (ErrorInBindingGroup nms) detail =
10101042 paras [ detail
@@ -1016,19 +1048,19 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
10161048 ]
10171049 renderHint (ErrorInTypeSynonym name) detail =
10181050 paras [ detail
1019− , line $ "in type synonym " ++ runProperName name
1051+ , line $ "in type synonym " ++ markCode (runProperName name)
10201052 ]
10211053 renderHint (ErrorInValueDeclaration n) detail =
10221054 paras [ detail
1023− , line $ "in value declaration " ++ showIdent n
1055+ , line $ "in value declaration " ++ markCode (showIdent n)
10241056 ]
10251057 renderHint (ErrorInTypeDeclaration n) detail =
10261058 paras [ detail
1027− , line $ "in type declaration for " ++ showIdent n
1059+ , line $ "in type declaration for " ++ markCode (showIdent n)
10281060 ]
10291061 renderHint (ErrorInForeignImport nm) detail =
10301062 paras [ detail
1031− , line $ "in foreign import " ++ showIdent nm
1063+ , line $ "in foreign import " ++ markCode (showIdent nm)
10321064 ]
10331065 renderHint (PositionedError srcSpan) detail =
10341066 paras [ line $ "at " ++ displaySourceSpan srcSpan
@@ -1036,22 +1068,34 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
10361068 ]
10371069
10381070 printName :: Qualified Name -> String
1039− printName (Qualified mn (IdentName name)) =
1040− "value " ++ showQualified showIdent (Qualified mn name)
1041− printName (Qualified mn (ValOpName op)) =
1042− "operator " ++ showQualified showOp (Qualified mn op)
1043− printName (Qualified mn (TyName name)) =
1044− "type " ++ showQualified runProperName (Qualified mn name)
1045− printName (Qualified mn (TyOpName op)) =
1046− "type operator " ++ showQualified showOp (Qualified mn op)
1047− printName (Qualified mn (DctorName name)) =
1048− "data constructor " ++ showQualified runProperName (Qualified mn name)
1049− printName (Qualified mn (TyClassName name)) =
1050− "type class " ++ showQualified runProperName (Qualified mn name)
1051− printName (Qualified Nothing (ModName name)) =
1052− "module " ++ runModuleName name
1053− printName (Qualified _ ModName{}) =
1054− internalError "qualified ModName in printName"
1071+ printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)
1072+
1073+ nameType :: Name -> String
1074+ nameType (IdentName _) = "value"
1075+ nameType (ValOpName _) = "operator"
1076+ nameType (TyName _) = "type"
1077+ nameType (TyOpName _) = "type operator"
1078+ nameType (DctorName _) = "data constructor"
1079+ nameType (TyClassName _) = "type class"
1080+ nameType (ModName _) = "module"
1081+
1082+ runName :: Qualified Name -> String
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)) =
1096+ runModuleName name
1097+ runName (Qualified _ ModName{}) =
1098+ internalError "qualified ModName in runName"
10551099
10561100 valueDepth :: Int
10571101 valueDepth | full = 1000
@@ -1119,57 +1163,72 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
11191163-- Pretty print and export declaration
11201164prettyPrintExport :: DeclarationRef -> String
11211165prettyPrintExport (TypeRef pn _) = runProperName pn
1122−prettyPrintExport ref = prettyPrintRef ref
1166+prettyPrintExport ref =
1167+ fromMaybe
1168+ (internalError "prettyPrintRef returned Nothing in prettyPrintExport")
1169+ (prettyPrintRef ref)
11231170
11241171prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
11251172prettyPrintImport mn idt qual =
11261173 let i = case idt of
11271174 Implicit -> runModuleName mn
1128− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
1129− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
1175+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"
1176+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"
11301177 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
11311178
1132−prettyPrintRef :: DeclarationRef -> String
1133−prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
1134−prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
1135−prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1136−prettyPrintRef (TypeOpRef op) = "type " ++ showOp op
1137−prettyPrintRef (ValueRef ident) = showIdent ident
1138−prettyPrintRef (ValueOpRef op) = showOp op
1139−prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
1140−prettyPrintRef (TypeInstanceRef ident) = showIdent ident
1141−prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
1142−prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
1179+prettyPrintRef :: DeclarationRef -> Maybe String
1180+prettyPrintRef (TypeRef pn Nothing) =
1181+ Just $ runProperName pn ++ "(..)"
1182+prettyPrintRef (TypeRef pn (Just [])) =
1183+ Just $ runProperName pn
1184+prettyPrintRef (TypeRef pn (Just dctors)) =
1185+ Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1186+prettyPrintRef (TypeOpRef op) =
1187+ Just $ "type " ++ showOp op
1188+prettyPrintRef (ValueRef ident) =
1189+ Just $ showIdent ident
1190+prettyPrintRef (ValueOpRef op) =
1191+ Just $ showOp op
1192+prettyPrintRef (TypeClassRef pn) =
1193+ Just $ "class " ++ runProperName pn
1194+prettyPrintRef (TypeInstanceRef ident) =
1195+ Just $ showIdent ident
1196+prettyPrintRef (ModuleRef name) =
1197+ Just $ "module " ++ runModuleName name
1198+prettyPrintRef (ReExportRef _ _) =
1199+ Nothing
1200+prettyPrintRef (PositionedDeclarationRef _ _ ref) =
1201+ prettyPrintRef ref
11431202
11441203-- |
11451204-- Pretty print multiple errors
11461205--
1147−prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
1148−prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full
1206+prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String
1207+prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions
11491208
11501209-- |
11511210-- Pretty print multiple warnings
11521211--
1153−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
1154−prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full
1212+prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String
1213+prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions
11551214
11561215-- | Pretty print warnings as a Box
1157−prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]
1158−prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning"
1216+prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
1217+prettyPrintMultipleWarningsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Warning }) "Warning found:" "Warning"
11591218
11601219-- | Pretty print errors as a Box
1161−prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]
1162−prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"
1220+prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
1221+prettyPrintMultipleErrorsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Error }) "Error found:" "Error"
11631222
1164−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]
1165−prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
1166− let result = prettyPrintSingleError full level True e
1223+prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box]
1224+prettyPrintMultipleErrorsWith ppeOptions intro _ (MultipleErrors [e]) =
1225+ let result = prettyPrintSingleError ppeOptions e
11671226 in [ Box.vcat Box.left [ Box.text intro
11681227 , result
11691228 ]
11701229 ]
1171−prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =
1172− let result = map (prettyPrintSingleError full level True) es
1230+prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) =
1231+ let result = map (prettyPrintSingleError ppeOptions) es
11731232 in concat $ zipWith withIntro [1 :: Int ..] result
11741233 where
11751234 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")