{-# LANGUAGE BangPatterns, CPP, TypeApplications #-}

module HIE.Bios.Ghc.Logger (
    withLogger
  ) where

import GHC (DynFlags(..), SrcSpan(..), GhcMonad, getSessionDynFlags)
import qualified GHC as G
import Control.Monad.IO.Class

import GHC.Data.Bag
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices))
import GHC.Types.SourceError
import GHC.Utils.Error
import GHC.Utils.Logger

import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.Maybe (fromMaybe)

import System.FilePath (normalise)

import HIE.Bios.Ghc.Doc (showPage, getStyle)
import HIE.Bios.Ghc.Api (withDynFlags)
import qualified HIE.Bios.Ghc.Gap as Gap

#if __GLASGOW_HASKELL__ >= 903
import GHC.Types.Error
import GHC.Driver.Errors.Types
#endif

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

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 :: LogRef -> IO String
readAndClearLogRef :: LogRef -> IO String
readAndClearLogRef (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 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
$! [String] -> String
unlines (Builder
b [])

appendLogRef :: DynFlags -> Gap.PprStyle -> LogRef -> LogAction
appendLogRef :: DynFlags -> PprStyle -> LogRef -> LogAction
appendLogRef DynFlags
df PprStyle
style (LogRef IORef Builder
ref) LogFlags
_
#if __GLASGOW_HASKELL__ < 903
    _ sev
#elif __GLASGOW_HASKELL__ < 905
    (MCDiagnostic sev _)
#else
    (MCDiagnostic Severity
sev DiagnosticReason
_ Maybe DiagnosticCode
_)
#endif
  SrcSpan
src SDoc
msg = do
        let !l :: String
l = SrcSpan -> Severity -> DynFlags -> PprStyle -> SDoc -> String
ppMsg SrcSpan
src Severity
sev DynFlags
df PprStyle
style SDoc
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]
:))

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

-- | 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 ::
  (GhcMonad m)
  => (DynFlags -> DynFlags) -> m () -> m (Either String String)
withLogger :: forall (m :: * -> *).
GhcMonad m =>
(DynFlags -> DynFlags) -> m () -> m (Either String String)
withLogger DynFlags -> DynFlags
setDF m ()
body = (SourceError -> m (Either String String))
-> m (Either String String) -> m (Either String String)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
Gap.handle SourceError -> m (Either String String)
forall (m :: * -> *).
GhcMonad m =>
SourceError -> m (Either String String)
sourceError (m (Either String String) -> m (Either String String))
-> m (Either String String) -> m (Either String String)
forall a b. (a -> b) -> a -> b
$ do
    LogRef
logref <- IO LogRef -> m LogRef
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LogRef
newLogRef
    DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    PprStyle
style <- DynFlags -> m PprStyle
forall (m :: * -> *). GhcMonad m => DynFlags -> m PprStyle
getStyle DynFlags
dflags
    (LogAction -> LogAction) -> m ()
forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
G.pushLogHookM (LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const (LogAction -> LogAction -> LogAction)
-> LogAction -> LogAction -> LogAction
forall a b. (a -> b) -> a -> b
$ DynFlags -> PprStyle -> LogRef -> LogAction
appendLogRef DynFlags
dflags PprStyle
style LogRef
logref)
    let setLogger :: p -> p -> p
setLogger p
_ p
df = p
df
    Either String String
r <- (DynFlags -> DynFlags)
-> m (Either String String) -> m (Either String String)
forall (m :: * -> *) a.
GhcMonad m =>
(DynFlags -> DynFlags) -> m a -> m a
withDynFlags (LogRef -> DynFlags -> DynFlags
forall {p} {p}. p -> p -> p
setLogger LogRef
logref (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
setDF) (m (Either String String) -> m (Either String String))
-> m (Either String String) -> m (Either String String)
forall a b. (a -> b) -> a -> b
$ do
      m ()
body
      IO (Either String String) -> m (Either String String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String) -> m (Either String String))
