{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DisambiguateRecordFields #-}
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
module Development.IDE.GHC.Error
  (
    -- * Producing Diagnostic values
    diagFromGhcErrorMessages
  , diagFromErrMsgs
  , diagFromErrMsg
  , diagFromSDocErrMsgs
  , diagFromSDocErrMsg
  , 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           Control.Lens
import           Data.Maybe
import           Data.String                       (fromString)
import qualified Data.Text                         as T
import           Data.Tuple.Extra                  (uncurry3)
import           Development.IDE.GHC.Compat        (GhcMessage, MsgEnvelope,
                                                    errMsgDiagnostic,
                                                    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 -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic
diagFromText :: Text
-> DiagnosticSeverity
-> SrcSpan
-> Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev SrcSpan
loc Text
msg Maybe (MsgEnvelope GhcMessage)
origMsg =
  Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
D.ideErrorWithSource
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
diagSource) (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
sev)
    (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)
    Text
msg Maybe (MsgEnvelope GhcMessage)
origMsg
    FileDiagnostic
-> (FileDiagnostic -> FileDiagnostic) -> FileDiagnostic
forall a b. a -> (a -> b) -> b
& (Diagnostic -> Identity Diagnostic)
-> FileDiagnostic -> Identity FileDiagnostic
Lens' FileDiagnostic Diagnostic
fdLspDiagnosticL ((Diagnostic -> Identity Diagnostic)
 -> FileDiagnostic -> Identity FileDiagnostic)
-> (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Diagnostic
diag -> Diagnostic
diag { D._range = fromMaybe noRange $ srcSpanToRange loc }

-- | Produce a GHC-style error from a source span and a message.
diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic]
diagFromErrMsg :: Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dflags MsgEnvelope GhcMessage
origErr =
    let err :: MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err = (GhcMessage -> (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)))
-> MsgEnvelope GhcMessage
-> MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\GhcMessage
e -> (GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
Compat.renderDiagnosticMessageWithHints GhcMessage
e, MsgEnvelope GhcMessage -> Maybe (MsgEnvelope GhcMessage)
forall a. a -> Maybe a
Just MsgEnvelope GhcMessage
origErr)) MsgEnvelope GhcMessage
origErr
    in
    Text
-> DynFlags
-> MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> [FileDiagnostic]
diagFromSDocWithOptionalOrigMsg Text
diagSource DynFlags
dflags MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err

-- | Compatibility function for creating '[FileDiagnostic]' from
-- a 'Compat.Bag' of GHC error messages.
-- The function signature changes based on the GHC version.
-- While this is not desirable, it avoids more CPP statements in code
-- that implements actual logic.
#if MIN_VERSION_ghc(9,5,0)
diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic]
diagFromGhcErrorMessages :: Text
-> DynFlags -> Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic]
diagFromGhcErrorMessages Text
sourceParser DynFlags
dflags Bag (MsgEnvelope GhcMessage)
errs =
    Text
-> DynFlags -> Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic]
diagFromErrMsgs Text
sourceParser DynFlags
dflags Bag (MsgEnvelope GhcMessage)
errs
#else
diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic]
diagFromGhcErrorMessages sourceParser dflags errs =
    diagFromSDocErrMsgs sourceParser dflags errs
#endif

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

diagFromSDocErrMsg :: T.Text -> DynFlags -> MsgEnvelope Compat.DecoratedSDoc -> [FileDiagnostic]
diagFromSDocErrMsg :: Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromSDocErrMsg Text
diagSource DynFlags
dflags MsgEnvelope DecoratedSDoc
err =
    Text
-> DynFlags
-> MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> [FileDiagnostic]
diagFromSDocWithOptionalOrigMsg Text
diagSource DynFlags
dflags ((DecoratedSDoc -> (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)))
-> MsgEnvelope DecoratedSDoc
-> MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Maybe (MsgEnvelope GhcMessage)
forall a. Maybe a
Nothing) MsgEnvelope DecoratedSDoc
err)

diagFromSDocErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic]
diagFromSDocErrMsgs :: Text
-> DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
diagFromSDocErrMsgs 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]
diagFromSDocErrMsg 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

diagFromSDocWithOptionalOrigMsg :: T.Text -> DynFlags -> MsgEnvelope (Compat.DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> [FileDiagnostic]
diagFromSDocWithOptionalOrigMsg :: Text
-> DynFlags
-> MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> [FileDiagnostic]
diagFromSDocWithOptionalOrigMsg Text
diagSource DynFlags
dflags MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err =
    [ Text
-> DiagnosticSeverity
-> SrcSpan
-> Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev (MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err) (String -> Text
T.pack (DynFlags -> MsgEnvelope DecoratedSDoc -> String
formatErrorWithQual DynFlags
dflags (((DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> DecoratedSDoc)
-> MsgEnvelope (DecoratedSDoc, Maybe (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 (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> DecoratedSDoc
forall a b. (a, b) -> a
fst MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err))) ((DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> Maybe (MsgEnvelope GhcMessage)
forall a b. (a, b) -> b
snd (MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err))
    | Just DiagnosticSeverity
sev <- [Severity -> Maybe DiagnosticSeverity
toDSeverity (Severity -> Maybe DiagnosticSeverity)
-> Severity -> Maybe DiagnosticSeverity
forall a b. (a -> b) -> a -> b
$ MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
-> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope (DecoratedSDoc, Maybe (MsgEnvelope GhcMessage))
err]]

-- | 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
toDSeverity :: Severity -> Maybe DiagnosticSeverity
toDSeverity Severity
SevIgnore  = Maybe DiagnosticSeverity
forall a. Maybe a
Nothing
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, Maybe (MsgEnvelope GhcMessage))] -> [FileDiagnostic]
diagFromStrings :: Text
-> DiagnosticSeverity
-> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))]
-> [FileDiagnostic]
diagFromStrings Text
diagSource DiagnosticSeverity
sev = ((SrcSpan, String, Maybe (MsgEnvelope GhcMessage))
 -> [FileDiagnostic])
-> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))]
-> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((SrcSpan
 -> String -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic])
-> (SrcSpan, String, Maybe (MsgEnvelope GhcMessage))
-> [FileDiagnostic]
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 (Text
-> DiagnosticSeverity
-> SrcSpan
-> String
-> Maybe (MsgEnvelope GhcMessage)
-> [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 -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic]
diagFromString :: Text
-> DiagnosticSeverity
-> SrcSpan
-> String
-> Maybe (MsgEnvelope GhcMessage)
-> [FileDiagnostic]
diagFromString Text
diagSource DiagnosticSeverity
sev SrcSpan
sp String
x Maybe (MsgEnvelope GhcMessage)
origMsg = [Text
-> DiagnosticSeverity
-> SrcSpan
-> Text
-> Maybe (MsgEnvelope GhcMessage)
-> FileDiagnostic
diagFromText Text
diagSource DiagnosticSeverity
sev SrcSpan
sp (String -> Text
T.pack String
x) Maybe (MsgEnvelope GhcMessage)
origMsg]


-- | 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 {f :: * -> *} {b}.
Applicative f =>
SourceError -> f (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 -> f (Either [FileDiagnostic] b)
sourceErrorToDiagnostics SourceError
diag = Either [FileDiagnostic] b -> f (Either [FileDiagnostic] b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [FileDiagnostic] b -> f (Either [FileDiagnostic] b))
-> Either [FileDiagnostic] b -> f (Either [FileDiagnostic] b)
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Either [FileDiagnostic] b
forall a b. a -> Either a b
Left ([FileDiagnostic] -> Either [FileDiagnostic] b)
-> [FileDiagnostic] -> Either [FileDiagnostic] b
forall a b. (a -> b) -> a -> b
$
          Text
-> DynFlags -> Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic]
diagFromErrMsgs Text
fromWhere DynFlags
dflags (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
Compat.getMessages (SourceError -> Messages GhcMessage
srcErrorMessages SourceError
diag))

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

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."