{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

module GHC.Types.Error
   ( -- * Messages
     Messages
   , WarningMessages
   , ErrorMessages
   , mkMessages
   , emptyMessages
   , isEmptyMessages
   , addMessage
   , unionMessages
   , MsgEnvelope (..)
   , WarnMsg
   , SDoc
   , DecoratedSDoc (unDecorated)
   , Severity (..)
   , RenderableDiagnostic (..)
   , pprMessageBag
   , mkDecorated
   , mkLocMessage
   , mkLocMessageAnn
   , getSeverityColour
   , getCaretDiagnostic
   , makeIntoWarning
   -- * Constructing individual errors
   , mkMsgEnvelope
   , mkPlainMsgEnvelope
   , mkErr
   , mkLongMsgEnvelope
   , mkWarnMsg
   , mkPlainWarnMsg
   , mkLongWarnMsg
   -- * Queries
   , isErrorMessage
   , isWarningMessage
   , getErrorMessages
   , getWarningMessages
   , partitionMessages
   , errorsFound
   )
where

import GHC.Prelude

import GHC.Driver.Flags

import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Types.SrcLoc as SrcLoc
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json

import System.IO.Error  ( catchIOError )

{-
Note [Messages]
~~~~~~~~~~~~~~~

We represent the 'Messages' as a single bag of warnings and errors.

The reason behind that is that there is a fluid relationship between errors and warnings and we want to
be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors
or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an
error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably
shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of
"impossible states" (e.g. a waning with 'SevInfo', for example).

'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but
in future iterations these can be either parameterised over an 'e' message type (to make type signatures
a bit more declarative) or removed altogether.
-}

-- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically
-- a warning or an error. See Note [Messages].
newtype Messages e = Messages (Bag (MsgEnvelope e))

instance Functor Messages where
  fmap :: forall a b. (a -> b) -> Messages a -> Messages b
fmap a -> b
f (Messages Bag (MsgEnvelope a)
xs) = Bag (MsgEnvelope b) -> Messages b
forall e. Bag (MsgEnvelope e) -> Messages e
Messages ((MsgEnvelope a -> MsgEnvelope b)
-> Bag (MsgEnvelope a) -> Bag (MsgEnvelope b)
forall a b. (a -> b) -> Bag a -> Bag b
mapBag ((a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Bag (MsgEnvelope a)
xs)

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

isEmptyMessages :: Messages e -> Bool
isEmptyMessages :: forall e. Messages e -> Bool
isEmptyMessages (Messages Bag (MsgEnvelope e)
msgs) = Bag (MsgEnvelope e) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (MsgEnvelope 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) = 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)

-- | Joins two collections of messages together.
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)

type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)
type ErrorMessages   = Bag (MsgEnvelope DecoratedSDoc)

type WarnMsg         = MsgEnvelope DecoratedSDoc

-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]'
-- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets
-- between each elements of the list.
-- The type of decoration depends on the formatting function used, but in practice GHC uses the
-- 'formatBulleted'.
newtype DecoratedSDoc = Decorated { DecoratedSDoc -> [SDoc]
unDecorated :: [SDoc] }

-- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'.
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated = [SDoc] -> DecoratedSDoc
Decorated

{-
Note [Rendering Messages]
~~~~~~~~~~~~~~~~~~~~~~~~~

Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it
happens typically at the application boundaries (i.e. from the 'Driver' upwards).

For now (see #18516) this class is very boring as it has only one instance, but the idea is that as
the more domain-specific types are defined, the more instances we would get. For example, given something like:

data TcRnMessage
  = TcRnOutOfScope ..
  | ..

We could then define how a 'TcRnMessage' is displayed to the user. Rather than scattering pieces of
'SDoc' around the codebase, we would write once for all:

instance RenderableDiagnostic TcRnMessage where
  renderDiagnostic = \case
    TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]
    ...

This way, we can easily write generic rendering functions for errors that all they care about is the
knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint.

-}

-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'.
-- For more information, see Note [Rendering Messages].
class RenderableDiagnostic a where
  renderDiagnostic :: a -> DecoratedSDoc

