-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
module Development.IDE.GHC.Error
  (
    -- * Producing Diagnostic values
    diagFromErrMsgs
  , diagFromErrMsg
  , diagFromString
  , diagFromStrings
  , diagFromGhcException
  , catchSrcErrors

  -- * utilities working with spans
  , srcSpanToLocation
  , srcSpanToRange
  , realSrcSpanToRange
  , realSrcLocToPosition
  , realSrcSpanToLocation
  , srcSpanToFilename
  , rangeToSrcSpan
  , rangeToRealSrcSpan
  , positionToRealSrcLoc
  , zeroSpan
  , realSpan
  , isInsideSrcSpan
  , noSpan

  -- * utilities working with severities
  , toDSeverity
  ) where

import           Data.Maybe
import           Data.String                       (fromString)
import qualified Data.Text                         as T
import           Development.IDE.GHC.Compat        (DecoratedSDoc, MsgEnvelope,
                                                    errMsgSeverity, errMsgSpan,
                                                    formatErrorWithQual,
                                                    srcErrorMessages)
import qualified Development.IDE.GHC.Compat        as Compat
import qualified Development.IDE.GHC.Compat.Util   as Compat
import           Development.IDE.GHC.Orphans       ()
import           Development.IDE.Types.Diagnostics as D
import           Development.IDE.Types.Location
import           GHC


diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
diagFromText :: Text -> DiagnosticSeverity -> SrcSpan -> Text -> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev SrcSpan
loc Text
msg = (FilePath -> NormalizedFilePath
toNormalizedFilePath' (FilePath -> NormalizedFilePath) -> FilePath -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
noFilePath (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe FilePath
srcSpanToFilename SrcSpan
loc,ShowDiagnostic
ShowDiag,)
    Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
Diagnostic
    { $sel:_range:Diagnostic :: Range
_range    = Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
noRange (Maybe Range -> Range) -> Maybe Range -> Range
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
loc
    , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
sev
    , $sel:_source:Diagnostic :: Maybe Text
_source   = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
diagSource -- not shown in the IDE, but useful for ghcide developers
    , $sel:_message:Diagnostic :: Text
_message  = Text
msg
    , $sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code     = Maybe (Int32 |? Text)
forall a. Maybe a
Nothing
    , $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing
    , $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags     = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
    }

-- | Produce a GHC-style error from a source span and a message.
diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromErrMsg :: Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dflags MsgEnvelope DecoratedSDoc
e =
    [ Text -> DiagnosticSeverity -> SrcSpan -> Text -> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev (MsgEnvelope DecoratedSDoc -> SrcSpan
errMsgSpan MsgEnvelope DecoratedSDoc
e)
      (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgEnvelope DecoratedSDoc -> FilePath
formatErrorWithQual DynFlags
dflags MsgEnvelope DecoratedSDoc
e
    | Just DiagnosticSeverity
sev <- [Severity -> Maybe DiagnosticSeverity
toDSeverity (Severity -> Maybe DiagnosticSeverity)
-> Severity -> Maybe DiagnosticSeverity
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DecoratedSDoc -> Severity
errMsgSeverity MsgEnvelope DecoratedSDoc
e]]

diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs :: Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
diagSource DynFlags
dflags = (MsgEnvelope DecoratedSDoc -> [FileDiagnostic])
-> [MsgEnvelope DecoratedSDoc] -> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dflags) ([MsgEnvelope DecoratedSDoc] -> [FileDiagnostic])
-> (Bag (MsgEnvelope DecoratedSDoc) -> [MsgEnvelope DecoratedSDoc])
-> Bag (MsgEnvelope DecoratedSDoc)
-> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope DecoratedSDoc) -> [MsgEnvelope DecoratedSDoc]
forall a. Bag a -> [a]
Compat.bagToList

-- | Convert a GHC SrcSpan to a DAML compiler Range
srcSpanToRange :: SrcSpan -> Maybe Range
srcSpanToRange :: SrcSpan -> Maybe Range
srcSpanToRange (UnhelpfulSpan FastString
_)           = Maybe Range
forall a. Maybe a
Nothing
srcSpanToRange (Compat.RealSrcSpan RealSrcSpan
real Maybe DecoratedSDoc
_) = Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
real
-- srcSpanToRange = fmap realSrcSpanToRange . realSpan

realSrcSpanToRange :: RealSrcSpan -> Range
realSrcSpanToRange :: RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
real =
  Position -> Position -> Range
Range (RealSrcLoc -> Position
realSrcLocToPosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
Compat.realSrcSpanStart RealSrcSpan
real)
        (RealSrcLoc -> Position
realSrcLocToPosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
Compat.realSrcSpanEnd   RealSrcSpan
real)

