{-# LANGUAGE BangPatterns, CPP #-}

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 (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 (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)
#if __GLASGOW_HASKELL__ < 903
    DynFlags
_ WarnReason
_ Severity
sev SrcSpan
src
#else
    _ (MCDiagnostic sev _) src
#endif
#if __GLASGOW_HASKELL__ < 900
  PprStyle
_style
#endif
  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]
:))

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

-- | 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 :: (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.
(ExceptionMonad 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 (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
#if __GLASGOW_HASKELL__ >= 902
    G.pushLogHookM (const $ appendLogRef dflags style logref)
    let setLogger _ df = df
#else
    let setLogger :: LogRef -> DynFlags -> DynFlags
setLogger LogRef
logref_ DynFlags
df = DynFlags
df { log_action :: LogAction
log_action =  DynFlags -> PprStyle -> LogRef -> LogAction
appendLogRef DynFlags
df PprStyle
style LogRef
logref_ }
#endif
    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
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 (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
#if __GLASGOW_HASKELL__ >= 902
    G.popLogHookM
#endif
    Either String String -> m (Either String String)
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 :: 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 = unlines . errBagToStrList dflag style . getMessages . srcErrorMessages $ err
#else
    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 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
#endif
    Either String String -> m (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)

#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
     msg = pprLocMsgEnvelope err
     -- fixme
#elif __GLASGOW_HASKELL__ >= 902
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
#else
errBagToStrList :: DynFlags -> Gap.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 -> Gap.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 -- ++ ext
   where
     spn :: SrcSpan
spn = ErrMsg -> SrcSpan
errMsgSpan ErrMsg
err
     msg :: MsgDoc
msg = ErrMsg -> MsgDoc
pprLocErrMsg ErrMsg
err
     -- fixme
--     ext = showPage dflag style (pprLocErrMsg $ errMsgReason err)
#endif

ppMsg :: SrcSpan -> G.Severity-> DynFlags -> Gap.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 :: 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