packages feed

simple-log 0.6.0 → 0.7.0

raw patch · 11 files changed

+513/−805 lines, 11 filesdep +base-unicode-symbolsdep +hspecdep +microlens-platformdep ~base

Dependencies added: base-unicode-symbols, hspec, microlens-platform, simple-log

Dependency ranges changed: base

Files

simple-log.cabal view
@@ -1,5 +1,5 @@ Name:                 simple-log
-Version:              0.6.0
+Version:              0.7.0
 Synopsis:             Simple log for Haskell
 Description:          Log library for Haskell with removing unnecessary traces
 License:              BSD3
@@ -9,18 +9,19 @@ Maintainer:           voidex@live.com
 Category:             Logging
 Build-type:           Simple
-Cabal-version:        >= 1.6
+Cabal-version:        >= 1.10
 Tested-with:          GHC == 7.6.1
 
 source-repository head
   type: git
   location: git://github.com/mvoidex/simple-log.git
 
-Library
-  HS-Source-Dirs: src
-  Build-Depends:
+library
+  hs-source-dirs: src
+  build-depends:
     base >= 4.0 && < 6,
     async >= 2.0 && < 3.0,
+    base-unicode-symbols >= 0.2 && < 0.3,
     containers >= 0.5 && < 0.6,
     data-default == 0.7.*,
     deepseq >= 1.4 && < 1.5,
@@ -28,19 +29,34 @@     exceptions >= 0.8 && < 0.9,
     filepath >= 1.4 && < 1.5,
     hformat == 0.2.*,
+    microlens-platform == 0.3.*,
     mtl >= 2.2 && < 2.3,
     SafeSemaphore >= 0.9.0 && < 1.0.0,
     text >= 0.11.0 && < 2.0.0,
     time >= 1.5 && < 1.7,
     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.9 && < 6,
+    simple-log,
+    hspec >= 2.3 && < 2.5,
+    text >= 0.11.0 && < 2.0.0
src/System/Log/Simple.hs view
@@ -1,242 +1,104 @@ -- | 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@ function
+-- And change handlers with @updateLogHandlers@
 -- 
--- 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 $ sendLog Info \"This will go to test.log 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,
+	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,
 
-    runConsoleLog, runLogMsgs, runLogTexts
-    ) where
+	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 hiding (entries, flatten, rules)
-import System.Log.Simple.Config
-import System.Log.Simple.Monad
+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, askLog, sendLog, component, scope_, scope, scopeM, scoper, scoperM, trace)
 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
 
-runConsoleLog :: RulesLoad -> LogT IO a -> IO a
-runConsoleLog rs = runLog rs [logger text console]
+globalLog ∷ Log
+globalLog = unsafePerformIO $ newLog defCfg [handler text console]
 
-runLogChan :: MonadIO m => (Chan w -> Logger) -> RulesLoad -> LogT m a -> m (a, [w])
-runLogChan c rs act = do
-    ch <- liftIO newChan
-    mch <- liftIO newChan
-    _ <- liftIO $ forkIO $ getChanContents ch >>= mapM_ (writeChan mch . Just)
-    r <- runLog rs [c ch] act
-    liftIO $ writeChan mch Nothing
-    msgs <- liftIO ((catMaybes . takeWhile isJust) <$> getChanContents mch)
-    return (r, msgs)
+runGlobalLog ∷ LogT IO a → IO a
+runGlobalLog = withLog globalLog
 
-runLogMsgs :: MonadIO m => RulesLoad -> LogT m a -> m (a, [Message])
+runConsoleLog ∷ LogConfig → LogT IO a → IO a
+runConsoleLog cfg = runLog cfg [handler text console]
+
+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 => RulesLoad -> LogT m a -> m (a, [Text])
-runLogTexts = runLogChan (logger text . 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,372 +1,325 @@-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, RankNTypes #-}
 
 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, updateLogConfig, updateLogHandlers, writeLog, stopLog,
+	) where
 
-import Prelude hiding (log)
+import Prelude.Unicode
 
