{-# LANGUAGE CPP #-}
-- 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
  , realSrcSpanToCodePointRange
  , realSrcLocToCodePointPosition
  , srcSpanToFilename
  , rangeToSrcSpan
  , rangeToRealSrcSpan
  , positionToRealSrcLoc
  , zeroSpan
  , realSpan
  , isInsideSrcSpan
  , spanContainsRange
  , 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
import           Language.LSP.Protocol.Types       (isSubrangeOf)
import           Language.LSP.VFS                  (CodePointPosition (CodePointPosition),
                                                    CodePointRange (CodePointRange))


diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
diagFromText :: Text -> DiagnosticSeverity -> SrcSpan -> Text -> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev SrcSpan
loc Text
msg = (String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
noFilePath (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe String
srcSpanToFilename SrcSpan
loc,ShowDiagnostic
ShowDiag,)
    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 [DiagnosticRelatedInformation]
_relatedInformation = Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing
    , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags     = Maybe [DiagnosticTag]
forall a. Maybe a
Nothing
    , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = Maybe CodeDescription
forall a. Maybe a
Nothing
    , $sel:_data_:Diagnostic :: Maybe Value
_data_   = Maybe Value
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
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope DecoratedSDoc
e)
      (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgEnvelope DecoratedSDoc -> String
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
forall e. MsgEnvelope e -> 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 UnhelpfulSpanReason
_)           = Maybe Range
forall a. Maybe a
Nothing
srcSpanToRange (Compat.RealSrcSpan RealSrcSpan
real Maybe BufSpan
_) = 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)

-- Note [Unicode support]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- the current situation is:
-- LSP Positions use UTF-16 code units(Unicode may count as variable columns);
-- GHC use Unicode code points(Unicode count as one column).
-- To support unicode, ideally range should be in lsp standard,
-- and codePoint should be in ghc standard.
-- see https://github.com/haskell/lsp/pull/407

-- | Convert a GHC SrcSpan to CodePointRange
-- see Note [Unicode support]
realSrcSpanToCodePointRange :: RealSrcSpan -> CodePointRange
realSrcSpanToCodePointRange :: RealSrcSpan -> CodePointRange
realSrcSpanToCodePointRange RealSrcSpan
real =
  CodePointPosition -> CodePointPosition -> CodePointRange
CodePointRange
    (RealSrcLoc -> CodePointPosition
realSrcLocToCodePointPosition (RealSrcLoc -> CodePointPosition)
-> RealSrcLoc -> CodePointPosition
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
Compat.realSrcSpanStart RealSrcSpan
real)
    (RealSrcLoc -> CodePointPosition
realSrcLocToCodePointPosition (RealSrcLoc -> CodePointPosition)
-> RealSrcLoc -> CodePointPosition
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
Compat.realSrcSpanEnd RealSrcSpan
real)

-- | Convert a GHC RealSrcLoc to CodePointPosition
-- see Note [Unicode support]
realSrcLocToCodePointPosition :: RealSrcLoc -> CodePointPosition
realSrcLocToCodePointPosition :: RealSrcLoc -> CodePointPosition
realSrcLocToCodePointPosition RealSrcLoc
real =
  UInt -> UInt -> CodePointPosition
CodePointPosition (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 String
srcSpanToFilename (UnhelpfulSpan UnhelpfulSpanReason
_)  = Maybe String
forall a. Maybe a
Nothing
srcSpanToFilename (Compat.RealSrcSpan RealSrcSpan
real Maybe BufSpan
_) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ FastString -> String
Compat.unpackFS (FastString -> String) -> FastString -> String
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
$ String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ FastString -> String
Compat.unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real

srcSpanToLocation :: SrcSpan -> Maybe Location
srcSpanToLocation :: SrcSpan -> Maybe Location
srcSpanToLocation SrcSpan
src = do
  String
fs <- SrcSpan -> Maybe String
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 a. a -> Maybe a
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
$ String -> NormalizedFilePath
toNormalizedFilePath' String
fs) Range
rng

rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
rangeToSrcSpan = (RealSrcSpan -> SrcSpan)
-> (Range -> RealSrcSpan) -> Range -> SrcSpan
forall a b. (a -> b) -> (Range -> a) -> Range -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RealSrcSpan
x -> RealSrcSpan -> Maybe BufSpan -> SrcSpan
Compat.RealSrcSpan RealSrcSpan
x Maybe BufSpan
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 a b. (Range -> a -> b) -> (Range -> a) -> Range -> b
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 (String -> FastString
forall a. IsString a => String -> a
fromString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
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

-- Returns Nothing if the SrcSpan does not represent a valid range
spanContainsRange :: SrcSpan -> Range -> Maybe Bool
spanContainsRange :: SrcSpan -> Range -> Maybe Bool
spanContainsRange SrcSpan
srcSpan Range
range = (Range
range `isSubrangeOf`) (Range -> Bool) -> Maybe Range -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
srcSpan

-- | Convert a GHC severity to a DAML compiler Severity. Severities below
-- "Warning" level are dropped (returning Nothing).
toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity
#if !MIN_VERSION_ghc(9,3,0)
toDSeverity SevOutput      = Nothing
toDSeverity SevInteractive = Nothing
toDSeverity SevDump        = Nothing
toDSeverity SevInfo        = Just DiagnosticSeverity_Information
toDSeverity SevFatal       = Just DiagnosticSeverity_Error
#else
toDSeverity :: Severity -> Maybe DiagnosticSeverity
toDSeverity Severity
SevIgnore      = Maybe DiagnosticSeverity
forall a. Maybe a
Nothing
#endif
toDSeverity Severity
SevWarning     = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Warning
toDSeverity Severity
SevError       = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error


-- | 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, String)] -> [FileDiagnostic]
diagFromStrings Text
diagSource DiagnosticSeverity
sev = ((SrcSpan, String) -> [FileDiagnostic])
-> [(SrcSpan, String)] -> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((SrcSpan -> String -> [FileDiagnostic])
-> (SrcSpan, String) -> [FileDiagnostic]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> DiagnosticSeverity -> SrcSpan -> String -> [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 -> String -> [FileDiagnostic]
diagFromString Text
diagSource DiagnosticSeverity
sev SrcSpan
sp String
x = [Text -> DiagnosticSeverity -> SrcSpan -> Text -> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev SrcSpan
sp (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
x]


-- | Produces an "unhelpful" source span with the given string.
noSpan :: String -> SrcSpan
noSpan :: String -> SrcSpan
noSpan = FastString -> SrcSpan
Compat.mkGeneralSrcSpan (FastString -> SrcSpan)
-> (String -> FastString) -> String -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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 BufSpan
_ -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
r
  UnhelpfulSpan UnhelpfulSpanReason
_        -> 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 :: forall a.
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 GhcException -> IO (Either [FileDiagnostic] a)
forall {b}. GhcException -> IO (Either [FileDiagnostic] b)
ghcExceptionToDiagnostics (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.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> IO (Either [FileDiagnostic] a)
forall {b}. SourceError -> IO (Either [FileDiagnostic] b)
sourceErrorToDiagnostics (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 :: GhcException -> IO (Either [FileDiagnostic] b)
ghcExceptionToDiagnostics = Either [FileDiagnostic] b -> IO (Either [FileDiagnostic] b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] b -> IO (Either [FileDiagnostic] b))
-> (GhcException -> Either [FileDiagnostic] b)
-> GhcException
-> IO (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 :: SourceError -> IO (Either [FileDiagnostic] b)
sourceErrorToDiagnostics = Either [FileDiagnostic] b -> IO (Either [FileDiagnostic] b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] b -> IO (Either [FileDiagnostic] b))
-> (SourceError -> Either [FileDiagnostic] b)
-> SourceError
-> IO (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
#if MIN_VERSION_ghc(9,3,0)
                                        (Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic])
-> (SourceError -> Bag (MsgEnvelope DecoratedSDoc))
-> SourceError
-> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope GhcMessage -> MsgEnvelope DecoratedSDoc)
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope DecoratedSDoc)
forall a b. (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GhcMessage -> DecoratedSDoc)
-> MsgEnvelope GhcMessage -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
Compat.renderDiagnosticMessageWithHints) (Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope DecoratedSDoc))
-> (SourceError -> Bag (MsgEnvelope GhcMessage))
-> SourceError
-> Bag (MsgEnvelope DecoratedSDoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Compat.getMessages
#endif
                                        (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> (SourceError -> Messages GhcMessage)
-> SourceError
-> Bag (MsgEnvelope GhcMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Messages GhcMessage
srcErrorMessages


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

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

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

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


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

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

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

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