realSrcLocToPosition :: RealSrcLoc -> Position
realSrcLocToPosition :: RealSrcLoc -> Position
realSrcLocToPosition RealSrcLoc
real =
  UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> Int
srcLocLine RealSrcLoc
real Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> Int
srcLocCol RealSrcLoc
real Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones)
-- FIXME This may not be an _absolute_ file name, needs fixing.
srcSpanToFilename :: SrcSpan -> Maybe FilePath
srcSpanToFilename :: SrcSpan -> Maybe FilePath
srcSpanToFilename (UnhelpfulSpan FastString
_)  = Maybe FilePath
forall a. Maybe a
Nothing
srcSpanToFilename (Compat.RealSrcSpan RealSrcSpan
real Maybe DecoratedSDoc
_) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FastString -> FilePath
Compat.unpackFS (FastString -> FilePath) -> FastString -> FilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real
-- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan

realSrcSpanToLocation :: RealSrcSpan -> Location
realSrcSpanToLocation :: RealSrcSpan -> Location
realSrcSpanToLocation RealSrcSpan
real = Uri -> Range -> Location
Location Uri
file (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
real)
  where file :: Uri
file = NormalizedUri -> Uri
fromNormalizedUri (NormalizedUri -> Uri) -> NormalizedUri -> Uri
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' (NormalizedFilePath -> NormalizedUri)
-> NormalizedFilePath -> NormalizedUri
forall a b. (a -> b) -> a -> b
$ FilePath -> NormalizedFilePath
toNormalizedFilePath' (FilePath -> NormalizedFilePath) -> FilePath -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ FastString -> FilePath
Compat.unpackFS (FastString -> FilePath) -> FastString -> FilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real

srcSpanToLocation :: SrcSpan -> Maybe Location
srcSpanToLocation :: SrcSpan -> Maybe Location
srcSpanToLocation SrcSpan
src = do
  FilePath
fs <- SrcSpan -> Maybe FilePath
srcSpanToFilename SrcSpan
src
  Range
rng <- SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
src
  -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
  Location -> Maybe Location
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Location -> Maybe Location) -> Location -> Maybe Location
forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
Location (NormalizedUri -> Uri
fromNormalizedUri (NormalizedUri -> Uri) -> NormalizedUri -> Uri
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' (NormalizedFilePath -> NormalizedUri)
-> NormalizedFilePath -> NormalizedUri
forall a b. (a -> b) -> a -> b
$ FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
fs) Range
rng

rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
rangeToSrcSpan = (RealSrcSpan -> SrcSpan)
-> (Range -> RealSrcSpan) -> Range -> SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RealSrcSpan
x -> RealSrcSpan -> Maybe DecoratedSDoc -> SrcSpan
Compat.RealSrcSpan RealSrcSpan
x Maybe DecoratedSDoc
forall a. Maybe a
Nothing) ((Range -> RealSrcSpan) -> Range -> SrcSpan)
-> (NormalizedFilePath -> Range -> RealSrcSpan)
-> NormalizedFilePath
-> Range
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan

rangeToRealSrcSpan
    :: NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan NormalizedFilePath
nfp =
    RealSrcLoc -> RealSrcLoc -> RealSrcSpan
Compat.mkRealSrcSpan
        (RealSrcLoc -> RealSrcLoc -> RealSrcSpan)
-> (Range -> RealSrcLoc) -> Range -> RealSrcLoc -> RealSrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc NormalizedFilePath
nfp (Position -> RealSrcLoc)
-> (Range -> Position) -> Range -> RealSrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Position
_start
        (Range -> RealSrcLoc -> RealSrcSpan)
-> (Range -> RealSrcLoc) -> Range -> RealSrcSpan
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc NormalizedFilePath
nfp (Position -> RealSrcLoc)
-> (Range -> Position) -> Range -> RealSrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Position
_end

positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc NormalizedFilePath
nfp (Position UInt
l UInt
c)=
    FastString -> Int -> Int -> RealSrcLoc
Compat.mkRealSrcLoc (FilePath -> FastString
forall a. IsString a => FilePath -> a
fromString (FilePath -> FastString) -> FilePath -> FastString
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> FilePath
fromNormalizedFilePath NormalizedFilePath
nfp) (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
l UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
c UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1)

isInsideSrcSpan :: Position -> SrcSpan -> Bool
Position
p isInsideSrcSpan :: Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
r = case SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
r of
  Just (Range Position
sp Position
ep) -> Position
sp Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
p Bool -> Bool -> Bool
&& Position
p Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
ep
  Maybe Range