-import Control.Arrow
+import Control.Applicative
 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.Catch
-import Control.Monad.IO.Class
+import Control.Monad.Cont
 import Data.Default
-import Data.List
+import Data.Function (fix)
+import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (catMaybes, isJust)
+import Data.Maybe (catMaybes, isJust, fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
 import Data.String
+import Lens.Micro.Platform
+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
 
-instance Default Politics where
-    def = defaultPolitics
+-- | 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)
 
--- | Default politics
-defaultPolitics :: Politics
-defaultPolitics = Politics Info Warning
+instance Show Component where
+	show = T.unpack ∘ T.intercalate "." ∘ reverse ∘ componentPath
 
--- | Debug politics
-debugPolitics :: Politics
-debugPolitics = Politics Debug Info
+instance FormatBuild Component
 
--- | Trace politics
-tracePolitics :: Politics
-tracePolitics = Politics Trace Info
+instance Read Component where
+	readsPrec _ = return ∘ flip (,) "" ∘ Component ∘ reverse ∘ splitBy '.' ∘ T.pack
 
--- | Silent politics
-silentPolitics :: Politics
-silentPolitics = Politics Info Fatal
+instance IsString Component where
+	fromString = read
 
--- | Supress all messages politics
-supressPolitics :: Politics
-supressPolitics = Politics Fatal Fatal
+instance Monoid Component where
+	mempty = Component []
+	Component l `mappend` Component r = Component $ r ++ l
 
--- | Rule for politics
-data Rule = Rule {
-    rulePath :: [Text] -> Bool,
-    rulePolitics :: Politics -> Politics }
+instance NFData Component where
+	rnf (Component cs) = rnf cs
 
-type Rules = [Rule]
+-- | Log scope, also stored in reverse order
+newtype Scope = Scope { scopePath ∷ [Text] } deriving (Eq, Ord)
 
--- | Make rule
-rule :: ([Text] -> Bool) -> (Politics -> Politics) -> Rule
-rule = Rule
+instance Show Scope where
+	show = T.unpack ∘ T.intercalate "/" ∘ reverse ∘ scopePath
 
--- | Absolute scope-path
-absolute :: [Text] -> [Text] -> Bool
-absolute p = (== p)
+instance FormatBuild Scope
 
--- | Relative scope-path
-relative :: [Text] -> [Text] -> Bool
-relative p = (p `isSuffixOf`)
+instance Read Scope where
+	readsPrec _ = return ∘ flip (,) "" ∘ Scope ∘ reverse ∘ splitBy '/' ∘ T.pack
 
--- | Scope-path for child
-child :: ([Text] -> Bool) -> [Text] -> Bool
-child _ [] = False
-child r (_:ps) = r ps
+instance IsString Scope where
+	fromString = read
 
--- | Root scope-path
-root :: [Text] -> Bool
-root = null
+instance Monoid Scope where
+	mempty = Scope []
+	Scope l `mappend` Scope r = Scope $ r ++ l
 
--- | 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 NFData Scope where
+	rnf (Scope s) = rnf s
 
--- | Rule by path
-(%=) :: Text -> (Politics -> Politics) -> Rule
-p %= r = rule (path p) r
+class HasParent a where
+	getParent ∷ a → Maybe a
 
--- | Just set new politics
-politics :: Level -> Level -> Politics -> Politics
-politics l h _ = Politics l h
+instance HasParent Component where
+	getParent (Component []) = Nothing
+	getParent (Component (_:cs)) = Just $ Component cs
 
--- | Use predefined politics
-use :: Politics -> Politics -> Politics
-use p _ = p
+instance HasParent Scope where
+	getParent (Scope []) = Nothing
+	getParent (Scope (_:ps)) = Just $ Scope ps
 
--- | Set new low level
-low :: Level -> Politics -> Politics
-low l (Politics _ h) = Politics l h
+-- | 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]]
 
--- | Set new high level
-high :: Level -> Politics -> Politics
-high h (Politics l _) = Politics l h
+-- | 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 }
+-- | Convert consumer creater to logger creater
+handler ∷ Converter a → Consumer a → Consumer Message
+handler conv = fmap (∘ conv)
 
