simple-log-0.9.12: src/System/Log/Simple/Monad.hs

{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ConstraintKinds, FlexibleContexts, CPP, ImplicitParams #-}

module System.Log.Simple.Monad (
	-- | Monad log
	MonadLog(..), LogT(..),
	noLog, withLog, runLog,

	-- | Getters
	askComponent, askScope,

	-- | Log functions
	log, sendLog,
	component,
	scope_, scope, scopeM, scoper, scoperM,
	trace,
	modifyLogConfig, modifyLogHandlers,
	) where

import Prelude hiding (log)
import Prelude.Unicode

#if __GLASGOW_HASKELL__ >= 800
import Control.Exception (SomeException)
#endif
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Fail
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Monad.Reader
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Stack
import System.Log.Simple.Base

class (MonadIO m, MonadMask m) => MonadLog m where
	askLog ∷ m Log
	localLog ∷ (Log → Log) → m a → m a

instance {-# OVERLAPPABLE #-} (MonadLog m, MonadTrans t, MFunctor t, MonadIO (t m), MonadMask (t m)) ⇒ MonadLog (t m) where
	askLog = lift askLog
	localLog fn = hoist (localLog fn)

newtype LogT m a = LogT { runLogT ∷ ReaderT Log m a }
	deriving (Functor, Applicative, Monad, MonadFail, MonadIO, MonadReader Log, MonadThrow, MonadCatch, MonadMask)

instance MonadTrans LogT where
	lift = LogT ∘ lift

instance (MonadIO m, MonadMask m) => MonadLog (LogT m) where
	askLog = LogT ask
	localLog fn = LogT ∘ local fn ∘ runLogT

-- | Run with no logging
noLog ∷ (MonadIO m, MonadMask m) ⇒ LogT m a → m a
noLog = runLog defCfg []

-- | Run @LogT@ monad with @Log@
withLog ∷ Log → LogT m a → m a
withLog l act = runReaderT (runLogT act) l

-- | Run @LogT@ monad with log config and handlers
runLog ∷ (MonadIO m, MonadMask m) ⇒ LogConfig → [LogHandler] → LogT m a → m a
runLog cfg handlers = bracket (liftIO $ newLog cfg handlers) (liftIO ∘ stopLog) ∘ flip withLog

-- | Ask current component
askComponent ∷ MonadLog m ⇒ m Component
askComponent = logComponent <$> askLog

-- | Ask current scope
askScope ∷ MonadLog m ⇒ m Scope
askScope = logScope <$> askLog

-- | Log message
log ∷ MonadLog m ⇒ Level → Text → m ()
log lev msg = do
	l ← askLog
	writeLog l lev msg

-- | Log message, same as @log@
sendLog ∷ MonadLog m ⇒ Level → Text → m ()
sendLog = log

-- | Log component, also sets root scope
component ∷ MonadLog m ⇒ Text → m a → m a
component c = localLog (getLog (read ∘ T.unpack $ c) mempty)

-- | Create local scope
scope_ ∷ MonadLog m ⇒ Text → m a → m a
scope_ s = localLog (subLog mempty (read ∘ T.unpack $ s))

#if __GLASGOW_HASKELL__ < 800
type HasCallStack = ?callStack ∷ CallStack

callStack ∷ HasCallStack ⇒ CallStack
callStack = ?callStack

prettyCallStack ∷ CallStack → String
prettyCallStack = showCallStack
#endif

-- | Scope with log all exceptions
scope ∷ (MonadLog m, HasCallStack) ⇒ Text → m a → m a
scope s act = scope_ s $ catch act onErr where
	onErr ∷ MonadLog m ⇒ SomeException → m a
	onErr e = do
		log Error $ T.unlines [
			T.concat ["Scope leaves with exception: ", fromString ∘ show $ e],
			fromString $ prettyCallStack callStack]
		throwM e

-- | Scope with log exception from @MonadError@
scopeM ∷ (MonadLog m, MonadError e m, Show e, HasCallStack) ⇒ Text → m a → m a
scopeM s act = scope_ s $ catchError act onErr where
	onErr ∷ (MonadLog m, MonadError e m, Show e) ⇒ e → m a
	onErr e = do
		log Error $ T.unlines [
			T.concat ["Scope leaves with exception: ", fromString ∘ show $ e],
			fromString $ prettyCallStack callStack]
		throwError e

-- | Scope with tracing result
scoper ∷ (MonadLog m, Show a, HasCallStack) ⇒ 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, HasCallStack) ⇒ 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 value
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

-- | Modify config, same as @updateLogConfig@, but within @MonadLog@
modifyLogConfig ∷ MonadLog m ⇒ (LogConfig → LogConfig) → m LogConfig
modifyLogConfig fn = askLog >>= flip updateLogConfig fn

-- | Modify handlers, same as @updateLogHandlers@, but within @MonadLog@
modifyLogHandlers ∷ MonadLog m ⇒ ([LogHandler] → [LogHandler]) → m ()
modifyLogHandlers fn = askLog >>= flip updateLogHandlers fn