_                  -> Bool
False

-- | Convert a GHC severity to a DAML compiler Severity. Severities below
-- "Warning" level are dropped (returning Nothing).
toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity
toDSeverity :: Severity -> Maybe DiagnosticSeverity
toDSeverity Severity
SevOutput      = Maybe DiagnosticSeverity
forall a. Maybe a
Nothing
toDSeverity Severity
SevInteractive = Maybe DiagnosticSeverity
forall a. Maybe a
Nothing
toDSeverity Severity
SevDump        = Maybe DiagnosticSeverity
forall a. Maybe a
Nothing
toDSeverity Severity
SevInfo        = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DsInfo
toDSeverity Severity
SevWarning     = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DsWarning
toDSeverity Severity
SevError       = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DsError
toDSeverity Severity
SevFatal       = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DsError


-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given
--   (optional) locations and message strings.
diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]
diagFromStrings :: Text
-> DiagnosticSeverity -> [(SrcSpan, FilePath)] -> [FileDiagnostic]
diagFromStrings Text
diagSource DiagnosticSeverity
sev = ((SrcSpan, FilePath) -> [FileDiagnostic])
-> [(SrcSpan, FilePath)] -> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((SrcSpan -> FilePath -> [FileDiagnostic])
-> (SrcSpan, FilePath) -> [FileDiagnostic]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text
-> DiagnosticSeverity -> SrcSpan -> FilePath -> [FileDiagnostic]
diagFromString Text
diagSource DiagnosticSeverity
sev))

