{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
module GHC.Types.Error
(
Messages
, mkMessages
, getMessages
, emptyMessages
, isEmptyMessages
, singleMessage
, addMessage
, unionMessages
, unionManyMessages
, filterMessages
, MsgEnvelope (..)
, MessageClass (..)
, Severity (..)
, Diagnostic (..)
, UnknownDiagnostic (..)
, mkSimpleUnknownDiagnostic
, mkUnknownDiagnostic
, embedUnknownDiagnostic
, DiagnosticMessage (..)
, DiagnosticReason (WarningWithFlag, ..)
, ResolvedDiagnosticReason(..)
, DiagnosticHint (..)
, mkPlainDiagnostic
, mkPlainError
, mkDecoratedDiagnostic
, mkDecoratedError
, pprDiagnostic
, HasDefaultDiagnosticOpts(..)
, defaultDiagnosticOpts
, 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 GHC.Unit.Module.Warnings (WarningCategory)
import Data.Bifunctor
import Data.Foldable ( fold, toList )
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
import Data.Typeable ( Typeable )
import Numeric.Natural ( Natural )
import Text.Printf ( printf )
import GHC.Version (cProjectVersion)
import GHC.Types.Hint.Ppr ()
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 =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Resolved:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ResolvedDiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr (MsgEnvelope e -> ResolvedDiagnosticReason
forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason MsgEnvelope e
envelope),
e -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic (MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope e
envelope)
]
instance Diagnostic e => ToJson (Messages e) where
json :: Messages e -> JsonDoc
json Messages e
msgs = [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc)
-> (Bag JsonDoc -> [JsonDoc]) -> Bag JsonDoc -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag JsonDoc -> [JsonDoc]
forall a. Bag a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Bag JsonDoc -> JsonDoc) -> Bag JsonDoc -> JsonDoc
forall a b. (a -> b) -> a -> b
$ MsgEnvelope e -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (MsgEnvelope e -> JsonDoc) -> Bag (MsgEnvelope e) -> Bag JsonDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
msgs
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
filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e
filterMessages :: forall e. (MsgEnvelope e -> Bool) -> Messages e -> Messages e
filterMessages MsgEnvelope e -> Bool
f (Messages Bag (MsgEnvelope e)
msgs) =
Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages ((MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag MsgEnvelope e -> Bool
f Bag (MsgEnvelope e)
msgs)
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 HasDefaultDiagnosticOpts opts where
defaultOpts :: opts
defaultDiagnosticOpts :: forall opts . HasDefaultDiagnosticOpts (DiagnosticOpts opts) => DiagnosticOpts opts
defaultDiagnosticOpts :: forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts = forall opts. HasDefaultDiagnosticOpts opts => opts
defaultOpts @(DiagnosticOpts opts)
class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
type DiagnosticOpts a
diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticReason :: a -> DiagnosticReason
diagnosticHints :: a -> [GhcHint]
diagnosticCode :: a -> Maybe DiagnosticCode
data UnknownDiagnostic opts where
UnknownDiagnostic :: (Diagnostic a, Typeable a)
=> (opts -> DiagnosticOpts a)
-> a
-> UnknownDiagnostic opts
instance HasDefaultDiagnosticOpts opts => Diagnostic (UnknownDiagnostic opts) where
type DiagnosticOpts (UnknownDiagnostic opts) = opts
diagnosticMessage :: DiagnosticOpts (UnknownDiagnostic opts)
-> UnknownDiagnostic opts -> DecoratedSDoc
diagnosticMessage DiagnosticOpts (UnknownDiagnostic opts)
opts (UnknownDiagnostic opts -> DiagnosticOpts a
f a
diag) = DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (opts -> DiagnosticOpts a
f opts
DiagnosticOpts (UnknownDiagnostic opts)
opts) a
diag
diagnosticReason :: UnknownDiagnostic opts -> DiagnosticReason
diagnosticReason (UnknownDiagnostic opts -> DiagnosticOpts a
_ a
diag) = a -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason a
diag
diagnosticHints :: UnknownDiagnostic opts -> [GhcHint]
diagnosticHints (UnknownDiagnostic opts -> DiagnosticOpts a
_ a
diag) = a -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
diag
diagnosticCode :: UnknownDiagnostic opts -> Maybe DiagnosticCode
diagnosticCode (UnknownDiagnostic opts -> DiagnosticOpts a
_ a
diag) = a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
diag
data NoDiagnosticOpts = NoDiagnosticOpts
instance HasDefaultDiagnosticOpts NoDiagnosticOpts where
defaultOpts :: NoDiagnosticOpts
defaultOpts = NoDiagnosticOpts
NoDiagnosticOpts
mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic :: forall a b.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic = (b -> DiagnosticOpts a) -> a -> UnknownDiagnostic b
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
UnknownDiagnostic (NoDiagnosticOpts -> b -> NoDiagnosticOpts
forall a b. a -> b -> a
const NoDiagnosticOpts
NoDiagnosticOpts)
mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic :: forall a.
(Typeable a, Diagnostic a) =>
a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic = (DiagnosticOpts a -> DiagnosticOpts a)
-> a -> UnknownDiagnostic (DiagnosticOpts a)
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
UnknownDiagnostic DiagnosticOpts a -> DiagnosticOpts a
forall a. a -> a
id
embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
embedUnknownDiagnostic :: forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
embedUnknownDiagnostic = (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
UnknownDiagnostic
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 opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
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
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
| WarningWithFlags !(NE.NonEmpty WarningFlag)
| WarningWithCategory !WarningCategory
| 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)
newtype ResolvedDiagnosticReason
= ResolvedDiagnosticReason { ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason :: DiagnosticReason }
pattern WarningWithFlag :: WarningFlag -> DiagnosticReason
pattern $mWarningWithFlag :: forall {r}.
DiagnosticReason -> (WarningFlag -> r) -> ((# #) -> r) -> r
$bWarningWithFlag :: WarningFlag -> DiagnosticReason
WarningWithFlag w = WarningWithFlags (w :| [])
instance Outputable DiagnosticReason where
ppr :: DiagnosticReason -> SDoc
ppr = \case
DiagnosticReason
WarningWithoutFlag -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WarningWithoutFlag"
WarningWithFlags NonEmpty WarningFlag
wf -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"WarningWithFlags " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonEmpty WarningFlag -> String
forall a. Show a => a -> String
show NonEmpty WarningFlag
wf)
WarningWithCategory WarningCategory
cat -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WarningWithCategory" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat
DiagnosticReason
ErrorWithoutFlag -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ErrorWithoutFlag"
instance Outputable ResolvedDiagnosticReason where
ppr :: ResolvedDiagnosticReason -> SDoc
ppr = DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DiagnosticReason -> SDoc)
-> (ResolvedDiagnosticReason -> DiagnosticReason)
-> ResolvedDiagnosticReason
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason
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
, forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason :: ResolvedDiagnosticReason
} 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 ResolvedDiagnosticReason (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, Eq Severity
Eq Severity =>
(Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Severity -> Severity -> Ordering
compare :: Severity -> Severity -> Ordering
$c< :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
>= :: Severity -> Severity -> Bool
$cmax :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
min :: Severity -> Severity -> Severity
Ord, 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
SevIgnore = String -> JsonDoc
JSString String
"Ignore"
json Severity
SevWarning = String -> JsonDoc
JSString String
"Warning"
json Severity
SevError = String -> JsonDoc
JSString String
"Error"
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 ResolvedDiagnosticReason
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
<+> ResolvedDiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr ResolvedDiagnosticReason
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 ToJson DiagnosticCode where
json :: DiagnosticCode -> JsonDoc
json DiagnosticCode
c = Int -> JsonDoc
JSInt (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DiagnosticCode -> Natural
diagnosticCodeNumber DiagnosticCode
c))
schemaVersion :: String
schemaVersion :: String
schemaVersion = String
"1.0"
instance Diagnostic e => ToJson (MsgEnvelope e) where
json :: MsgEnvelope e -> JsonDoc
json MsgEnvelope e
m = [(String, JsonDoc)] -> JsonDoc
JSObject [
(String
"version", String -> JsonDoc
JSString String
schemaVersion),
(String
"ghcVersion", String -> JsonDoc
JSString (String -> JsonDoc) -> String -> JsonDoc
forall a b. (a -> b) -> a -> b
$ String
"ghc-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion),
(String
"span", SrcSpan -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (SrcSpan -> JsonDoc) -> SrcSpan -> JsonDoc
forall a b. (a -> b) -> a -> b
$ MsgEnvelope e -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope e
m),
(String
"severity", Severity -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (Severity -> JsonDoc) -> Severity -> JsonDoc
forall a b. (a -> b) -> a -> b
$ MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope e
m),
(String
"code", JsonDoc
-> (DiagnosticCode -> JsonDoc) -> Maybe DiagnosticCode -> JsonDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JsonDoc
JSNull DiagnosticCode -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (e -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode e
diag)),
(String
"message", [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc) -> [JsonDoc] -> JsonDoc
forall a b. (a -> b) -> a -> b
$ (SDoc -> JsonDoc) -> [SDoc] -> [JsonDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> JsonDoc
renderToJSString [SDoc]
diagMsg),
(String
"hints", [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc) -> [JsonDoc] -> JsonDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> JsonDoc) -> [GhcHint] -> [JsonDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> JsonDoc
renderToJSString (SDoc -> JsonDoc) -> (GhcHint -> SDoc) -> GhcHint -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr) (e -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints e
diag) )
]
where diag :: e
diag = MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope e
m
opts :: DiagnosticOpts e
opts = forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @e
style :: PprStyle
style = NamePprCtx -> PprStyle
mkErrStyle (MsgEnvelope e -> NamePprCtx
forall e. MsgEnvelope e -> NamePprCtx
errMsgContext MsgEnvelope e
m)
ctx :: SDocContext
ctx = SDocContext
defaultSDocContext {sdocStyle = style }
diagMsg :: [SDoc]
diagMsg = (SDoc -> Bool) -> [SDoc] -> [SDoc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> Bool
isEmpty SDocContext
ctx) (DecoratedSDoc -> [SDoc]
unDecorated (DiagnosticOpts e -> e -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (DiagnosticOpts e
opts) e
diag))
renderToJSString :: SDoc -> JsonDoc
renderToJSString :: SDoc -> JsonDoc
renderToJSString = String -> JsonDoc
JSString (String -> JsonDoc) -> (SDoc -> String) -> SDoc -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx)
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 opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
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 ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"error"
MCDiagnostic Severity
SevWarning ResolvedDiagnosticReason
_ 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 ResolvedDiagnosticReason
reason Maybe DiagnosticCode
_code
| Just SDoc
msg <- Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
sev (ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason ResolvedDiagnosticReason
reason)
-> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets SDoc
msg
MessageClass
_ -> SDoc
forall doc. IsOutput doc => doc
empty
ppr_with_hyperlink :: DiagnosticCode -> SDoc
ppr_with_hyperlink DiagnosticCode
code =
(SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption (\ SDocContext
ctx -> SDocContext -> Bool
sdocPrintErrIndexLinks SDocContext
ctx) ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$
\ Bool
use_hyperlinks ->
if Bool
use_hyperlinks
then LinkedDiagCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LinkedDiagCode -> SDoc) -> LinkedDiagCode -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticCode -> LinkedDiagCode
LinkedDiagCode DiagnosticCode
code
else DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
code
code_doc :: SDoc
code_doc =
case MessageClass
msg_class of
MCDiagnostic Severity
_ ResolvedDiagnosticReason
_ (Just DiagnosticCode
code) -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (DiagnosticCode -> SDoc
ppr_with_hyperlink 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 (WarningWithFlags (WarningFlag
wflag :| [WarningFlag]
_)) =
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
<+> [WarningGroup] -> SDoc
warn_flag_grp (WarningFlag -> [WarningGroup]
smallestWarningGroups 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 (WarningWithCategory WarningCategory
cat) =
SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-W" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [WarningGroup] -> SDoc
warn_flag_grp [WarningGroup]
smallestWarningGroupsForCategory
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
<+> PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-Werror=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat)
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 (WarningWithFlags (WarningFlag
wflag :| [WarningFlag]
_)) =
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
<+> [WarningGroup] -> SDoc
warn_flag_grp (WarningFlag -> [WarningGroup]
smallestWarningGroups WarningFlag
wflag))
flag_msg Severity
SevWarning (WarningWithCategory WarningCategory
cat) =
SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-W" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [WarningGroup] -> SDoc
warn_flag_grp [WarningGroup]
smallestWarningGroupsForCategory)
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 :: [WarningGroup] -> SDoc
warn_flag_grp [WarningGroup]
groups
| Bool
show_warn_groups, Bool -> Bool
not ([WarningGroup] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WarningGroup]
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
", " ((WarningGroup -> String) -> [WarningGroup] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"-W"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (WarningGroup -> String) -> WarningGroup -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningGroup -> String
warningGroupName) [WarningGroup]
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 ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code) = Scheme -> PprColour
Col.sError
getMessageClassColour (MCDiagnostic Severity
SevWarning ResolvedDiagnosticReason
_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
content <- String -> IO StringBuffer
hGetStringBuffer String
fn
case atLine i 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
. ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason (ResolvedDiagnosticReason -> DiagnosticReason)
-> (MsgEnvelope e -> ResolvedDiagnosticReason)
-> MsgEnvelope e
-> DiagnosticReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> ResolvedDiagnosticReason
forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason
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
}
deriving ( DiagnosticCode -> DiagnosticCode -> Bool
(DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool) -> Eq DiagnosticCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiagnosticCode -> DiagnosticCode -> Bool
== :: DiagnosticCode -> DiagnosticCode -> Bool
$c/= :: DiagnosticCode -> DiagnosticCode -> Bool
/= :: DiagnosticCode -> DiagnosticCode -> Bool
Eq, Eq DiagnosticCode
Eq DiagnosticCode =>
(DiagnosticCode -> DiagnosticCode -> Ordering)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> DiagnosticCode)
-> (DiagnosticCode -> DiagnosticCode -> DiagnosticCode)
-> Ord DiagnosticCode
DiagnosticCode -> DiagnosticCode -> Bool
DiagnosticCode -> DiagnosticCode -> Ordering
DiagnosticCode -> DiagnosticCode -> DiagnosticCode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DiagnosticCode -> DiagnosticCode -> Ordering
compare :: DiagnosticCode -> DiagnosticCode -> Ordering
$c< :: DiagnosticCode -> DiagnosticCode -> Bool
< :: DiagnosticCode -> DiagnosticCode -> Bool
$c<= :: DiagnosticCode -> DiagnosticCode -> Bool
<= :: DiagnosticCode -> DiagnosticCode -> Bool
$c> :: DiagnosticCode -> DiagnosticCode -> Bool
> :: DiagnosticCode -> DiagnosticCode -> Bool
$c>= :: DiagnosticCode -> DiagnosticCode -> Bool
>= :: DiagnosticCode -> DiagnosticCode -> Bool
$cmax :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
max :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
$cmin :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
min :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
Ord )
instance Show DiagnosticCode where
show :: DiagnosticCode -> String
show (DiagnosticCode String
prefix Natural
c) =
String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Natural -> String
forall r. PrintfType r => String -> r
printf String
"%05d" Natural
c
instance Outputable DiagnosticCode where
ppr :: DiagnosticCode -> SDoc
ppr DiagnosticCode
code = String -> SDoc
forall doc. IsLine doc => String -> doc
text (DiagnosticCode -> String
forall a. Show a => a -> String
show DiagnosticCode
code)
newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode
instance Outputable LinkedDiagCode where
ppr :: LinkedDiagCode -> SDoc
ppr (LinkedDiagCode d :: DiagnosticCode
d@DiagnosticCode{}) = DiagnosticCode -> SDoc
linkEscapeCode DiagnosticCode
d
linkEscapeCode :: DiagnosticCode -> SDoc
linkEscapeCode :: DiagnosticCode -> SDoc
linkEscapeCode DiagnosticCode
d = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\ESC]8;;" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DiagnosticCode -> SDoc
hfErrorLink DiagnosticCode
d
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\ESC\\" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
d SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\ESC]8;;\ESC\\"
hfErrorLink :: DiagnosticCode -> SDoc
hfErrorLink :: DiagnosticCode -> SDoc
hfErrorLink DiagnosticCode
errorCode = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"https://errors.haskell.org/messages/" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
errorCode