{-# 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(..)) -- errMsgSpan
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) -- dummy
        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) -- dummy
        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]
:))

----------------------------------------------------------------

-- | Set the session flag (e.g. "-Wall" or "-w:") then
--   executes a body. Log messages are returned as 'String'.
--   Right is success and Left is failure.
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

----------------------------------------------------------------

-- | Converting 'SourceError' to 'String'.
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
--         spn = errMsgSpan err
         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 SevError is not necessary for historical reasons
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