-- | Produce a GHC-style error from a source span and a message.
diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]
diagFromString :: Text
-> DiagnosticSeverity -> SrcSpan -> FilePath -> [FileDiagnostic]
diagFromString Text
diagSource DiagnosticSeverity
sev SrcSpan
sp FilePath
x = [Text -> DiagnosticSeverity -> SrcSpan -> Text -> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev SrcSpan
sp (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
x]


-- | Produces an "unhelpful" source span with the given string.
noSpan :: String -> SrcSpan
noSpan :: FilePath -> SrcSpan
noSpan = FastString -> SrcSpan
Compat.mkGeneralSrcSpan (FastString -> SrcSpan)
-> (FilePath -> FastString) -> FilePath -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FastString
Compat.fsLit


-- | creates a span with zero length in the filename of the argument passed
zeroSpan :: Compat.FastString -- ^ file path of span
         -> RealSrcSpan
zeroSpan :: FastString -> RealSrcSpan
zeroSpan FastString
file = RealSrcLoc -> RealSrcSpan
Compat.realSrcLocSpan (FastString -> Int -> Int -> RealSrcLoc
Compat.mkRealSrcLoc FastString
file Int
1 Int
1)

realSpan :: SrcSpan
         -> Maybe RealSrcSpan
realSpan :: SrcSpan -> Maybe RealSrcSpan
realSpan = \case
  Compat.RealSrcSpan RealSrcSpan
r Maybe DecoratedSDoc
_ -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
r
  UnhelpfulSpan FastString
_        -> Maybe RealSrcSpan
forall a. Maybe a
Nothing


-- | Catch the errors thrown by GHC (SourceErrors and
-- compiler-internal exceptions like Panic or InstallationError), and turn them into
-- diagnostics
catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors :: DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors DynFlags
dflags Text
fromWhere IO a
ghcM = do
    (GhcException -> IO (Either [FileDiagnostic] a))
-> IO (Either [FileDiagnostic] a) -> IO (Either [FileDiagnostic] a)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
Compat.handleGhcException (DynFlags -> GhcException -> IO (Either [FileDiagnostic] a)
forall (m :: * -> *) b.
Monad m =>
DynFlags -> GhcException -> m (Either [FileDiagnostic] b)
ghcExceptionToDiagnostics DynFlags
dflags) (IO (Either [FileDiagnostic] a) -> IO (Either [FileDiagnostic] a))
-> IO (Either [FileDiagnostic] a) -> IO (Either [FileDiagnostic] a)
forall a b. (a -> b) -> a -> b
$
      (SourceError -> IO (Either [FileDiagnostic] a))
-> IO (Either [FileDiagnostic] a) -> IO (Either [FileDiagnostic] a)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (DynFlags -> SourceError -> IO (Either [FileDiagnostic] a)
forall (m :: * -> *) b.
Monad m =>
DynFlags -> SourceError -> m (Either [FileDiagnostic] b)
sourceErrorToDiagnostics DynFlags
dflags) (IO (Either [FileDiagnostic] a) -> IO (Either [FileDiagnostic] a))
-> IO (Either [FileDiagnostic] a) -> IO (Either [FileDiagnostic] a)
forall a b. (a -> b) -> a -> b
$
      a -> Either [FileDiagnostic] a
forall a b. b -> Either a b
Right (a -> Either [FileDiagnostic] a)
-> IO a -> IO (Either [FileDiagnostic] a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
ghcM
    where
        ghcExceptionToDiagnostics :: DynFlags -> GhcException -> m (Either [FileDiagnostic] b)
ghcExceptionToDiagnostics DynFlags
dflags = Either [FileDiagnostic] b -> m (Either [FileDiagnostic] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] b -> m (Either [FileDiagnostic] b))
-> (GhcException -> Either [FileDiagnostic] b)
-> GhcException
-> m (Either [FileDiagnostic] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Either [FileDiagnostic] b
forall a b. a -> Either a b
Left ([FileDiagnostic] -> Either [FileDiagnostic] b)
-> (GhcException -> [FileDiagnostic])
-> GhcException
-> Either [FileDiagnostic] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
fromWhere DynFlags
dflags
        sourceErrorToDiagnostics :: DynFlags -> SourceError -> m (Either [FileDiagnostic] b)
sourceErrorToDiagnostics DynFlags
dflags = Either [FileDiagnostic] b -> m (Either [FileDiagnostic] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] b -> m (Either [FileDiagnostic] b))
-> (SourceError -> Either [FileDiagnostic] b)
-> SourceError
-> m (Either [FileDiagnostic] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Either [FileDiagnostic] b
forall a b. a -> Either a b
Left ([FileDiagnostic] -> Either [FileDiagnostic] b)
-> (SourceError -> [FileDiagnostic])
-> SourceError
-> Either [FileDiagnostic] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromErrMsgs Text
fromWhere DynFlags
dflags (Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic])
-> (SourceError -> Bag (MsgEnvelope DecoratedSDoc))
-> SourceError
-> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Bag (MsgEnvelope DecoratedSDoc)
srcErrorMessages


diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException :: Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException Text
diagSource DynFlags
dflags GhcException
exc = Text
-> DiagnosticSeverity -> SrcSpan -> FilePath -> [FileDiagnostic]
diagFromString Text
diagSource DiagnosticSeverity
DsError (FilePath -> SrcSpan
noSpan FilePath
"<Internal>") (DynFlags -> GhcException -> FilePath
showGHCE DynFlags
dflags GhcException
exc)

showGHCE :: DynFlags -> GhcException -> String
showGHCE :: DynFlags -> GhcException -> FilePath
showGHCE DynFlags
dflags GhcException
exc = case GhcException
exc of
        Signal Int
n
          -> FilePath
"Signal: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n

        Panic FilePath
s
          -> [FilePath] -> FilePath
unwords [FilePath
"Compilation Issue:", FilePath
s, FilePath
"\n", FilePath
requestReport]
        PprPanic  FilePath
s SDoc
sdoc
          -> [FilePath] -> FilePath
unlines [FilePath
"Compilation Issue", FilePath
s,FilePath
""
                     , DynFlags -> SDoc -> FilePath
Compat.showSDoc DynFlags
dflags SDoc
sdoc
                     , FilePath
requestReport ]

        Sorry FilePath
s
          -> FilePath
"Unsupported feature: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
s
        PprSorry FilePath
s SDoc
sdoc
          -> [FilePath] -> FilePath
unlines [FilePath
"Unsupported feature: ", FilePath
s,FilePath
""
                     , DynFlags -> SDoc -> FilePath
Compat.showSDoc DynFlags
dflags SDoc
sdoc]


        ---------- errors below should not happen at all --------
        InstallationError FilePath
str
          -> FilePath
"Installation error: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
str

        UsageError FilePath
str -- should never happen
          -> [FilePath] -> FilePath
unlines [FilePath
"Unexpected usage error", FilePath
str]

        CmdLineError FilePath
str
          -> [FilePath] -> FilePath
unlines [FilePath
"Unexpected usage error", FilePath
str]

        ProgramError FilePath
str
            -> FilePath
"Program error: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
str
        PprProgramError FilePath
str  SDoc
sdoc  ->
            [FilePath] -> FilePath
unlines [FilePath
"Program error:", FilePath
str,FilePath
""
                    , DynFlags -> SDoc -> FilePath
Compat.showSDoc DynFlags
dflags SDoc
sdoc]
  where
    requestReport :: FilePath
requestReport = FilePath
"Please report this bug to the compiler authors."