module System.Log.Simple.Monad (
LogT(..),
withNoLog,
withLog,
log,
scope_,
scope,
scopeM_,
scopeM,
scoper,
scoperM,
ignoreError,
ignoreErrorM,
trace,
MonadLog(..)
) where
import Prelude hiding (log)
import Control.Exception (SomeException)
import Control.Concurrent.MSem
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Except
import Control.Monad.Catch
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import System.Log.Simple.Base
class (MonadIO m, MonadMask m) => MonadLog m where
askLog :: m Log
instance MonadLog m => MonadLog (ReaderT r m) where
askLog = lift askLog
instance MonadLog m => MonadLog (StateT s m) where
askLog = lift askLog
instance (Monoid w, MonadLog m) => MonadLog (WriterT w m) where
askLog = lift askLog
newtype LogT m a = LogT { runLogT :: ReaderT Log m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadReader Log, MonadThrow, MonadCatch, MonadMask)
instance (MonadIO m, MonadMask m) => MonadLog (LogT m) where
askLog = LogT ask
withNoLog :: LogT m a -> m a
withNoLog act = runReaderT (runLogT act) noLog
withLog :: Log -> LogT m a -> m a
withLog l act = runReaderT (runLogT act) l
log :: (MonadLog m) => Level -> Text -> m ()
log l msg = do
(Log post _ _) <- askLog
tm <- liftIO getZonedTime
liftIO $ post $ PostMessage (Message tm l [] msg)
scope_ :: (MonadLog m) => Text -> m a -> m a
scope_ s act = do
(Log post _ getRules) <- askLog
rs <- liftIO getRules
sem <- liftIO $ new (0 :: Integer)
bracket_ (liftIO $ post $ EnterScope s rs) (liftIO (post (LeaveScope $ signal sem) >> wait sem)) act
scope :: (MonadLog m) => Text -> m a -> m a
scope s act = scope_ s $ catch act onError where
onError :: (MonadLog m) => SomeException -> m a
onError e = do
log Error $ T.concat ["Scope leaves with exception: ", fromString . show $ e]
throwM e
scopeM_ :: (MonadLog m, MonadError e m) => Text -> m a -> m a
scopeM_ s act = do
(Log post _ getRules) <- askLog
rs <- liftIO getRules
sem <- liftIO $ new (0 :: Integer)
let
close = liftIO $ do
post $ LeaveScope $ signal sem
wait sem
bracket_ (liftIO $ post $ EnterScope s rs) close (catchError act (\e -> close >> throwError e))
scopeM :: (Show e, MonadLog m, MonadError e m) => Text -> m a -> m a
scopeM s act = scopeM_ s $ catch act' onError' where
onError' :: (MonadLog m) => SomeException -> m a
onError' e = logE e >> throwM e
act' = catchError act onError
onError :: (MonadLog m, Show e, MonadError e m) => e -> m a
onError e = logE e >> throwError e
logE :: (MonadLog m, Show e) => e -> m ()
logE e = log Error $ T.concat ["Scope leaves with exception: ", fromString . show $ e]
scoper :: (Show a, MonadLog m) => Text -> m a -> m a
scoper s act = do
r <- scope s act
log Trace $ T.concat ["Scope ", s, " leaves with result: ", fromString . show $ r]
return r
scoperM :: (Show e, Show a, MonadLog m, MonadError e m) => Text -> m a -> m a
scoperM s act = do
r <- scopeM s act
log Trace $ T.concat ["Scope", s, " leaves with result: ", fromString . show $ r]
return r
ignoreError :: (MonadLog m) => m () -> m ()
ignoreError act = catch act onError where
onError :: (MonadLog m) => SomeException -> m ()
onError _ = return ()
ignoreErrorM :: (MonadLog m, MonadError e m) => m () -> m ()
ignoreErrorM act = catchError act onError where
onError :: MonadLog m => e -> m ()
onError _ = return ()
trace :: (Show a, MonadLog m) => Text -> m a -> m a
trace name act = do
v <- act
log Trace $ T.concat [name, " = ", fromString . show $ v]
return v