module System.Log.Simple.Monad (
MonadLog, LogT(..),
noLog, withLog, runLog,
askLog, askComponent, askScope,
log, sendLog,
component,
scope_, scope, scopeM, scoper, scoperM,
trace,
) where
import Prelude hiding (log)
import Prelude.Unicode
import Control.Exception (SomeException)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Except
import Control.Monad.Catch
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Stack
import System.Log.Simple.Base
type MonadLog m = (MonadIO m, MonadMask m, MonadReader Log m)
newtype LogT m a = LogT { runLogT ∷ ReaderT Log m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadReader Log, MonadThrow, MonadCatch, MonadMask)
instance MonadTrans LogT where
lift = LogT ∘ lift
noLog ∷ (MonadIO m, MonadMask m) ⇒ LogT m a → m a
noLog = runLog defCfg []
withLog ∷ Log → LogT m a → m a
withLog l act = runReaderT (runLogT act) l
runLog ∷ (MonadIO m, MonadMask m) ⇒ LogConfig → [LogHandler] → LogT m a → m a
runLog cfg handlers = bracket (liftIO $ newLog cfg handlers) (liftIO ∘ stopLog) ∘ flip withLog
askLog ∷ MonadLog m ⇒ m Log
askLog = ask
askComponent ∷ MonadLog m ⇒ m Component
askComponent = asks logComponent
askScope ∷ MonadLog m ⇒ m Scope
askScope = asks logScope
log ∷ MonadLog m ⇒ Level → Text → m ()
log lev msg = do
l ← ask
writeLog l lev msg
sendLog ∷ MonadLog m ⇒ Level → Text → m ()
sendLog = log
component ∷ MonadLog m ⇒ Text → m a → m a
component c = local (getLog (read ∘ T.unpack $ c) mempty)
scope_ ∷ MonadLog m ⇒ Text → m a → m a
scope_ s = local (subLog mempty (read ∘ T.unpack $ s))
scope ∷ MonadLog m ⇒ Text → m a → m a
scope s act = scope_ s $ catch act onError where
onError ∷ (MonadLog m, HasCallStack) ⇒ SomeException → m a
onError e = do
log Error $ T.unlines [
T.concat ["Scope leaves with exception: ", fromString ∘ show $ e],
fromString $ prettyCallStack callStack]
throwM e
scopeM ∷ (MonadLog m, MonadError e m, Show e) ⇒ Text → m a → m a
scopeM s act = scope_ s $ catchError act onError where
onError ∷ (MonadLog m, MonadError e m, Show e, HasCallStack) ⇒ e → m a
onError e = do
log Error $ T.unlines [
T.concat ["Scope leaves with exception: ", fromString ∘ show $ e],
fromString $ prettyCallStack callStack]
throwError e
scoper ∷ (MonadLog m, Show a) ⇒ 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 ∷ (MonadLog m, MonadError e m, Show e, Show a) ⇒ 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
trace ∷ (MonadLog m, Show a) ⇒ Text → m a → m a
trace name act = do
v ← act
log Trace $ T.concat [name, " = ", fromString . show $ v]
return v