{-# 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 (IORef ([LogInfo] -> [LogInfo]) -> LogRef)
-> IO (IORef ([LogInfo] -> [LogInfo])) -> IO LogRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([LogInfo] -> [LogInfo]) -> IO (IORef ([LogInfo] -> [LogInfo]))
forall a. a -> IO (IORef a)
newIORef [LogInfo] -> [LogInfo]
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 <- IORef ([LogInfo] -> [LogInfo]) -> IO ([LogInfo] -> [LogInfo])
forall a. IORef a -> IO a
readIORef IORef ([LogInfo] -> [LogInfo])
ref
    IORef ([LogInfo] -> [LogInfo]) -> ([LogInfo] -> [LogInfo]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ([LogInfo] -> [LogInfo])
ref [LogInfo] -> [LogInfo]
forall a. a -> a
id
    let logInfos :: [LogInfo]
logInfos = [LogInfo] -> [LogInfo]
build []
        logmsg :: [String]
logmsg = (LogInfo -> String) -> [LogInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LogInfo -> String
ppMsg [LogInfo]
logInfos
    String -> IO String
forall a. a -> IO a
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 [String]
logmsg

appendLogRef :: LogRef -> LogAction
#if __GLASGOW_HASKELL__ >= 906
appendLogRef :: LogRef -> LogAction
appendLogRef (LogRef IORef ([LogInfo] -> [LogInfo])
ref) LogFlags
flag MessageClass
mc SrcSpan
src SDoc
msg = do
    let (Bool
dump,Severity
sev) = case MessageClass
mc of
          MCDiagnostic Severity
sev0 DiagnosticReason
_ Maybe DiagnosticCode
_ -> (Bool
False, Severity
sev0)
          MessageClass
_                     -> (Bool
True,  Severity
SevError) -- dummy
        ctx :: SDocContext
ctx = LogFlags -> SDocContext
log_default_user_context LogFlags
flag
        !l :: LogInfo
l = (Bool
dump, SDocContext
ctx, Severity
sev, SrcSpan
src, SDoc
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 ref) flag _ sev src msg = do
    let ctx = initSDocContext flag styleUnqualified
        dump = isDumpSplices flag
        !l = (dump, ctx, sev, src, msg)
#endif
    IORef ([LogInfo] -> [LogInfo])
-> (([LogInfo] -> [LogInfo]) -> [LogInfo] -> [LogInfo]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ([LogInfo] -> [LogInfo])
ref (\[LogInfo] -> [LogInfo]
b -> [LogInfo] -> [LogInfo]
b ([LogInfo] -> [LogInfo])
-> ([LogInfo] -> [LogInfo]) -> [LogInfo] -> [LogInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogInfo
lLogInfo -> [LogInfo] -> [LogInfo]
forall 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 = (SourceError -> Ghc (Either String String))
-> Ghc (Either String String) -> Ghc (Either String String)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (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 a. IO a -> Ghc a
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 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
            LogAction -> Ghc ()
setLogger (LogAction -> Ghc ()) -> LogAction -> Ghc ()
forall a b. (a -> b) -> a -> b
$ LogRef -> LogAction
appendLogRef LogRef
logref
            Ghc ()
body
            IO (Either String String) -> Ghc (Either String String)
forall a. IO a -> Ghc a
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
    wflags :: [String]
wflags = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-fno-warn" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String]) -> [String] -> [String]
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 <- Ghc DynFlags
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 = 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
. SDocContext -> ErrorMessages -> [String]
errBagToStrList SDocContext
ctx (ErrorMessages -> [String])
-> (SourceError -> ErrorMessages) -> SourceError -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> ErrorMessages
srcErrorMessages (SourceError -> String) -> SourceError -> String
forall a b. (a -> b) -> a -> b
$ SourceError
err
    Either String String -> Ghc (Either String String)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left String
ret)

errBagToStrList :: SDocContext -> ErrorMessages -> [String]
errBagToStrList :: SDocContext -> ErrorMessages -> [String]
errBagToStrList SDocContext
ctx = (MsgEnvelope GhcMessage -> String)
-> [MsgEnvelope GhcMessage] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope GhcMessage -> String
ppErrMsg ([MsgEnvelope GhcMessage] -> [String])
-> (ErrorMessages -> [MsgEnvelope GhcMessage])
-> ErrorMessages
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgEnvelope GhcMessage] -> [MsgEnvelope GhcMessage]
forall a. [a] -> [a]
reverse ([MsgEnvelope GhcMessage] -> [MsgEnvelope GhcMessage])
-> (ErrorMessages -> [MsgEnvelope GhcMessage])
-> ErrorMessages
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> (ErrorMessages -> Bag (MsgEnvelope GhcMessage))
-> ErrorMessages
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages
  where
    ppErrMsg :: MsgEnvelope GhcMessage -> String
ppErrMsg MsgEnvelope GhcMessage
err = SDocContext -> SDoc -> String
showPage SDocContext
ctx SDoc
msg
       where
--         spn = errMsgSpan err
         msg :: SDoc
msg = MsgEnvelope GhcMessage -> SDoc
pprLocErrMessage MsgEnvelope GhcMessage
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> SDoc -> String
showPage SDocContext
ctx SDoc
msg
  where
    prefix :: String
prefix = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
checkErrorPrefix (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 a. a -> Maybe a
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 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
_) = 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

#if __GLASGOW_HASKELL__ < 904
isDumpSplices :: DynFlags -> Bool
isDumpSplices dflag = dopt Opt_D_dump_splices dflag
#endif

getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)
getSrcSpan :: SrcSpan -> Maybe (Int, Int, Int, Int)
getSrcSpan (RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_) = (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