packages feed

gore-and-ash-logging 1.2.1.0 → 2.0.0.0

raw patch · 5 files changed

+195/−68 lines, 5 filesdep +extradep +hashabledep +unordered-containers

Dependencies added: extra, hashable, unordered-containers

Files

gore-and-ash-logging.cabal view
@@ -1,5 +1,5 @@ name:                gore-and-ash-logging-version:             1.2.1.0+version:             2.0.0.0 synopsis:            Core module for gore-and-ash with logging utilities description:         Please see README.md homepage:            https://github.com/Teaspot-Studio/gore-and-ash-logging@@ -31,8 +31,11 @@                      , text-show >= 2                      , transformers >= 0.4.2                      , transformers-base >= 0.4.4+                     , hashable >= 1.2.4.0+                     , unordered-containers >= 0.2.5.1+                     , extra >= 1.4.3 -  default-extensions:  +  default-extensions:                        DataKinds                        DeriveGeneric                        FlexibleInstances
src/Game/GoreAndAsh/Logging.hs view
@@ -10,7 +10,7 @@ The module contains all API for Gore&Ash logging module. The module doesn't depends on others core modules and could be place in any place in game monad stack. -The core module is pure on it first phase and could be used with 'Identity' end monad.+The core module is not pure on it first phase and could be used with 'IO' as end monad. See 'ModuleStack' documentation.  Example of embedding:@@ -21,46 +21,51 @@ newtype AppState = AppState (ModuleState AppStack)   deriving (Generic) -instance NFData AppState +instance NFData AppState  -- | Wrapper around type family newtype AppMonad a = AppMonad (AppStack a)   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, ... other modules monads ... )-  -instance GameModule AppMonad AppState where ++instance GameModule AppMonad AppState where   type ModuleState AppMonad = AppState-  runModule (AppMonad m) (AppState s) = do -    (a, s') <- runModule m s +  runModule (AppMonad m) (AppState s) = do+    (a, s') <- runModule m s     return (a, AppState s')   newModuleState = AppState <$> newModuleState   withModule _ = withModule (Proxy :: Proxy AppStack)-  cleanupModule (AppState s) = cleanupModule s +  cleanupModule (AppState s) = cleanupModule s  -- | Arrow that is build over the monad stack type AppWire a b = GameWire AppMonad a b @-playerActor :: ActorMonad m => (PlayerId -> Player) -> GameActor m PlayerId Game Player +playerActor :: ActorMonad m => (PlayerId -> Player) -> GameActor m PlayerId Game Player playerActor initialPlayer = makeActor $ \i -> stateWire (initialPlayer i) $ mainController i   where   mainController i = proc (g, p) -> do-    + @ -} module Game.GoreAndAsh.Logging(   -- * Low-level API     LoggingState   , LoggingT+  , LoggingLevel(..)+  , LoggingSink(..)   , LoggingMonad(..)+  , loggingSetFile   -- * Arrow API   , logA   , logALn   , logE   , logELn   -- ** Every frame+  , logDebugA   , logInfoA   , logWarnA   , logErrorA   -- ** Event based+  , logDebugE   , logInfoE   , logWarnE   , logErrorE@@ -70,5 +75,5 @@   ) where  import Game.GoreAndAsh.Logging.API-import Game.GoreAndAsh.Logging.Module +import Game.GoreAndAsh.Logging.Module import Game.GoreAndAsh.Logging.State
src/Game/GoreAndAsh/Logging/API.hs view
@@ -11,6 +11,7 @@ -} module Game.GoreAndAsh.Logging.API(     LoggingMonad(..)+  , loggingSetFile   -- * Arrow API   , logA   , logALn@@ -18,10 +19,12 @@   , logELn    -- ** Every frame+  , logDebugA   , logInfoA   , logWarnA   , logErrorA   -- ** Event based+  , logDebugE   , logInfoE   , logWarnE   , logErrorE@@ -31,84 +34,124 @@   , 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.Sequence as S -import TextShow +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  -- | Low level API for module-class Monad m => LoggingMonad m where +class MonadIO m => LoggingMonad m where   -- | Put message to the console.-  putMsgM :: Text -> m ()+  putMsgM :: LoggingLevel -> Text -> m ()   -- | Put message and new line to the console.-  putMsgLnM :: Text -> m ()+  putMsgLnM :: LoggingLevel -> Text -> m ()+  -- | Setting current logging file handler+  loggingSetHandle :: IO.Handle -> m ()+  -- | Setting allowed sinks for given logging level.+  --+  -- By default all messages are passed into file and console.+  loggingSetFilter :: LoggingLevel -> [LoggingSink] -> m () -instance {-# OVERLAPPING #-} Monad m => LoggingMonad (LoggingT s m) where-  putMsgM t = do -    cntx <- get -    let newMsgs = case S.viewr $ loggingMsgs cntx of -          S.EmptyR -> loggingMsgs cntx S.|> t-          (s' S.:> t') -> s' S.|> (t' <> t)+instance {-# OVERLAPPING #-} 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 t = do -    cntx <- get -    put $ cntx { loggingMsgs = loggingMsgs cntx S.|> t }+  putMsgLnM l t = do+    cntx <- get+    put $ cntx { loggingMsgs = loggingMsgs cntx S.|> (l, t) } -instance {-# OVERLAPPABLE #-} (Monad (mt m), LoggingMonad m, MonadTrans mt) => LoggingMonad (mt m) where -  putMsgM = lift . putMsgM-  putMsgLnM = lift . putMsgLnM+  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 {-# OVERLAPPABLE #-} (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+ -- | Put message to console on every frame without newline-logA :: LoggingMonad m => GameWire m Text ()-logA = liftGameMonad1 putMsgM+logA :: LoggingMonad m => LoggingLevel -> GameWire m Text ()+logA l = liftGameMonad1 (putMsgM l)  -- | Put message to console on every frame-logALn :: LoggingMonad m => GameWire m Text ()-logALn = liftGameMonad1 putMsgLnM+logALn :: LoggingMonad m => LoggingLevel -> GameWire m Text ()+logALn l = liftGameMonad1 (putMsgLnM l)  -- | Put message to console on event without newline-logE :: LoggingMonad m => GameWire m (Event Text) (Event ())-logE = liftGameMonadEvent1 putMsgM+logE :: LoggingMonad m => LoggingLevel -> GameWire m (Event Text) (Event ())+logE l = liftGameMonadEvent1 (putMsgM l)  -- | Put message to console on event-logELn :: LoggingMonad m => GameWire m (Event Text) (Event ())-logELn = liftGameMonadEvent1 putMsgLnM+logELn :: LoggingMonad m => LoggingLevel -> GameWire m (Event Text) (Event ())+logELn l = liftGameMonadEvent1 (putMsgLnM l)  -- | Put info msg to console+logDebugA :: LoggingMonad m => GameWire m Text ()+logDebugA = logALn LogDebug . arr ("Debug: " <>)++-- | Put info msg to console logInfoA :: LoggingMonad m => GameWire m Text ()-logInfoA = logALn . arr ("Info: " <>)+logInfoA = logALn LogInfo . arr ("Info: " <>)  -- | Put warn msg to console logWarnA :: LoggingMonad m => GameWire m Text ()-logWarnA = logALn . arr ("Info: " <>)+logWarnA = logALn LogWarn . arr ("Warning: " <>)  -- | Put error msg to console logErrorA :: LoggingMonad m => GameWire m Text ()-logErrorA = logALn . arr ("Info: " <>)+logErrorA = logALn LogError . arr ("Error: " <>)  -- | Put info msg to console on event+logDebugE :: LoggingMonad m => GameWire m (Event Text) (Event ())+logDebugE = logELn LogDebug . mapE ("Debug: " <>)++-- | Put info msg to console on event logInfoE :: LoggingMonad m => GameWire m (Event Text) (Event ())-logInfoE = logELn . mapE ("Info: " <>)+logInfoE = logELn LogInfo . mapE ("Info: " <>)  -- | Put warn msg to console on event logWarnE :: LoggingMonad m => GameWire m (Event Text) (Event ())-logWarnE = logELn . mapE ("Info: " <>)+logWarnE = logELn LogWarn . mapE ("Warning: " <>)  -- | Put error msg to console on event logErrorE :: LoggingMonad m => GameWire m (Event Text) (Event ())-logErrorE = logELn . mapE ("Info: " <>)+logErrorE = logELn LogError . mapE ("Error: " <>)  -- | Prints event with given function traceEvent :: LoggingMonad m => (a -> Text) -> GameWire m (Event a) (Event ())-traceEvent f = logELn . mapE f+traceEvent f = logELn LogDebug . mapE f --- | Prints event +-- | Prints event traceEventShow :: (TextShow a, LoggingMonad m) => GameWire m (Event a) (Event ()) traceEventShow = traceEvent showt++-- | Helper to set logging file as local path+loggingSetFile :: (LoggingMonad m) => FilePath -- ^ Path to logging file+  -> Bool -- ^ If 'False', rewrites contents of the file, if 'True' opens in append mode+  -> m ()+loggingSetFile fname isAppend = do+  h <- liftIO $ IO.openFile fname $ if isAppend then AppendMode else WriteMode+  loggingSetHandle h
src/Game/GoreAndAsh/Logging/Module.hs view
@@ -18,12 +18,15 @@ import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Error.Class-import Control.Monad.Fix +import Control.Monad.Extra (whenJust)+import Control.Monad.Fix import Control.Monad.State.Strict import Control.Monad.Trans.Resource-import Data.Proxy +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@@ -37,7 +40,7 @@ -- [@a@] - Type of result value; -- -- How to embed module:--- +-- -- @ -- type AppStack = ModuleStack [LoggingT, ... other modules ... ] IO --@@ -53,27 +56,36 @@ 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 +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' { +    return (a, s' {         loggingMsgs = S.empty-      , loggingNextState = nextState +      , loggingNextState = nextState       })-    where -      printAllMsgs LoggingState{..} = liftIO $ mapM_ T.putStrLn loggingMsgs      +    where+      printAllMsgs ls@LoggingState{..} = do+        mapM_ (uncurry $ consoleOutput ls) loggingMsgs+        mapM_ (uncurry $ fileOutput ls) loggingMsgs -  newModuleState = do-    s <- newModuleState-    return $ LoggingState {-        loggingMsgs = S.empty-      , loggingNextState = s-      }+  newModuleState = emptyLoggingState <$> newModuleState    withModule _ = withModule (Proxy :: Proxy m)-  cleanupModule _ = return ()+  cleanupModule LoggingState{..} = case loggingFile of+    Nothing -> return ()+    Just h -> IO.hClose h++-- | Output given message to logging file if allowed+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++-- | Output given message to console if allowed+consoleOutput :: MonadIO m => LoggingState s -> LoggingLevel -> Text -> m ()+consoleOutput ls ll msg = when (filterLogMessage ls ll LoggingConsole) $+  liftIO $ T.putStrLn msg
src/Game/GoreAndAsh/Logging/State.hs view
@@ -11,19 +11,83 @@ -} module Game.GoreAndAsh.Logging.State(     LoggingState(..)+  , LoggingLevel(..)+  , LoggingSink(..)+  , emptyLoggingState+  , filterLogMessage   ) where -import qualified Data.Sequence as S-import Data.Text +import Control.DeepSeq+import Data.Hashable+import Data.Text import GHC.Generics (Generic)-import Control.DeepSeq +import qualified Data.HashMap.Strict as H+import qualified Data.HashSet as HS+import qualified Data.Sequence as S+import System.IO ++-- | Distanation of logging+data LoggingSink =+  -- | Putting to user terminal+    LoggingConsole+  -- | Putting into file+  | LoggingFile+  deriving (Eq, Ord, Bounded, Show, Read, Generic)++instance NFData LoggingSink+instance Hashable LoggingSink++-- | Describes important of logging message+data LoggingLevel =+  -- | Used for detailed logging+    LogDebug+  -- | Used for messages about normal operation of application+  | LogInfo+  -- | Used for recoverable errors or defaulting to fallback behavior+  | LogWarn+  -- | Used before throwing an exception or fatal fales+  | LogError+  -- | Special case of message, that never goes to console, but saved into file+  | LogMuted+  deriving (Eq, Ord, Bounded, Show, Read, Generic)++instance NFData LoggingLevel+instance Hashable LoggingLevel++type LoggingFilter = H.HashMap LoggingLevel (HS.HashSet LoggingSink)+ -- | Inner state of logger. -- -- [@s@] next state, states of modules are chained via nesting data LoggingState s = LoggingState {-  loggingMsgs :: !(S.Seq Text)+  loggingMsgs :: !(S.Seq (LoggingLevel, Text)) , loggingNextState :: !s+, loggingFile :: !(Maybe Handle)+, loggingFilter :: !(LoggingFilter)+, loggignDebug :: !Bool } deriving (Generic) -instance NFData s => NFData (LoggingState s)+instance NFData s => NFData (LoggingState s) where+  rnf LoggingState{..} =+     loggingMsgs `deepseq`+     loggingNextState `deepseq`+     loggingFile `seq`+     loggingFilter `deepseq`+     loggignDebug `seq` ()++-- | Create empty module state+emptyLoggingState :: s -> LoggingState s+emptyLoggingState s = LoggingState {+    loggingMsgs = S.empty+  , loggingNextState = s+  , loggingFile = Nothing+  , loggingFilter = H.empty+  , loggignDebug = False+  }++-- | Returns 'True' if given message level is allowed to go in the sink+filterLogMessage :: LoggingState s -> LoggingLevel -> LoggingSink -> Bool+filterLogMessage LoggingState{..} ll ls = case H.lookup ll loggingFilter of+  Nothing -> True+  Just ss -> HS.member ls ss