module Development.IDE.GHC.Error
(
diagFromErrMsgs
, diagFromErrMsg
, diagFromString
, diagFromStrings
, diagFromGhcException
, catchSrcErrors
, srcSpanToLocation
, srcSpanToRange
, srcSpanToFilename
, zeroSpan
, realSpan
, isInsideSrcSpan
, noSpan
, toDSeverity
) where
import Development.IDE.Types.Diagnostics as D
import qualified Data.Text as T
import Development.IDE.Types.Location
import Development.IDE.GHC.Orphans()
import qualified FastString as FS
import GHC
import Bag
import DynFlags
import HscTypes
import Panic
import ErrUtils
import SrcLoc
import qualified Outputable as Out
diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)
Diagnostic
{ _range = srcSpanToRange loc
, _severity = Just sev
, _source = Just diagSource
, _message = msg
, _code = Nothing
, _relatedInformation = Nothing
}
diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
diagFromErrMsg diagSource dflags e =
[ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e
| Just sev <- [toDSeverity $ errMsgSeverity e]]
diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
srcSpanToRange :: SrcSpan -> Range
srcSpanToRange (UnhelpfulSpan _) = noRange
srcSpanToRange (RealSrcSpan real) = realSrcSpanToRange real
realSrcSpanToRange :: RealSrcSpan -> Range
realSrcSpanToRange real =
Range (Position (srcSpanStartLine real - 1) (srcSpanStartCol real - 1))
(Position (srcSpanEndLine real - 1) (srcSpanEndCol real - 1))
srcSpanToFilename :: SrcSpan -> FilePath
srcSpanToFilename (UnhelpfulSpan fs) = FS.unpackFS fs
srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
srcSpanToLocation :: SrcSpan -> Location
srcSpanToLocation src =
Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
isInsideSrcSpan :: Position -> SrcSpan -> Bool
p `isInsideSrcSpan` r = sp <= p && p <= ep
where Range sp ep = srcSpanToRange r
toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity
toDSeverity SevOutput = Nothing
toDSeverity SevInteractive = Nothing
toDSeverity SevDump = Nothing
toDSeverity SevInfo = Just DsInfo
toDSeverity SevWarning = Just DsWarning
toDSeverity SevError = Just DsError
toDSeverity SevFatal = Just DsError
diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]
diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev))
diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]
diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x]
noSpan :: String -> SrcSpan
noSpan = UnhelpfulSpan . FS.fsLit
zeroSpan :: FS.FastString
-> RealSrcSpan
zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1)
realSpan :: SrcSpan
-> Maybe RealSrcSpan
realSpan = \case
RealSrcSpan r -> Just r
UnhelpfulSpan _ -> Nothing
catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
catchSrcErrors fromWhere ghcM = do
dflags <- getDynFlags
handleGhcException (ghcExceptionToDiagnostics dflags) $
handleSourceError (sourceErrorToDiagnostics dflags) $
Right <$> ghcM
where
ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages
diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "<Internal>") (showGHCE dflags exc)
showGHCE :: DynFlags -> GhcException -> String
showGHCE dflags exc = case exc of
Signal n
-> "Signal: " <> show n
Panic s
-> unwords ["Compilation Issue:", s, "\n", requestReport]
PprPanic s sdoc
-> unlines ["Compilation Issue", s,""
, Out.showSDoc dflags sdoc
, requestReport ]
Sorry s
-> "Unsupported feature: " <> s
PprSorry s sdoc
-> unlines ["Unsupported feature: ", s,""
, Out.showSDoc dflags sdoc]
InstallationError str
-> "Installation error: " <> str
UsageError str
-> unlines ["Unexpected usage error", str]
CmdLineError str
-> unlines ["Unexpected usage error", str]
ProgramError str
-> "Program error: " <> str
PprProgramError str sdoc ->
unlines ["Program error:", str,""
, Out.showSDoc dflags sdoc]
where
requestReport = "Please report this bug to the compiler authors."