--- | Empty log
-noLog :: Log
-noLog = Log post' (return ()) (return []) where
-    post' (EnterScope _ _) = return ()
-    post' (LeaveScope io) = io
-    post' (PostMessage _) = return ()
+data LogConfig = LogConfig {
+	_logConfigMap ∷ Map Component Level }
 
--- | Type to initialize rule updater
-type RulesLoad = IO (IO Rules)
+instance Default LogConfig where
+	def = LogConfig mempty
 
-type ThreadMap = M.Map ThreadId (A.Async (), Chan (Maybe Command))
-type FChan a = Chan (Maybe a)
+instance Show LogConfig where
+	show (LogConfig cfg) = unlines [show comp ++ ":" ++ show lev | (comp, lev) ← M.toList cfg]
 
-writeFChan :: FChan a -> a -> IO ()
-writeFChan ch = writeChan ch . Just
+-- | Default log config — info level
+defCfg ∷ LogConfig
+defCfg = def
 
-stopFChan :: FChan a -> IO ()
-stopFChan ch = writeChan ch Nothing
+-- | Make log config by list of components and levels
+logCfg ∷ [(Component, Level)] → LogConfig
+logCfg = LogConfig ∘ M.fromList
 
-getFChanContents :: FChan a -> IO [a]
-getFChanContents = liftM (catMaybes . takeWhile isJust) . getChanContents
+makeLenses ''LogConfig
 
--- | 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
+-- | Component config level lens
+componentCfg ∷ Component → Lens' LogConfig (Maybe Level)
+componentCfg comp = logConfigMap . at comp
 
-    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
+-- | Get politics for specified component
+componentLevel ∷ LogConfig → Component → Level
+componentLevel cfg comp = fromMaybe def $ (cfg ^. componentCfg comp) <|> (componentLevel cfg <$> getParent comp)
 
-        -- | 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
+-- | 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 () }
 
-        -- | 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)
+type FChan a = Chan (Maybe a)
+type LogId = (Component, ThreadId)
+type LogJob = (A.Async (), FChan Message)
+type LogMap = Map LogId LogJob
 
-        -- | Filter commands
-        uncommand :: [Command] -> [Command]
-        uncommand = flatten . rules r [] . entries
+writeFChan ∷ FChan a → a → IO ()
+writeFChan ch = writeChan ch ∘ Just
 
-        fatalMsg :: String -> IO Message
-        fatalMsg s = do
-            tm <- getZonedTime
-            return $ Message tm Fatal ["*"] $ fromString s
+stopFChan ∷ FChan a → IO ()
+stopFChan ch = writeChan ch Nothing
 
+getFChanContents ∷ FChan a → IO [a]
+getFChanContents = liftM (catMaybes ∘ takeWhile isJust) ∘ getChanContents
 
-        -- | 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 $ fatalMsg ("Exception during logging message: " ++ show e) >>= logMsg
-            ignoreError :: E.SomeException -> IO ()
-            ignoreError _ = return ()
-        tryLog _ (LeaveScope io) = io
+-- | 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 (LogId, Message))
+	chOut ← newChan ∷ IO (FChan Message)
+	cts ← getFChanContents ch
+	cfgVar ← newMVar cfg
+	handlersVar ← newMVar handlers
+	handlersThread ← newEmptyMVar
 
-        -- | Initialize all loggers
-        startLog :: Logger -> IO ()
-        startLog (Consumer withCons) = withCons $ \logMsg -> do
-            mapM_ (tryLog logMsg) msgs
+	let
+		-- | Write commands from separate threads to separate channels
+		process ∷ LogMap → (LogId, Message) → IO LogMap
+		process m (logId, msg) = do
+			(thAsync, thChan) ← maybe newChild return $ M.lookup logId m
+			writeFChan thChan msg
+			return $ M.insert logId (thAsync, thChan) m
 
-        -- | Write command with myThreadId
-        writeCommand :: Command -> IO ()
-        writeCommand cmd = do
-            i <- myThreadId
-            writeFChan ch (i, cmd)
+		-- | Stop all spawned asyncs for threads
+		stopChildren ∷ LogMap → IO ()
+		stopChildren m = do
+			forM_ (M.elems m) $ \(thAsync, thChan) → do
+				stopFChan thChan
+				A.wait thAsync
+			stopFChan chOut
 
-    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
+		-- | 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
 
--- | 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)
+		-- | New chan for thread, accepts commands from thread, writes processed messages to log-thread
+		newChild ∷ IO (A.Async (), FChan Message)
+		newChild = do
+			thChan ← newChan
+			thCts ← getFChanContents thChan
+			thAsync ← A.async $ mapM_ (passMessage $ writeFChan chOut) thCts
+			return (thAsync, thChan)
 
--- | Wait log messages and stop log
-stopLog :: MonadIO m => Log -> m ()
-stopLog (Log _ stop _) = liftIO stop
+		fatalMsg ∷ String → IO Message
+		fatalMsg s = do
+			tm ← getZonedTime
+			return $ Message tm Fatal "*" "" $ fromString s
 
--- | New log-scope
-scopeLog_ :: (MonadIO m, MonadMask 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
+		-- | 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 lifting exceptions as errors
-scopeLog :: (MonadIO m, MonadMask m) => Log -> Text -> m a -> m a
-scopeLog l s act = scopeLog_ l s (catch act onError) where
-    onError :: (MonadIO m, MonadThrow m) => E.SomeException -> m a
-    onError e = do
-        writeLog l Error $ fromString $ "Scope leaves with exception: " ++ show e
-        throwM e
+		-- | 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 ()
 
--- | New log-scope with tracing scope result
-scoperLog :: (MonadIO m, MonadMask 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
+		-- | Start handlers thread
+		startHandlers ∷ IO (A.Async ())
+		startHandlers = readMVar handlersVar >>= A.async ∘ flip runContT return ∘ runHandlers chOut
 
--- | Log entry, scope or message
-data Entry =
-    Entry Message |
-    Scope Text Rules (IO ()) [Entry]
+		-- | Restart handlers thread
+		restartHandlers ∷ IO ()
+		restartHandlers = modifyMVar_ handlersThread $ \th → A.cancel th >> startHandlers
 
-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)
+		-- | Write message with myThreadId
+		writeMessage ∷ Message → IO ()
+		writeMessage msg = do
+			my ← myThreadId
+			writeFChan ch ((messageComponent msg, my), msg)
 
--- | Command to logger
-data Command =
-    EnterScope Text Rules |
-    LeaveScope (IO ()) |
-    PostMessage Message
+	p ← A.async $ void $ do
+		m ← foldM process M.empty cts
+		stopChildren m
+	startHandlers >>= putMVar handlersThread
+	return $ Log {
+		logComponent = mempty,
+		logScope = mempty,
+		logPost = writeMessage,
+		logStop = stopFChan ch >> A.wait p,
+		logConfig = cfgVar,
+		logHandlers = handlersVar,
+		logRestartHandlers = restartHandlers }
 
--- | 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
+-- | Get root log, i.e. just drop current component and scope
+rootLog ∷ Log → Log
+rootLog l = l { logComponent = mempty, logScope = mempty }
 
--- | 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
+-- | Get log for specified component and scope
+getLog ∷ Component → Scope → Log → Log
+getLog comp scope l = l { logComponent = comp, logScope = scope }
 
--- | 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 sub-log
+subLog ∷ Component → Scope → Log → Log
+subLog comp scope l = l {
+	logComponent = logComponent l `mappend` comp,
+	logScope = logScope l `mappend` scope }
 
-    -- current politics
-    ps = apply rs (reverse rpath) defaultPolitics
+-- | Modify log config
+updateLogConfig ∷ MonadIO m ⇒ Log → (LogConfig → LogConfig) → m ()
+updateLogConfig l update = liftIO $ modifyMVar_ (logConfig l) (return ∘ update)
 
-    -- 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
+-- | 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
 
-    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
+-- | 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
 
--- | 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
+-- | Wait log messages and stop log
+stopLog ∷ MonadIO m ⇒ Log → m ()
+stopLog = liftIO ∘ logStop
src/System/Log/Simple/Chan.hs view
@@ -1,10 +1,9 @@ module System.Log.Simple.Chan (
-    chan
-    ) where
+	chan
+	) where
 
 import Control.Concurrent.Chan (Chan, writeChan)
 import System.Log.Simple.Base
 
-chan :: Chan a -> Consumer a
-chan ch = Consumer withChan where
-    withChan f = f (writeChan ch)
+chan ∷ Chan a → Consumer a
+chan ch = return $ writeChan ch
− src/System/Log/Simple/Config.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
-
-module System.Log.Simple.Config (
-    parseRule, parseRules,
-    parseRule_, parseRules_,
-    rule_, rules_,
-    rulesCfg, mvarCfg, 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 $ "Unable to parse: " ++ T.unpack u
-
-        value v = maybe noValue return $ lookup v values where
-            noValue = throwError $ "Invalid value: " ++ T.unpack v
-
-        predefined v = maybe noPredefined return $ lookup v predefineds where
-            noPredefined = throwError $ "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
-
-rule_ :: Text -> Rule
-rule_ = parseRule_
-
-rules_ :: [Text] -> Rules
-rules_ = map rule_
-
--- | 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
-rulesCfg :: Rules -> IO (IO Rules)
-rulesCfg = return . return
-
--- | Rules from mvar
-mvarCfg :: MVar Rules -> IO (IO Rules)
-mvarCfg = 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'
-    mvarCfg 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,157 +1,120 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ConstraintKinds, FlexibleContexts #-}
 
 module System.Log.Simple.Monad (
-    LogT(..),
-    withNoLog, withLog,
-    runLog, runNoLog,
-    log, sendLog,
-    scope_,
-    scope,
-    scopeM_,
-    scopeM,
-    scoper,
-    scoperM,
-    ignoreError,
-    ignoreErrorM,
-    trace,
-    MonadLog(..)
-    ) where
+	-- | Monad log
+	MonadLog, LogT(..),
+	noLog, withLog, runLog,
 
+	-- | Getters
+	askLog, askComponent, askScope,
+
+	-- | Log functions
+	log, sendLog,
+	component,
+	scope_, scope, scopeM, scoper, scoperM,
+	trace,
+	) where
+
 import Prelude hiding (log)
+import Prelude.Unicode
 
 import Control.Exception (SomeException)
-import Control.Concurrent.MSem
 import Control.Monad.IO.Class
 import Control.Monad.Reader
-import Control.Monad.State
-import qualified Control.Monad.State.Strict as Strict
-import Control.Monad.Writer
-import qualified Control.Monad.Writer.Strict as Strict
 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 GHC.Stack
 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 MonadLog m => MonadLog (Strict.StateT s m) where
-    askLog = lift askLog
-
-instance (Monoid w, MonadLog m) => MonadLog (WriterT w m) where
-    askLog = lift askLog
-
-instance (Monoid w, MonadLog m) => MonadLog (Strict.WriterT w m) where
-    askLog = lift askLog
+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)
+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
+	lift = LogT ∘ lift
 
-withNoLog :: LogT m a -> m a
-withNoLog act = runReaderT (runLogT act) noLog
+-- | Run with no logging
+noLog ∷ (MonadIO m, MonadMask m) ⇒ LogT m a → m a
+noLog = runLog defCfg []
 
-withLog :: Log -> LogT m a -> m a
+-- | Run @LogT@ monad with @Log@
+withLog ∷ Log → LogT m a → m a
 withLog l act = runReaderT (runLogT act) l
 
-runLog :: MonadIO m => RulesLoad -> [Logger] -> LogT m a -> m a
-runLog rs ls act = do
-    l <- liftIO $ newLog rs ls
-    withLog l act
+-- | 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
 