-> IO (Either String String) -> m (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
<$> LogRef -> IO String
readAndClearLogRef LogRef
logref
    m ()
forall (m :: * -> *). GhcMonad m => m ()
G.popLogHookM
    Either String String -> m (Either String String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String String
r



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

-- | Converting 'SourceError' to 'String'.
sourceError ::
  (GhcMonad m)
  => SourceError -> m (Either String String)
sourceError :: forall (m :: * -> *).
GhcMonad m =>
SourceError -> m (Either String String)
sourceError SourceError
err = do
    DynFlags
dflag <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    PprStyle
style <- DynFlags -> m PprStyle
forall (m :: * -> *). GhcMonad m => DynFlags -> m PprStyle
getStyle DynFlags
dflag
#if __GLASGOW_HASKELL__ >= 903
    let ret :: String
ret = [String] -> String
unlines ([String] -> String)
-> (SourceError -> [String]) -> SourceError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String]
errBagToStrList DynFlags
dflag PprStyle
style (Bag (MsgEnvelope GhcMessage) -> [String])
-> (SourceError -> Bag (MsgEnvelope GhcMessage))
-> SourceError
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> (SourceError -> Messages GhcMessage)
-> SourceError
-> Bag (MsgEnvelope GhcMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Messages GhcMessage
srcErrorMessages (SourceError -> String) -> SourceError -> String
forall a b. (a -> b) -> a -> b
$ SourceError
err
#else
    let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err
#endif
    Either String String -> m (Either String String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left String
ret)

#if __GLASGOW_HASKELL__ >= 903
errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String]
errBagToStrList :: DynFlags -> PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String]
errBagToStrList DynFlags
dflag PprStyle
style = (MsgEnvelope GhcMessage -> String)
-> [MsgEnvelope GhcMessage] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> PprStyle -> MsgEnvelope GhcMessage -> String
ppErrMsg DynFlags
dflag PprStyle
style) ([MsgEnvelope GhcMessage] -> [String])
-> (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> Bag (MsgEnvelope GhcMessage)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgEnvelope GhcMessage] -> [MsgEnvelope GhcMessage]
forall a. [a] -> [a]
reverse ([MsgEnvelope GhcMessage] -> [MsgEnvelope GhcMessage])
-> (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> Bag (MsgEnvelope GhcMessage)
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
bagToList


ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope GhcMessage -> String
ppErrMsg :: DynFlags -> PprStyle -> MsgEnvelope GhcMessage -> String
ppErrMsg DynFlags
dflag PprStyle
style MsgEnvelope GhcMessage
err = SrcSpan -> Severity -> DynFlags -> PprStyle -> SDoc -> String
ppMsg SrcSpan
spn Severity
SevError DynFlags
dflag PprStyle
style SDoc
msg -- ++ ext
   where
     spn :: SrcSpan
spn = MsgEnvelope GhcMessage -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope GhcMessage
err
#if __GLASGOW_HASKELL__ >= 905
     msg :: SDoc
msg = DiagnosticOpts GhcMessage -> MsgEnvelope GhcMessage -> SDoc
forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
pprLocMsgEnvelope (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @GhcMessage) MsgEnvelope GhcMessage
err
#else
     msg = pprLocMsgEnvelope err
#endif
     -- fixme
#else
errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String]
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList


ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope DecoratedSDoc -> String
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext
   where
     spn = errMsgSpan err
     msg = pprLocMsgEnvelope err
     -- fixme
#endif

ppMsg :: SrcSpan -> G.Severity-> DynFlags -> Gap.PprStyle -> SDoc -> String
ppMsg :: SrcSpan -> Severity -> DynFlags -> PprStyle -> SDoc -> String
ppMsg SrcSpan
spn Severity
sev DynFlags
dflag PprStyle
style SDoc
msg = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cts
  where
    cts :: String
cts  = DynFlags -> PprStyle -> SDoc -> String
showPage DynFlags
dflag PprStyle
style SDoc
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 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 :: G.Severity -> String
showSeverityCaption :: Severity -> String
showSeverityCaption Severity
G.SevWarning = String
"Warning: "
showSeverityCaption Severity
_          = String
""

getSrcFile :: SrcSpan -> Maybe String
getSrcFile :: SrcSpan -> Maybe String
getSrcFile (Gap.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 (Gap.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