module Game.GoreAndAsh.Logging.Module(
LoggingT(..)
) where
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.Extra (whenJust)
import Control.Monad.Fix
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import Data.Proxy
import Data.Text (Text)
import qualified Data.Sequence as S
import qualified Data.Text.IO as T
import qualified System.IO as IO
import Game.GoreAndAsh
import Game.GoreAndAsh.Logging.State
newtype LoggingT s m a = LoggingT { runLoggingT :: StateT (LoggingState s) m a }
deriving (Functor, Applicative, Monad, MonadState (LoggingState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadError e)
instance MonadBase IO m => MonadBase IO (LoggingT s m) where
liftBase = LoggingT . liftBase
instance MonadResource m => MonadResource (LoggingT s m) where
liftResourceT = LoggingT . liftResourceT
instance GameModule m s => GameModule (LoggingT s m) (LoggingState s) where
type ModuleState (LoggingT s m) = LoggingState s
runModule (LoggingT m) s = do
((a, s'), nextState) <- runModule (runStateT m s) (loggingNextState s)
printAllMsgs s'
return (a, s' {
loggingMsgs = S.empty
, loggingNextState = nextState
})
where
printAllMsgs ls@LoggingState{..} = do
mapM_ (uncurry $ consoleOutput ls) loggingMsgs
mapM_ (uncurry $ fileOutput ls) loggingMsgs
newModuleState = emptyLoggingState <$> newModuleState
withModule _ = withModule (Proxy :: Proxy m)
cleanupModule LoggingState{..} = case loggingFile of
Nothing -> return ()
Just h -> IO.hClose h
fileOutput :: MonadIO m => LoggingState s -> LoggingLevel -> Text -> m ()
fileOutput ls ll msg = when (filterLogMessage ls ll LoggingFile) $
whenJust (loggingFile ls) $ \h -> liftIO $ T.hPutStrLn h msg
consoleOutput :: MonadIO m => LoggingState s -> LoggingLevel -> Text -> m ()
consoleOutput ls ll msg = when (filterLogMessage ls ll LoggingConsole) $
liftIO $ T.putStrLn msg