{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module Hhp.Logger (
withLogger
, checkErrorPrefix
, getSrcSpan
) where
import GHC (Ghc, DynFlags(..), SrcSpan(..))
import qualified GHC as G
import GHC.Data.Bag (bagToList)
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Session (initSDocContext)
import GHC.Utils.Error (Severity(..))
import GHC.Utils.Monad (liftIO)
import GHC.Utils.Outputable (SDoc, SDocContext)
#if __GLASGOW_HASKELL__ >= 904
import GHC.Utils.Error (MessageClass(..))
import GHC.Utils.Logger (LogFlags(..))
#else
import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices))
import Hhp.Doc (styleUnqualified)
#endif
import Control.Monad.Catch (handle)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import System.FilePath (normalise)
import Hhp.Doc (showPage, getStyle)
import Hhp.Gap
import Hhp.GHCApi (withDynFlags, withCmdFlags)
import Hhp.Types (Options(..), convert)
type LogInfo = (Bool,SDocContext,Severity,SrcSpan,SDoc)
newtype LogRef = LogRef (IORef ([LogInfo] -> [LogInfo]))
newLogRef :: IO LogRef
newLogRef :: IO LogRef
newLogRef = IORef ([LogInfo] -> [LogInfo]) -> LogRef
LogRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. a -> a
id
readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef Options
opt (LogRef IORef ([LogInfo] -> [LogInfo])
ref) = do
[LogInfo] -> [LogInfo]
build <- forall a. IORef a -> IO a
readIORef IORef ([LogInfo] -> [LogInfo])
ref
forall a. IORef a -> a -> IO ()
writeIORef IORef ([LogInfo] -> [LogInfo])
ref forall a. a -> a
id
let logInfos :: [LogInfo]
logInfos = [LogInfo] -> [LogInfo]
build []
logmsg :: [String]
logmsg = forall a b. (a -> b) -> [a] -> [b]
map LogInfo -> String
ppMsg [LogInfo]
logInfos
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. ToString a => Options -> a -> String
convert Options
opt [String]
logmsg
appendLogRef :: LogRef -> LogAction
#if __GLASGOW_HASKELL__ >= 906
appendLogRef (LogRef ref) flag mc src msg = do
let (dump,sev) = case mc of
MCDiagnostic sev0 _ _ -> (False, sev0)
_ -> (True, SevError)
ctx = log_default_user_context flag
!l = (dump, ctx, sev, src, msg)
#elif __GLASGOW_HASKELL__ >= 904
appendLogRef (LogRef ref) flag mc src msg = do
let (dump,sev) = case mc of
MCDiagnostic sev0 _ -> (False, sev0)
_ -> (True, SevError)
ctx = log_default_user_context flag
!l = (dump, ctx, sev, src, msg)
#else
appendLogRef :: LogRef -> LogAction
appendLogRef (LogRef IORef ([LogInfo] -> [LogInfo])
ref) DynFlags
flag WarnReason
_ Severity
sev SrcSpan
src SDoc
msg = do
let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
flag PprStyle
styleUnqualified
dump :: Bool
dump = DynFlags -> Bool
isDumpSplices DynFlags
flag
!l :: LogInfo
l = (Bool
dump, SDocContext
ctx, Severity
sev, SrcSpan
src, SDoc
msg)
#endif
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ([LogInfo] -> [LogInfo])
ref (\[LogInfo] -> [LogInfo]
b -> [LogInfo] -> [LogInfo]
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogInfo
lforall a. a -> [a] -> [a]
:))
withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)
withLogger :: Options
-> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)
withLogger Options
opt DynFlags -> DynFlags
setDF Ghc ()
body = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (Options -> SourceError -> Ghc (Either String String)
sourceError Options
opt) forall a b. (a -> b) -> a -> b
$ do
LogRef
logref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LogRef
newLogRef
forall a. (DynFlags -> DynFlags) -> Ghc a -> Ghc a
withDynFlags DynFlags -> DynFlags
setDF forall a b. (a -> b) -> a -> b
$ do
forall a. [String] -> Ghc a -> Ghc a
withCmdFlags [String]
wflags forall a b. (a -> b) -> a -> b
$ do
LogAction -> Ghc ()
setLogger forall a b. (a -> b) -> a -> b
$ LogRef -> LogAction
appendLogRef LogRef
logref
Ghc ()
body
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
<$> Options -> LogRef -> IO String
readAndClearLogRef Options
opt LogRef
logref
where
wflags :: [String]
wflags = forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-fno-warn" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall a b. (a -> b) -> a -> b
$ Options -> [String]
ghcOpts Options
opt
sourceError :: Options -> SourceError -> Ghc (Either String String)
sourceError :: Options -> SourceError -> Ghc (Either String String)
sourceError Options
opt SourceError
err = do
DynFlags
dflag <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
PprStyle
style <- Ghc PprStyle
getStyle
let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflag PprStyle
style
ret :: String
ret = forall a. ToString a => Options -> a -> String
convert Options
opt forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> ErrorMessages -> [String]
errBagToStrList SDocContext
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> ErrorMessages
srcErrorMessages forall a b. (a -> b) -> a -> b
$ SourceError
err
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left String
ret)
errBagToStrList :: SDocContext -> ErrorMessages -> [String]
errBagToStrList :: SDocContext -> ErrorMessages -> [String]
errBagToStrList SDocContext
ctx = forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope DecoratedSDoc -> String
ppErrMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bag a -> [a]
bagToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a
getMessages
where
ppErrMsg :: MsgEnvelope DecoratedSDoc -> String
ppErrMsg MsgEnvelope DecoratedSDoc
err = SDocContext -> SDoc -> String
showPage SDocContext
ctx SDoc
msg
where
msg :: SDoc
msg = MsgEnvelope DecoratedSDoc -> SDoc
pprLocErrMessage MsgEnvelope DecoratedSDoc
err
ppMsg :: (Bool, SDocContext, Severity, SrcSpan, SDoc) -> String
ppMsg :: LogInfo -> String
ppMsg (Bool
True,SDocContext
ctx,Severity
_ ,SrcSpan
_ ,SDoc
msg) = SDocContext -> SDoc -> String
showPage SDocContext
ctx SDoc
msg
ppMsg (Bool
_, SDocContext
ctx,Severity
sev,SrcSpan
spn,SDoc
msg) = String
prefix forall a. [a] -> [a] -> [a]
++ SDocContext -> SDoc -> String
showPage SDocContext
ctx SDoc
msg
where
prefix :: String
prefix = forall a. a -> Maybe a -> a
fromMaybe String
checkErrorPrefix forall a b. (a -> b) -> a -> b
$ do
(Int
line,Int
col,Int
_,Int
_) <- SrcSpan -> Maybe (Int, Int, Int, Int)
getSrcSpan SrcSpan
spn
String
file <- String -> String
normalise forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe String
getSrcFile SrcSpan
spn
let severityCaption :: String
severityCaption = Severity -> String
showSeverityCaption Severity
sev
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
file forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
line forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
col forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
severityCaption
checkErrorPrefix :: String
checkErrorPrefix :: String
checkErrorPrefix = String
"Dummy:0:0:Error:"
showSeverityCaption :: Severity -> String
showSeverityCaption :: Severity -> String
showSeverityCaption Severity
SevWarning = String
"Warning: "
showSeverityCaption Severity
_ = String
""
getSrcFile :: SrcSpan -> Maybe String
getSrcFile :: SrcSpan -> Maybe String
getSrcFile (G.RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
G.srcSpanFile forall a b. (a -> b) -> a -> b
$ RealSrcSpan
spn
getSrcFile SrcSpan
_ = forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ < 904
isDumpSplices :: DynFlags -> Bool
isDumpSplices :: DynFlags -> Bool
isDumpSplices DynFlags
dflag = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_splices DynFlags
dflag
#endif
getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)
getSrcSpan :: SrcSpan -> Maybe (Int, Int, Int, Int)
getSrcSpan (RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_) = forall a. a -> Maybe a
Just ( RealSrcSpan -> Int
G.srcSpanStartLine RealSrcSpan
spn
, RealSrcSpan -> Int
G.srcSpanStartCol RealSrcSpan
spn
, RealSrcSpan -> Int
G.srcSpanEndLine RealSrcSpan
spn
, RealSrcSpan -> Int
G.srcSpanEndCol RealSrcSpan
spn)
getSrcSpan SrcSpan
_ = forall a. Maybe a
Nothing