packages feed

simple-log 0.3.4 → 0.9.12

raw patch · 13 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012, Alexandr `Voidex` Ruchkin
+Copyright (c) 2013, Alexandr `Voidex` Ruchkin
 
 All rights reserved.
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
simple-log.cabal view
@@ -1,7 +1,7 @@ Name:                 simple-log
-Version:              0.3.4
+Version:              0.9.12
 Synopsis:             Simple log for Haskell
-Description:          Log library for Haskell with removing unnecessary traces
+Description:          Log library for Haskell
 License:              BSD3
 License-file:         LICENSE
 Author:               Alexandr `Voidex` Ruchkin
@@ -9,31 +9,59 @@ Maintainer:           voidex@live.com
 Category:             Logging
 Build-type:           Simple
-Cabal-version:        >= 1.6
-Tested-with:          GHC == 7.6.1
+Cabal-version:        >= 1.10
 
-Library
-  HS-Source-Dirs: src
-  Build-Depends:
+source-repository head
+  type: git
+  location: git://github.com/mvoidex/simple-log.git
+
+library
+  hs-source-dirs: src
+  if !impl(ghc >= 8.0)
+    build-depends:
+      semigroups >= 0.18.2 && < 0.19
+  build-depends:
     base >= 4.0 && < 6,
     async >= 2.0 && < 3.0,
-    containers >= 0.5 && < 0.6,
+    base-unicode-symbols >= 0.2 && < 0.3,
+    containers >= 0.5 && < 0.7,
+    data-default >= 0.5 && < 0.8,
     deepseq >= 1.4 && < 1.5,
-    directory >= 1.2 && < 1.3,
+    directory >= 1.2 && < 1.4,
+    exceptions >= 0.8 && < 0.11,
     filepath >= 1.4 && < 1.5,
-    MonadCatchIO-transformers >= 0.2 && < 0.4,
+    hformat == 0.3.*,
+    microlens == 0.4.*,
+    microlens-platform >= 0.3 && < 0.5,
+    mmorph >= 1.0 && < 1.2,
     mtl >= 2.2 && < 2.3,
     SafeSemaphore >= 0.9.0 && < 1.0.0,
     text >= 0.11.0 && < 2.0.0,
-    time >= 1.5 && < 1.6,
+    time >= 1.5 && < 1.10,
     transformers >= 0.4 && < 0.6
-  Exposed-Modules:
+  exposed-modules:
     System.Log.Simple
     System.Log.Simple.Base
-    System.Log.Simple.Config
+    System.Log.Simple.Chan
     System.Log.Simple.Monad
     System.Log.Simple.Text
-    System.Log.Simple.Console
+    System.Log.Simple.Stream
     System.Log.Simple.File
 
-  Ghc-Options: -Wall
+  default-language: Haskell2010
+  default-extensions: UnicodeSyntax
+  ghc-options: -Wall -fno-warn-tabs
+
+test-suite test
+  main-is: Test.hs
+  hs-source-dirs: tests
+  ghc-options: -threaded -Wall -fno-warn-tabs
+  type: exitcode-stdio-1.0
+  default-language: Haskell2010
+  default-extensions: UnicodeSyntax
+  build-depends:
+    base >= 4.0 && < 6,
+    simple-log,
+    hspec >= 2.3 && < 2.8,
+    microlens-platform >= 0.3 && < 0.5,
+    text >= 0.11.0 && < 2.0.0
src/System/Log/Simple.hs view
@@ -1,215 +1,110 @@ -- | Fast start
 --
--- The best way is to define config file, which is auto reloaded periodically, so you can change config while program is running to turn on tracing some function.
---
--- Typical config file with rule for root scope (see below for explanation):
---
--- @
--- \/: use default
--- @
---
--- If you want to trace scope named \"foo\", just add:
---
--- @
--- \/: use default
--- foo: low trace
--- @
---
--- Now \"foo\" and children will be traced even there are no errors. To trace only \"foo\" without children:
---
--- @
--- \/: use default
--- foo: low trace
--- foo\/: use default
--- @
---
--- \"foo\/\" defines rules for children of \"foo\".
---
--- Note, that by default all function will log their traces on error, so there is no need to turn on trace manually. You may want to turn on tracing when there are logic errors present without explicit errors (exceptions, or messages with error level).
---
--- Now we can run our log with auto reloading config every 60 seconds:
---
--- @
---run :: IO ()
---run = do
---    l <- newLog (fileCfg \"log.cfg\" 60) [logger text (file \"out.log\")]
---    withLog l yourFunction
--- @
---
--- And use it:
---
--- @
---yourFunction :: (MonadLog m) => m ()
---yourFunction = scope \"your\" $ do
---    log Trace \"Hello from your function\"
--- @
---
--- The main ideas of this log library are:
---
---     * we don't want to see all unnecessary trace messages when there are no errors,
---
---     * but we want to have all possible information about error.
--- 
--- This library is based on scopes. Every scope have a name, and logs traces only if there are some errors. Otherwise it logs only message with 'Info' level.
--- 
--- Let's start by simple example:
---
--- @
---test :: ReaderT Log IO ()
---test = scope \"test\" $ do
---log Trace \"Trace message\"
---    log Info \"Starting test\"
---    s \<- liftIO T.getLine
---    when (T.null s) $ log Error \"Oh no!\"
---    log Trace $ T.concat [\"Your input: \", s]
--- @
---
--- When you input some valid string, it will produce output:
---
--- @
---08\/10\/12 22:23:34   INFO    test> Starting test
---abc
--- @
---
--- wihtout any traces
---
--- But if you input empty strings, you'll get:
---
--- @
---08\/10\/12 22:24:20   INFO    test> Starting test
---08\/10\/12 22:24:20   TRACE   test> Trace message
---08\/10\/12 22:24:21   ERROR   test> Oh no!
---08\/10\/12 22:24:21   TRACE   test> Your input: 
--- @
---
--- Note, that first 'Trace' is written after 'Info', that's because logger don't know whether 'Trace' message will be written or not, but he must write 'Info' message immediately. But that's not a big problem.
---
--- There are three scope functions: 'scope_', 'scope' and 'scoper'. 'scope_' is basic function. 'scope' catches all exceptions and logs error with it, then rethrows. 'scoper' is like 'scope', but logs (with 'Trace' level) result of do-block.
---
--- Of course, scopes can be nested:
---
--- @
---test :: ReaderT Log IO ()
---test = scope \"test\" $ do
---    log Trace \"test trace\"
---    foo
---    log Info \"some info\"
---    bar
---
---foo :: ReaderT Log IO ()
---foo = scope \"foo\" $ do
---    log Trace \"foo trace\"
---
---bar :: ReaderT Log IO ()
---bar = scope \"bar\" $ do
---    log Trace \"bar trace\"
---    log Error \"bar error\"
--- @
---
--- Output:
+-- Create log config:
 --
 -- @
---08\/10\/12 22:32:53   INFO    test> some info
---08\/10\/12 22:32:53   TRACE   test/bar> bar trace
---08\/10\/12 22:32:53   ERROR   test/bar> bar error
+--myCfg = logCfg [(\"\", Info), (\"app\", Trace), (\"app.sub\", Debug)]
 -- @
 --
--- Note, no messages for \"foo\" and no trace messages for \"test\", because error was in \"bar\", not in \"foo\".
---
--- Code to run log:
+-- Create log and run log monad
 --
 -- @
---rules :: Rules
---rules = []
---
---run :: IO ()
---run = do
---    l <- newLog (constant rules) [logger text console]
---    withLog l test
+--run ∷ IO ()
+--run = runLog myCfg [handler text (file \"out.log\")] $ yourFunction
 -- @
 --
--- Politics sets 'low' and 'high' levels. By default, 'low' and 'high' are INFO and WARN. Levels below 'low' are "traces" ('Trace' and 'Debug' by default). Levels above 'high' are "errors" ('Error' and 'Fatal' by default).
---
--- If you set 'low' to 'Trace', all messages will be written. If you set 'low' to 'Debug' and 'high' to 'Fatal', "traces" (in this case only 'Trace') will be never written.
---
--- Sometimes we need to trace function, but we don't want to write all traces. We can get this by setting rules. Rules changes politics for specified scope-path (scope-path is list of nested scopes, for example [\"test\"], [\"test\", \"bar\"], [\"test\", \"bar\", \"baz\", \"quux\"] etc.)
---
--- For example, we want to trace function 'foo':
+-- Function within log monad:
 --
 -- @
---rules = [
---    rule root $ use defaultPolitics,
---    rule (relative [\"foo\"]) $ low Trace]
+--yourFunction ∷ MonadLog m ⇒ m ()
+--yourFunction = component \"app\" $ scope \"your\" $ do
+--	sendLog Trace \"Hello from your function\"
 -- @
 --
--- From now all scope-paths, that contains \"foo\" (all scopes with name \"foo\") will have politics with 'low' set to Trace.
---
--- We may adjust politics for scope 'foo', that is nested directly in scope 'quux':
+-- Each component can have different level in config, subcomponents are specified with \'.\'
+-- Components have independent scopes
+-- Scopes can be nested and separated with \'/\':
 --
 -- @
---rules = [
---    rule root $ use defaultPolitics,
---    relative [\"quux\", \"foo\"] $ low Trace]
+--function2 ∷ MonadLog m ⇒ m ()
+--function2 = component \"app.sub\" $ scope \"foo\" $ do
+--	scope \"bar/baz\" $ do
+--		sendLog Info \"Component app.sub and scope foo/bar/baz\"
+--		sendLog Trace \"Invisible: app.sub configured with debug level\"
+--	sendLog Info \"Same component and scope foo\"
+--	component \"module\" $ sendLog Info \"Component module and root scope\"
 -- @
 --
--- And, of course, we may specify absolute path:
---
--- @
---rules = [
---    rule root $ use defaultPolitics,
---    absolute [\"bar\", \"baz\", \"foo\"] $ low Trace]
--- @
+-- You can update config with @updateLogConfig@ (or @modifyLogConfig@ within log monad) function
+-- And change handlers with @updateLogHandlers@ (@modifyLogHandlers@)
 -- 
--- Politics will be changed only for scope \"foo\", which is nested directly in \"baz\", which is nested in \"bar\", which is top scope.
---
--- Another way to define rule is using special functions from "System.Log.Config" module:
---
--- @
---rules = [
---    \"\/\" %= use defaultPolitics,
---    \"\/bar\/baz\/foo\" %= low Trace,
---    \"quux\/foo\" %= low Debug]
--- @
---
--- One more way to use special syntax for rules:
---
--- @
---rules = parseRules_ $ T.unlines [
---    \"\/: use default\",
---    \"\/bar\/baz\/foo: low trace\",
---    \"quux\/foo: low debug\"]
--- @
---
--- Here \"\/\" is for root, \"\/path\" for absolute path, \"path\" for relative and \"path\/\" for child of \"path\" (which may be also prefixed with \"\/\" to be absolute)
---
--- This syntax is useful to config log by file. Having file \"log.cfg\":
+-- There're also global logger @globalLog@, that can be used with @runGlobalLog@
 --
 -- @
--- \/: use default
--- \/bar\/baz\/foo: low trace
--- quux\/foo: low debug
+--test ∷ IO ()
+--test = do
+--	updateLogHandlers globalLog ([handler text (file \"test.log\")]:)
+--	runGlobalLog $ do
+--		sendLog Info \"This will go to test.log too\"
+--		modifyLogConfig (set (ix \"\") Debug)
+--		sendLog Debug \"Now debug is logged too\"
 -- @
 --
--- We can use it to config log
---
--- @
---    l <- newLog (fileCfg \"log.cfg\" 60) [logger text console]
--- @
--- 
--- where 60 is period (in seconds) of auto reload or 0 for no reloading.
---
 module System.Log.Simple (
-    module System.Log.Simple.Base,
-    module System.Log.Simple.Config,
-    module System.Log.Simple.Monad,
-    module System.Log.Simple.Text,
-    module System.Log.Simple.Console,
-    module System.Log.Simple.File
-    ) where
+	module System.Log.Simple.Base,
+	module System.Log.Simple.Monad,
+	module System.Log.Simple.Text,
+	module System.Log.Simple.Stream,
+	module System.Log.Simple.File,
 
-import System.Log.Simple.Base hiding (entries, flatten, rules)
-import System.Log.Simple.Config
-import System.Log.Simple.Monad
+	globalLog,
+	runGlobalLog, runConsoleLog, runLogMsgs, runLogTexts
+	) where
+
+import Prelude.Unicode
+
+import Control.Monad.IO.Class
+import Control.Monad.Catch (MonadMask)
+import Control.Concurrent
+import Data.Maybe
+import Data.Text (Text)
+import System.IO.Unsafe (unsafePerformIO)
+
+import System.Log.Simple.Base (
+	Level(..), Message, Converter, Consumer, LogHandler, handler,
+	LogConfig(..), defCfg, logCfg, componentCfg, Log(..),
+	newLog, rootLog, getLog, subLog,
+	updateLogConfig, updateLogHandlers, writeLog, stopLog)
+import System.Log.Simple.Monad (
+	MonadLog(..), LogT(..), noLog, withLog, runLog, sendLog,
+	component, scope_, scope, scopeM, scoper, scoperM, trace,
+	modifyLogConfig, modifyLogHandlers)
 import System.Log.Simple.Text
-import System.Log.Simple.Console
+import System.Log.Simple.Stream
 import System.Log.Simple.File
+import System.Log.Simple.Chan
+
+globalLog ∷ Log
+globalLog = unsafePerformIO $ newLog defCfg [handler text coloredConsole]
+
+runGlobalLog ∷ LogT m a → m a
+runGlobalLog = withLog globalLog
+
+runConsoleLog ∷ (MonadIO m, MonadMask m) ⇒ LogConfig → LogT m a → m a
+runConsoleLog cfg = runLog cfg [handler text coloredConsole]
+
+runLogChan ∷ (MonadIO m, MonadMask m) ⇒ (Chan w → LogHandler) → LogConfig → LogT m a → m (a, [w])
+runLogChan c cfg act = do
+	ch ← liftIO newChan
+	mch ← liftIO newChan
+	_ ← liftIO $ forkIO $ getChanContents ch >>= mapM_ (writeChan mch . Just)
+	r ← runLog cfg [c ch] act
+	liftIO $ writeChan mch Nothing
+	msgs ← liftIO ((catMaybes ∘ takeWhile isJust) <$> getChanContents mch)
+	return (r, msgs)
+
+runLogMsgs ∷ (MonadIO m, MonadMask m) ⇒ LogConfig → LogT m a → m (a, [Message])
+runLogMsgs = runLogChan chan
+
+runLogTexts ∷ (MonadIO m, MonadMask m) ⇒ Converter Text → LogConfig → LogT m a → m (a, [Text])
+runLogTexts txt = runLogChan (handler txt ∘ chan)
src/System/Log/Simple/Base.hs view
@@ -1,361 +1,320 @@-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, RankNTypes, TypeFamilies #-}
 
 module System.Log.Simple.Base (
-    Level(..),
-    Politics(..), Rule(..), Rules,
-    defaultPolitics, debugPolitics, tracePolitics, silentPolitics, supressPolitics,
-    rule, absolute, relative, child, root, path,
-    (%=),
-    politics, use, low, high,
-    Message(..),
-    Converter, Consumer(..),
-    Entry(..), Command(..),
-    entries, flatten, rules,
-    Logger, logger,
-    RulesLoad,
-    Log(..), noLog,
-    newLog,
-    writeLog,
-    stopLog,
-    scopeLog_,
-    scopeLog,
-    scoperLog
-    ) where
+	Level(..), level, level_,
+	Component(..), Scope(..),
+	Message(..),
+	Converter, Consumer, consumer,
+	LogHandler, handler,
+	LogConfig(..), defCfg, logCfg, componentCfg, componentLevel,
+	Log(..),
+	newLog, rootLog, getLog, subLog, getLogConfig, updateLogConfig, updateLogHandlers, writeLog, stopLog,
+	) where
 
-import Prelude hiding (log)
+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
-import Control.Concurrent.MSem
 import Control.DeepSeq
 import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.CatchIO
-import Data.List
+import Control.Monad.Cont
+import Data.Default
+import Data.Function (fix)
+import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (catMaybes, isJust)
+import Data.Maybe (fromMaybe)
+import Data.Semigroup (Semigroup(..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
 import Data.String
+import Lens.Micro.Platform
+import Lens.Micro.Internal
+import Text.Format
 
+
+-- Helper function
+splitBy ∷ Char → Text → [Text]
+splitBy _ "" = []
+splitBy ch t = T.split (≡ ch) t
+
+
+
 -- | Level of message
 data Level = Trace | Debug | Info | Warning | Error | Fatal
-    deriving (Eq, Ord, Read, Show, Enum, Bounded)
+	deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
--- | Scope politics
-data Politics = Politics {
-    politicsLow :: Level,
-    politicsHigh :: Level }
-        deriving (Eq, Ord, Read, Show)
+instance Default Level where
+	def = Trace
 
--- | Default politics
-defaultPolitics :: Politics
-defaultPolitics = Politics Info Warning
+instance Formattable Level where
+	formattable Trace _ = "TRACE" `withFlags` ["gray"]
+	formattable Debug _ = "DEBUG" `withFlags` ["yellow"]
+	formattable Info _ = "INFO" `withFlags` ["blue"]
+	formattable Warning _ = "WARN" `withFlags` ["darkyellow"]
+	formattable Error _ = "ERROR" `withFlags` ["red"]
+	formattable Fatal _ = "FATAL" `withFlags` ["bg=red"]
 
--- | Debug politics
-debugPolitics :: Politics
-debugPolitics = Politics Debug Info
+-- | Component — each one have separate log scopes and can have different politics
+-- Child component's root politics inherits its parent root politics
+-- Component name parts stored in reverse order
+newtype Component = Component { componentPath ∷ [Text] } deriving (Eq, Ord)
 
--- | Trace politics
-tracePolitics :: Politics
-tracePolitics = Politics Trace Info
+instance Show Component where
+	show = T.unpack ∘ T.intercalate "." ∘ reverse ∘ componentPath
 
--- | Silent politics
-silentPolitics :: Politics
-silentPolitics = Politics Info Fatal
+instance Formattable Component
 
--- | Supress all messages politics
-supressPolitics :: Politics
-supressPolitics = Politics Fatal Fatal
+instance Read Component where
+	readsPrec _ = return ∘ flip (,) "" ∘ Component ∘ reverse ∘ splitBy '.' ∘ T.pack
 
--- | Rule for politics
-data Rule = Rule {
-    rulePath :: [Text] -> Bool,
-    rulePolitics :: Politics -> Politics }
+instance IsString Component where
+	fromString = read
 
-type Rules = [Rule]
+instance Semigroup Component where
+	Component l <> Component r = Component $ r ++ l
 
--- | Make rule
-rule :: ([Text] -> Bool) -> (Politics -> Politics) -> Rule
-rule = Rule
+instance Monoid Component where
+	mempty = Component []
+	Component l `mappend` Component r = Component $ r ++ l
 
--- | Absolute scope-path
-absolute :: [Text] -> [Text] -> Bool
-absolute p = (== p)
+instance NFData Component where
+	rnf (Component cs) = rnf cs
 
--- | Relative scope-path
-relative :: [Text] -> [Text] -> Bool
-relative p = (p `isSuffixOf`)
+-- | Log scope, also stored in reverse order
+newtype Scope = Scope { scopePath ∷ [Text] } deriving (Eq, Ord)
 
--- | Scope-path for child
-child :: ([Text] -> Bool) -> [Text] -> Bool
-child _ [] = False
-child r (_:ps) = r ps
+instance Show Scope where
+	show = T.unpack ∘ T.intercalate "/" ∘ reverse ∘ scopePath
 
--- | Root scope-path
-root :: [Text] -> Bool
-root = null
+instance Formattable Scope
 
--- | Scope-path by text
---
--- @
--- \/ -- root
--- foo\/bar -- relative
--- \/foo\/bar -- absolute
--- foo\/bar\/ -- child of relative
--- \/foo\/bar\/ -- child of absolute
--- @
---
-path :: Text -> ([Text] -> Bool)
-path "/" = root
-path p = path' $ T.split (== '/') p where
-    path' ps
-        | null ps = const False
-        | T.null (head ps) && T.null (last ps) = child . absolute . init . tail $ ps
-        | T.null (head ps) = absolute . tail $ ps
-        | T.null (last ps) = child . relative . init $ ps
-        | otherwise = relative ps
+instance Read Scope where
+	readsPrec _ = return ∘ flip (,) "" ∘ Scope ∘ reverse ∘ splitBy '/' ∘ T.pack
 
--- | Rule by path
-(%=) :: Text -> (Politics -> Politics) -> Rule
-p %= r = rule (path p) r
+instance IsString Scope where
+	fromString = read
 
--- | Just set new politics
-politics :: Level -> Level -> Politics -> Politics
-politics l h _ = Politics l h
+instance Semigroup Scope where
+	Scope l <> Scope r = Scope $ r ++ l
 
--- | Use predefined politics
-use :: Politics -> Politics -> Politics
-use p _ = p
+instance Monoid Scope where
+	mempty = Scope []
+	Scope l `mappend` Scope r = Scope $ r ++ l
 
--- | Set new low level
-low :: Level -> Politics -> Politics
-low l (Politics _ h) = Politics l h
+instance NFData Scope where
+	rnf (Scope s) = rnf s
 
--- | Set new high level
-high :: Level -> Politics -> Politics
-high h (Politics l _) = Politics l h
+class HasParent a where
+	getParent ∷ a → Maybe a
 
+instance HasParent Component where
+	getParent (Component []) = Nothing
+	getParent (Component (_:cs)) = Just $ Component cs
+
+instance HasParent Scope where
+	getParent (Scope []) = Nothing
+	getParent (Scope (_:ps)) = Just $ Scope ps
+
+-- | Parse level
+level ∷ Text → Maybe Level
+level = flip M.lookup levels ∘ T.toLower where
+	levels = M.fromList [(T.toLower ∘ T.pack ∘ show $ l', l') | l' ← [minBound .. maxBound]]
+
+-- | Parse level, failing on invalid input
+level_ ∷ Text → Level
+level_ t = fromMaybe (error errMsg) ∘ level $ t where
+	errMsg = "invalid level: " ++ T.unpack t
+
 -- | Log message
 data Message = Message {
-    messageTime :: ZonedTime,
-    messageLevel :: Level,
-    messagePath :: [Text],
-    messageText :: Text }
-        deriving (Read, Show)
+	messageTime ∷ ZonedTime,
+	messageLevel ∷ Level,
+	messageComponent ∷ Component,
+	messageScope ∷ Scope,
+	messageText ∷ Text }
+		deriving (Read, Show)
 
 instance NFData Message where
-    rnf (Message t l p m) = t `seq` l `seq` rnf p `seq` rnf m
+	rnf (Message t l c s m) = t `seq` l  `seq` rnf c `seq` rnf s `seq` rnf m
 
--- | Converts message some representation
-type Converter a = Message -> a
+type Converter a = Message → a
 
--- Stores message
-data Consumer a = Consumer {
-    withConsumer :: ((a -> IO ()) -> IO ()) -> IO () }
+-- | Returns function which accepts consumed value
+type Consumer a = ContT () IO (a → IO ())
 
--- | Logger
-type Logger = Consumer Message
+-- | Make consumer
+consumer ∷ (((a → IO ()) → IO ()) → IO ()) → Consumer a
+consumer = ContT
 
--- | Convert consumer creater to logger creater
-logger :: Converter a -> Consumer a -> Consumer Message
-logger conv (Consumer withCons) = Consumer withCons' where
-    withCons' f = withCons $ \logMsg -> f (logMsg . conv)
+-- | Message handler
+type LogHandler = Consumer Message
 
--- | Log
-data Log = Log {
-    logPost :: Command -> IO (),
-    logStop :: IO (),
-    logRules :: IO Rules }
+handler ∷ Converter a → Consumer a → Consumer Message
+handler conv = fmap (∘ conv)
 
--- | Empty log
-noLog :: Log
-noLog = Log (const (return ())) (return ()) (return [])
+data LogConfig = LogConfig {
+	_logConfigMap ∷ Map Component Level }
 
--- | Type to initialize rule updater
-type RulesLoad = IO (IO Rules)
+makeLenses ''LogConfig
 
-type ThreadMap = M.Map ThreadId (A.Async (), Chan (Maybe Command))
-type FChan a = Chan (Maybe a)
+instance Default LogConfig where
+	def = LogConfig mempty
 
-writeFChan :: FChan a -> a -> IO ()
-writeFChan ch = writeChan ch . Just
+instance Show LogConfig where
+	show (LogConfig cfg) = unlines [show comp ++ ":" ++ show lev | (comp, lev) ← M.toList cfg]
 
-stopFChan :: FChan a -> IO ()
-stopFChan ch = writeChan ch Nothing
+type instance Index LogConfig = Component
+type instance IxValue LogConfig = Level
 
-getFChanContents :: FChan a -> IO [a]
-getFChanContents = liftM (catMaybes . takeWhile isJust) . getChanContents
+instance Ixed LogConfig where
+	ix n = logConfigMap ∘ ix n
 
--- | Create log
---
--- Messages from distinct threads are splitted in several chans, where they are processed, and then messages combined back and sent to log-thread
---
-newLog :: RulesLoad -> [Logger] -> IO Log
-newLog _ [] = return noLog
-newLog rsInit ls = do
-    ch <- newChan :: IO (FChan (ThreadId, Command))
-    chOut <- newChan :: IO (FChan Command)
-    cts <- getFChanContents ch
-    msgs <- getFChanContents chOut
-    rs <- rsInit
-    r <- rs
+instance At LogConfig where
+	at n = logConfigMap ∘ at n
 
-    let
-        -- | Write commands from separate threads to separate channels
-        process :: ThreadMap -> (ThreadId, Command) -> IO ThreadMap
-        process m (thId, cmd) = do
-            (thAsync, thChan) <- maybe newChild return $ M.lookup thId m
-            writeFChan thChan cmd
-            return $ M.insert thId (thAsync, thChan) m
+-- | Default log config — info level
+defCfg ∷ LogConfig
+defCfg = def
 
-        -- | Stop all spawned asyncs for threads
-        stopChildren :: ThreadMap -> IO ()
-        stopChildren m = do
-            forM_ (M.elems m) $ \(thAsync, thChan) -> do
-                stopFChan thChan
-                A.wait thAsync
-            stopFChan chOut
+-- | Make log config by list of components and levels
+logCfg ∷ [(Component, Level)] → LogConfig
+logCfg = LogConfig ∘ M.fromList
 
-        -- | New chan for thread, accepts commands from thread, writes processed messages to log-thread
-        newChild :: IO (A.Async (), FChan Command)
-        newChild = do
-            thChan <- newChan
-            thCts <- getFChanContents thChan
-            thAsync <- A.async $ mapM_ (writeFChan chOut) $
-                uncommand thCts
-            return (thAsync, thChan)
+-- | Component config level lens
+componentCfg ∷ Component → Lens' LogConfig (Maybe Level)
+componentCfg comp = logConfigMap . at comp
 
-        -- | Filter commands
-        uncommand :: [Command] -> [Command]
-        uncommand = flatten . rules r [] . entries
+-- | Get politics for specified component
+componentLevel ∷ LogConfig → Component → Level
+componentLevel cfg comp = fromMaybe def $ (cfg ^. componentCfg comp) <|> (componentLevel cfg <$> getParent comp)
 
-        -- | Perform log
-        tryLog :: (Message -> IO ()) -> Command -> IO ()
-        tryLog _ (EnterScope _ _) = return ()
-        tryLog logMsg (PostMessage m) = E.handle onError (m `deepseq` logMsg m) where
-            onError :: E.SomeException -> IO ()
-            onError e = E.handle ignoreError $ do
-                tm <- getZonedTime
-                logMsg $ Message tm Error ["*"] $ fromString $ "Exception during logging message: " ++ show e
-            ignoreError :: E.SomeException -> IO ()
-            ignoreError _ = return ()
-        tryLog _ (LeaveScope io) = io
+-- | Log
+data Log = Log {
+	-- | Current log component
+	logComponent ∷ Component,
+	-- | Current log scope
+	logScope ∷ Scope,
+	-- | Log message, it is low-level function, i.e. it doesn't take into account current component and scope and writes message as is
+	logPost ∷ Message → IO (),
+	-- | Stop log and wait until it writes all
+	logStop ∷ IO (),
+	-- | Log config
+	logConfig ∷ MVar LogConfig,
+	-- | Handlers list
+	logHandlers ∷ MVar [LogHandler],
+	-- | Restart all handlers
+	logRestartHandlers ∷ IO () }
 
-        -- | Initialize all loggers
-        startLog :: Logger -> IO ()
-        startLog (Consumer withCons) = withCons $ \logMsg -> do
-            mapM_ (tryLog logMsg) msgs
+type FChan a = Chan (Maybe a)
 
-        -- | Write command with myThreadId
-        writeCommand :: Command -> IO ()
-        writeCommand cmd = do
-            i <- myThreadId
-            writeFChan ch (i, cmd)
+writeFChan ∷ FChan a → a → IO ()
+writeFChan ch = writeChan ch ∘ Just
 
-    p <- A.async $ void $ do
-        m <- foldM process M.empty cts
-        stopChildren m
-    mapM_ (forkIO . startLog) ls
-    return $ Log writeCommand (stopFChan ch >> A.wait p) rs
+stopFChan ∷ FChan a → IO ()
+stopFChan ch = writeChan ch Nothing
 
--- | Write message to log
-writeLog :: MonadIO m => Log -> Level -> Text -> m ()
-writeLog (Log post _ _) l msg = liftIO $ do
-    tm <- getZonedTime
-    post $ PostMessage (Message tm l [] msg)
+-- | Create log, returns root logger for root component
+--
+-- Messages from distinct threads and components are splitted in several chans, where they are processed, and then messages combined back and sent to log-thread
+--
+newLog ∷ LogConfig → [LogHandler] → IO Log
+newLog cfg handlers = do
+	ch ← newChan ∷ IO (FChan Message)
+	cfgVar ← newMVar cfg
+	handlersVar ← newMVar handlers
+	handlersThread ← newEmptyMVar
 
--- | Wait log messages and stop log
-stopLog :: MonadIO m => Log -> m ()
-stopLog (Log _ stop _) = liftIO stop
+	let
+		-- | Pass message firther if it passes config
+		passMessage ∷ (Message → IO ()) → Message → IO ()
+		passMessage fn msg = do
+			cfg' ← readMVar cfgVar
+			when (componentLevel cfg' (messageComponent msg) ≤ messageLevel msg) $ fn msg
 
--- | New log-scope
-scopeLog_ :: MonadCatchIO m => Log -> Text -> m a -> m a
-scopeLog_ (Log post _ getRules) s act = do
-    rs <- liftIO getRules
-    sem <- liftIO $ new (0 :: Integer)
-    bracket_
-        (liftIO $ post $ EnterScope s rs)
-        (liftIO $ post (LeaveScope $ signal sem) >> wait sem)
-        act
+		fatalMsg ∷ String → IO Message
+		fatalMsg s = do
+			tm ← getZonedTime
+			return $ Message tm Fatal "*" "" $ fromString s
 
--- | New log-scope with lifting exceptions as errors
-scopeLog :: MonadCatchIO m => Log -> Text -> m a -> m a
-scopeLog l s act = scopeLog_ l s (catch act onError) where
-    onError :: MonadIO m => E.SomeException -> m a
-    onError e = do
-        writeLog l Error $ fromString $ "Scope leaves with exception: " ++ show e
-        throw e
+		-- | Perform log
+		tryLog ∷ (Message → IO ()) → Message → IO ()
+		tryLog logMsg m = E.handle onError (m `deepseq` logMsg m) where
+			onError ∷ E.SomeException → IO ()
+			onError e = E.handle ignoreError $ fatalMsg ("Exception during logging message: " ++ show e) >>= logMsg
+			ignoreError ∷ E.SomeException → IO ()
+			ignoreError _ = return ()
 
--- | New log-scope with tracing scope result
-scoperLog :: MonadCatchIO m => Show a => Log -> Text -> m a -> m a
-scoperLog l s act = do
-    r <- scopeLog l s act
-    writeLog l Trace $ T.concat ["Scope ", s, " leaves with result: ", fromString . show $ r]
-    return r
+		-- | Consume messages and send to handlers
+		runHandlers ∷ FChan Message → [LogHandler] → ContT () IO ()
+		runHandlers inCh hs = do
+			hs' ← sequence $ map (fmap tryLog) hs
+			fix $ \loop' → do
+				msg ← liftIO $ readChan inCh
+				case msg of
+					Just msg' → liftIO (mapM_ ($ msg') hs') >> loop'
+					Nothing → return ()
 
--- | Log entry, scope or message
-data Entry =
-    Entry Message |
-    Scope Text Rules (IO ()) [Entry]
+		-- | Start handlers thread
+		startHandlers ∷ IO (A.Async ())
+		startHandlers = readMVar handlersVar >>= A.async ∘ flip runContT return ∘ runHandlers ch
 
-foldEntry :: (Message -> a) -> (Text -> Rules -> IO () -> [a] -> a) -> Entry -> a
-foldEntry r _ (Entry m) = r m
-foldEntry r s (Scope t rs io es) = s t rs io (map (foldEntry r s) es)
+		-- | Restart handlers thread
+		restartHandlers ∷ IO ()
+		restartHandlers = modifyMVar_ handlersThread $ \th → A.cancel th >> startHandlers
 
--- | Command to logger
-data Command =
-    EnterScope Text Rules |
-    LeaveScope (IO ()) |
-    PostMessage Message
+		-- | Write message with myThreadId
+		writeMessage ∷ Message → IO ()
+		writeMessage = passMessage (writeFChan ch)
 
--- | Apply commands to construct list of entries
-entries :: [Command] -> [Entry]
-entries = fst . fst . entries' where
-    entries' :: [Command] -> (([Entry], IO ()), [Command])
-    entries' [] = (([], return ()), [])
-    entries' (EnterScope s scopeRules : cs) = first (first (Scope s scopeRules io rs :)) $ entries' cs' where
-        ((rs, io), cs') = entries' cs
-    entries' (LeaveScope io : cs) = (([], io), cs)
-    entries' (PostMessage m : cs) = first (first (Entry m :)) $ entries' cs
+		waitHandlers ∷ IO ()
+		waitHandlers = readMVar handlersThread >>= A.wait
 
--- | Flatten entries to raw list of commands
-flatten :: [Entry] -> [Command]
-flatten = concatMap $ foldEntry postMessage flatScope where
-    postMessage :: Message -> [Command]
-    postMessage m = [PostMessage m]
-    flatScope :: Text -> Rules -> IO () -> [[Command]] -> [Command]
-    flatScope s rs io cs = EnterScope s rs : (map (addScope s) (concat cs) ++ [LeaveScope io])
-    addScope :: Text -> Command -> Command
-    addScope s (PostMessage (Message tm l p str)) = PostMessage $ Message tm l (s : p) str
-    addScope _ m = m
+	startHandlers >>= putMVar handlersThread
+	return $ Log {
+		logComponent = mempty,
+		logScope = mempty,
+		logPost = writeMessage,
+		logStop = stopFChan ch >> waitHandlers,
+		logConfig = cfgVar,
+		logHandlers = handlersVar,
+		logRestartHandlers = restartHandlers }
 
--- | Apply rules
-rules :: Rules -> [Text] -> [Entry] -> [Entry]
-rules rs rpath = map untraceScope . concatEntries . first (partition isNotTrace) . break isError where
-    -- untrace inner scopes
-    untraceScope (Entry msg) = Entry msg
-    untraceScope (Scope t scopeRules io es) = Scope t scopeRules io $ rules scopeRules (t : rpath) es
+-- | Get root log, i.e. just drop current component and scope
+rootLog ∷ Log → Log
+rootLog l = l { logComponent = mempty, logScope = mempty }
 
-    -- current politics
-    ps = apply rs (reverse rpath) defaultPolitics
+-- | Get log for specified component and scope
+getLog ∷ Component → Scope → Log → Log
+getLog comp scope l = l { logComponent = comp, logScope = scope }
 
-    -- If there is no errors, use only infos and scopes and drop all traces
-    -- otherwise concat all messages
-    concatEntries ((x, y), z) = x ++ if null z then [] else y ++ z
+-- | Get sub-log
+subLog ∷ Component → Scope → Log → Log
+subLog comp scope l = l {
+	logComponent = logComponent l `mappend` comp,
+	logScope = logScope l `mappend` scope }
 
-    isError = onLevel False (> politicsHigh ps)
-    isNotTrace = onLevel True (>= politicsLow ps)
-    
-    onLevel :: a -> (Level -> a) -> Entry -> a
-    onLevel v _ (Scope _ _ _ _) = v
-    onLevel _ f (Entry (Message _ l _ _)) = f l
+-- | Read log config
+getLogConfig ∷ MonadIO m ⇒ Log → m LogConfig
+getLogConfig l = liftIO $ readMVar (logConfig l)
 
--- | Apply rules to path
-apply :: Rules -> [Text] -> Politics -> Politics
-apply rs = foldr (.) id . map applier . reverse . inits where
-    applier :: [Text] -> Politics -> Politics
-    applier spath = foldr (.) id . map rulePolitics . filter (`rulePath` spath) $ rs
+-- | Modify log config
+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 ()
+updateLogHandlers l update = liftIO $ modifyMVar_ (logHandlers l) (return ∘ update) >> logRestartHandlers l
+
+-- | Write message to log for current component and scope
+writeLog ∷ MonadIO m ⇒ Log → Level → Text → m ()
+writeLog l lev msg = liftIO $ do
+	tm ← getZonedTime
+	logPost l $ Message tm lev (logComponent l) (logScope l) msg
+
+-- | Wait log messages and stop log
+stopLog ∷ MonadIO m ⇒ Log → m ()
+stopLog = liftIO ∘ logStop
+ src/System/Log/Simple/Chan.hs view
@@ -0,0 +1,9 @@+module System.Log.Simple.Chan (
+	chan
+	) where
+
+import Control.Concurrent.Chan (Chan, writeChan)
+import System.Log.Simple.Base
+
+chan ∷ Chan a → Consumer a
+chan ch = return $ writeChan ch
− src/System/Log/Simple/Config.hs 
@@ -1,125 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
-
-module System.Log.Simple.Config (
-    parseRule, parseRules,
-    parseRule_, parseRules_,
-    constant, mvar, fileCfg
-    ) where
-
-import Control.Arrow
-import Control.Concurrent
-import Control.Exception
-import Control.Monad.Except
-import Control.Monad.Writer
-import Data.Either
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-
-import System.Log.Simple.Base
-
--- | Parse rule
---
--- Format:
---
--- @
---path: rule1, rule2
--- @
---
--- where \"path\" is argument for 'path', and \"rule\" is one of
---
---     * /low low-value/ for 'low'
---
---     * /high high-value/ for 'high'
---
---     * /set low-value high-value/ for 'politics'
---
---     * /use predefind/ for 'use'
---
--- Examples:
---
--- @
--- \/: use trace
--- \/foo: low trace
--- foo\/bar\/quux: use silent
--- @
---
-parseRule :: Text -> Writer [Text] Rule
-parseRule txt = do
-    r' <- parseUses . T.strip . T.drop 1 $ r
-    return $ T.strip p %= r'
-    where
-        (p, r) = T.break (== ':') txt
-        parseUses uses = do
-            tell $ map T.pack fails
-            return $ foldr (.) id oks
-            where
-                (fails, oks) = (lefts &&& rights) . map (parseUse . T.strip) . T.split (== ',') $ uses
-
-        parseUse u = case map T.strip . T.words $ u of
-            ["low", v] -> low <$> value v
-            ["high", v] -> high <$> value v
-            ["set", l, h] -> politics <$> value l <*> value h
-            ["use", v] -> use <$> predefined v
-            _ -> throwError $ concat ["Unable to parse: ", T.unpack u]
-
-        value v = maybe noValue return $ lookup v values where
-            noValue = throwError $ concat ["Invalid value: ", T.unpack v]
-
-        predefined v = maybe noPredefined return $ lookup v predefineds where
-            noPredefined = throwError $ concat ["Invalid predefined: ", T.unpack v]
-
-parseRules :: Text -> Writer [Text] Rules
-parseRules = mapM parseRule . filter (not . T.null . T.strip) . T.lines
-
--- | Try parse rule ignoring errors
-parseRule_ :: Text -> Rule
-parseRule_ = fst . runWriter . parseRule
-
--- | Try parse rules ignoring errors
-parseRules_ :: Text -> Rules
-parseRules_ = fst . runWriter . parseRules
-
--- | Value names
-values :: [(Text, Level)]
-values = [
-    ("trace", Trace),
-    ("debug", Debug),
-    ("info", Info),
-    ("warning", Warning),
-    ("error", Error),
-    ("fatal", Fatal)]
-
--- | Predefined politics
-predefineds :: [(Text, Politics)]
-predefineds = [
-    ("default", defaultPolitics),
-    ("debug", debugPolitics),
-    ("trace", tracePolitics),
-    ("silent", silentPolitics),
-    ("supress", supressPolitics)]
-
--- | Constant rules
-constant :: Rules -> IO (IO Rules)
-constant = return . return
-
--- | Rules from mvar
-mvar :: MVar Rules -> IO (IO Rules)
-mvar = return . readMVar
-
--- | Rules from file
-fileCfg :: FilePath -> Int -> IO (IO Rules)
-fileCfg f seconds = do
-    rs <- readRules
-    var <- newMVar rs
-    when (seconds /= 0) $ void $ forkIO $ forever $ handle ignoreIO $ do
-        threadDelay (seconds * 1000000)
-        rs' <- readRules
-        void $ swapMVar var rs'
-    mvar var
-    where
-        readRules = do
-            cts <- T.readFile f
-            return . parseRules_ $ cts
-        ignoreIO :: IOException -> IO ()
-        ignoreIO _ = return ()
− src/System/Log/Simple/Console.hs 
@@ -1,14 +0,0 @@-module System.Log.Simple.Console (
-    console
-    ) where
-
-import Data.Text (Text)
-import qualified Data.Text.IO as T
-import System.Log.Simple.Base
-import System.IO
-
-console :: Consumer Text
-console = Consumer withConsole where
-    withConsole f = do
-        hSetEncoding stdout utf8
-        f T.putStrLn
src/System/Log/Simple/File.hs view
@@ -1,18 +1,18 @@ module System.Log.Simple.File (
-    file
-    ) where
+	file
+	) where
 
+import Control.Monad.Cont
 import Data.Text (Text)
-import qualified Data.Text.IO as T
 import System.Log.Simple.Base
 import System.FilePath
 import System.Directory
 import System.IO
 
-file :: FilePath -> Consumer Text
-file fileName = Consumer withFileLog where
-    withFileLog f = do
-        createDirectoryIfMissing True $ takeDirectory fileName
-        f $ \txt -> withFile fileName AppendMode $ \h -> do
-            hSetEncoding h utf8
-            T.hPutStrLn h txt
+import System.Log.Simple.Stream (stream)
+
+file ∷ FilePath → Consumer Text
+file fileName = do
+	liftIO $ createDirectoryIfMissing True $ takeDirectory fileName
+	h ← ContT $ withFile fileName AppendMode
+	stream h
src/System/Log/Simple/Monad.hs view
@@ -1,120 +1,149 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ConstraintKinds, FlexibleContexts, CPP, ImplicitParams #-}
 
 module System.Log.Simple.Monad (
-    withNoLog,
-    withLog,
-    log,
-    scope_,
-    scope,
-    scopeM_,
-    scopeM,
-    scoper,
-    scoperM,
-    ignoreError,
-    ignoreErrorM,
-    trace,
-    MonadLog(..)
-    ) where
+	-- | 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)
-import Control.Concurrent.MSem
+#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 Control.Monad.Except
-import Control.Monad.CatchIO as C
 import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Time
+import GHC.Stack
 import System.Log.Simple.Base
 
-class (MonadCatchIO m) => MonadLog m where
-    askLog :: m Log
+class (MonadIO m, MonadMask m) => MonadLog m where
+	askLog ∷ m Log
+	localLog ∷ (Log → Log) → m a → m a
 
-instance (MonadCatchIO m) => MonadLog (ReaderT Log m) where
-    askLog = ask
+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)
 
-withNoLog :: ReaderT Log m a -> m a
-withNoLog act = runReaderT act noLog
+newtype LogT m a = LogT { runLogT ∷ ReaderT Log m a }
+	deriving (Functor, Applicative, Monad, MonadFail, MonadIO, MonadReader Log, MonadThrow, MonadCatch, MonadMask)
 
-withLog :: Log -> ReaderT Log m a -> m a
-withLog l act = runReaderT act l
+instance MonadTrans LogT where
+	lift = LogT ∘ lift
 
-log :: (MonadLog m) => Level -> Text -> m ()
-log l msg = do
-    (Log post _ _) <- askLog
-    tm <- liftIO getZonedTime
-    liftIO $ post $ PostMessage (Message tm l [] msg)
+instance (MonadIO m, MonadMask m) => MonadLog (LogT m) where
+	askLog = LogT ask
+	localLog fn = LogT ∘ local fn ∘ runLogT
 
-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
+-- | Run with no logging
+noLog ∷ (MonadIO m, MonadMask m) ⇒ LogT m a → m a
+noLog = runLog defCfg []
 
--- | Scope with log all exceptions
-scope :: (MonadLog m) => Text -> m a -> m a
-scope s act = scope_ s $ C.catch act onError where
-    onError :: (MonadLog m) => SomeException -> m a
-    onError e = do
-        log Error $ T.concat ["Scope leaves with exception: ", fromString . show $ e]
-        throw e
+-- | Run @LogT@ monad with @Log@
+withLog ∷ Log → LogT m a → m a
+withLog l act = runReaderT (runLogT act) l
 
--- | Workaround: we must explicitely post 'LeaveScope'
-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))
+-- | 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
 
--- | Scope with log exceptions from 'MonadError'
--- | Workaround: we must explicitely post 'LeaveScope'
-scopeM :: (Show e, MonadLog m, MonadError e m) => Text -> m a -> m a
-scopeM s act = scopeM_ s $ C.catch act' onError' where
-    onError' :: (MonadLog m) => SomeException -> m a
-    onError' e = logE e >> throw 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]
+-- | 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 :: (Show a, MonadLog m) => Text -> m a -> m a
+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
+	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 ∷ (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
-
--- | Ignore error
-ignoreError :: (MonadLog m) => m () -> m ()
-ignoreError act = C.catch act onError where
-    onError :: (MonadLog m) => SomeException -> m ()
-    onError _ = return ()
-
--- | Ignore MonadError error
-ignoreErrorM :: (MonadLog m, MonadError e m) => m () -> m ()
-ignoreErrorM act = catchError act onError where
-    onError :: (MonadLog m, MonadError e m) => e -> m ()
-    onError _ = return ()
+	r ← scopeM s act
+	log Trace $ T.concat ["Scope", s, " leaves with result: ", fromString . show $ r]
+	return r
 
 -- | Trace value
-trace :: (Show a, MonadLog m) => Text -> m a -> m a
+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
+	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
+ src/System/Log/Simple/Stream.hs view
@@ -0,0 +1,28 @@+module System.Log.Simple.Stream (
+	stream, console,
+	coloredStream, coloredConsole
+	) where
+
+import Control.Monad.IO.Class
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+import System.Log.Simple.Base
+import System.IO
+import Text.Format (Formatted)
+import Text.Format.Colored
+
+stream ∷ Handle → Consumer Text
+stream h = do
+	liftIO $ hSetEncoding h utf8
+	return $ \txt → T.hPutStrLn h txt >> hFlush h
+
+console ∷ Consumer Text
+console = stream stderr
+
+coloredStream ∷ Handle → Consumer Formatted
+coloredStream h = do
+	liftIO $ hSetEncoding h utf8
+	return $ \f → hColoredLine h f >> hFlush h
+
+coloredConsole ∷ Consumer Formatted
+coloredConsole = coloredStream stderr
src/System/Log/Simple/Text.hs view
@@ -1,29 +1,32 @@ module System.Log.Simple.Text (
-    defaultTimeFormat,
-    textFmt, text
-    ) where
+	defaultTimeFormat,
+	textFmt, text, shortText, msgOnly
+	) where
 
-import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time
+import Text.Format
+
 import System.Log.Simple.Base
 
 -- | Default time format
-defaultTimeFormat :: String
-defaultTimeFormat = "%d/%m/%y %T %z"
+defaultTimeFormat ∷ String
+defaultTimeFormat = "%_Y-%m-%d %T.%3q %z"
 
--- | Text log converter with time format
-textFmt :: String -> Converter Text
-textFmt fmt (Message tm l p msg) = T.intercalate (T.pack "\t") [T.pack s, T.pack (toStr l), msg'] where
-    s = formatTime defaultTimeLocale fmt tm
-    msg' = T.concat [T.intercalate (T.pack "/") p, T.pack "> ", msg]
-    toStr Trace = "TRACE"
-    toStr Debug = "DEBUG"
-    toStr Info = "INFO"
-    toStr Warning = "WARN"
-    toStr Error = "ERROR"
-    toStr Fatal = "FATAL"
+textFmt ∷ FormatResult r ⇒ String → String → Converter r
+textFmt tmFmt msgFmt (Message tm l comp scope msg) = format msgFmt ~~ args where
+	args = [
+		"time" ~% formatTime defaultTimeLocale tmFmt tm,
+		"level" ~% l,
+		"component" ~% comp,
+		"scope" ~% scope,
+		"message" ~% msg]
 
 -- | Text log converter with default time format
-text :: Converter Text
-text = textFmt defaultTimeFormat
+text ∷ FormatResult r ⇒ Converter r
+text = textFmt defaultTimeFormat "{time:cyan}\t{level}\t{component:magenta}:{scope:green}> {message}"
+
+shortText ∷ FormatResult r ⇒ Converter r
+shortText = textFmt defaultTimeFormat "{level}\t{component:magenta}: {message}"
+
+msgOnly ∷ FormatResult r ⇒ Converter r
+msgOnly = textFmt defaultTimeFormat "{message}"
+ tests/Test.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (
+	main
+	) where
+
+import Data.Text (Text)
+import Test.Hspec
+import Lens.Micro.Platform
+
+import System.Log.Simple
+
+main ∷ IO ()
+main = hspec $ do
+	it "works" $ do
+		(_, msgs) ← runLogTexts testText testCfg $ do
+			component "main" $ do
+				sendLog Trace "Should be invisible"
+				sendLog Info "Should be visible"
+			component "app" $ scope "foo" $ do
+				sendLog Trace "This is visible"
+				sendLog Debug "And this is visible too"
+				component "app.sub" $ scope "bar/baz" $ scope "quux" $ do
+					sendLog Debug "Debugs here are visible"
+					sendLog Trace "But not traces"
+			sendLog Trace "Root doesn't log traces"
+			sendLog Info "Root logs infos"
+			_ ← modifyLogConfig (set (ix "") Trace)
+			sendLog Trace "But now root logs traces too"
+		msgs `shouldBe` validMsgs
+
+testCfg ∷ LogConfig
+testCfg = logCfg [
+	("", Info),
+	("app", Trace),
+	("app.sub", Debug)]
+
+testText ∷ Converter Text
+testText = textFmt defaultTimeFormat "{level} {component}:{scope}> {message}"
+
+validMsgs ∷ [Text]
+validMsgs = [
+	"INFO main:> Should be visible",
+	"TRACE app:foo> This is visible",
+	"DEBUG app:foo> And this is visible too",
+	"DEBUG app.sub:bar/baz/quux> Debugs here are visible",
+	"INFO :> Root logs infos",
+	"TRACE :> But now root logs traces too"]