{-# 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
  , 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)


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' forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
noFilePath forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe String
srcSpanToFilename SrcSpan
loc,ShowDiagnostic
ShowDiag,)
    Diagnostic
    { $sel:_range:Diagnostic :: Range
_range    = forall a. a -> Maybe a -> a
fromMaybe Range
noRange forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
loc
    , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
sev
    , $sel:_source:Diagnostic :: Maybe Text
_source   = 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     = forall a. Maybe a
Nothing
    , $sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = forall a. Maybe a
Nothing
    , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags     = forall a. Maybe a
Nothing
    , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = forall a. Maybe a
Nothing
    , $sel:_data_:Diagnostic :: Maybe Value
_data_   = 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 (forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope DecoratedSDoc
e)
      forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgEnvelope DecoratedSDoc -> String
formatErrorWithQual DynFlags
dflags MsgEnvelope DecoratedSDoc
e
    | Just DiagnosticSeverity
sev <- [Severity -> Maybe DiagnosticSeverity
toDSeverity forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dflags) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_)           = forall a. Maybe a
Nothing
srcSpanToRange (Compat.RealSrcSpan RealSrcSpan
real Maybe BufSpan
_) = forall a. a -> Maybe a
Just 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 forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
Compat.realSrcSpanStart RealSrcSpan
real)
        (RealSrcLoc -> Position
realSrcLocToPosition 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> Int
srcLocLine RealSrcLoc
real forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> Int
srcLocCol RealSrcLoc
real 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
_)  = forall a. Maybe a
Nothing
srcSpanToFilename (Compat.RealSrcSpan RealSrcSpan
real Maybe BufSpan
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FastString -> String
Compat.unpackFS 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 forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' forall a b. (a -> b) -> a -> b
$ String -> NormalizedFilePath
toNormalizedFilePath' forall a b. (a -> b) -> a -> b
$ FastString -> String
Compat.unpackFS 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Uri -> Range -> Location
Location (NormalizedUri -> Uri
fromNormalizedUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> NormalizedUri
filePathToUri' forall a b. (a -> b) -> a -> b
$ String -> NormalizedFilePath
toNormalizedFilePath' String
fs) Range
rng

rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan
rangeToSrcSpan = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RealSrcSpan
x -> RealSrcSpan -> Maybe BufSpan -> SrcSpan
Compat.RealSrcSpan RealSrcSpan
x forall a. Maybe a
Nothing) 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
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc NormalizedFilePath
nfp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Position
_start
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc NormalizedFilePath
nfp 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 (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
l forall a. Num a => a -> a -> a
+ UInt
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
c 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 forall a. Ord a => a -> a -> Bool
<= Position
p Bool -> Bool -> Bool
&& Position
p 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 Range -> Range -> Bool
`isSubrangeOf`) 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 :: Severity -> Maybe DiagnosticSeverity
toDSeverity Severity
SevOutput      = forall a. Maybe a
Nothing
toDSeverity Severity
SevInteractive = forall a. Maybe a
Nothing
toDSeverity Severity
SevDump        = forall a. Maybe a
Nothing
toDSeverity Severity
SevInfo        = forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Information
toDSeverity Severity
SevFatal       = forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error
#else
toDSeverity SevIgnore      = Nothing
#endif
toDSeverity Severity
SevWarning     = forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Warning
toDSeverity Severity
SevError       = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (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 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 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
_ -> forall a. a -> Maybe a
Just RealSrcSpan
r
  UnhelpfulSpan UnhelpfulSpanReason
_        -> 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
    forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
Compat.handleGhcException forall {b}. GhcException -> IO (Either [FileDiagnostic] b)
ghcExceptionToDiagnostics forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError forall {b}. SourceError -> IO (Either [FileDiagnostic] b)
sourceErrorToDiagnostics forall a b. (a -> b) -> a -> b
$
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
ghcM
    where
        ghcExceptionToDiagnostics :: GhcException -> IO (Either [FileDiagnostic] b)
ghcExceptionToDiagnostics = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left 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)
                                        . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages
#endif
                                        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 -> 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: " forall a. Semigroup a => a -> a -> a
<> 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: " 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: " 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: " 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."