-- | An envelope for GHC's facts about a running program, parameterised over the
-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
--
-- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped
-- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc.
-- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user.
data MsgEnvelope e = MsgEnvelope
   { forall e. MsgEnvelope e -> SrcSpan
errMsgSpan        :: SrcSpan
      -- ^ The SrcSpan is used for sorting errors into line-number order
   , forall e. MsgEnvelope e -> PrintUnqualified
errMsgContext     :: PrintUnqualified
   , forall e. MsgEnvelope e -> e
errMsgDiagnostic  :: e
   , forall e. MsgEnvelope e -> Severity
errMsgSeverity    :: Severity
   , forall e. MsgEnvelope e -> WarnReason
errMsgReason      :: WarnReason
   } 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
<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
$c<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
fmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
$cfmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
Functor

instance RenderableDiagnostic DecoratedSDoc where
  renderDiagnostic :: DecoratedSDoc -> DecoratedSDoc
renderDiagnostic = DecoratedSDoc -> DecoratedSDoc
forall a. a -> a
id

data Severity
  = SevOutput
  | SevFatal
  | SevInteractive

  | SevDump
    -- ^ Log message intended for compiler developers
    -- No file\/line\/column stuff

  | SevInfo
    -- ^ Log messages intended for end users.
    -- No file\/line\/column stuff.

  | SevWarning
  | SevError
    -- ^ SevWarning and SevError are used for warnings and errors
    --   o The message has a file\/line\/column heading,
    --     plus "warning:" or "error:",
    --     added by mkLocMessags
    --   o Output is intended for end users
  deriving (Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c== :: 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
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show)


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 Show (MsgEnvelope DecoratedSDoc) where
    show :: MsgEnvelope DecoratedSDoc -> String
show = MsgEnvelope DecoratedSDoc -> String
forall a. RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope

-- | Shows an 'MsgEnvelope'.
showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope :: forall a. RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope MsgEnvelope a
err =
  SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext ([SDoc] -> SDoc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (DecoratedSDoc -> [SDoc]) -> (a -> DecoratedSDoc) -> a -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DecoratedSDoc
forall a. RenderableDiagnostic a => a -> DecoratedSDoc
renderDiagnostic (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
vcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
blankLine (Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
msgs))

-- | Make an unannotated error message with location info.
mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage = Maybe String -> Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn Maybe String
forall a. Maybe a
Nothing

-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> Severity                           -- ^ severity
  -> SrcSpan                            -- ^ location
  -> SDoc                             -- ^ message
  -> SDoc
  -- Always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn Maybe String
ann Severity
severity 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)

          sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity Scheme
col_scheme

          -- Add optional information
          optAnn :: SDoc
optAnn = case Maybe String
ann of
            Maybe String
Nothing -> String -> SDoc
text String
""
            Just String
i  -> String -> SDoc
text String
" [" SDoc -> SDoc -> SDoc
<> PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
text String
i) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"]"

          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
          header :: SDoc
header = SDoc
locn' SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
                   PprColour -> SDoc -> SDoc
coloured PprColour
sevColour SDoc
sevText SDoc -> SDoc -> SDoc
<> SDoc
optAnn

      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)

  where
    sevText :: SDoc
sevText =
      case Severity
severity of
        Severity
SevWarning -> String -> SDoc
text String
"warning:"
        Severity
SevError   -> String -> SDoc
text String
"error:"
        Severity
SevFatal   -> String -> SDoc
text String
"fatal:"
        Severity
_          -> SDoc
empty

getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour :: Severity -> Scheme -> PprColour
getSeverityColour Severity
SevWarning = Scheme -> PprColour
Col.sWarning
getSeverityColour Severity
SevError   = Scheme -> PprColour
Col.sError
getSeverityColour Severity
SevFatal   = Scheme -> PprColour
Col.sFatal
getSeverityColour Severity
_          = PprColour -> Scheme -> PprColour
forall a b. a -> b -> a
const PprColour
forall a. Monoid a => a
mempty

getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic Severity
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = SDoc -> IO SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
getCaretDiagnostic Severity
severity (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 a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ ->
          Maybe String -> IO (Maybe String)
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 has advantages over readFile:
      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
      -- (b) always UTF-8, rather than some system-dependent encoding
      --     (Haskell source code must be UTF-8 anyway)
      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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

    -- allow user to visibly see that their code is incorrectly encoded
    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
    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
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 = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity Scheme
col_scheme
          marginColour :: PprColour
marginColour = Scheme -> PprColour
Col.sMargin Scheme
col_scheme
      in
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
text String
marginSpace) SDoc -> SDoc -> SDoc
<>
      String -> SDoc
text (String
"\n") SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
text String
marginRow) SDoc -> SDoc -> SDoc
<>
      String -> SDoc
