{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Hhp.Logger (
withLogger
, checkErrorPrefix
, getSrcSpan
) where
import Bag (Bag, bagToList)
import CoreMonad (liftIO)
import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices))
import ErrUtils
import Exception (ghandle)
import FastString (unpackFS)
import GHC (Ghc, DynFlags(..), SrcSpan(..))
#if __GLASGOW_HASKELL__ < 808
import GHC (Severity(SevError))
#endif
import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages)
import Outputable (PprStyle, SDoc)
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.GHCApi (withDynFlags, withCmdFlags)
import Hhp.Types (Options(..), convert)
type Builder = [String] -> [String]
newtype LogRef = LogRef (IORef Builder)
newLogRef :: IO LogRef
newLogRef :: IO LogRef
newLogRef = IORef Builder -> LogRef
LogRef (IORef Builder -> LogRef) -> IO (IORef Builder) -> IO LogRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. a -> a
id
readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef Options
opt (LogRef IORef Builder
ref) = do
Builder
b <- IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
ref
IORef Builder -> Builder -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Builder
ref Builder
forall a. a -> a
id
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$! Options -> [String] -> String
forall a. ToString a => Options -> a -> String
convert Options
opt (Builder
b [])
appendLogRef :: DynFlags -> LogRef -> LogAction
appendLogRef :: DynFlags -> LogRef -> LogAction
appendLogRef DynFlags
df (LogRef IORef Builder
ref) DynFlags
_ WarnReason
_ Severity
sev SrcSpan
src PprStyle
style MsgDoc
msg = do
let !l :: String
l = SrcSpan -> Severity -> DynFlags -> PprStyle -> MsgDoc -> String
ppMsg SrcSpan
src Severity
sev DynFlags
df PprStyle
style MsgDoc
msg
IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
ref (\Builder
b -> Builder
b Builder -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
lString -> Builder
forall 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 = (SourceError -> Ghc (Either String String))
-> Ghc (Either String String) -> Ghc (Either String String)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle (Options -> SourceError -> Ghc (Either String String)
sourceError Options
opt) (Ghc (Either String String) -> Ghc (Either String String))
-> Ghc (Either String String) -> Ghc (Either String String)
forall a b. (a -> b) -> a -> b
$ do
LogRef
logref <- IO LogRef -> Ghc LogRef
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LogRef
newLogRef
(DynFlags -> DynFlags)
-> Ghc (Either String String) -> Ghc (Either String String)
forall a. (DynFlags -> DynFlags) -> Ghc a -> Ghc a
withDynFlags (LogRef -> DynFlags -> DynFlags
setLogger LogRef
logref (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
setDF) (Ghc (Either String String) -> Ghc (Either String String))
-> Ghc (Either String String) -> Ghc (Either String String)
forall a b. (a -> b) -> a -> b
$ do
[String]
-> Ghc (Either String String) -> Ghc (Either String String)
forall a. [String] -> Ghc a -> Ghc a
withCmdFlags [String]
wflags (Ghc (Either String String) -> Ghc (Either String String))
-> Ghc (Either String String) -> Ghc (Either String String)
forall a b. (a -> b) -> a -> b
$ do
Ghc ()
body
IO (Either String String) -> Ghc (Either String String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String) -> Ghc (Either String String))
-> IO (Either String String) -> Ghc (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> IO String -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> LogRef -> IO String
readAndClearLogRef Options
opt LogRef
logref
where
setLogger :: LogRef -> DynFlags -> DynFlags
setLogger LogRef
logref DynFlags
df = DynFlags
df { log_action :: LogAction
log_action = DynFlags -> LogRef -> LogAction
appendLogRef DynFlags
df LogRef
logref }
wflags :: [String]
wflags = (String -> Bool) -> Builder
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-fno-warn" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) Builder -> Builder
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 <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
PprStyle
style <- DynFlags -> Ghc PprStyle
getStyle DynFlags
dflag
let ret :: String
ret = Options -> [String] -> String
forall a. ToString a => Options -> a -> String
convert Options
opt ([String] -> String)
-> (SourceError -> [String]) -> SourceError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList DynFlags
dflag PprStyle
style (Bag ErrMsg -> [String])
-> (SourceError -> Bag ErrMsg) -> SourceError -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Bag ErrMsg
srcErrorMessages (SourceError -> String) -> SourceError -> String
forall a b. (a -> b) -> a -> b
$ SourceError
err
Either String String -> Ghc (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left String
ret)
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList DynFlags
dflag PprStyle
style = (ErrMsg -> String) -> [ErrMsg] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg DynFlags
dflag PprStyle
style) ([ErrMsg] -> [String])
-> (Bag ErrMsg -> [ErrMsg]) -> Bag ErrMsg -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrMsg] -> [ErrMsg]
forall a. [a] -> [a]
reverse ([ErrMsg] -> [ErrMsg])
-> (Bag ErrMsg -> [ErrMsg]) -> Bag ErrMsg -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
bagToList
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg DynFlags
dflag PprStyle
style ErrMsg
err = SrcSpan -> Severity -> DynFlags -> PprStyle -> MsgDoc -> String
ppMsg SrcSpan
spn Severity
SevError DynFlags
dflag PprStyle
style MsgDoc
msg
where
spn :: SrcSpan
spn = ErrMsg -> SrcSpan
errMsgSpan ErrMsg
err
msg :: MsgDoc
msg = ErrMsg -> MsgDoc
pprLocErrMsg ErrMsg
err
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg :: SrcSpan -> Severity -> DynFlags -> PprStyle -> MsgDoc -> String
ppMsg SrcSpan
spn Severity
sev DynFlags
dflag PprStyle
style MsgDoc
msg = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cts
where
cts :: String
cts = DynFlags -> PprStyle -> MsgDoc -> String
showPage DynFlags
dflag PprStyle
style MsgDoc
msg
defaultPrefix :: String
defaultPrefix
| DynFlags -> Bool
isDumpSplices DynFlags
dflag = String
""
| Bool
otherwise = String
checkErrorPrefix
prefix :: String
prefix = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultPrefix (Maybe String -> String) -> Maybe String -> String
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 (String -> String) -> Maybe String -> Maybe String
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
String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> 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) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (RealSrcSpan -> String) -> RealSrcSpan -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS (FastString -> String)
-> (RealSrcSpan -> FastString) -> RealSrcSpan -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
G.srcSpanFile (RealSrcSpan -> Maybe String) -> RealSrcSpan -> Maybe String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
spn
getSrcFile SrcSpan
_ = Maybe String
forall a. Maybe a
Nothing
isDumpSplices :: DynFlags -> Bool
isDumpSplices :: DynFlags -> Bool
isDumpSplices DynFlags
dflag = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_splices DynFlags
dflag
getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)
getSrcSpan :: SrcSpan -> Maybe (Int, Int, Int, Int)
getSrcSpan (RealSrcSpan RealSrcSpan
spn) = (Int, Int, Int, Int) -> Maybe (Int, Int, Int, Int)
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
_ = Maybe (Int, Int, Int, Int)
forall a. Maybe a
Nothing