@@ -1,201 +1,45 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE NamedFieldPuns #-}
43
5−module Language.PureScript.Errors where
4+module Language.PureScript.Errors
5+ ( module Language.PureScript.AST
6+ , module Language.PureScript.Errors
7+ ) where
68
7−import Prelude ()
89import Prelude.Compat
910
10−import Data.Ord (comparing)
11+import Control.Arrow ((&&&))
12+import Control.Monad
13+import Control.Monad.Error.Class (MonadError(..))
14+import Control.Monad.Trans.State.Lazy
15+import Control.Monad.Writer
16+
1117import Data.Char (isSpace)
1218import Data.Either (lefts, rights)
13−import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
1419import Data.Foldable (fold)
15−import Data.Maybe (maybeToList)
16−
20+import Data.Functor.Identity (Identity(..))
21+import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)
22+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
23+import Data.Ord (comparing)
1724import qualified Data.Map as M
1825
19−import Control.Monad
20−import Control.Monad.Writer
21−import Control.Monad.Error.Class (MonadError(..))
22−import Control.Monad.Trans.State.Lazy
23−import Control.Arrow ((&&&))
24−
25−import Language.PureScript.Crash
2626import Language.PureScript.AST
27+import Language.PureScript.Crash
28+import Language.PureScript.Names
2729import Language.PureScript.Pretty
28−import Language.PureScript.Pretty.Common (before)
30+import Language.PureScript.Traversals
2931import Language.PureScript.Types
30−import Language.PureScript.Names
31−import Language.PureScript.Kinds
32+import Language.PureScript.Pretty.Common (endWith)
3233import qualified Language.PureScript.Bundle as Bundle
34+import qualified Language.PureScript.Constants as C
3335
34−import qualified Text.PrettyPrint.Boxes as Box
36+import qualified System.Console.ANSI as ANSI
3537
3638import qualified Text.Parsec as P
3739import qualified Text.Parsec.Error as PE
40+import qualified Text.PrettyPrint.Boxes as Box
3841import Text.Parsec.Error (Message(..))
3942
40−-- | A type of error messages
41−data SimpleErrorMessage
42− = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
43− | ErrorParsingModule P.ParseError
44− | MissingFFIModule ModuleName
45− | MultipleFFIModules ModuleName [FilePath]
46− | UnnecessaryFFIModule ModuleName FilePath
47− | MissingFFIImplementations ModuleName [Ident]
48− | UnusedFFIImplementations ModuleName [Ident]
49− | InvalidFFIIdentifier ModuleName String
50− | CannotGetFileInfo FilePath
51− | CannotReadFile FilePath
52− | CannotWriteFile FilePath
53− | InfiniteType Type
54− | InfiniteKind Kind
55− | MultipleFixities Ident
56− | OrphanTypeDeclaration Ident
57− | OrphanFixityDeclaration String
58− | RedefinedModule ModuleName [SourceSpan]
59− | RedefinedIdent Ident
60− | OverlappingNamesInLet
61− | UnknownModule ModuleName
62− | UnknownType (Qualified (ProperName 'TypeName))
63− | UnknownTypeOp (Qualified Ident)
64− | UnknownTypeClass (Qualified (ProperName 'ClassName))
65− | UnknownValue (Qualified Ident)
66− | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))
67− | UnknownTypeConstructor (Qualified (ProperName 'TypeName))
68− | UnknownImportType ModuleName (ProperName 'TypeName)
69− | UnknownExportType (ProperName 'TypeName)
70− | UnknownImportTypeOp ModuleName Ident
71− | UnknownExportTypeOp Ident
72− | UnknownImportTypeClass ModuleName (ProperName 'ClassName)
73− | UnknownExportTypeClass (ProperName 'ClassName)
74− | UnknownImportValue ModuleName Ident
75− | UnknownExportValue Ident
76− | UnknownExportModule ModuleName
77− | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
78− | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
79− | ScopeConflict String [ModuleName]
80− | ScopeShadowing String (Maybe ModuleName) [ModuleName]
81− | ConflictingTypeDecls (ProperName 'TypeName)
82− | ConflictingCtorDecls (ProperName 'ConstructorName)
83− | TypeConflictsWithClass (ProperName 'TypeName)
84− | CtorConflictsWithClass (ProperName 'ConstructorName)
85− | ClassConflictsWithType (ProperName 'ClassName)
86− | ClassConflictsWithCtor (ProperName 'ClassName)
87− | DuplicateModuleName ModuleName
88− | DuplicateClassExport (ProperName 'ClassName)
89− | DuplicateValueExport Ident
90− | DuplicateTypeOpExport Ident
91− | DuplicateTypeArgument String
92− | InvalidDoBind
93− | InvalidDoLet
94− | CycleInDeclaration Ident
95− | CycleInTypeSynonym (Maybe (ProperName 'TypeName))
96− | CycleInModules [ModuleName]
97− | NameIsUndefined Ident
98− | UndefinedTypeVariable (ProperName 'TypeName)
99− | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
100− | EscapedSkolem (Maybe Expr)
101− | TypesDoNotUnify Type Type
102− | KindsDoNotUnify Kind Kind
103− | ConstrainedTypeUnified Type Type
104− | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
105− | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]
106− | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
107− | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
108− | CannotFindDerivingType (ProperName 'TypeName)
109− | DuplicateLabel String (Maybe Expr)
110− | DuplicateValueDeclaration Ident
111− | ArgListLengthsDiffer Ident
112− | OverlappingArgNames (Maybe Ident)
113− | MissingClassMember Ident
114− | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
115− | ExpectedType Type Kind
116− | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))
117− | ExprDoesNotHaveType Expr Type
118− | PropertyIsMissing String
119− | AdditionalProperty String
120− | CannotApplyFunction Type Expr
121− | TypeSynonymInstance
122− | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
123− | InvalidNewtype (ProperName 'TypeName)
124− | InvalidInstanceHead Type
125− | TransitiveExportError DeclarationRef [DeclarationRef]
126− | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
127− | ShadowedName Ident
128− | ShadowedTypeVar String
129− | UnusedTypeVar String
130− | WildcardInferredType Type
131− | HoleInferredType String Type
132− | MissingTypeDeclaration Ident Type
133− | NotExhaustivePattern [[Binder]] Bool
134− | OverlappingPattern [[Binder]] Bool
135− | IncompleteExhaustivityCheck
136− | ClassOperator (ProperName 'ClassName) Ident
137− | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
138− | ImportHidingModule ModuleName
139− | UnusedImport ModuleName
140− | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
141− | UnusedDctorImport (ProperName 'TypeName)
142− | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
143− | DeprecatedOperatorDecl String
144− | DeprecatedOperatorSection Expr (Either Expr Expr)
145− | DeprecatedQualifiedSyntax ModuleName ModuleName
146− | DeprecatedClassImport ModuleName (ProperName 'ClassName)
147− | DeprecatedClassExport (ProperName 'ClassName)
148− | DuplicateSelectiveImport ModuleName
149− | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
150− | DuplicateImportRef String
151− | DuplicateExportRef String
152− | IntOutOfRange Integer String Integer Integer
153− | RedundantEmptyHidingImport ModuleName
154− | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]
155− | ImplicitImport ModuleName [DeclarationRef]
156− | HidingImport ModuleName [DeclarationRef]
157− | CaseBinderLengthDiffers Int [Binder]
158− | IncorrectAnonymousArgument
159− | InvalidOperatorInBinder Ident Ident
160− | DeprecatedRequirePath
161− | CannotGeneralizeRecursiveFunction Ident Type
162− deriving (Show)
163−
164−-- | Error message hints, providing more detailed information about failure.
165−data ErrorMessageHint
166− = ErrorUnifyingTypes Type Type
167− | ErrorInExpression Expr
168− | ErrorInModule ModuleName
169− | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
170− | ErrorInSubsumption Type Type
171− | ErrorCheckingAccessor Expr String
172− | ErrorCheckingType Expr Type
173− | ErrorCheckingKind Type
174− | ErrorCheckingGuard
175− | ErrorInferringType Expr
176− | ErrorInApplication Expr Type Expr
177− | ErrorInDataConstructor (ProperName 'ConstructorName)
178− | ErrorInTypeConstructor (ProperName 'TypeName)
179− | ErrorInBindingGroup [Ident]
180− | ErrorInDataBindingGroup
181− | ErrorInTypeSynonym (ProperName 'TypeName)
182− | ErrorInValueDeclaration Ident
183− | ErrorInTypeDeclaration Ident
184− | ErrorInForeignImport Ident
185− | PositionedError SourceSpan
186− deriving Show
187−
188−-- | Categories of hints
189−data HintCategory
190− = ExprHint
191− | KindHint
192− | CheckHint
193− | PositionHint
194− | OtherHint
195− deriving (Show, Eq)
196−
197−data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
198−
19943newtype ErrorSuggestion = ErrorSuggestion String
20044
20145-- | Get the source span for an error
@@ -241,42 +85,22 @@ errorCode em = case unwrapErrorMessage em of
24185 CannotWriteFile{} -> "CannotWriteFile"
24286 InfiniteType{} -> "InfiniteType"
24387 InfiniteKind{} -> "InfiniteKind"
244− MultipleFixities{} -> "MultipleFixities"
88+ MultipleValueOpFixities{} -> "MultipleValueOpFixities"
89+ MultipleTypeOpFixities{} -> "MultipleTypeOpFixities"
24590 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"
246− OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"
24791 RedefinedModule{} -> "RedefinedModule"
24892 RedefinedIdent{} -> "RedefinedIdent"
24993 OverlappingNamesInLet -> "OverlappingNamesInLet"
250− UnknownModule{} -> "UnknownModule"
251− UnknownType{} -> "UnknownType"
252− UnknownTypeOp{} -> "UnknownTypeOp"
253− UnknownTypeClass{} -> "UnknownTypeClass"
254− UnknownValue{} -> "UnknownValue"
255− UnknownDataConstructor{} -> "UnknownDataConstructor"
256− UnknownTypeConstructor{} -> "UnknownTypeConstructor"
257− UnknownImportType{} -> "UnknownImportType"
258− UnknownImportTypeOp{} -> "UnknownImportTypeOp"
259− UnknownExportType{} -> "UnknownExportType"
260− UnknownExportTypeOp{} -> "UnknownExportTypeOp"
261− UnknownImportTypeClass{} -> "UnknownImportTypeClass"
262− UnknownExportTypeClass{} -> "UnknownExportTypeClass"
263− UnknownImportValue{} -> "UnknownImportValue"
264− UnknownExportValue{} -> "UnknownExportValue"
265− UnknownExportModule{} -> "UnknownExportModule"
94+ UnknownName{} -> "UnknownName"
95+ UnknownImport{} -> "UnknownImport"
26696 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"
97+ UnknownExport{} -> "UnknownExport"
26798 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
26899 ScopeConflict{} -> "ScopeConflict"
269100 ScopeShadowing{} -> "ScopeShadowing"
270− ConflictingTypeDecls{} -> "ConflictingTypeDecls"
271− ConflictingCtorDecls{} -> "ConflictingCtorDecls"
272− TypeConflictsWithClass{} -> "TypeConflictsWithClass"
273− CtorConflictsWithClass{} -> "CtorConflictsWithClass"
274− ClassConflictsWithType{} -> "ClassConflictsWithType"
275− ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
101+ DeclConflict{} -> "DeclConflict"
102+ ExportConflict{} -> "ExportConflict"
276103 DuplicateModuleName{} -> "DuplicateModuleName"
277− DuplicateClassExport{} -> "DuplicateClassExport"
278− DuplicateValueExport{} -> "DuplicateValueExport"
279− DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"
280104 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
281105 InvalidDoBind -> "InvalidDoBind"
282106 InvalidDoLet -> "InvalidDoLet"
@@ -319,27 +143,19 @@ errorCode em = case unwrapErrorMessage em of
319143 WildcardInferredType{} -> "WildcardInferredType"
320144 HoleInferredType{} -> "HoleInferredType"
321145 MissingTypeDeclaration{} -> "MissingTypeDeclaration"
322− NotExhaustivePattern{} -> "NotExhaustivePattern"
323146 OverlappingPattern{} -> "OverlappingPattern"
324147 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
325− ClassOperator{} -> "ClassOperator"
326148 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"
327149 ImportHidingModule{} -> "ImportHidingModule"
328150 UnusedImport{} -> "UnusedImport"
329151 UnusedExplicitImport{} -> "UnusedExplicitImport"
330152 UnusedDctorImport{} -> "UnusedDctorImport"
331153 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"
332− DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"
333− DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"
334− DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"
335− DeprecatedClassImport{} -> "DeprecatedClassImport"
336− DeprecatedClassExport{} -> "DeprecatedClassExport"
337154 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"
338155 DuplicateImport{} -> "DuplicateImport"
339156 DuplicateImportRef{} -> "DuplicateImportRef"
340157 DuplicateExportRef{} -> "DuplicateExportRef"
341158 IntOutOfRange{} -> "IntOutOfRange"
342− RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"
343159 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"
344160 ImplicitImport{} -> "ImplicitImport"
345161 HidingImport{} -> "HidingImport"
@@ -377,18 +193,25 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors
377193
378194-- | Add a hint to an error message
379195addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
380−addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
196+addHint hint = addHints [hint]
197+
198+-- | Add hints to an error message
199+addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors
200+addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hints ++ hints') se
381201
382202-- | A map from rigid type variable name/unknown variable pairs to new variables.
383203data TypeMap = TypeMap
384− { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)
385− , umNextSkolem :: Int
386− , umUnknownMap :: M.Map Int Int
387− , umNextUnknown :: Int
204+ { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)
205+ -- ^ a map from skolems to their new names, including source and naming info
206+ , umUnknownMap :: M.Map Int Int
207+ -- ^ a map from unification variables to their new names
208+ , umNextIndex :: Int
209+ -- ^ unknowns and skolems share a source of names during renaming, to
210+ -- avoid overlaps in error messages. This is the next label for either case.
388211 } deriving Show
389212
390213defaultUnknownMap :: TypeMap
391−defaultUnknownMap = TypeMap M.empty 0 M.empty 0
214+defaultUnknownMap = TypeMap M.empty M.empty 0
392215
393216-- | How critical the issue is
394217data Level = Error | Warning deriving Show
@@ -407,21 +230,24 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
407230 m <- get
408231 case M.lookup u (umUnknownMap m) of
409232 Nothing -> do
410− let u' = umNextUnknown m
411− put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }
233+ let u' = umNextIndex m
234+ put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 }
412235 return (TUnknown u')
413236 Just u' -> return (TUnknown u')
414237 replaceTypes (Skolem name s sko ss) = do
415238 m <- get
416239 case M.lookup s (umSkolemMap m) of
417240 Nothing -> do
418− let s' = umNextSkolem m
419− put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }
241+ let s' = umNextIndex m
242+ put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }
420243 return (Skolem name s' sko ss)
421244 Just (_, s', _) -> return (Skolem name s' sko ss)
422245 replaceTypes other = return other
423246
424−onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
247+onTypesInErrorMessage :: (Type -> Type) -> ErrorMessage -> ErrorMessage
248+onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f)
249+
250+onTypesInErrorMessageM :: Applicative m => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
425251onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
426252 where
427253 gSimple (InfiniteType t) = InfiniteType <$> f t
@@ -430,17 +256,16 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
430256 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
431257 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
432258 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
433− gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts
259+ gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
434260 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
435261 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
436262 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
437263 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
438264 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
439− gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty
440− gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty
265+ gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
266+ gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx
441267 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
442268 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
443−
444269 gSimple other = pure other
445270
446271 gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
@@ -449,6 +274,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
449274 gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
450275 gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
451276 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts
277+ gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con
452278 gHint other = pure other
453279
454280wikiUri :: ErrorMessage -> String
@@ -457,18 +283,16 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error
457283-- TODO Other possible suggestions:
458284-- WildcardInferredType - source span not small enough
459285-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert
460−-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span?
461286errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
462287errorSuggestion err = case err of
463288 UnusedImport{} -> emptySuggestion
464− RedundantEmptyHidingImport{} -> emptySuggestion
465289 DuplicateImport{} -> emptySuggestion
466− DeprecatedQualifiedSyntax name qualName -> suggest $
467− "import " ++ runModuleName name ++ " as " ++ runModuleName qualName
468290 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
469291 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
470292 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
471293 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
294+ MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty
295+ WildcardInferredType ty _ -> suggest $ prettyPrintType ty
472296 _ -> Nothing
473297
474298 where
@@ -477,26 +301,87 @@ errorSuggestion err = case err of
477301
478302 importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
479303 importSuggestion mn refs qual =
480− "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual
304+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual
481305
482306 qstr :: Maybe ModuleName -> String
483307 qstr (Just mn) = " as " ++ runModuleName mn
484308 qstr Nothing = ""
485309
310+suggestionSpan :: ErrorMessage -> Maybe SourceSpan
311+suggestionSpan e =
312+ getSpan (unwrapErrorMessage e) <$> errorSpan e
313+ where
314+ startOnly SourceSpan{spanName, spanStart} = SourceSpan {spanName, spanStart, spanEnd = spanStart}
315+
316+ getSpan simple ss =
317+ case simple of
318+ MissingTypeDeclaration{} -> startOnly ss
319+ _ -> ss
320+
486321showSuggestion :: SimpleErrorMessage -> String
487322showSuggestion suggestion = case errorSuggestion suggestion of
488323 Just (ErrorSuggestion x) -> x
489324 _ -> ""
490325
326+ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String
327+ansiColor (intesity, color) =
328+ ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intesity color]
329+
330+ansiColorReset :: String
331+ansiColorReset =
332+ ANSI.setSGRCode [ANSI.Reset]
333+
334+colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String
335+colorCode codeColor code = case codeColor of
336+ Nothing -> code
337+ Just cc -> concat [ansiColor cc, code, ansiColorReset]
338+
339+colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box
340+colorCodeBox codeColor b = case codeColor of
341+ Nothing -> b
342+ Just cc
343+ | Box.rows b == 1 ->
344+ Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset
345+
346+ | 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
347+ [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc
348+ , b
349+ , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset
350+ ]
351+
352+
353+-- | Default color intesity and color for code
354+defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color)
355+defaultCodeColor = (ANSI.Dull, ANSI.Yellow)
356+
357+-- | `prettyPrintSingleError` Options
358+data PPEOptions = PPEOptions
359+ { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not
360+ , ppeFull :: Bool -- ^ Should write a full error message?
361+ , ppeLevel :: Level -- ^ Should this report an error or a warning?
362+ , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page?
363+ }
364+
365+-- | Default options for PPEOptions
366+defaultPPEOptions :: PPEOptions
367+defaultPPEOptions = PPEOptions
368+ { ppeCodeColor = Just defaultCodeColor
369+ , ppeFull = False
370+ , ppeLevel = Error
371+ , ppeShowWiki = True
372+ }
373+
374+
491375-- |
492376-- Pretty print a single error, simplifying if necessary
493377--
494−prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box
495−prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do
378+prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
379+prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do
496380 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
497381 um <- get
498382 return (prettyPrintErrorMessage um em)
499383 where
384+ (markCode, markCodeBox) = (colorCode &&& colorCodeBox) codeColor
500385
501386 -- Pretty print an ErrorMessage
502387 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
@@ -505,9 +390,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
505390 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
506391 ] ++
507392 maybe [] (return . Box.moveDown 1) typeInformation ++
508− [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "
509− , line $ "or to contribute content related to this " ++ levelText ++ "."
510− ]
393+ [ Box.moveDown 1 $ paras
394+ [ line $ "See " ++ wikiUri e ++ " for more information, "
395+ , line $ "or to contribute content related to this " ++ levelText ++ "."
396+ ]
511397 | showWiki
512398 ]
513399 where
@@ -522,11 +408,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
522408 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box
523409 skolemInfo (name, s, ss) =
524410 paras $
525− line (name ++ show s ++ " is a rigid type variable")
411+ line (markCode (name ++ show s) ++ " is a rigid type variable")
526412 : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss
527413
528414 unknownInfo :: Int -> Box.Box
529− unknownInfo u = line $ "_" ++ show u ++ " is an unknown type"
415+ unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type"
530416
531417 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
532418 renderSimpleErrorMessage (CannotGetFileInfo path) =
@@ -545,35 +431,35 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
545431 paras $ [ line "Unable to parse foreign module:"
546432 , indent . line $ path
547433 ] ++
548− (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)))
434+ map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))
549435 renderSimpleErrorMessage (ErrorParsingModule err) =
550436 paras [ line "Unable to parse module: "
551437 , prettyPrintParseError err
552438 ]
553439 renderSimpleErrorMessage (MissingFFIModule mn) =
554− line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing."
440+ line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing."
555441 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
556− paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": "
442+ paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": "
557443 , indent . line $ path
558− , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."
444+ , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary."
559445 ]
560446 renderSimpleErrorMessage (MissingFFIImplementations mn idents) =
561− paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": "
447+ paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": "
562448 , indent . paras $ map (line . runIdent) idents
563449 ]
564450 renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =
565− paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "
451+ paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: "
566452 , indent . paras $ map (line . runIdent) idents
567453 ]
568454 renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =
569− paras [ line $ "In the FFI module for " ++ runModuleName mn ++ ":"
455+ paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":"
570456 , indent . paras $
571− [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript."
457+ [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript."
572458 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."
573459 ]
574460 ]
575461 renderSimpleErrorMessage (MultipleFFIModules mn paths) =
576− paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "
462+ paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": "
577463 , indent . paras $ map line paths
578464 ]
579465 renderSimpleErrorMessage InvalidDoBind =
@@ -584,126 +470,78 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
584470 line "The same name was used more than once in a let binding."
585471 renderSimpleErrorMessage (InfiniteType ty) =
586472 paras [ line "An infinite type was inferred for an expression: "
587− , indent $ typeAsBox ty
473+ , markCodeBox $ indent $ typeAsBox ty
588474 ]
589475 renderSimpleErrorMessage (InfiniteKind ki) =
590476 paras [ line "An infinite kind was inferred for a type: "
591− , indent $ line $ prettyPrintKind ki
477+ , indent $ line $ markCode $ prettyPrintKind ki
592478 ]
593− renderSimpleErrorMessage (MultipleFixities name) =
594− line $ "There are multiple fixity/precedence declarations for " ++ showIdent name
479+ renderSimpleErrorMessage (MultipleValueOpFixities op) =
480+ line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op)
481+ renderSimpleErrorMessage (MultipleTypeOpFixities op) =
482+ line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)
595483 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
596− line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition."
597− renderSimpleErrorMessage (OrphanFixityDeclaration op) =
598− line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition."
484+ line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."
599485 renderSimpleErrorMessage (RedefinedModule name filenames) =
600− paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:")
486+ paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:")
601487 , indent . paras $ map (line . displaySourceSpan) filenames
602488 ]
603489 renderSimpleErrorMessage (RedefinedIdent name) =
604− line $ "The value " ++ showIdent name ++ " has been defined multiple times"
605− renderSimpleErrorMessage (UnknownModule mn) =
606− line $ "Unknown module " ++ runModuleName mn
607− renderSimpleErrorMessage (UnknownType name) =
608− line $ "Unknown type " ++ showQualified runProperName name
609− renderSimpleErrorMessage (UnknownTypeOp name) =
610− line $ "Unknown type operator " ++ showQualified showIdent name
611− renderSimpleErrorMessage (UnknownTypeClass name) =
612− line $ "Unknown type class " ++ showQualified runProperName name
613− renderSimpleErrorMessage (UnknownValue name) =
614− line $ "Unknown value " ++ showQualified showIdent name
615− renderSimpleErrorMessage (UnknownTypeConstructor name) =
616− line $ "Unknown type constructor " ++ showQualified runProperName name
617− renderSimpleErrorMessage (UnknownDataConstructor dc tc) =
618− line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
619− renderSimpleErrorMessage (UnknownImportType mn name) =
620− paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn
621− , line "It either does not exist or the module does not export it."
622− ]
623− renderSimpleErrorMessage (UnknownExportType name) =
624− line $ "Cannot export unknown type " ++ runProperName name
625− renderSimpleErrorMessage (UnknownImportTypeOp mn name) =
626− paras [ line $ "Cannot import type operator " ++ showIdent name ++ " from module " ++ runModuleName mn
490+ line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"
491+ renderSimpleErrorMessage (UnknownName name) =
492+ line $ "Unknown " ++ printName name
493+ renderSimpleErrorMessage (UnknownImport mn name) =
494+ paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn)
627495 , line "It either does not exist or the module does not export it."
628496 ]
629− renderSimpleErrorMessage (UnknownExportTypeOp name) =
630− line $ "Cannot export unknown type operator " ++ showIdent name
631− renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
632− paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn
633− , line "It either does not exist or the module does not export it."
634− ]
635− renderSimpleErrorMessage (UnknownExportTypeClass name) =
636− line $ "Cannot export unknown type class " ++ runProperName name
637− renderSimpleErrorMessage (UnknownImportValue mn name) =
638− paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn
639− , line "It either does not exist or the module does not export it."
640− ]
641− renderSimpleErrorMessage (UnknownExportValue name) =
642− line $ "Cannot export unknown value " ++ showIdent name
643− renderSimpleErrorMessage (UnknownExportModule name) =
644− paras [ line $ "Cannot export unknown module " ++ runModuleName name
645− , line "It either does not exist or has not been imported by the current module."
646− ]
647497 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
648− line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
498+ line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon)
499+ renderSimpleErrorMessage (UnknownExport name) =
500+ line $ "Cannot export unknown " ++ printName (Qualified Nothing name)
649501 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
650− line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."
502+ line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared."
651503 renderSimpleErrorMessage (ScopeConflict nm ms) =
652− paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"
653− , indent $ paras $ map (line . runModuleName) ms
504+ paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:"
505+ , indent $ paras $ map (line . markCode . runModuleName) ms
654506 ]
655507 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =
656− paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:"
657− , indent $ paras $ map (line . ("import " ++) . runModuleName) ms
508+ paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:"
509+ , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms
658510 , line $ "These will be ignored and the " ++ case exmn of
659− Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used."
511+ Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."
660512 Nothing -> "local declaration will be used."
661513 ]
662− renderSimpleErrorMessage (ConflictingTypeDecls nm) =
663− line $ "Conflicting type declarations for " ++ runProperName nm
664− renderSimpleErrorMessage (ConflictingCtorDecls nm) =
665− line $ "Conflicting data constructor declarations for " ++ runProperName nm
666− renderSimpleErrorMessage (TypeConflictsWithClass nm) =
667− line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."
668− renderSimpleErrorMessage (CtorConflictsWithClass nm) =
669− line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."
670− renderSimpleErrorMessage (ClassConflictsWithType nm) =
671− line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name."
672− renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
673− line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name."
514+ renderSimpleErrorMessage (DeclConflict new existing) =
515+ line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."
516+ renderSimpleErrorMessage (ExportConflict new existing) =
517+ line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing
674518 renderSimpleErrorMessage (DuplicateModuleName mn) =
675− line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
676− renderSimpleErrorMessage (DuplicateClassExport nm) =
677− line $ "Duplicate export declaration for type class " ++ runProperName nm
678− renderSimpleErrorMessage (DuplicateValueExport nm) =
679− line $ "Duplicate export declaration for value " ++ showIdent nm
680− renderSimpleErrorMessage (DuplicateTypeOpExport nm) =
681− line $ "Duplicate export declaration for type operator " ++ showIdent nm
519+ line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."
682520 renderSimpleErrorMessage (CycleInDeclaration nm) =
683− line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."
521+ line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."
684522 renderSimpleErrorMessage (CycleInModules mns) =
685523 paras [ line "There is a cycle in module dependencies in these modules: "
686− , indent $ paras (map (line . runModuleName) mns)
524+ , indent $ paras (map (line . markCode . runModuleName) mns)
687525 ]
688526 renderSimpleErrorMessage (CycleInTypeSynonym name) =
689527 paras [ line $ case name of
690− Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn
528+ Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn)
691529 Nothing -> "A cycle appears in a set of type synonym definitions."
692530 , line "Cycles are disallowed because they can lead to loops in the type checker."
693531 , line "Consider using a 'newtype' instead."
694532 ]
695533 renderSimpleErrorMessage (NameIsUndefined ident) =
696− line $ "Value " ++ showIdent ident ++ " is undefined."
534+ line $ "Value " ++ markCode (showIdent ident) ++ " is undefined."
697535 renderSimpleErrorMessage (UndefinedTypeVariable name) =
698− line $ "Type variable " ++ runProperName name ++ " is undefined."
536+ line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined."
699537 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
700− paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied."
538+ paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied."
701539 , line "Type synonyms must be applied to all of their type arguments."
702540 ]
703541 renderSimpleErrorMessage (EscapedSkolem binding) =
704542 paras $ [ line "A type variable has escaped its scope." ]
705543 <> foldMap (\expr -> [ line "Relevant expression: "
706− , indent $ prettyPrintValue valueDepth expr
544+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr
707545 ]) binding
708546 renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
709547 = let (sorted1, sorted2) = sortRows u1 u2
@@ -725,39 +563,56 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
725563 , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)
726564 )
727565 in paras [ line "Could not match type"
728− , indent $ typeAsBox sorted1
566+ , markCodeBox $ indent $ typeAsBox sorted1
729567 , line "with type"
730− , indent $ typeAsBox sorted2
568+ , markCodeBox $ indent $ typeAsBox sorted2
731569 ]
732570
733571 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
734572 paras [ line "Could not match kind"
735− , indent $ line $ prettyPrintKind k1
573+ , indent $ line $ markCode $ prettyPrintKind k1
736574 , line "with kind"
737− , indent $ line $ prettyPrintKind k2
575+ , indent $ line $ markCode $ prettyPrintKind k2
738576 ]
739577 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
740578 paras [ line "Could not match constrained type"
741− , indent $ typeAsBox t1
579+ , markCodeBox $ indent $ typeAsBox t1
742580 , line "with type"
743− , indent $ typeAsBox t2
581+ , markCodeBox $ indent $ typeAsBox t2
744582 ]
745583 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
746584 paras [ line "Overlapping type class instances found for"
747− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
748− , Box.vcat Box.left (map typeAtomAsBox ts)
749− ]
585+ , markCodeBox $ indent $ Box.hsep 1 Box.left
586+ [ line (showQualified runProperName nm)
587+ , Box.vcat Box.left (map typeAtomAsBox ts)
588+ ]
750589 , line "The following instances were found:"
751590 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
752591 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."
753592 , line "They may be disallowed completely in a future version of the compiler."
754593 ]
755594 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
756− renderSimpleErrorMessage (NoInstanceFound nm ts) =
595+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =
596+ paras [ line "A custom type error occurred while solving type class constraints:"
597+ , indent . paras . map line . lines $ message
598+ ]
599+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
600+ _
601+ (Just (PartialConstraintData bs b)))) =
602+ paras [ line "A case expression could not be determined to cover all inputs."
603+ , line "The following additional cases are required to cover all inputs:\n"
604+ , indent $ paras $
605+ Box.hsep 1 Box.left
606+ (map (paras . map (line . markCode)) (transpose bs))
607+ : [line "..." | not b]
608+ , line "Alternatively, add a Partial constraint to the type of the enclosing value."
609+ ]
610+ renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) =
757611 paras [ line "No type class instance was found for"
758− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
759− , Box.vcat Box.left (map typeAtomAsBox ts)
760− ]
612+ , markCodeBox $ indent $ Box.hsep 1 Box.left
613+ [ line (showQualified runProperName nm)
614+ , Box.vcat Box.left (map typeAtomAsBox ts)
615+ ]
761616 , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."
762617 | any containsUnknowns ts
763618 ]
@@ -770,130 +625,118 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
770625 go _ = False
771626 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
772627 paras [ line "Type class instance for"
773− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
774− , Box.vcat Box.left (map typeAtomAsBox ts)
775− ]
628+ , markCodeBox $ indent $ Box.hsep 1 Box.left
629+ [ line (showQualified runProperName nm)
630+ , Box.vcat Box.left (map typeAtomAsBox ts)
631+ ]
776632 , line "is possibly infinite."
777633 ]
778634 renderSimpleErrorMessage (CannotDerive nm ts) =
779635 paras [ line "Cannot derive a type class instance for"
780− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
781− , Box.vcat Box.left (map typeAtomAsBox ts)
782− ]
636+ , markCodeBox $ indent $ Box.hsep 1 Box.left
637+ [ line (showQualified runProperName nm)
638+ , Box.vcat Box.left (map typeAtomAsBox ts)
639+ ]
783640 ]
784641 renderSimpleErrorMessage (CannotFindDerivingType nm) =
785− line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
642+ line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
786643 renderSimpleErrorMessage (DuplicateLabel l expr) =
787− paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ]
644+ paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ]
788645 <> foldMap (\expr' -> [ line "Relevant expression: "
789− , indent $ prettyPrintValue valueDepth expr'
646+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr'
790647 ]) expr
791648 renderSimpleErrorMessage (DuplicateTypeArgument name) =
792− line $ "Type argument " ++ show name ++ " appears more than once."
649+ line $ "Type argument " ++ markCode name ++ " appears more than once."
793650 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
794− line $ "Multiple value declarations exist for " ++ showIdent nm ++ "."
651+ line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "."
795652 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
796− line $ "Argument list lengths differ in declaration " ++ showIdent ident
653+ line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident)
797654 renderSimpleErrorMessage (OverlappingArgNames ident) =
798655 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident
799656 renderSimpleErrorMessage (MissingClassMember ident) =
800− line $ "Type class member " ++ showIdent ident ++ " has not been implemented."
657+ line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented."
801658 renderSimpleErrorMessage (ExtraneousClassMember ident className) =
802− line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className
659+ line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className)
803660 renderSimpleErrorMessage (ExpectedType ty kind) =
804− paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
661+ paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "."
805662 , line "The error arises from the type"
806− , indent $ typeAsBox ty
663+ , markCodeBox $ indent $ typeAsBox ty
807664 , line "having the kind"
808− , indent $ line $ prettyPrintKind kind
665+ , indent $ line $ markCode $ prettyPrintKind kind
809666 , line "instead."
810667 ]
811668 renderSimpleErrorMessage (IncorrectConstructorArity nm) =
812− line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression."
669+ line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression."
813670 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
814671 paras [ line "Expression"
815− , indent $ prettyPrintValue valueDepth expr
672+ , markCodeBox $ indent $ prettyPrintValue valueDepth expr
816673 , line "does not have type"
817− , indent $ typeAsBox ty
674+ , markCodeBox $ indent $ typeAsBox ty
818675 ]
819676 renderSimpleErrorMessage (PropertyIsMissing prop) =
820− line $ "Type of expression lacks required label " ++ show prop ++ "."
677+ line $ "Type of expression lacks required label " ++ markCode prop ++ "."
821678 renderSimpleErrorMessage (AdditionalProperty prop) =
822− line $ "Type of expression contains additional label " ++ show prop ++ "."
679+ line $ "Type of expression contains additional label " ++ markCode prop ++ "."
823680 renderSimpleErrorMessage (CannotApplyFunction fn arg) =
824681 paras [ line "A function of type"
825− , indent $ typeAsBox fn
682+ , markCodeBox $ indent $ typeAsBox fn
826683 , line "can not be applied to the argument"
827− , indent $ prettyPrintValue valueDepth arg
684+ , markCodeBox $ indent $ prettyPrintValue valueDepth arg
828685 ]
829686 renderSimpleErrorMessage TypeSynonymInstance =
830687 line "Type class instances for type synonyms are disallowed."
831688 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
832− paras [ line $ "Type class instance " ++ showIdent nm ++ " for "
833− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)
834− , Box.vcat Box.left (map typeAtomAsBox ts)
835− ]
689+ paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for "
690+ , markCodeBox $ indent $ Box.hsep 1 Box.left
691+ [ line (showQualified runProperName cnm)
692+ , Box.vcat Box.left (map typeAtomAsBox ts)
693+ ]
836694 , line "is an orphan instance."
837695 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
838696 , line "Consider moving the instance, if possible, or using a newtype wrapper."
839697 ]
840698 renderSimpleErrorMessage (InvalidNewtype name) =
841− paras [ line $ "Newtype " ++ runProperName name ++ " is invalid."
699+ paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid."
842700 , line "Newtypes must define a single constructor with a single argument."
843701 ]
844702 renderSimpleErrorMessage (InvalidInstanceHead ty) =
845703 paras [ line "Type class instance head is invalid due to use of type"
846− , indent $ typeAsBox ty
704+ , markCodeBox $ indent $ typeAsBox ty
847705 , 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."
848706 ]
849707 renderSimpleErrorMessage (TransitiveExportError x ys) =
850− paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
851− , indent $ paras $ map (line . prettyPrintExport) ys
708+ paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: "
709+ , indent $ paras $ map (line . markCode . prettyPrintExport) ys
852710 ]
853711 renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =
854− paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: "
855− , indent $ line $ runProperName ctor
712+ paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: "
713+ , indent $ line $ markCode $ runProperName ctor
856714 ]
857715 renderSimpleErrorMessage (ShadowedName nm) =
858− line $ "Name '" ++ showIdent nm ++ "' was shadowed."
716+ line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed."
859717 renderSimpleErrorMessage (ShadowedTypeVar tv) =
860− line $ "Type variable '" ++ tv ++ "' was shadowed."
718+ line $ "Type variable " ++ markCode tv ++ " was shadowed."
861719 renderSimpleErrorMessage (UnusedTypeVar tv) =
862− line $ "Type variable '" ++ tv ++ "' was declared but not used."
863− renderSimpleErrorMessage (ClassOperator className opName) =
864− paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."
865− , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
866− , indent . line $ showIdent opName ++ " = someMember"
867− ]
720+ line $ "Type variable " ++ markCode tv ++ " was declared but not used."
868721 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
869− line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."
722+ line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors."
870723 renderSimpleErrorMessage (ImportHidingModule name) =
871− paras [ line "'hiding' imports cannot be used to hide modules."
872− , line $ "An attempt was made to hide the import of " ++ runModuleName name
873− ]
874− renderSimpleErrorMessage (WildcardInferredType ty) =
875− paras [ line "Wildcard type definition has the inferred type "
876− , indent $ typeAsBox ty
877− ]
878− renderSimpleErrorMessage (HoleInferredType name ty) =
879− paras [ line $ "Hole '" ++ name ++ "' has the inferred type "
880− , indent $ typeAsBox ty
881− ]
724+ paras [ line "hiding imports cannot be used to hide modules."
725+ , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)
726+ ]
727+ renderSimpleErrorMessage (WildcardInferredType ty ctx) =
728+ paras $ [ line "Wildcard type definition has the inferred type "
729+ , markCodeBox $ indent $ typeAsBox ty
730+ ] ++ renderContext ctx
731+ renderSimpleErrorMessage (HoleInferredType name ty ctx) =
732+ paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "
733+ , markCodeBox $ indent $ typeAsBox ty
734+ ] ++ renderContext ctx
882735 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =
883− paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."
736+ paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."
884737 , line "It is good practice to provide type declarations as a form of documentation."
885− , line $ "The inferred type of " ++ showIdent ident ++ " was:"
886− , indent $ typeAsBox ty
887− ]
888− renderSimpleErrorMessage (NotExhaustivePattern bs b) =
889− paras [ line "A case expression could not be determined to cover all inputs."
890− , line "The following additional cases are required to cover all inputs:\n"
891− , indent $ paras $
892− Box.hsep 1 Box.left
893− (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
894− : [line "..." | not b]
895− , line "Or alternatively, add a Partial constraint to the type of the enclosing value."
896− , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
738+ , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"
739+ , markCodeBox $ indent $ typeAsBox ty
897740 ]
898741 renderSimpleErrorMessage (OverlappingPattern bs b) =
899742 paras $ [ line "A case expression contains unreachable cases:\n"
@@ -905,109 +748,51 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
905748 , line "You may want to decompose your data types into smaller types."
906749 ]
907750 renderSimpleErrorMessage (UnusedImport name) =
908− line $ "The import of module " ++ runModuleName name ++ " is redundant"
751+ line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant"
909752
910753 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
911− paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"
754+ paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"
912755 , indent $ paras $ map line names
913756 , line "It could be replaced with:"
914− , indent $ line $ showSuggestion msg ]
757+ , indent $ line $ markCode $ showSuggestion msg ]
915758
916759 renderSimpleErrorMessage (UnusedDctorImport name) =
917− line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"
760+ line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used"
918761
919762 renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =
920− paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"
921− , indent $ paras $ map (line .runProperName) names ]
922−
923− renderSimpleErrorMessage (DeprecatedOperatorDecl name) =
924− paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."
925− , line "Operator aliases are declared by using a fixity declaration, for example:"
926− , indent $ line $ "infixl 9 someFunction as " ++ name
927− , line "Support for value-declared operators will be removed in PureScript 0.9."
928− ]
929−
930− renderSimpleErrorMessage (DeprecatedOperatorSection op val) =
931− paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:"
932− , indent $ foldr1 before $
933− case val of
934− Left l ->
935− [ line "("
936− , prettyPrintValue valueDepth l
937− , line " "
938− , renderOperator op
939− , line " _)"
940− ]
941− Right r ->
942− [ line "(_ "
943− , renderOperator op
944− , line " "
945− , prettyPrintValue valueDepth r
946− , line ")"
947− ]
948− , line "Support for legacy operator sections will be removed in PureScript 0.9."
949− ]
950− where
951− renderOperator (PositionedValue _ _ ex) = renderOperator ex
952− renderOperator (Var (Qualified _ (Op ident))) = line ident
953− renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ]
954− renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =
955− paras [ line "Import uses the deprecated 'qualified' syntax:"
956− , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName
957− , line "Should instead use the form:"
958− , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName
959− , line "The deprecated syntax will be removed in PureScript 0.9."
960− ]
961−
962− renderSimpleErrorMessage (DeprecatedClassImport mn name) =
963− paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:"
964− , indent $ line $ runProperName name
965− , line "Should instead use the form:"
966− , indent $ line $ "class " ++ runProperName name
967− , line "The deprecated syntax will be removed in PureScript 0.9."
968− ]
969−
970− renderSimpleErrorMessage (DeprecatedClassExport name) =
971− paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:"
972− , indent $ line $ runProperName name
973− , line "Should instead use the form:"
974− , indent $ line $ "class " ++ runProperName name
975− , line "The deprecated syntax will be removed in PureScript 0.9."
976− ]
763+ paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:"
764+ , indent $ paras $ map (line . markCode . runProperName) names ]
977765
978766 renderSimpleErrorMessage (DuplicateSelectiveImport name) =
979− line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists"
767+ line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"
980768
981769 renderSimpleErrorMessage (DuplicateImport name imp qual) =
982− line $ "Duplicate import of " ++ prettyPrintImport name imp qual
770+ line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual)
983771
984− renderSimpleErrorMessage (DuplicateImportRef ref) =
985− line $ "Import list contains multiple references to " ++ ref
772+ renderSimpleErrorMessage (DuplicateImportRef name) =
773+ line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)
986774
987− renderSimpleErrorMessage (DuplicateExportRef ref) =
988− line $ "Export list contains multiple references to " ++ ref
775+ renderSimpleErrorMessage (DuplicateExportRef name) =
776+ line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)
989777
990778 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =
991− paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."
992− , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]
993−
994− renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =
995− line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."
779+ paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend."
780+ , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ]
996781
997782 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =
998− paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."
999− , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"
1000− , indent $ line $ showSuggestion msg
783+ paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports."
784+ , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:"
785+ , indent $ line $ markCode $ showSuggestion msg
1001786 ]
1002787
1003788 renderSimpleErrorMessage msg@(ImplicitImport mn _) =
1004− paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "
1005− , indent $ line $ showSuggestion msg
789+ paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: "
790+ , indent $ line $ markCode $ showSuggestion msg
1006791 ]
1007792
1008793 renderSimpleErrorMessage msg@(HidingImport mn _) =
1009− paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "
1010− , indent $ line $ showSuggestion msg
794+ paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: "
795+ , indent $ line $ markCode $ showSuggestion msg
1011796 ]
1012797
1013798 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
@@ -1020,7 +805,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1020805 line "An anonymous function argument appears in an invalid context."
1021806
1022807 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
1023− paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."
808+ paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "."
1024809 , line "Only aliases for data constructors may be used in patterns."
1025810 ]
1026811
@@ -1028,9 +813,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1028813 line "The require-path option is deprecated and will be removed in PureScript 0.9."
1029814
1030815 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
1031− paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "."
1032− , line $ "The inferred type of " ++ showIdent ident ++ " was:"
1033− , indent $ typeAsBox ty
816+ paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "."
817+ , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"
818+ , markCodeBox $ indent $ typeAsBox ty
1034819 , line "Try adding a type signature."
1035820 ]
1036821
@@ -1038,42 +823,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1038823 renderHint (ErrorUnifyingTypes t1 t2) detail =
1039824 paras [ detail
1040825 , Box.hsep 1 Box.top [ line "while trying to match type"
1041− , typeAsBox t1
826+ , markCodeBox $ typeAsBox t1
1042827 ]
1043828 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"
1044− , typeAsBox t2
829+ , markCodeBox $ typeAsBox t2
1045830 ]
1046831 ]
1047832 renderHint (ErrorInExpression expr) detail =
1048833 paras [ detail
1049834 , Box.hsep 1 Box.top [ Box.text "in the expression"
1050− , prettyPrintValue valueDepth expr
835+ , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr
1051836 ]
1052837 ]
1053838 renderHint (ErrorInModule mn) detail =
1054− paras [ line $ "in module " ++ runModuleName mn
839+ paras [ line $ "in module " ++ markCode (runModuleName mn)
1055840 , detail
1056841 ]
1057842 renderHint (ErrorInSubsumption t1 t2) detail =
1058843 paras [ detail
1059844 , Box.hsep 1 Box.top [ line "while checking that type"
1060− , typeAsBox t1
845+ , markCodeBox $ typeAsBox t1
1061846 ]
1062847 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"
1063− , typeAsBox t2
848+ , markCodeBox $ typeAsBox t2
1064849 ]
1065850 ]
1066851 renderHint (ErrorInInstance nm ts) detail =
1067852 paras [ detail
1068− , Box.hsep 1 Box.top [ line "in type class instance"
1069− , line (showQualified runProperName nm)
1070− , Box.vcat Box.left (map typeAtomAsBox ts)
1071− ]
853+ , line "in type class instance"
854+ , markCodeBox $ indent $ Box.hsep 1 Box.top
855+ [ line $ showQualified runProperName nm
856+ , Box.vcat Box.left (map typeAtomAsBox ts)
857+ ]
1072858 ]
1073859 renderHint (ErrorCheckingKind ty) detail =
1074860 paras [ detail
1075861 , Box.hsep 1 Box.top [ line "while checking the kind of"
1076− , typeAsBox ty
862+ , markCodeBox $ typeAsBox ty
1077863 ]
1078864 ]
1079865 renderHint ErrorCheckingGuard detail =
@@ -1083,43 +869,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1083869 renderHint (ErrorInferringType expr) detail =
1084870 paras [ detail
1085871 , Box.hsep 1 Box.top [ line "while inferring the type of"
1086− , prettyPrintValue valueDepth expr
872+ , markCodeBox $ prettyPrintValue valueDepth expr
1087873 ]
1088874 ]
1089875 renderHint (ErrorCheckingType expr ty) detail =
1090876 paras [ detail
1091877 , Box.hsep 1 Box.top [ line "while checking that expression"
1092− , prettyPrintValue valueDepth expr
878+ , markCodeBox $ prettyPrintValue valueDepth expr
1093879 ]
1094880 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"
1095− , typeAsBox ty
881+ , markCodeBox $ typeAsBox ty
1096882 ]
1097883 ]
1098884 renderHint (ErrorCheckingAccessor expr prop) detail =
1099885 paras [ detail
1100886 , Box.hsep 1 Box.top [ line "while checking type of property accessor"
1101− , prettyPrintValue valueDepth (Accessor prop expr)
887+ , markCodeBox $ prettyPrintValue valueDepth (Accessor prop expr)
1102888 ]
1103889 ]
1104890 renderHint (ErrorInApplication f t a) detail =
1105891 paras [ detail
1106892 , Box.hsep 1 Box.top [ line "while applying a function"
1107− , prettyPrintValue valueDepth f
893+ , markCodeBox $ prettyPrintValue valueDepth f
1108894 ]
1109895 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"
1110− , typeAsBox t
896+ , markCodeBox $ typeAsBox t
1111897 ]
1112898 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"
1113− , prettyPrintValue valueDepth a
899+ , markCodeBox $ prettyPrintValue valueDepth a
1114900 ]
1115901 ]
1116902 renderHint (ErrorInDataConstructor nm) detail =
1117903 paras [ detail
1118− , line $ "in data constructor " ++ runProperName nm
904+ , line $ "in data constructor " ++ markCode (runProperName nm)
1119905 ]
1120906 renderHint (ErrorInTypeConstructor nm) detail =
1121907 paras [ detail
1122− , line $ "in type constructor " ++ runProperName nm
908+ , line $ "in type constructor " ++ markCode (runProperName nm)
1123909 ]
1124910 renderHint (ErrorInBindingGroup nms) detail =
1125911 paras [ detail
@@ -1131,25 +917,75 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
1131917 ]
1132918 renderHint (ErrorInTypeSynonym name) detail =
1133919 paras [ detail
1134− , line $ "in type synonym " ++ runProperName name
920+ , line $ "in type synonym " ++ markCode (runProperName name)
1135921 ]
1136922 renderHint (ErrorInValueDeclaration n) detail =
1137923 paras [ detail
1138− , line $ "in value declaration " ++ showIdent n
924+ , line $ "in value declaration " ++ markCode (showIdent n)
1139925 ]
1140926 renderHint (ErrorInTypeDeclaration n) detail =
1141927 paras [ detail
1142− , line $ "in type declaration for " ++ showIdent n
928+ , line $ "in type declaration for " ++ markCode (showIdent n)
1143929 ]
1144930 renderHint (ErrorInForeignImport nm) detail =
1145931 paras [ detail
1146− , line $ "in foreign import " ++ showIdent nm
932+ , line $ "in foreign import " ++ markCode (showIdent nm)
933+ ]
934+ renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =
935+ paras [ detail
936+ , line "while solving type class constriant"
937+ , markCodeBox $ indent $ Box.hsep 1 Box.left
938+ [ line (showQualified runProperName nm)
939+ , Box.vcat Box.left (map typeAtomAsBox ts)
940+ ]
1147941 ]
1148942 renderHint (PositionedError srcSpan) detail =
1149943 paras [ line $ "at " ++ displaySourceSpan srcSpan
1150944 , detail
1151945 ]
1152946
947+ renderContext :: Context -> [Box.Box]
948+ renderContext [] = []
949+ renderContext ctx =
950+ [ line "in the following context:"
951+ , indent $ paras
952+ [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
953+ , markCodeBox $ typeAsBox ty'
954+ ]
955+ | (ident, ty') <- take 5 ctx
956+ ]
957+ ]
958+
959+ printName :: Qualified Name -> String
960+ printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)
961+
962+ nameType :: Name -> String
963+ nameType (IdentName _) = "value"
964+ nameType (ValOpName _) = "operator"
965+ nameType (TyName _) = "type"
966+ nameType (TyOpName _) = "type operator"
967+ nameType (DctorName _) = "data constructor"
968+ nameType (TyClassName _) = "type class"
969+ nameType (ModName _) = "module"
970+
971+ runName :: Qualified Name -> String
972+ runName (Qualified mn (IdentName name)) =
973+ showQualified showIdent (Qualified mn name)
974+ runName (Qualified mn (ValOpName op)) =
975+ showQualified showOp (Qualified mn op)
976+ runName (Qualified mn (TyName name)) =
977+ showQualified runProperName (Qualified mn name)
978+ runName (Qualified mn (TyOpName op)) =
979+ showQualified showOp (Qualified mn op)
980+ runName (Qualified mn (DctorName name)) =
981+ showQualified runProperName (Qualified mn name)
982+ runName (Qualified mn (TyClassName name)) =
983+ showQualified runProperName (Qualified mn name)
984+ runName (Qualified Nothing (ModName name)) =
985+ runModuleName name
986+ runName (Qualified _ ModName{}) =
987+ internalError "qualified ModName in runName"
988+
1153989 valueDepth :: Int
1154990 valueDepth | full = 1000
1155991 | otherwise = 3
@@ -1192,6 +1028,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
11921028 where
11931029 isUnifyHint ErrorUnifyingTypes{} = True
11941030 isUnifyHint _ = False
1031+ stripRedudantHints NoInstanceFound{} = stripFirst isSolverHint
1032+ where
1033+ isSolverHint ErrorSolvingConstraint{} = True
1034+ isSolverHint _ = False
11951035 stripRedudantHints _ = id
11961036
11971037 stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]
@@ -1203,70 +1043,86 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
12031043 stripFirst _ [] = []
12041044
12051045 hintCategory :: ErrorMessageHint -> HintCategory
1206− hintCategory ErrorCheckingType{} = ExprHint
1207− hintCategory ErrorInferringType{} = ExprHint
1208− hintCategory ErrorInExpression{} = ExprHint
1209− hintCategory ErrorUnifyingTypes{} = CheckHint
1210− hintCategory ErrorInSubsumption{} = CheckHint
1211− hintCategory ErrorInApplication{} = CheckHint
1212− hintCategory ErrorCheckingKind{} = CheckHint
1213− hintCategory PositionedError{} = PositionHint
1214− hintCategory _ = OtherHint
1046+ hintCategory ErrorCheckingType{} = ExprHint
1047+ hintCategory ErrorInferringType{} = ExprHint
1048+ hintCategory ErrorInExpression{} = ExprHint
1049+ hintCategory ErrorUnifyingTypes{} = CheckHint
1050+ hintCategory ErrorInSubsumption{} = CheckHint
1051+ hintCategory ErrorInApplication{} = CheckHint
1052+ hintCategory ErrorCheckingKind{} = CheckHint
1053+ hintCategory ErrorSolvingConstraint{} = SolverHint
1054+ hintCategory PositionedError{} = PositionHint
1055+ hintCategory _ = OtherHint
12151056
12161057-- Pretty print and export declaration
12171058prettyPrintExport :: DeclarationRef -> String
12181059prettyPrintExport (TypeRef pn _) = runProperName pn
1219−prettyPrintExport ref = prettyPrintRef ref
1060+prettyPrintExport ref =
1061+ fromMaybe
1062+ (internalError "prettyPrintRef returned Nothing in prettyPrintExport")
1063+ (prettyPrintRef ref)
12201064
12211065prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
12221066prettyPrintImport mn idt qual =
12231067 let i = case idt of
12241068 Implicit -> runModuleName mn
1225− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
1226− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
1069+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"
1070+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"
12271071 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
12281072
1229−prettyPrintRef :: DeclarationRef -> String
1230−prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
1231−prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
1232−prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1233−prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident
1234−prettyPrintRef (ValueRef ident) = showIdent ident
1235−prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
1236−prettyPrintRef (ProperRef name) = name
1237−prettyPrintRef (TypeInstanceRef ident) = showIdent ident
1238−prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
1239−prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
1073+prettyPrintRef :: DeclarationRef -> Maybe String
1074+prettyPrintRef (TypeRef pn Nothing) =
1075+ Just $ runProperName pn ++ "(..)"
1076+prettyPrintRef (TypeRef pn (Just [])) =
1077+ Just $ runProperName pn
1078+prettyPrintRef (TypeRef pn (Just dctors)) =
1079+ Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1080+prettyPrintRef (TypeOpRef op) =
1081+ Just $ "type " ++ showOp op
1082+prettyPrintRef (ValueRef ident) =
1083+ Just $ showIdent ident
1084+prettyPrintRef (ValueOpRef op) =
1085+ Just $ showOp op
1086+prettyPrintRef (TypeClassRef pn) =
1087+ Just $ "class " ++ runProperName pn
1088+prettyPrintRef (TypeInstanceRef ident) =
1089+ Just $ showIdent ident
1090+prettyPrintRef (ModuleRef name) =
1091+ Just $ "module " ++ runModuleName name
1092+prettyPrintRef (ReExportRef _ _) =
1093+ Nothing
1094+prettyPrintRef (PositionedDeclarationRef _ _ ref) =
1095+ prettyPrintRef ref
12401096
12411097-- |
12421098-- Pretty print multiple errors
12431099--
1244−prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
1245−prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full
1100+prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String
1101+prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions
12461102
12471103-- |
12481104-- Pretty print multiple warnings
12491105--
1250−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
1251−prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full
1106+prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String
1107+prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions
12521108
12531109-- | Pretty print warnings as a Box
1254−prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]
1255−prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning"
1110+prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
1111+prettyPrintMultipleWarningsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Warning }) "Warning found:" "Warning"
12561112
12571113-- | Pretty print errors as a Box
1258−prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]
1259−prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"
1114+prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
1115+prettyPrintMultipleErrorsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Error }) "Error found:" "Error"
12601116
1261−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]
1262−prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
1263− let result = prettyPrintSingleError full level True e
1117+prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box]
1118+prettyPrintMultipleErrorsWith ppeOptions intro _ (MultipleErrors [e]) =
1119+ let result = prettyPrintSingleError ppeOptions e
12641120 in [ Box.vcat Box.left [ Box.text intro
12651121 , result
12661122 ]
12671123 ]
1268−prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =
1269− let result = map (prettyPrintSingleError full level True) es
1124+prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) =
1125+ let result = map (prettyPrintSingleError ppeOptions) es
12701126 in concat $ zipWith withIntro [1 :: Int ..] result
12711127 where
12721128 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")