module Game.GoreAndAsh.Logging.API(
LoggingMonad(..)
, loggingSetFile
, logA
, logALn
, logE
, logELn
, logDebugA
, logInfoA
, logWarnA
, logErrorA
, logDebugE
, logInfoE
, logWarnE
, logErrorE
, traceEvent
, traceEventShow
) where
import Control.Monad.Extra (whenJust)
import Control.Monad.State.Strict
import Control.Wire
import Data.Text
import Prelude hiding (id, (.))
import qualified Data.HashMap.Strict as H
import qualified Data.HashSet as HS
import qualified Data.Sequence as S
import System.IO as IO
import TextShow
import Game.GoreAndAsh
import Game.GoreAndAsh.Logging.State
import Game.GoreAndAsh.Logging.Module
class MonadIO m => LoggingMonad m where
putMsgM :: LoggingLevel -> Text -> m ()
putMsgLnM :: LoggingLevel -> Text -> m ()
loggingSetHandle :: IO.Handle -> m ()
loggingSetFilter :: LoggingLevel -> [LoggingSink] -> m ()
instance MonadIO m => LoggingMonad (LoggingT s m) where
putMsgM l t = do
cntx <- get
let newMsgs = case S.viewr $ loggingMsgs cntx of
S.EmptyR -> loggingMsgs cntx S.|> (l, t)
(s' S.:> (l', t')) -> s' S.|> (l', t' <> t)
put $ cntx { loggingMsgs = newMsgs }
putMsgLnM l t = do
cntx <- get
put $ cntx { loggingMsgs = loggingMsgs cntx S.|> (l, t) }
loggingSetHandle h = do
cntx <- get
whenJust (loggingFile cntx) $ liftIO . IO.hClose
put $ cntx { loggingFile = Just h }
loggingSetFilter l ss = do
cntx <- get
let lfilter = case l `H.lookup` loggingFilter cntx of
Nothing -> H.insert l (HS.fromList ss) . loggingFilter $ cntx
Just ss' -> H.insert l (HS.fromList ss `HS.union` ss') . loggingFilter $ cntx
put $ cntx { loggingFilter = lfilter }
instance (MonadIO (mt m), LoggingMonad m, MonadTrans mt) => LoggingMonad (mt m) where
putMsgM a b = lift $ putMsgM a b
putMsgLnM a b = lift $ putMsgLnM a b
loggingSetHandle = lift . loggingSetHandle
loggingSetFilter a b = lift $ loggingSetFilter a b
logA :: LoggingMonad m => LoggingLevel -> GameWire m Text ()
logA l = liftGameMonad1 (putMsgM l)
logALn :: LoggingMonad m => LoggingLevel -> GameWire m Text ()
logALn l = liftGameMonad1 (putMsgLnM l)
logE :: LoggingMonad m => LoggingLevel -> GameWire m (Event Text) (Event ())
logE l = liftGameMonadEvent1 (putMsgM l)
logELn :: LoggingMonad m => LoggingLevel -> GameWire m (Event Text) (Event ())
logELn l = liftGameMonadEvent1 (putMsgLnM l)
logDebugA :: LoggingMonad m => GameWire m Text ()
logDebugA = logALn LogDebug . arr ("Debug: " <>)
logInfoA :: LoggingMonad m => GameWire m Text ()
logInfoA = logALn LogInfo . arr ("Info: " <>)
logWarnA :: LoggingMonad m => GameWire m Text ()
logWarnA = logALn LogWarn . arr ("Warning: " <>)
logErrorA :: LoggingMonad m => GameWire m Text ()
logErrorA = logALn LogError . arr ("Error: " <>)
logDebugE :: LoggingMonad m => GameWire m (Event Text) (Event ())
logDebugE = logELn LogDebug . mapE ("Debug: " <>)
logInfoE :: LoggingMonad m => GameWire m (Event Text) (Event ())
logInfoE = logELn LogInfo . mapE ("Info: " <>)
logWarnE :: LoggingMonad m => GameWire m (Event Text) (Event ())
logWarnE = logELn LogWarn . mapE ("Warning: " <>)
logErrorE :: LoggingMonad m => GameWire m (Event Text) (Event ())
logErrorE = logELn LogError . mapE ("Error: " <>)
traceEvent :: LoggingMonad m => (a -> Text) -> GameWire m (Event a) (Event ())
traceEvent f = logELn LogDebug . mapE f
traceEventShow :: (TextShow a, LoggingMonad m) => GameWire m (Event a) (Event ())
traceEventShow = traceEvent showt
loggingSetFile :: (LoggingMonad m) => FilePath
-> Bool
-> m ()
loggingSetFile fname isAppend = do
h <- liftIO $ IO.openFile fname $ if isAppend then AppendMode else WriteMode
loggingSetHandle h