{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Types.Error
(
Messages
, mkMessages
, getMessages
, emptyMessages
, isEmptyMessages
, singleMessage
, addMessage
, unionMessages
, unionManyMessages
, MsgEnvelope (..)
, MessageClass (..)
, Severity (..)
, Diagnostic (..)
, UnknownDiagnostic (..)
, DiagnosticMessage (..)
, DiagnosticReason (..)
, DiagnosticHint (..)
, mkPlainDiagnostic
, mkPlainError
, mkDecoratedDiagnostic
, mkDecoratedError
, NoDiagnosticOpts(..)
, GhcHint (..)
, AvailableBindings(..)
, LanguageExtensionHint(..)
, suggestExtension
, suggestExtensionWithInfo
, suggestExtensions
, suggestExtensionsWithInfo
, suggestAnyExtension
, suggestAnyExtensionWithInfo
, useExtensionInOrderTo
, noHints
, SDoc
, DecoratedSDoc (unDecorated)
, mkDecorated, mkSimpleDecorated
, unionDecoratedSDoc
, mapDecoratedSDoc
, pprMessageBag
, mkLocMessage
, mkLocMessageWarningGroups
, getCaretDiagnostic
, isIntrinsicErrorMessage
, isExtrinsicErrorMessage
, isWarningMessage
, getErrorMessages
, getWarningMessages
, partitionMessages
, errorsFound
, errorsOrFatalWarningsFound
, DiagnosticCode(..)
)
where
import GHC.Prelude
import GHC.Driver.Flags
import GHC.Data.Bag
import GHC.IO (catchException)
import GHC.Utils.Outputable as Outputable
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Hint
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json
import GHC.Utils.Panic
import Data.Bifunctor
import Data.Foldable ( fold )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
import Data.Typeable ( Typeable )
import Numeric.Natural ( Natural )
import Text.Printf ( printf )
newtype Messages e = Messages { forall e. Messages e -> Bag (MsgEnvelope e)
getMessages :: Bag (MsgEnvelope e) }
deriving newtype (NonEmpty (Messages e) -> Messages e
Messages e -> Messages e -> Messages e
(Messages e -> Messages e -> Messages e)
-> (NonEmpty (Messages e) -> Messages e)
-> (forall b. Integral b => b -> Messages e -> Messages e)
-> Semigroup (Messages e)
forall b. Integral b => b -> Messages e -> Messages e
forall e. NonEmpty (Messages e) -> Messages e
forall e. Messages e -> Messages e -> Messages e
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall e b. Integral b => b -> Messages e -> Messages e
$c<> :: forall e. Messages e -> Messages e -> Messages e
<> :: Messages e -> Messages e -> Messages e
$csconcat :: forall e. NonEmpty (Messages e) -> Messages e
sconcat :: NonEmpty (Messages e) -> Messages e
$cstimes :: forall e b. Integral b => b -> Messages e -> Messages e
stimes :: forall b. Integral b => b -> Messages e -> Messages e
Semigroup, Semigroup (Messages e)
Messages e
Semigroup (Messages e) =>
Messages e
-> (Messages e -> Messages e -> Messages e)
-> ([Messages e] -> Messages e)
-> Monoid (Messages e)
[Messages e] -> Messages e
Messages e -> Messages e -> Messages e
forall e. Semigroup (Messages e)
forall e. Messages e
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall e. [Messages e] -> Messages e
forall e. Messages e -> Messages e -> Messages e
$cmempty :: forall e. Messages e
mempty :: Messages e
$cmappend :: forall e. Messages e -> Messages e -> Messages e
mappend :: Messages e -> Messages e -> Messages e
$cmconcat :: forall e. [Messages e] -> Messages e
mconcat :: [Messages e] -> Messages e
Monoid)
deriving stock ((forall a b. (a -> b) -> Messages a -> Messages b)
-> (forall a b. a -> Messages b -> Messages a) -> Functor Messages
forall a b. a -> Messages b -> Messages a
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Messages a -> Messages b
fmap :: forall a b. (a -> b) -> Messages a -> Messages b
$c<$ :: forall a b. a -> Messages b -> Messages a
<$ :: forall a b. a -> Messages b -> Messages a
Functor, (forall m. Monoid m => Messages m -> m)
-> (forall m a. Monoid m => (a -> m) -> Messages a -> m)
-> (forall m a. Monoid m => (a -> m) -> Messages a -> m)
-> (forall a b. (a -> b -> b) -> b -> Messages a -> b)
-> (forall a b. (a -> b -> b) -> b -> Messages a -> b)
-> (forall b a. (b -> a -> b) -> b -> Messages a -> b)
-> (forall b a. (b -> a -> b) -> b -> Messages a -> b)
-> (forall a. (a -> a -> a) -> Messages a -> a)
-> (forall a. (a -> a -> a) -> Messages a -> a)
-> (forall a. Messages a -> [a])
-> (forall a. Messages a -> Bool)
-> (forall a. Messages a -> Int)
-> (forall a. Eq a => a -> Messages a -> Bool)
-> (forall a. Ord a => Messages a -> a)
-> (forall a. Ord a => Messages a -> a)
-> (forall a. Num a => Messages a -> a)
-> (forall a. Num a => Messages a -> a)
-> Foldable Messages
forall a. Eq a => a -> Messages a -> Bool
forall a. Num a => Messages a -> a
forall a. Ord a => Messages a -> a
forall m. Monoid m => Messages m -> m
forall a. Messages a -> Bool
forall a. Messages a -> Int
forall a. Messages a -> [a]
forall a. (a -> a -> a) -> Messages a -> a
forall m a. Monoid m => (a -> m) -> Messages a -> m
forall b a. (b -> a -> b) -> b -> Messages a -> b
forall a b. (a -> b -> b) -> b -> Messages a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Messages m -> m
fold :: forall m. Monoid m => Messages m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Messages a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Messages a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Messages a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Messages a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Messages a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Messages a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Messages a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Messages a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Messages a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Messages a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Messages a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Messages a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Messages a -> a
foldr1 :: forall a. (a -> a -> a) -> Messages a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Messages a -> a
foldl1 :: forall a. (a -> a -> a) -> Messages a -> a
$ctoList :: forall a. Messages a -> [a]
toList :: forall a. Messages a -> [a]
$cnull :: forall a. Messages a -> Bool
null :: forall a. Messages a -> Bool
$clength :: forall a. Messages a -> Int
length :: forall a. Messages a -> Int
$celem :: forall a. Eq a => a -> Messages a -> Bool
elem :: forall a. Eq a => a -> Messages a -> Bool
$cmaximum :: forall a. Ord a => Messages a -> a
maximum :: forall a. Ord a => Messages a -> a
$cminimum :: forall a. Ord a => Messages a -> a
minimum :: forall a. Ord a => Messages a -> a
$csum :: forall a. Num a => Messages a -> a
sum :: forall a. Num a => Messages a -> a
$cproduct :: forall a. Num a => Messages a -> a
product :: forall a. Num a => Messages a -> a
Foldable, Functor Messages
Foldable Messages
(Functor Messages, Foldable Messages) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b))
-> (forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b))
-> (forall (m :: * -> *) a.
Monad m =>
Messages (m a) -> m (Messages a))
-> Traversable Messages
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
$csequence :: forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
sequence :: forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
Traversable)
emptyMessages :: Messages e
emptyMessages :: forall e. Messages e
emptyMessages = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages Bag (MsgEnvelope e)
forall a. Bag a
emptyBag
mkMessages :: Bag (MsgEnvelope e) -> Messages e
mkMessages :: forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages (Bag (MsgEnvelope e) -> Messages e)
-> (Bag (MsgEnvelope e) -> Bag (MsgEnvelope e))
-> Bag (MsgEnvelope e)
-> Messages e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag MsgEnvelope e -> Bool
forall e. MsgEnvelope e -> Bool
interesting
where
interesting :: MsgEnvelope e -> Bool
interesting :: forall e. MsgEnvelope e -> Bool
interesting = Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Severity
SevIgnore (Severity -> Bool)
-> (MsgEnvelope e -> Severity) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity
isEmptyMessages :: Messages e -> Bool
isEmptyMessages :: forall a. Messages a -> Bool
isEmptyMessages (Messages Bag (MsgEnvelope e)
msgs) = Bag (MsgEnvelope e) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (MsgEnvelope e)
msgs
singleMessage :: MsgEnvelope e -> Messages e
singleMessage :: forall e. MsgEnvelope e -> Messages e
singleMessage MsgEnvelope e
e = MsgEnvelope e -> Messages e -> Messages e
forall e. MsgEnvelope e -> Messages e -> Messages e
addMessage MsgEnvelope e
e Messages e
forall e. Messages e
emptyMessages
instance Diagnostic e => Outputable (Messages e) where
ppr :: Messages e -> SDoc
ppr Messages e
msgs = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((MsgEnvelope e -> SDoc) -> [MsgEnvelope e] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope e -> SDoc
ppr_one (Bag (MsgEnvelope e) -> [MsgEnvelope e]
forall a. Bag a -> [a]
bagToList (Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
msgs))))
where
ppr_one :: MsgEnvelope e -> SDoc
ppr_one :: MsgEnvelope e -> SDoc
ppr_one MsgEnvelope e
envelope = e -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic (MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope e
envelope)
addMessage :: MsgEnvelope e -> Messages e -> Messages e
addMessage :: forall e. MsgEnvelope e -> Messages e -> Messages e
addMessage MsgEnvelope e
x (Messages Bag (MsgEnvelope e)
xs)
| Severity
SevIgnore <- MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope e
x = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages Bag (MsgEnvelope e)
xs
| Bool
otherwise = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages (MsgEnvelope e
x MsgEnvelope e -> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope e)
xs)
unionMessages :: Messages e -> Messages e -> Messages e
unionMessages :: forall e. Messages e -> Messages e -> Messages e
unionMessages (Messages Bag (MsgEnvelope e)
msgs1) (Messages Bag (MsgEnvelope e)
msgs2) =
Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages (Bag (MsgEnvelope e)
msgs1 Bag (MsgEnvelope e) -> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (MsgEnvelope e)
msgs2)
unionManyMessages :: Foldable f => f (Messages e) -> Messages e
unionManyMessages :: forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages = f (Messages e) -> Messages e
forall m. Monoid m => f m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
newtype DecoratedSDoc = Decorated { DecoratedSDoc -> [SDoc]
unDecorated :: [SDoc] }
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated = [SDoc] -> DecoratedSDoc
Decorated
mkSimpleDecorated :: SDoc -> DecoratedSDoc
mkSimpleDecorated :: SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
doc = [SDoc] -> DecoratedSDoc
Decorated [SDoc
doc]
unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc
unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc
unionDecoratedSDoc (Decorated [SDoc]
s1) (Decorated [SDoc]
s2) =
[SDoc] -> DecoratedSDoc
Decorated ([SDoc]
s1 [SDoc] -> [SDoc] -> [SDoc]
forall a. Monoid a => a -> a -> a
`mappend` [SDoc]
s2)
mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc
mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc
mapDecoratedSDoc SDoc -> SDoc
f (Decorated [SDoc]
s1) =
[SDoc] -> DecoratedSDoc
Decorated ((SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
f [SDoc]
s1)
class Diagnostic a where
type DiagnosticOpts a
defaultDiagnosticOpts :: DiagnosticOpts a
diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticReason :: a -> DiagnosticReason
diagnosticHints :: a -> [GhcHint]
diagnosticCode :: a -> Maybe DiagnosticCode
data UnknownDiagnostic where
UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a)
=> a -> UnknownDiagnostic
instance Diagnostic UnknownDiagnostic where
type DiagnosticOpts UnknownDiagnostic = NoDiagnosticOpts
defaultDiagnosticOpts :: DiagnosticOpts UnknownDiagnostic
defaultDiagnosticOpts = NoDiagnosticOpts
DiagnosticOpts UnknownDiagnostic
NoDiagnosticOpts
diagnosticMessage :: DiagnosticOpts UnknownDiagnostic
-> UnknownDiagnostic -> DecoratedSDoc
diagnosticMessage DiagnosticOpts UnknownDiagnostic
_ (UnknownDiagnostic a
diag) = DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage NoDiagnosticOpts
DiagnosticOpts a
NoDiagnosticOpts a
diag
diagnosticReason :: UnknownDiagnostic -> DiagnosticReason
diagnosticReason (UnknownDiagnostic a
diag) = a -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason a
diag
diagnosticHints :: UnknownDiagnostic -> [GhcHint]
diagnosticHints (UnknownDiagnostic a
diag) = a -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
diag
diagnosticCode :: UnknownDiagnostic -> Maybe DiagnosticCode
diagnosticCode (UnknownDiagnostic a
diag) = a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
diag
data NoDiagnosticOpts = NoDiagnosticOpts
pprDiagnostic :: forall e . Diagnostic e => e -> SDoc
pprDiagnostic :: forall e. Diagnostic e => e -> SDoc
pprDiagnostic e
e = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
e)
, Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (DiagnosticOpts e -> e -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts e
opts e
e))) ]
where opts :: DiagnosticOpts e
opts = forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @e
data DiagnosticHint = DiagnosticHint !SDoc
instance Outputable DiagnosticHint where
ppr :: DiagnosticHint -> SDoc
ppr (DiagnosticHint SDoc
msg) = SDoc
msg
data DiagnosticMessage = DiagnosticMessage
{ DiagnosticMessage -> DecoratedSDoc
diagMessage :: !DecoratedSDoc
, DiagnosticMessage -> DiagnosticReason
diagReason :: !DiagnosticReason
, DiagnosticMessage -> [GhcHint]
diagHints :: [GhcHint]
}
instance Diagnostic DiagnosticMessage where
type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts
defaultDiagnosticOpts :: DiagnosticOpts DiagnosticMessage
defaultDiagnosticOpts = NoDiagnosticOpts
DiagnosticOpts DiagnosticMessage
NoDiagnosticOpts
diagnosticMessage :: DiagnosticOpts DiagnosticMessage
-> DiagnosticMessage -> DecoratedSDoc
diagnosticMessage DiagnosticOpts DiagnosticMessage
_ = DiagnosticMessage -> DecoratedSDoc
diagMessage
diagnosticReason :: DiagnosticMessage -> DiagnosticReason
diagnosticReason = DiagnosticMessage -> DiagnosticReason
diagReason
diagnosticHints :: DiagnosticMessage -> [GhcHint]
diagnosticHints = DiagnosticMessage -> [GhcHint]
diagHints
diagnosticCode :: DiagnosticMessage -> Maybe DiagnosticCode
diagnosticCode DiagnosticMessage
_ = Maybe DiagnosticCode
forall a. Maybe a
Nothing
noHints :: [GhcHint]
noHints :: [GhcHint]
noHints = [GhcHint]
forall a. Monoid a => a
mempty
mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
rea [GhcHint]
hints SDoc
doc = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage (SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
doc) DiagnosticReason
rea [GhcHint]
hints
mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
hints SDoc
doc = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage (SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
doc) DiagnosticReason
ErrorWithoutFlag [GhcHint]
hints
mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedDiagnostic DiagnosticReason
rea [GhcHint]
hints [SDoc]
docs = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc]
docs) DiagnosticReason
rea [GhcHint]
hints
mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedError [GhcHint]
hints [SDoc]
docs = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc]
docs) DiagnosticReason
ErrorWithoutFlag [GhcHint]
hints
data DiagnosticReason
= WarningWithoutFlag
| WarningWithFlag !WarningFlag
| ErrorWithoutFlag
deriving (DiagnosticReason -> DiagnosticReason -> Bool
(DiagnosticReason -> DiagnosticReason -> Bool)
-> (DiagnosticReason -> DiagnosticReason -> Bool)
-> Eq DiagnosticReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiagnosticReason -> DiagnosticReason -> Bool
== :: DiagnosticReason -> DiagnosticReason -> Bool
$c/= :: DiagnosticReason -> DiagnosticReason -> Bool
/= :: DiagnosticReason -> DiagnosticReason -> Bool
Eq, Int -> DiagnosticReason -> ShowS
[DiagnosticReason] -> ShowS
DiagnosticReason -> String
(Int -> DiagnosticReason -> ShowS)
-> (DiagnosticReason -> String)
-> ([DiagnosticReason] -> ShowS)
-> Show DiagnosticReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiagnosticReason -> ShowS
showsPrec :: Int -> DiagnosticReason -> ShowS
$cshow :: DiagnosticReason -> String
show :: DiagnosticReason -> String
$cshowList :: [DiagnosticReason] -> ShowS
showList :: [DiagnosticReason] -> ShowS
Show)
instance Outputable DiagnosticReason where
ppr :: DiagnosticReason -> SDoc
ppr = \case
DiagnosticReason
WarningWithoutFlag -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WarningWithoutFlag"
WarningWithFlag WarningFlag
wf -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"WarningWithFlag " String -> ShowS
forall a. [a] -> [a] -> [a]
++ WarningFlag -> String
forall a. Show a => a -> String
show WarningFlag
wf)
DiagnosticReason
ErrorWithoutFlag -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ErrorWithoutFlag"
data MsgEnvelope e = MsgEnvelope
{ forall e. MsgEnvelope e -> SrcSpan
errMsgSpan :: SrcSpan
, forall e. MsgEnvelope e -> NamePprCtx
errMsgContext :: NamePprCtx
, forall e. MsgEnvelope e -> e
errMsgDiagnostic :: e
, forall e. MsgEnvelope e -> Severity
errMsgSeverity :: Severity
} deriving ((forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b)
-> (forall a b. a -> MsgEnvelope b -> MsgEnvelope a)
-> Functor MsgEnvelope
forall a b. a -> MsgEnvelope b -> MsgEnvelope a
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
fmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
$c<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
Functor, (forall m. Monoid m => MsgEnvelope m -> m)
-> (forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m)
-> (forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m)
-> (forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b)
-> (forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b)
-> (forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b)
-> (forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b)
-> (forall a. (a -> a -> a) -> MsgEnvelope a -> a)
-> (forall a. (a -> a -> a) -> MsgEnvelope a -> a)
-> (forall a. MsgEnvelope a -> [a])
-> (forall e. MsgEnvelope e -> Bool)
-> (forall a. MsgEnvelope a -> Int)
-> (forall a. Eq a => a -> MsgEnvelope a -> Bool)
-> (forall a. Ord a => MsgEnvelope a -> a)
-> (forall a. Ord a => MsgEnvelope a -> a)
-> (forall a. Num a => MsgEnvelope a -> a)
-> (forall a. Num a => MsgEnvelope a -> a)
-> Foldable MsgEnvelope
forall a. Eq a => a -> MsgEnvelope a -> Bool
forall a. Num a => MsgEnvelope a -> a
forall a. Ord a => MsgEnvelope a -> a
forall m. Monoid m => MsgEnvelope m -> m
forall e. MsgEnvelope e -> Bool
forall a. MsgEnvelope a -> Int
forall a. MsgEnvelope a -> [a]
forall a. (a -> a -> a) -> MsgEnvelope a -> a
forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => MsgEnvelope m -> m
fold :: forall m. Monoid m => MsgEnvelope m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
foldr :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
foldl :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
foldr1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
foldl1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
$ctoList :: forall a. MsgEnvelope a -> [a]
toList :: forall a. MsgEnvelope a -> [a]
$cnull :: forall e. MsgEnvelope e -> Bool
null :: forall e. MsgEnvelope e -> Bool
$clength :: forall a. MsgEnvelope a -> Int
length :: forall a. MsgEnvelope a -> Int
$celem :: forall a. Eq a => a -> MsgEnvelope a -> Bool
elem :: forall a. Eq a => a -> MsgEnvelope a -> Bool
$cmaximum :: forall a. Ord a => MsgEnvelope a -> a
maximum :: forall a. Ord a => MsgEnvelope a -> a
$cminimum :: forall a. Ord a => MsgEnvelope a -> a
minimum :: forall a. Ord a => MsgEnvelope a -> a
$csum :: forall a. Num a => MsgEnvelope a -> a
sum :: forall a. Num a => MsgEnvelope a -> a
$cproduct :: forall a. Num a => MsgEnvelope a -> a
product :: forall a. Num a => MsgEnvelope a -> a
Foldable, Functor MsgEnvelope
Foldable MsgEnvelope
(Functor MsgEnvelope, Foldable MsgEnvelope) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b))
-> (forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b))
-> (forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a))
-> Traversable MsgEnvelope
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
sequence :: forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
Traversable)
data MessageClass
= MCOutput
| MCFatal
| MCInteractive
| MCDump
| MCInfo
| MCDiagnostic Severity DiagnosticReason (Maybe DiagnosticCode)
data Severity
= SevIgnore
| SevWarning
| SevError
deriving (Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
/= :: Severity -> Severity -> Bool
Eq, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Severity -> ShowS
showsPrec :: Int -> Severity -> ShowS
$cshow :: Severity -> String
show :: Severity -> String
$cshowList :: [Severity] -> ShowS
showList :: [Severity] -> ShowS
Show)
instance Outputable Severity where
ppr :: Severity -> SDoc
ppr = \case
Severity
SevIgnore -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SevIgnore"
Severity
SevWarning -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SevWarning"
Severity
SevError -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SevError"
instance ToJson Severity where
json :: Severity -> JsonDoc
json Severity
s = String -> JsonDoc
JSString (Severity -> String
forall a. Show a => a -> String
show Severity
s)
instance ToJson MessageClass where
json :: MessageClass -> JsonDoc
json MessageClass
MCOutput = String -> JsonDoc
JSString String
"MCOutput"
json MessageClass
MCFatal = String -> JsonDoc
JSString String
"MCFatal"
json MessageClass
MCInteractive = String -> JsonDoc
JSString String
"MCInteractive"
json MessageClass
MCDump = String -> JsonDoc
JSString String
"MCDump"
json MessageClass
MCInfo = String -> JsonDoc
JSString String
"MCInfo"
json (MCDiagnostic Severity
sev DiagnosticReason
reason Maybe DiagnosticCode
code) =
String -> JsonDoc
JSString (String -> JsonDoc) -> String -> JsonDoc
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MCDiagnostic" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Severity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Severity
sev SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
reason SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe DiagnosticCode
code)
instance Show (MsgEnvelope DiagnosticMessage) where
show :: MsgEnvelope DiagnosticMessage -> String
show = MsgEnvelope DiagnosticMessage -> String
forall a. Diagnostic a => MsgEnvelope a -> String
showMsgEnvelope
showMsgEnvelope :: forall a . Diagnostic a => MsgEnvelope a -> String
showMsgEnvelope :: forall a. Diagnostic a => MsgEnvelope a -> String
showMsgEnvelope MsgEnvelope a
err =
SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (DecoratedSDoc -> [SDoc]) -> (a -> DecoratedSDoc) -> a -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @a)) (a -> [SDoc]) -> a -> [SDoc]
forall a b. (a -> b) -> a -> b
$ MsgEnvelope a -> a
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope a
err))
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag Bag SDoc
msgs = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
blankLine (Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
msgs))
mkLocMessage
:: MessageClass
-> SrcSpan
-> SDoc
-> SDoc
mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage = Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageWarningGroups Bool
True
mkLocMessageWarningGroups
:: Bool
-> MessageClass
-> SrcSpan
-> SDoc
-> SDoc
mkLocMessageWarningGroups :: Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageWarningGroups Bool
show_warn_groups MessageClass
msg_class SrcSpan
locn SDoc
msg
= (SDocContext -> Scheme) -> (Scheme -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Scheme
sdocColScheme ((Scheme -> SDoc) -> SDoc) -> (Scheme -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
let locn' :: SDoc
locn' = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocErrorSpans ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
Bool
True -> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
locn
Bool
False -> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
locn)
msg_colour :: PprColour
msg_colour = MessageClass -> Scheme -> PprColour
getMessageClassColour MessageClass
msg_class Scheme
col_scheme
col :: String -> SDoc
col = PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (SDoc -> SDoc) -> (String -> SDoc) -> String -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
text
msg_title :: SDoc
msg_title = PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
case MessageClass
msg_class of
MCDiagnostic Severity
SevError DiagnosticReason
_ Maybe DiagnosticCode
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"error"
MCDiagnostic Severity
SevWarning DiagnosticReason
_ Maybe DiagnosticCode
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"warning"
MessageClass
MCFatal -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fatal"
MessageClass
_ -> SDoc
forall doc. IsOutput doc => doc
empty
warning_flag_doc :: SDoc
warning_flag_doc =
case MessageClass
msg_class of
MCDiagnostic Severity
sev DiagnosticReason
reason Maybe DiagnosticCode
_code
| Just SDoc
msg <- Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
sev DiagnosticReason
reason -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets SDoc
msg
MessageClass
_ -> SDoc
forall doc. IsOutput doc => doc
empty
code_doc :: SDoc
code_doc =
case MessageClass
msg_class of
MCDiagnostic Severity
_ DiagnosticReason
_ (Just DiagnosticCode
code) -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
code)
MessageClass
_ -> SDoc
forall doc. IsOutput doc => doc
empty
flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
SevIgnore DiagnosticReason
_ = Maybe SDoc
forall a. Maybe a
Nothing
flag_msg Severity
SevError DiagnosticReason
WarningWithoutFlag = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
col String
"-Werror")
flag_msg Severity
SevError (WarningWithFlag WarningFlag
wflag) =
let name :: String
name = NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty String
warnFlagNames WarningFlag
wflag) in
SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
col (String
"-W" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WarningFlag -> SDoc
warn_flag_grp WarningFlag
wflag
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
col (String
"Werror=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)
flag_msg Severity
SevError DiagnosticReason
ErrorWithoutFlag = Maybe SDoc
forall a. Maybe a
Nothing
flag_msg Severity
SevWarning DiagnosticReason
WarningWithoutFlag = Maybe SDoc
forall a. Maybe a
Nothing
flag_msg Severity
SevWarning (WarningWithFlag WarningFlag
wflag) =
let name :: String
name = NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty String
warnFlagNames WarningFlag
wflag) in
SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
col (String
"-W" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WarningFlag -> SDoc
warn_flag_grp WarningFlag
wflag)
flag_msg Severity
SevWarning DiagnosticReason
ErrorWithoutFlag =
String -> SDoc -> Maybe SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SevWarning with ErrorWithoutFlag" (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"locn:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
locn
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"msg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
msg ]
warn_flag_grp :: WarningFlag -> SDoc
warn_flag_grp WarningFlag
flag
| Bool
show_warn_groups =
case WarningFlag -> [String]
smallestWarningGroups WarningFlag
flag of
[] -> SDoc
forall doc. IsOutput doc => doc
empty
[String]
groups -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"(in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-W"String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
groups) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
| Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty
header :: SDoc
header = SDoc
locn' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc
msg_title SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc
code_doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
warning_flag_doc
in PprColour -> SDoc -> SDoc
coloured (Scheme -> PprColour
Col.sMessage Scheme
col_scheme)
(SDoc -> Int -> SDoc -> SDoc
hang (PprColour -> SDoc -> SDoc
coloured (Scheme -> PprColour
Col.sHeader Scheme
col_scheme) SDoc
header) Int
4
SDoc
msg)
getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
getMessageClassColour :: MessageClass -> Scheme -> PprColour
getMessageClassColour (MCDiagnostic Severity
SevError DiagnosticReason
_reason Maybe DiagnosticCode
_code) = Scheme -> PprColour
Col.sError
getMessageClassColour (MCDiagnostic Severity
SevWarning DiagnosticReason
_reason Maybe DiagnosticCode
_code) = Scheme -> PprColour
Col.sWarning
getMessageClassColour MessageClass
MCFatal = Scheme -> PprColour
Col.sFatal
getMessageClassColour MessageClass
_ = PprColour -> Scheme -> PprColour
forall a b. a -> b -> a
const PprColour
forall a. Monoid a => a
mempty
getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic MessageClass
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
forall doc. IsOutput doc => doc
empty
getCaretDiagnostic MessageClass
msg_class (RealSrcSpan RealSrcSpan
span Maybe BufSpan
_) =
Maybe String -> SDoc
caretDiagnostic (Maybe String -> SDoc) -> IO (Maybe String) -> IO SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Int -> IO (Maybe String)
getSrcLine (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span) Int
row
where
getSrcLine :: FastString -> Int -> IO (Maybe String)
getSrcLine FastString
fn Int
i =
Int -> String -> IO (Maybe String)
getLine Int
i (FastString -> String
unpackFS FastString
fn)
IO (Maybe String)
-> (IOError -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(IOError
_ :: IOError) ->
Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
getLine :: Int -> String -> IO (Maybe String)
getLine Int
i String
fn = do
StringBuffer
content <- String -> IO StringBuffer
hGetStringBuffer String
fn
case Int -> StringBuffer -> Maybe StringBuffer
atLine Int
i StringBuffer
content of
Just StringBuffer
at_line -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
case String -> [String]
lines (Char -> Char
fix (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StringBuffer -> Int -> String
lexemeToString StringBuffer
at_line (StringBuffer -> Int
len StringBuffer
at_line)) of
String
srcLine : [String]
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
srcLine
[String]
_ -> Maybe String
forall a. Maybe a
Nothing
Maybe StringBuffer
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
fix :: Char -> Char
fix Char
'\0' = Char
'\xfffd'
fix Char
c = Char
c
row :: Int
row = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span
rowStr :: String
rowStr = Int -> String
forall a. Show a => a -> String
show Int
row
multiline :: Bool
multiline = Int
row Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span
caretDiagnostic :: Maybe String -> SDoc
caretDiagnostic Maybe String
Nothing = SDoc
forall doc. IsOutput doc => doc
empty
caretDiagnostic (Just String
srcLineWithNewline) =
(SDocContext -> Scheme) -> (Scheme -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Scheme
sdocColScheme((Scheme -> SDoc) -> SDoc) -> (Scheme -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
let sevColour :: PprColour
sevColour = MessageClass -> Scheme -> PprColour
getMessageClassColour MessageClass
msg_class Scheme
col_scheme
marginColour :: PprColour
marginColour = Scheme -> PprColour
Col.sMargin Scheme
col_scheme
in
PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
marginSpace) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"\n") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
marginRow) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcLinePre) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
srcLineSpan) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
srcLinePost String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
marginSpace) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
caretLine))
where
expandTabs :: Int -> Int -> ShowS
expandTabs Int
tabWidth Int
i String
s =
case String
s of
String
"" -> String
""
Char
'\t' : String
cs -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
effectiveWidth Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++
Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
effectiveWidth) String
cs
Char
c : String
cs -> Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
cs
where effectiveWidth :: Int
effectiveWidth = Int
tabWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tabWidth
srcLine :: String
srcLine = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (Int -> Int -> ShowS
expandTabs Int
8 Int
0 String
srcLineWithNewline)
start :: Int
start = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
end :: Int
end | Bool
multiline = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
srcLine
| Bool
otherwise = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)
marginWidth :: Int
marginWidth = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rowStr
marginSpace :: String
marginSpace = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
marginWidth Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |"
marginRow :: String
marginRow = String
rowStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |"
(String
srcLinePre, String
srcLineRest) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
start String
srcLine
(String
srcLineSpan, String
srcLinePost) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
width String
srcLineRest
caretEllipsis :: String
caretEllipsis | Bool
multiline = String
"..."
| Bool
otherwise = String
""
caretLine :: String
caretLine = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
start Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
'^' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
caretEllipsis
isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage :: forall e. Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage = DiagnosticReason -> DiagnosticReason -> Bool
forall a. Eq a => a -> a -> Bool
(==) DiagnosticReason
ErrorWithoutFlag (DiagnosticReason -> Bool)
-> (MsgEnvelope e -> DiagnosticReason) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason (e -> DiagnosticReason)
-> (MsgEnvelope e -> e) -> MsgEnvelope e -> DiagnosticReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic
isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage :: forall e. Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage = Bool -> Bool
not (Bool -> Bool) -> (MsgEnvelope e -> Bool) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> Bool
forall e. Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage
errorsFound :: Diagnostic e => Messages e -> Bool
errorsFound :: forall e. Diagnostic e => Messages e -> Bool
errorsFound (Messages Bag (MsgEnvelope e)
msgs) = (MsgEnvelope e -> Bool) -> Bag (MsgEnvelope e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any MsgEnvelope e -> Bool
forall e. Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage Bag (MsgEnvelope e)
msgs
isExtrinsicErrorMessage :: MsgEnvelope e -> Bool
isExtrinsicErrorMessage :: forall e. MsgEnvelope e -> Bool
isExtrinsicErrorMessage = Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
(==) Severity
SevError (Severity -> Bool)
-> (MsgEnvelope e -> Severity) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity
errorsOrFatalWarningsFound :: Messages e -> Bool
errorsOrFatalWarningsFound :: forall a. Messages a -> Bool
errorsOrFatalWarningsFound (Messages Bag (MsgEnvelope e)
msgs) = (MsgEnvelope e -> Bool) -> Bag (MsgEnvelope e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any MsgEnvelope e -> Bool
forall e. MsgEnvelope e -> Bool
isExtrinsicErrorMessage Bag (MsgEnvelope e)
msgs
getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages :: forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages (Messages Bag (MsgEnvelope e)
xs) = (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) -> Bag (MsgEnvelope e)
forall a b. (a, b) -> a
fst ((Bag (MsgEnvelope e), Bag (MsgEnvelope e)) -> Bag (MsgEnvelope e))
-> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
-> Bag (MsgEnvelope e)
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e)
-> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag MsgEnvelope e -> Bool
forall e. Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs
getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages :: forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages (Messages Bag (MsgEnvelope e)
xs) = (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) -> Bag (MsgEnvelope e)
forall a b. (a, b) -> a
fst ((Bag (MsgEnvelope e), Bag (MsgEnvelope e)) -> Bag (MsgEnvelope e))
-> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
-> Bag (MsgEnvelope e)
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e)
-> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag MsgEnvelope e -> Bool
forall e. Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage Bag (MsgEnvelope e)
xs
partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages :: forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages (Messages Bag (MsgEnvelope e)
xs) = (Bag (MsgEnvelope e) -> Messages e)
-> (Bag (MsgEnvelope e) -> Messages e)
-> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
-> (Messages e, Messages e)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages ((MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e)
-> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag MsgEnvelope e -> Bool
forall e. Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs)
data DiagnosticCode =
DiagnosticCode
{ DiagnosticCode -> String
diagnosticCodeNameSpace :: String
, DiagnosticCode -> Natural
diagnosticCodeNumber :: Natural
}
instance Outputable DiagnosticCode where
ppr :: DiagnosticCode -> SDoc
ppr (DiagnosticCode String
prefix Natural
c) =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
prefix SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> Natural -> String
forall r. PrintfType r => String -> r
printf String
"%05d" Natural
c)