simple-log 0.7.0 → 0.8.0

raw patch · 4 files changed

+32/−19 lines, 4 filesdep +mmorph

Dependencies added: mmorph

Files

• simple-log.cabal +2/−1
• src/System/Log/Simple.hs +1/−1
• src/System/Log/Simple/Base.hs +10/−5
• src/System/Log/Simple/Monad.hs +19/−12

@@ -1,5 +1,5 @@ Name:                 simple-log
-Version:              0.7.0
+Version:              0.8.0
 Synopsis:             Simple log for Haskell
 Description:          Log library for Haskell with removing unnecessary traces
 License:              BSD3
@@ -30,6 +30,7 @@     filepath >= 1.4 && < 1.5,
     hformat == 0.2.*,
     microlens-platform == 0.3.*,
+    mmorph == 1.0.*,
     mtl >= 2.2 && < 2.3,
     SafeSemaphore >= 0.9.0 && < 1.0.0,
     text >= 0.11.0 && < 2.0.0,

@@ -72,7 +72,7 @@ 	LogConfig(..), defCfg, logCfg, componentCfg, Log(..),
 	newLog, rootLog, getLog, subLog,
 	updateLogConfig, updateLogHandlers, writeLog, stopLog)
-import System.Log.Simple.Monad (MonadLog, LogT(..), noLog, withLog, runLog, askLog, sendLog, component, scope_, scope, scopeM, scoper, scoperM, trace)
+import System.Log.Simple.Monad (MonadLog(..), LogT(..), noLog, withLog, runLog, sendLog, component, scope_, scope, scopeM, scoper, scoperM, trace)
 import System.Log.Simple.Text
 import System.Log.Simple.Stream
 import System.Log.Simple.File

@@ -8,12 +8,13 @@ 	LogHandler, handler,
 	LogConfig(..), defCfg, logCfg, componentCfg, componentLevel,
 	Log(..),
-	newLog, rootLog, getLog, subLog, updateLogConfig, updateLogHandlers, writeLog, stopLog,
+	newLog, rootLog, getLog, subLog, getLogConfig, updateLogConfig, updateLogHandlers, writeLog, stopLog,
 	) where
 
 import Prelude.Unicode
 
 import Control.Applicative
+import Control.Arrow
 import qualified Control.Exception as E
 import Control.Concurrent
 import qualified Control.Concurrent.Async as A
@@ -259,10 +260,10 @@ 		runHandlers ∷ FChan Message → [LogHandler] → ContT () IO ()
 		runHandlers inCh hs = do
 			hs' ← sequence $ map (fmap tryLog) hs
-			fix $ \loop → do
+			fix $ \loop' → do
 				msg ← liftIO $ readChan inCh
 				case msg of
-					Just msg' → liftIO (mapM_ ($ msg') hs') >> loop
+					Just msg' → liftIO (mapM_ ($ msg') hs') >> loop'
 					Nothing → return ()
 
 		-- | Start handlers thread
@@ -306,9 +307,13 @@ 	logComponent = logComponent l `mappend` comp,
 	logScope = logScope l `mappend` scope }
 
+-- | Read log config
+getLogConfig ∷ MonadIO m ⇒ Log → m LogConfig
+getLogConfig l = liftIO $ readMVar (logConfig l)
+
 -- | Modify log config
-updateLogConfig ∷ MonadIO m ⇒ Log → (LogConfig → LogConfig) → m ()
-updateLogConfig l update = liftIO $ modifyMVar_ (logConfig l) (return ∘ update)
+updateLogConfig ∷ MonadIO m ⇒ Log → (LogConfig → LogConfig) → m LogConfig
+updateLogConfig l update = liftIO $ modifyMVar (logConfig l) (return ∘ (update &&& id))
 
 -- | Update log handlers, this restarts handlers thread
 updateLogHandlers ∷ MonadIO m ⇒ Log → ([LogHandler] → [LogHandler]) → m ()

@@ -2,11 +2,11 @@ 
 module System.Log.Simple.Monad (
 	-- | Monad log
-	MonadLog, LogT(..),
+	MonadLog(..), LogT(..),
 	noLog, withLog, runLog,
 
 	-- | Getters
-	askLog, askComponent, askScope,
+	askComponent, askScope,
 
 	-- | Log functions
 	log, sendLog,
@@ -20,6 +20,7 @@ 
 import Control.Exception (SomeException)
 import Control.Monad.IO.Class
+import Control.Monad.Morph
 import Control.Monad.Reader
 import Control.Monad.Except
 import Control.Monad.Catch
@@ -29,14 +30,24 @@ import GHC.Stack
 import System.Log.Simple.Base
 
-type MonadLog m = (MonadIO m, MonadMask m, MonadReader Log m)
+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, 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 []
@@ -49,22 +60,18 @@ 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 log
-askLog ∷ MonadLog m ⇒ m Log
-askLog = ask
-
 -- | Ask current component
 askComponent ∷ MonadLog m ⇒ m Component
-askComponent = asks logComponent
+askComponent = logComponent <$> askLog
 
 -- | Ask current scope
 askScope ∷ MonadLog m ⇒ m Scope
-askScope = asks logScope
+askScope = logScope <$> askLog
 
 -- | Log message
 log ∷ MonadLog m ⇒ Level → Text → m ()
 log lev msg = do
-	l ← ask
+	l ← askLog
 	writeLog l lev msg
 
 -- | Log message, same as @log@
@@ -73,11 +80,11 @@ 
 -- | Log component, also sets root scope
 component ∷ MonadLog m ⇒ Text → m a → m a
-component c = local (getLog (read ∘ T.unpack $ c) mempty)
+component c = localLog (getLog (read ∘ T.unpack $ c) mempty)
 
 -- | Create local scope
 scope_ ∷ MonadLog m ⇒ Text → m a → m a
-scope_ s = local (subLog mempty (read ∘ T.unpack $ s))
+scope_ s = localLog (subLog mempty (read ∘ T.unpack $ s))
 
 -- | Scope with log all exceptions
 scope ∷ MonadLog m ⇒ Text → m a → m a