{-# LANGUAGE BangPatterns #-}

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

import Bag (Bag, bagToList)
import CoreMonad (liftIO)
import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices))
import ErrUtils
import Exception (ghandle)
import FastString (unpackFS)
import GHC (DynFlags(..), SrcSpan(..), GhcMonad)
import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages)
import Outputable (PprStyle, SDoc)

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)

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

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 ref :: 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 -> LogRef -> LogAction
appendLogRef :: DynFlags -> LogRef -> LogAction
appendLogRef df :: DynFlags
df (LogRef ref :: IORef Builder
ref) _ _ sev :: Severity
sev src :: SrcSpan
src style :: PprStyle
style msg :: 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 (\b :: 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 setDF :: DynFlags -> DynFlags
setDF body :: 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
ghandle 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 -> 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
  where
    setLogger :: LogRef -> DynFlags -> DynFlags
setLogger logref :: LogRef
logref df :: DynFlags
df = DynFlags
df { log_action :: LogAction
log_action =  DynFlags -> LogRef -> LogAction
appendLogRef DynFlags
df LogRef
logref }

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

-- | Converting 'SourceError' to 'String'.
sourceError ::
  (GhcMonad m)
  => SourceError -> m (Either String String)
sourceError :: SourceError -> m (Either String String)
sourceError err :: SourceError
err = do
    DynFlags
dflag <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
    PprStyle
style <- DynFlags -> m PprStyle
forall (m :: * -> *). GhcMonad m => DynFlags -> m PprStyle
getStyle DynFlags
dflag
    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
    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)

errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag :: DynFlags
dflag style :: 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 -> PprStyle -> ErrMsg -> String
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg dflag :: DynFlags
dflag style :: PprStyle
style err :: 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)

ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg :: SrcSpan -> Severity -> DynFlags -> PprStyle -> MsgDoc -> String
ppMsg spn :: SrcSpan
spn sev :: Severity
sev dflag :: DynFlags
dflag style :: PprStyle
style msg :: 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 = ""
      | 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
        (line :: Int
line,col :: Int
col,_,_) <- 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
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
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
forall a. [a] -> [a] -> [a]
++ String
severityCaption

checkErrorPrefix :: String
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"

showSeverityCaption :: Severity -> String
showSeverityCaption :: Severity -> String
showSeverityCaption SevWarning = "Warning: "
showSeverityCaption _          = ""

getSrcFile :: SrcSpan -> Maybe String
getSrcFile :: SrcSpan -> Maybe String
getSrcFile (G.RealSrcSpan spn :: 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 _                   = Maybe String
forall a. Maybe a
Nothing

isDumpSplices :: DynFlags -> Bool
isDumpSplices :: DynFlags -> Bool
isDumpSplices dflag :: 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 (RealSrcSpan spn :: 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 _ = Maybe (Int, Int, Int, Int)
forall a. Maybe a
Nothing