text (String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcLinePre) SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
text String
srcLineSpan) SDoc -> SDoc -> SDoc
<>
      String -> SDoc
text (String
srcLinePost String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n") SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
text String
marginSpace) SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
text (String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
caretLine))

      where

        -- expand tabs in a device-independent manner #13664
        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 (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 (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

makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning :: forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning WarnReason
reason MsgEnvelope e
err = MsgEnvelope e
err
    { errMsgSeverity :: Severity
errMsgSeverity = Severity
SevWarning
    , errMsgReason :: WarnReason
errMsgReason = WarnReason
reason }

--
-- Creating MsgEnvelope(s)
--

mk_err_msg
  :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg :: forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
sev SrcSpan
locn PrintUnqualified
print_unqual e
err
 = MsgEnvelope { errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
locn
               , errMsgContext :: PrintUnqualified
errMsgContext = PrintUnqualified
print_unqual
               , errMsgDiagnostic :: e
errMsgDiagnostic = e
err
               , errMsgSeverity :: Severity
errMsgSeverity = Severity
sev
               , errMsgReason :: WarnReason
errMsgReason = WarnReason
NoReason }

mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr :: forall e. SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr = Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError

mkLongMsgEnvelope, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
-- ^ A long (multi-line) error message
mkMsgEnvelope, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> SDoc         -> MsgEnvelope DecoratedSDoc
-- ^ A short (one-line) error message
mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan ->                     SDoc         -> MsgEnvelope DecoratedSDoc
-- ^ Variant that doesn't care about qualified/unqualified names

mkLongMsgEnvelope :: SrcSpan
-> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongMsgEnvelope   SrcSpan
locn PrintUnqualified
unqual SDoc
msg SDoc
extra = Severity
-> SrcSpan
-> PrintUnqualified
-> DecoratedSDoc
-> MsgEnvelope DecoratedSDoc
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError   SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg,SDoc
extra])
mkMsgEnvelope :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope       SrcSpan
locn PrintUnqualified
unqual SDoc
msg       = Severity
-> SrcSpan
-> PrintUnqualified
-> DecoratedSDoc
-> MsgEnvelope DecoratedSDoc
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError   SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])
mkPlainMsgEnvelope :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope  SrcSpan
locn        SDoc
msg       = Severity
-> SrcSpan
-> PrintUnqualified
-> DecoratedSDoc
-> MsgEnvelope DecoratedSDoc
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError   SrcSpan
locn PrintUnqualified
alwaysQualify ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])
mkLongWarnMsg :: SrcSpan
-> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongWarnMsg       SrcSpan
locn PrintUnqualified
unqual SDoc
msg SDoc
extra = Severity
-> SrcSpan
-> PrintUnqualified
-> DecoratedSDoc
-> MsgEnvelope DecoratedSDoc
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevWarning SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg,SDoc
extra])
mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkWarnMsg           SrcSpan
locn PrintUnqualified
unqual SDoc
msg       = Severity
-> SrcSpan
-> PrintUnqualified
-> DecoratedSDoc
-> MsgEnvelope DecoratedSDoc
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevWarning SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])
mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg      SrcSpan
locn        SDoc
msg       = Severity
-> SrcSpan
-> PrintUnqualified
-> DecoratedSDoc
-> MsgEnvelope DecoratedSDoc
forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevWarning SrcSpan
locn PrintUnqualified
alwaysQualify ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])

--
-- Queries
--

isErrorMessage :: MsgEnvelope e -> Bool
isErrorMessage :: forall e. MsgEnvelope e -> Bool
isErrorMessage = (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

isWarningMessage :: MsgEnvelope e -> Bool
isWarningMessage :: forall 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. MsgEnvelope e -> Bool
isErrorMessage

errorsFound :: Messages e -> Bool
errorsFound :: forall 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. MsgEnvelope e -> Bool
isErrorMessage Bag (MsgEnvelope e)
msgs

getWarningMessages :: Messages e -> Bag (MsgEnvelope e)
getWarningMessages :: forall 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. MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs

getErrorMessages :: Messages e -> Bag (MsgEnvelope e)
getErrorMessages :: forall 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. MsgEnvelope e -> Bool
isErrorMessage Bag (MsgEnvelope e)
xs

-- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the
-- second the errors.
partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages :: forall e. Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages (Messages Bag (MsgEnvelope e)
xs) = (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. MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs