{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}

module Hhp.Logger (
    withLogger
  , checkErrorPrefix
  , getSrcSpan
  ) 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 (Ghc, DynFlags(..), SrcSpan(..))
#if __GLASGOW_HASKELL__ < 808
import GHC (Severity(SevError))
#endif
import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages)
import Outputable (PprStyle, SDoc)

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.GHCApi (withDynFlags, withCmdFlags)
import Hhp.Types (Options(..), convert)

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

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 :: Options -> LogRef -> IO String
readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef Options
opt (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
$! Options -> [String] -> String
forall a. ToString a => Options -> a -> String
convert Options
opt (Builder
b [])

appendLogRef :: DynFlags -> LogRef -> LogAction
appendLogRef :: DynFlags -> LogRef -> LogAction
appendLogRef DynFlags
df (LogRef IORef Builder
ref) DynFlags
_ WarnReason
_ Severity
sev SrcSpan
src PprStyle
style 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 :: 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.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle (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 (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 (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) (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
            Ghc ()
body
            IO (Either String String) -> Ghc (Either String String)
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
    setLogger :: LogRef -> DynFlags -> DynFlags
setLogger LogRef
logref DynFlags
df = DynFlags
df { log_action :: LogAction
log_action =  DynFlags -> LogRef -> LogAction
appendLogRef DynFlags
df LogRef
logref }
    wflags :: [String]
wflags = (String -> Bool) -> Builder
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-fno-warn" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) Builder -> Builder
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 <- DynFlags -> Ghc PprStyle
getStyle DynFlags
dflag
    let 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
. 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 -> Ghc (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 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 -> 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)

ppMsg :: SrcSpan -> Severity-> DynFlags -> 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 :: Severity -> String
showSeverityCaption :: Severity -> String
showSeverityCaption Severity
SevWarning = String
"Warning: "
showSeverityCaption Severity
_          = String
""

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