-runNoLog :: LogT m a -> m a
-runNoLog = withNoLog
+-- | Ask log
+askLog ∷ MonadLog m ⇒ m Log
+askLog = ask
 
-log :: (MonadLog m) => Level -> Text -> m ()
-log l msg = do
-    (Log post _ _) <- askLog
-    tm <- liftIO getZonedTime
-    liftIO $ post $ PostMessage (Message tm l [] msg)
+-- | Ask current component
+askComponent ∷ MonadLog m ⇒ m Component
+askComponent = asks logComponent
 
-sendLog :: MonadLog m => Level -> Text -> m ()
+-- | Ask current scope
+askScope ∷ MonadLog m ⇒ m Scope
+askScope = asks logScope
+
+-- | Log message
+log ∷ MonadLog m ⇒ Level → Text → m ()
+log lev msg = do
+	l ← ask
+	writeLog l lev msg
+
+-- | Log message, same as @log@
+sendLog ∷ MonadLog m ⇒ Level → Text → m ()
 sendLog = log
 
-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
+-- | Log component, also sets root scope
+component ∷ MonadLog m ⇒ Text → m a → m a
+component c = local (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 with log all exceptions
-scope :: (MonadLog m) => Text -> m a -> m a
+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
-
--- | 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))
+	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
 
--- | 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 $ 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]
+-- | Scope with log exception from @MonadError@
+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
 
 -- | Scope with tracing result
-scoper :: (Show a, MonadLog m) => Text -> m a -> m a
+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
+	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) ⇒ 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 = 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 => 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
+ src/System/Log/Simple/Stream.hs view
@@ -0,0 +1,17 @@+module System.Log.Simple.Stream (
+	stream, console
+	) 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
+
+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
src/System/Log/Simple/Text.hs view
@@ -1,39 +1,39 @@ module System.Log.Simple.Text (
-    defaultTimeFormat,
-    textFmt, text, shortText, msgOnly
-    ) 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 ∷ String
 defaultTimeFormat = "%_Y-%m-%d %T %z"
 
-textFmt :: String -> String -> Converter Text
-textFmt tmFmt msgFmt (Message tm l p msg) = format msgFmt ~~ args where
-    args = [
-        "time" ~% formatTime defaultTimeLocale tmFmt tm,
-        "level" ~% toStr l,
-        "scope" ~% T.intercalate (T.pack "/") p,
-        "message" ~% msg]
-    toStr Trace = "TRACE"
-    toStr Debug = "DEBUG"
-    toStr Info = "INFO"
-    toStr Warning = "WARN"
-    toStr Error = "ERROR"
-    toStr Fatal = "FATAL"
+textFmt ∷ String → String → Converter Text
+textFmt tmFmt msgFmt (Message tm l comp scope msg) = format msgFmt ~~ args where
+	args = [
+		"time" ~% formatTime defaultTimeLocale tmFmt tm,
+		"level" ~% toStr l,
+		"component" ~% comp,
+		"scope" ~% scope,
+		"message" ~% msg]
+	toStr Trace = "TRACE"
+	toStr Debug = "DEBUG"
+	toStr Info = "INFO"
+	toStr Warning = "WARN"
+	toStr Error = "ERROR"
+	toStr Fatal = "FATAL"
 
 -- | Text log converter with default time format
-text :: Converter Text
-text = textFmt defaultTimeFormat "{time}\t{level}\t{scope}> {message}"
+text ∷ Converter Text
+text = textFmt defaultTimeFormat "{time}\t{level}\t{component}:{scope}> {message}"
 
-shortText :: Converter Text
-shortText = textFmt defaultTimeFormat "{level}: {message}"
+shortText ∷ Converter Text
+shortText = textFmt defaultTimeFormat "{level}\t{component}: {message}"
 
-msgOnly :: Converter Text
+msgOnly ∷ Converter Text
 msgOnly = textFmt defaultTimeFormat "{message}"
+ tests/Test.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (
+	main
+	) where
+
+import Data.Text (Text)
+import Test.Hspec
+
+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"
+		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"]