-- 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
  , srcSpanToFilename
  , zeroSpan
  , realSpan
  , isInsideSrcSpan
  , noSpan

  -- * utilities working with severities
  , toDSeverity
  ) where

import                     Development.IDE.Types.Diagnostics as D
import qualified           Data.Text as T
import Data.Maybe
import Development.IDE.Types.Location
import Development.IDE.GHC.Orphans()
import qualified FastString as FS
import           GHC
import           Bag
import HscTypes
import Panic
import           ErrUtils
import           SrcLoc
import qualified Outputable                 as Out



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 NumberOrString
-> 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 NumberOrString
_code     = Maybe NumberOrString
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 -> ErrMsg -> [FileDiagnostic]
diagFromErrMsg :: Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dflags ErrMsg
e =
    [ Text -> DiagnosticSeverity -> SrcSpan -> Text -> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev (ErrMsg -> SrcSpan
errMsgSpan ErrMsg
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 -> ErrMsg -> FilePath
formatErrorWithQual DynFlags
dflags ErrMsg
e
    | Just DiagnosticSeverity
sev <- [Severity -> Maybe DiagnosticSeverity
toDSeverity (Severity -> Maybe DiagnosticSeverity)
-> Severity -> Maybe DiagnosticSeverity
forall a b. (a -> b) -> a -> b
$ ErrMsg -> Severity
errMsgSeverity ErrMsg
e]]

formatErrorWithQual :: DynFlags -> ErrMsg -> String
formatErrorWithQual :: DynFlags -> ErrMsg -> FilePath
formatErrorWithQual DynFlags
dflags ErrMsg
e =
    DynFlags -> SDoc -> FilePath
Out.showSDoc DynFlags
dflags
    (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
Out.withPprStyle (DynFlags -> PrintUnqualified -> PprStyle
Out.mkErrStyle DynFlags
dflags (PrintUnqualified -> PprStyle) -> PrintUnqualified -> PprStyle
forall a b. (a -> b) -> a -> b
$ ErrMsg -> PrintUnqualified
errMsgContext ErrMsg
e)
    (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> ErrDoc -> SDoc
ErrUtils.formatErrDoc DynFlags
dflags
    (ErrDoc -> SDoc) -> ErrDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrDoc
ErrUtils.errMsgDoc ErrMsg
e

diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs :: Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
diagSource DynFlags
dflags = (ErrMsg -> [FileDiagnostic]) -> [ErrMsg] -> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dflags) ([ErrMsg] -> [FileDiagnostic])
-> (Bag ErrMsg -> [ErrMsg]) -> Bag ErrMsg -> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
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 (RealSrcSpan RealSrcSpan
real) = 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

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
realSrcSpanStart RealSrcSpan
real)
        (RealSrcLoc -> Position
realSrcLocToPosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanEnd   RealSrcSpan
real)

realSrcLocToPosition :: RealSrcLoc -> Position
realSrcLocToPosition :: RealSrcLoc -> Position
realSrcLocToPosition RealSrcLoc
real =
  Int -> Int -> Position
Position (RealSrcLoc -> Int
srcLocLine RealSrcLoc
real Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (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 (RealSrcSpan RealSrcSpan
real) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FastString -> FilePath
FS.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

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
UnhelpfulSpan (FastString -> SrcSpan)
-> (FilePath -> FastString) -> FilePath -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FastString
FS.fsLit


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

realSpan :: SrcSpan
         -> Maybe RealSrcSpan
realSpan :: SrcSpan -> Maybe RealSrcSpan
realSpan = \case
  RealSrcSpan RealSrcSpan
r -> 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
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 ErrMsg -> [FileDiagnostic]
diagFromErrMsgs Text
fromWhere DynFlags
dflags (Bag ErrMsg -> [FileDiagnostic])
-> (SourceError -> Bag ErrMsg) -> SourceError -> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Bag ErrMsg
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
Out.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
Out.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
Out.showSDoc DynFlags
dflags SDoc
sdoc]
  where
    requestReport :: FilePath
requestReport = FilePath
"Please report this bug to the compiler authors."