{-# 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

#if __GLASGOW_HASKELL__ >= 902
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
#elif __GLASGOW_HASKELL__ >= 900
import GHC.Data.Bag
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Session (dopt, DumpFlag(Opt_D_dump_splices), LogAction)
import GHC.Driver.Types (SourceError, srcErrorMessages)
import GHC.Utils.Error
import GHC.Utils.Outputable (SDoc)
#else
import Bag (Bag, bagToList)
import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices))
import ErrUtils
import FastString (unpackFS)
import HscTypes (SourceError, srcErrorMessages)
import Outputable (SDoc)
#endif

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 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 :: LogRef -> IO String
readAndClearLogRef :: LogRef -> IO String
readAndClearLogRef (LogRef IORef Builder
ref) = do
    Builder
b <- forall a. IORef a -> IO a
readIORef IORef Builder
ref
    forall a. IORef a -> a -> IO ()
writeIORef IORef Builder
ref forall a. a -> a
id
    forall (m :: * -> *) a. Monad m => a -> m a
return 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)
#if __GLASGOW_HASKELL__ < 903
    DynFlags
_ WarnReason
_ Severity
sev SrcSpan
src
#elif __GLASGOW_HASKELL__ < 905
    _ (MCDiagnostic sev _) src
#else
    _ (MCDiagnostic sev _ _) src
#endif
#if __GLASGOW_HASKELL__ < 900
  _style
#endif
  SDoc
msg = do
        let !l :: String
l = SrcSpan -> Severity -> DynFlags -> PprStyle -> SDoc -> String
ppMsg SrcSpan
src Severity
sev DynFlags
df PprStyle
style SDoc
msg
        forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
ref (\Builder
b -> Builder
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
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 ::
  (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 = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
Gap.handle forall (m :: * -> *).
GhcMonad m =>
SourceError -> m (Either String String)
sourceError forall a b. (a -> b) -> a -> b
$ do
    LogRef
logref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO LogRef
newLogRef
    DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    PprStyle
style <- forall (m :: * -> *). GhcMonad m => DynFlags -> m PprStyle
getStyle DynFlags
dflags
#if __GLASGOW_HASKELL__ >= 902
    forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
G.pushLogHookM (forall a b. a -> b -> a
const 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
#else
    let setLogger logref_ df = df { log_action =  appendLogRef df style logref_ }
#endif
    Either String String
r <- forall (m :: * -> *) a.
GhcMonad m =>
(DynFlags -> DynFlags) -> m a -> m a
withDynFlags (forall {p} {p}. p -> p -> p
setLogger LogRef
logref forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
setDF) forall a b. (a -> b) -> a -> b
$ do
      m ()
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
<$> LogRef -> IO String
readAndClearLogRef LogRef
logref
#if __GLASGOW_HASKELL__ >= 902
    forall (m :: * -> *). GhcMonad m => m ()
G.popLogHookM
#endif
    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 <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    PprStyle
style <- forall (m :: * -> *). GhcMonad m => DynFlags -> m PprStyle
getStyle DynFlags
dflag
#if __GLASGOW_HASKELL__ >= 903
    let ret = unlines . errBagToStrList dflag style . getMessages . srcErrorMessages $ err
#else
    let ret :: String
ret = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String]
errBagToStrList DynFlags
dflag PprStyle
style forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Bag (MsgEnvelope DecoratedSDoc)
srcErrorMessages forall a b. (a -> b) -> a -> b
$ SourceError
err
#endif
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left String
ret)

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


ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope GhcMessage -> String
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext
   where
     spn = errMsgSpan err
#if __GLASGOW_HASKELL__ >= 905
     msg = pprLocMsgEnvelope (defaultDiagnosticOpts @GhcMessage) err
#else
     msg = pprLocMsgEnvelope err
#endif
     -- fixme
#elif __GLASGOW_HASKELL__ >= 902
errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String]
errBagToStrList :: DynFlags -> PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String]
errBagToStrList DynFlags
dflag PprStyle
style = forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> PprStyle -> MsgEnvelope DecoratedSDoc -> String
ppErrMsg DynFlags
dflag PprStyle
style) 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


ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope DecoratedSDoc -> String
ppErrMsg :: DynFlags -> PprStyle -> MsgEnvelope DecoratedSDoc -> String
ppErrMsg DynFlags
dflag PprStyle
style MsgEnvelope DecoratedSDoc
err = SrcSpan -> Severity -> DynFlags -> PprStyle -> SDoc -> String
ppMsg SrcSpan
spn Severity
SevError DynFlags
dflag PprStyle
style SDoc
msg -- ++ ext
   where
     spn :: SrcSpan
spn = forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope DecoratedSDoc
err
     msg :: SDoc
msg = forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope MsgEnvelope DecoratedSDoc
err
     -- fixme
#else
errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList

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

ppErrMsg :: DynFlags -> Gap.PprStyle -> ErrMsg -> String
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext
   where
     spn = errMsgSpan err
     msg = pprLocErrMsg err
     -- fixme
--     ext = showPage dflag style (pprLocErrMsg $ errMsgReason err)
#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 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 = forall a. a -> Maybe a -> a
fromMaybe String
defaultPrefix 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 :: 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) = 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

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) =
    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