packages feed

simple-log 0.2.0 → 0.3.0

raw patch · 15 files changed

+857/−835 lines, 15 filesdep +SafeSemaphoredep ~text

Dependencies added: SafeSemaphore

Dependency ranges changed: text

Files

simple-log.cabal view
@@ -1,5 +1,5 @@ Name:                 simple-log
-Version:              0.2.0
+Version:              0.3.0
 Synopsis:             Simple log for Haskell
 Description:          Log library for Haskell with removing unnecessary traces
 License:              BSD3
@@ -23,16 +23,17 @@     MonadCatchIO-transformers >= 0.2 && < 0.4,
     mtl >= 2.0 && < 2.2,
     old-locale >= 1.0 && < 1.1,
+    SafeSemaphore == 0.9.*,
     text == 0.11.*,
     time >= 1.3 && < 1.5,
     transformers >= 0.2 && < 0.4
   Exposed-Modules:
-    System.Log
-    System.Log.Base
-    System.Log.Config
-    System.Log.Monad
-    System.Log.Text
-    System.Log.Console
-    System.Log.File
+    System.Log.Simple
+    System.Log.Simple.Base
+    System.Log.Simple.Config
+    System.Log.Simple.Monad
+    System.Log.Simple.Text
+    System.Log.Simple.Console
+    System.Log.Simple.File
 
   Ghc-Options: -Wall
− src/System/Log.hs 
@@ -1,215 +0,0 @@--- | 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:
---
--- @
---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
--- @
---
--- Note, no messages for \"foo\" and no trace messages for \"test\", because error was in \"bar\", not in \"foo\".
---
--- Code to run log:
---
--- @
---rules :: Rules
---rules = []
---
---run :: IO ()
---run = do
---    l <- newLog (constant rules) [logger text console]
---    withLog l test
--- @
---
--- 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':
---
--- @
---rules = [
---    rule root $ use defaultPolitics,
---    rule (relative [\"foo\"]) $ low Trace]
--- @
---
--- 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':
---
--- @
---rules = [
---    rule root $ use defaultPolitics,
---    relative [\"quux\", \"foo\"] $ low Trace]
--- @
---
--- And, of course, we may specify absolute path:
---
--- @
---rules = [
---    rule root $ use defaultPolitics,
---    absolute [\"bar\", \"baz\", \"foo\"] $ low Trace]
--- @
--- 
--- 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\":
---
--- @
--- \/: use default
--- \/bar\/baz\/foo: low trace
--- quux\/foo: low debug
--- @
---
--- 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 (
-    module System.Log.Base,
-    module System.Log.Config,
-    module System.Log.Monad,
-    module System.Log.Text,
-    module System.Log.Console,
-    module System.Log.File
-    ) where
-
-import System.Log.Base hiding (entries, flatten, rules, writeLog, scopeLog_, scopeLog, scoperLog)
-import System.Log.Config
-import System.Log.Monad
-import System.Log.Text
-import System.Log.Console
-import System.Log.File
− src/System/Log/Base.hs 
@@ -1,310 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}
-
-module System.Log.Base (
-    Level(..),
-    Politics(..), Rule(..), Rules,
-    defaultPolitics, debugPolitics, tracePolitics, silentPolitics,
-    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,
-    scopeLog_,
-    scopeLog,
-    scoperLog
-    ) where
-
-import Prelude hiding (log)
-
-import Control.Arrow
-import qualified Control.Exception as E
-import Control.Concurrent
-import Control.DeepSeq
-import Control.Monad
-import Data.List
-import qualified Data.Map as M
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time
-import Data.String
-
--- | Level of message
-data Level = Trace | Debug | Info | Warning | Error | Fatal
-    deriving (Eq, Ord, Read, Show, Enum, Bounded)
-
--- | Scope politics
-data Politics = Politics {
-    politicsLow :: Level,
-    politicsHigh :: Level }
-        deriving (Eq, Ord, Read, Show)
-
--- | Default politics
-defaultPolitics :: Politics
-defaultPolitics = Politics Info Warning
-
--- | Debug politics
-debugPolitics :: Politics
-debugPolitics = Politics Debug Info
-
--- | Trace politics
-tracePolitics :: Politics
-tracePolitics = Politics Trace Info
-
--- | Silent politics
-silentPolitics :: Politics
-silentPolitics = Politics Info Fatal
-
--- | Rule for politics
-data Rule = Rule {
-    rulePath :: [Text] -> Bool,
-    rulePolitics :: Politics -> Politics }
-
-type Rules = [Rule]
-
--- | Make rule
-rule :: ([Text] -> Bool) -> (Politics -> Politics) -> Rule
-rule = Rule
-
--- | Absolute scope-path
-absolute :: [Text] -> [Text] -> Bool
-absolute p = (== p)
-
--- | Relative scope-path
-relative :: [Text] -> [Text] -> Bool
-relative p = (p `isSuffixOf`)
-
--- | Scope-path for child
-child :: ([Text] -> Bool) -> [Text] -> Bool
-child _ [] = False
-child r (_:ps) = r ps
-
--- | Root scope-path
-root :: [Text] -> Bool
-root = null
-
--- | 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
-
--- | Rule by path
-(%=) :: Text -> (Politics -> Politics) -> Rule
-p %= r = rule (path p) r
-
--- | Just set new politics
-politics :: Level -> Level -> Politics -> Politics
-politics l h _ = Politics l h
-
--- | Use predefined politics
-use :: Politics -> Politics -> Politics
-use p _ = p
-
--- | Set new low level
-low :: Level -> Politics -> Politics
-low l (Politics _ h) = Politics l h
-
--- | Set new high level
-high :: Level -> Politics -> Politics
-high h (Politics l _) = Politics l h
-
--- | Log message
-data Message = Message {
-    messageTime :: ZonedTime,
-    messageLevel :: Level,
-    messagePath :: [Text],
-    messageText :: Text }
-        deriving (Read, Show)
-
-instance NFData Message where
-    rnf (Message t l p m) = t `seq` l `seq` rnf p `seq` rnf m
-
--- | Converts message some representation
-type Converter a = Message -> a
-
--- Stores message
-data Consumer a = Consumer {
-    withConsumer :: ((a -> IO ()) -> IO ()) -> IO () }
-
--- | Logger
-type Logger = Consumer Message
-
--- | 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)
-
--- | Log
-data Log = Log {
-    logPost :: Command -> IO (),
-    logRules :: IO Rules }
-
--- | Empty log
-noLog :: Log
-noLog = Log (const (return ())) (return [])
-
--- | Type to initialize rule updater
-type RulesLoad = IO (IO Rules)
-
--- | 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 (Chan (ThreadId, Command))
-    chOut <- newChan :: IO (Chan Message)
-    cts <- getChanContents ch
-    msgs <- getChanContents chOut
-    rs <- rsInit
-    r <- rs
-
-    let
-        -- | Write commands from separate threads to separate channels
-        process :: M.Map ThreadId (Chan Command) -> (ThreadId, Command) -> IO (M.Map ThreadId (Chan Command))
-        process m (thId, cmd) = do
-            thChan <- maybe newThreadChan return $ M.lookup thId m
-            writeChan thChan cmd
-            return $ M.insert thId thChan m
-
-        -- | New chan for thread, accepts commands from thread, writes processed messages to log-thread
-        newThreadChan :: IO (Chan Command)
-        newThreadChan = do
-            thChan <- newChan
-            thCts <- getChanContents thChan
-            _ <- forkIO $ mapM_ (writeChan chOut) $ uncommand thCts
-            return thChan
-
-        -- | Convert commands to messages
-        uncommand :: [Command] -> [Message]
-        uncommand = flatten . rules r [] . entries
-
-        -- | 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 $ do
-                tm <- getZonedTime
-                logMsg $ Message tm Error ["*"] $ fromString $ "Exception during logging message: " ++ show e
-            ignoreError :: E.SomeException -> IO ()
-            ignoreError _ = return ()
-
-        -- | Initialize all loggers
-        startLog :: Logger -> IO ()
-        startLog (Consumer withCons) = withCons $ \logMsg -> do
-            mapM_ (tryLog logMsg) msgs
-
-        -- | Write command with myThreadId
-        writeCommand :: Command -> IO ()
-        writeCommand cmd = do
-            i <- myThreadId
-            writeChan ch (i, cmd)
-
-    void $ forkIO $ void $ foldM process M.empty cts
-    mapM_ (forkIO . startLog) ls
-    return $ Log writeCommand rs
-
--- | Write message to log
-writeLog :: Log -> Level -> Text -> IO ()
-writeLog (Log post _) l msg = do
-    tm <- getZonedTime
-    post $ PostMessage (Message tm l [] msg)
-
--- | New log-scope
-scopeLog_ :: Log -> Text -> IO a -> IO a
-scopeLog_ (Log post getRules) s act = do
-    rs <- getRules
-    E.bracket_ (post $ EnterScope s rs) (post LeaveScope) act
-
--- | New log-scope with lifting exceptions as errors
-scopeLog :: Log -> Text -> IO a -> IO a
-scopeLog l s act = scopeLog_ l s (E.catch act onError) where
-    onError :: E.SomeException -> IO a
-    onError e = do
-        writeLog l Error $ fromString $ "Scope leaves with exception: " ++ show e
-        E.throwIO e
-
--- | New log-scope with tracing scope result
-scoperLog :: Show a => Log -> Text -> IO a -> IO 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
-
--- | Log entry, scope or message
-data Entry =
-    Entry Message |
-    Scope Text Rules [Entry]
-
-foldEntry :: (Message -> a) -> (Text -> Rules -> [a] -> a) -> Entry -> a
-foldEntry r _ (Entry m) = r m
-foldEntry r s (Scope t rs es) = s t rs (map (foldEntry r s) es)
-
--- | Command to logger
-data Command =
-    EnterScope Text Rules |
-    LeaveScope |
-    PostMessage Message
-
--- | Apply commands to construct list of entries
-entries :: [Command] -> [Entry]
-entries = fst . entries' where
-    entries' [] = ([], [])
-    entries' (EnterScope s scopeRules : cs) = first (Scope s scopeRules rs :) $ entries' cs' where
-        (rs, cs') = entries' cs
-    entries' (LeaveScope : cs) = ([], cs)
-    entries' (PostMessage m : cs) = first (Entry m :) $ entries' cs
-
--- | Flattern entries to raw list of messages
-flatten :: [Entry] -> [Message]
-flatten = concatMap $ foldEntry return (\s _ ms -> map (addScope s) (concat ms)) where
-    addScope s (Message tm l p str) = Message tm l (s : p) str
-
--- | 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 es) = Scope t scopeRules $ rules scopeRules (t : rpath) es
-
-    -- current politics
-    ps = apply rs (reverse rpath) defaultPolitics
-
-    -- 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
-
-    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
-
--- | 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
− src/System/Log/Config.hs 
@@ -1,125 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}
-
-module System.Log.Config (
-    parseRule, parseRules,
-    parseRule_, parseRules_,
-    constant, mvar, fileCfg
-    ) where
-
-import Control.Applicative
-import Control.Arrow
-import Control.Concurrent
-import Control.Exception
-import Control.Monad.Error
-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.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)]
-
--- | 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/Console.hs 
@@ -1,14 +0,0 @@-module System.Log.Console (
-    console
-    ) where
-
-import Data.Text (Text)
-import qualified Data.Text.IO as T
-import System.Log.Base
-import System.IO
-
-console :: Consumer Text
-console = Consumer withConsole where
-    withConsole f = do
-        hSetEncoding stdout utf8
-        f T.putStrLn
− src/System/Log/File.hs 
@@ -1,18 +0,0 @@-module System.Log.File (
-    file
-    ) where
-
-import Data.Text (Text)
-import qualified Data.Text.IO as T
-import System.Log.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
− src/System/Log/Monad.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}
-
-module System.Log.Monad (
-    withNoLog,
-    withLog,
-    log,
-    scope_,
-    scope,
-    scopeM_,
-    scopeM,
-    scoper,
-    scoperM,
-    ignoreError,
-    ignoreErrorM,
-    trace,
-    MonadLog(..)
-    ) where
-
-import Prelude hiding (log)
-
-import Control.Exception (SomeException)
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Control.Monad.Error
-import Control.Monad.CatchIO as C
-import Data.String
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time
-import System.Log.Base
-
-class (MonadCatchIO m) => MonadLog m where
-    askLog :: m Log
-
-instance (MonadCatchIO m) => MonadLog (ReaderT Log m) where
-    askLog = ask
-
-withNoLog :: ReaderT Log m a -> m a
-withNoLog act = runReaderT act noLog
-
-withLog :: Log -> ReaderT Log m a -> m a
-withLog l act = runReaderT act l
-
-log :: (MonadLog m) => Level -> Text -> m ()
-log l msg = do
-    (Log post _) <- askLog
-    tm <- liftIO getZonedTime
-    liftIO $ post $ PostMessage (Message tm l [] msg)
-
-scope_ :: (MonadLog m) => Text -> m a -> m a
-scope_ s act = do
-    (Log post getRules) <- askLog
-    rs <- liftIO getRules
-    bracket_ (liftIO $ post $ EnterScope s rs) (liftIO $ post LeaveScope) act
-
--- | 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
-
--- | 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
-    let
-        close = liftIO $ post LeaveScope
-    bracket_ (liftIO $ post $ EnterScope s rs) close (catchError act (\e -> close >> throwError e))
-
--- | Scope with log exceptions from 'MonadError'
--- | Workaround: we must explicitely post 'LeaveScope'
-scopeM :: (Error e, 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]
-
--- | Scope with tracing result
-scoper :: (Show a, MonadLog m) => Text -> m a -> m a
-scoper s act = do
-    r <- scope s act
-    log Trace $ T.concat ["Scope ", s, " leaves with result: ", fromString . show $ r]
-    return r
-
-scoperM :: (Error e, Show e, Show a, MonadLog m, MonadError e m) => Text -> m a -> m a
-scoperM s act = do
-    r <- scopeM s act
-    log Trace $ T.concat ["Scope", s, " leaves with resul: ", 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 :: (Error e, MonadLog m, MonadError e m) => m () -> m ()
-ignoreErrorM act = catchError act onError where
-    onError :: (Error e, MonadLog m, MonadError e m) => e -> m ()
-    onError _ = return ()
-
--- | Trace value
-trace :: (Show a, MonadLog m) => Text -> m a -> m a
-trace name act = do
-    v <- act
-    log Trace $ T.concat [name, " = ", fromString . show $ v]
-    return v
+ src/System/Log/Simple.hs view
@@ -0,0 +1,215 @@+-- | 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:
+--
+-- @
+--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
+-- @
+--
+-- Note, no messages for \"foo\" and no trace messages for \"test\", because error was in \"bar\", not in \"foo\".
+--
+-- Code to run log:
+--
+-- @
+--rules :: Rules
+--rules = []
+--
+--run :: IO ()
+--run = do
+--    l <- newLog (constant rules) [logger text console]
+--    withLog l test
+-- @
+--
+-- 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':
+--
+-- @
+--rules = [
+--    rule root $ use defaultPolitics,
+--    rule (relative [\"foo\"]) $ low Trace]
+-- @
+--
+-- 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':
+--
+-- @
+--rules = [
+--    rule root $ use defaultPolitics,
+--    relative [\"quux\", \"foo\"] $ low Trace]
+-- @
+--
+-- And, of course, we may specify absolute path:
+--
+-- @
+--rules = [
+--    rule root $ use defaultPolitics,
+--    absolute [\"bar\", \"baz\", \"foo\"] $ low Trace]
+-- @
+-- 
+-- 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\":
+--
+-- @
+-- \/: use default
+-- \/bar\/baz\/foo: low trace
+-- quux\/foo: low debug
+-- @
+--
+-- 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
+
+import System.Log.Simple.Base hiding (entries, flatten, rules, writeLog, scopeLog_, scopeLog, scoperLog)
+import System.Log.Simple.Config
+import System.Log.Simple.Monad
+import System.Log.Simple.Text
+import System.Log.Simple.Console
+import System.Log.Simple.File
+ src/System/Log/Simple/Base.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE OverloadedStrings #-}
+
+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,
+    scopeLog_,
+    scopeLog,
+    scoperLog
+    ) where
+
+import Prelude hiding (log)
+
+import Control.Arrow
+import qualified Control.Exception as E
+import Control.Concurrent
+import Control.Concurrent.MSem
+import Control.DeepSeq
+import Control.Monad
+import Data.List
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time
+import Data.String
+
+-- | Level of message
+data Level = Trace | Debug | Info | Warning | Error | Fatal
+    deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+-- | Scope politics
+data Politics = Politics {
+    politicsLow :: Level,
+    politicsHigh :: Level }
+        deriving (Eq, Ord, Read, Show)
+
+-- | Default politics
+defaultPolitics :: Politics
+defaultPolitics = Politics Info Warning
+
+-- | Debug politics
+debugPolitics :: Politics
+debugPolitics = Politics Debug Info
+
+-- | Trace politics
+tracePolitics :: Politics
+tracePolitics = Politics Trace Info
+
+-- | Silent politics
+silentPolitics :: Politics
+silentPolitics = Politics Info Fatal
+
+-- | Supress all messages politics
+supressPolitics :: Politics
+supressPolitics = Politics Fatal Fatal
+
+-- | Rule for politics
+data Rule = Rule {
+    rulePath :: [Text] -> Bool,
+    rulePolitics :: Politics -> Politics }
+
+type Rules = [Rule]
+
+-- | Make rule
+rule :: ([Text] -> Bool) -> (Politics -> Politics) -> Rule
+rule = Rule
+
+-- | Absolute scope-path
+absolute :: [Text] -> [Text] -> Bool
+absolute p = (== p)
+
+-- | Relative scope-path
+relative :: [Text] -> [Text] -> Bool
+relative p = (p `isSuffixOf`)
+
+-- | Scope-path for child
+child :: ([Text] -> Bool) -> [Text] -> Bool
+child _ [] = False
+child r (_:ps) = r ps
+
+-- | Root scope-path
+root :: [Text] -> Bool
+root = null
+
+-- | 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
+
+-- | Rule by path
+(%=) :: Text -> (Politics -> Politics) -> Rule
+p %= r = rule (path p) r
+
+-- | Just set new politics
+politics :: Level -> Level -> Politics -> Politics
+politics l h _ = Politics l h
+
+-- | Use predefined politics
+use :: Politics -> Politics -> Politics
+use p _ = p
+
+-- | Set new low level
+low :: Level -> Politics -> Politics
+low l (Politics _ h) = Politics l h
+
+-- | Set new high level
+high :: Level -> Politics -> Politics
+high h (Politics l _) = Politics l h
+
+-- | Log message
+data Message = Message {
+    messageTime :: ZonedTime,
+    messageLevel :: Level,
+    messagePath :: [Text],
+    messageText :: Text }
+        deriving (Read, Show)
+
+instance NFData Message where
+    rnf (Message t l p m) = t `seq` l `seq` rnf p `seq` rnf m
+
+-- | Converts message some representation
+type Converter a = Message -> a
+
+-- Stores message
+data Consumer a = Consumer {
+    withConsumer :: ((a -> IO ()) -> IO ()) -> IO () }
+
+-- | Logger
+type Logger = Consumer Message
+
+-- | 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)
+
+-- | Log
+data Log = Log {
+    logPost :: Command -> IO (),
+    logRules :: IO Rules }
+
+-- | Empty log
+noLog :: Log
+noLog = Log (const (return ())) (return [])
+
+-- | Type to initialize rule updater
+type RulesLoad = IO (IO Rules)
+
+-- | 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 (Chan (ThreadId, Command))
+    chOut <- newChan :: IO (Chan Command)
+    cts <- getChanContents ch
+    msgs <- getChanContents chOut
+    rs <- rsInit
+    r <- rs
+
+    let
+        -- | Write commands from separate threads to separate channels
+        process :: M.Map ThreadId (Chan Command) -> (ThreadId, Command) -> IO (M.Map ThreadId (Chan Command))
+        process m (thId, cmd) = do
+            thChan <- maybe newThreadChan return $ M.lookup thId m
+            writeChan thChan cmd
+            return $ M.insert thId thChan m
+
+        -- | New chan for thread, accepts commands from thread, writes processed messages to log-thread
+        newThreadChan :: IO (Chan Command)
+        newThreadChan = do
+            thChan <- newChan
+            thCts <- getChanContents thChan
+            _ <- forkIO $ mapM_ (writeChan chOut) $ uncommand thCts
+            return thChan
+
+        -- | Filter commands
+        uncommand :: [Command] -> [Command]
+        uncommand = flatten . rules r [] . entries
+
+        -- | 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
+
+        -- | Initialize all loggers
+        startLog :: Logger -> IO ()
+        startLog (Consumer withCons) = withCons $ \logMsg -> do
+            mapM_ (tryLog logMsg) msgs
+
+        -- | Write command with myThreadId
+        writeCommand :: Command -> IO ()
+        writeCommand cmd = do
+            i <- myThreadId
+            writeChan ch (i, cmd)
+
+    void $ forkIO $ void $ foldM process M.empty cts
+    mapM_ (forkIO . startLog) ls
+    return $ Log writeCommand rs
+
+-- | Write message to log
+writeLog :: Log -> Level -> Text -> IO ()
+writeLog (Log post _) l msg = do
+    tm <- getZonedTime
+    post $ PostMessage (Message tm l [] msg)
+
+-- | New log-scope
+scopeLog_ :: Log -> Text -> IO a -> IO a
+scopeLog_ (Log post getRules) s act = do
+    rs <- getRules
+    sem <- new (0 :: Integer)
+    E.bracket_ (post $ EnterScope s rs) (post (LeaveScope $ signal sem) >> wait sem) act
+
+-- | New log-scope with lifting exceptions as errors
+scopeLog :: Log -> Text -> IO a -> IO a
+scopeLog l s act = scopeLog_ l s (E.catch act onError) where
+    onError :: E.SomeException -> IO a
+    onError e = do
+        writeLog l Error $ fromString $ "Scope leaves with exception: " ++ show e
+        E.throwIO e
+
+-- | New log-scope with tracing scope result
+scoperLog :: Show a => Log -> Text -> IO a -> IO 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
+
+-- | Log entry, scope or message
+data Entry =
+    Entry Message |
+    Scope Text Rules (IO ()) [Entry]
+
+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)
+
+-- | Command to logger
+data Command =
+    EnterScope Text Rules |
+    LeaveScope (IO ()) |
+    PostMessage Message
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+    -- current politics
+    ps = apply rs (reverse rpath) defaultPolitics
+
+    -- 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
+
+    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
+
+-- | 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
+ src/System/Log/Simple/Config.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module System.Log.Simple.Config (
+    parseRule, parseRules,
+    parseRule_, parseRules_,
+    constant, mvar, fileCfg
+    ) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Concurrent
+import Control.Exception
+import Control.Monad.Error
+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 view
@@ -0,0 +1,14 @@+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
@@ -0,0 +1,18 @@+module System.Log.Simple.File (
+    file
+    ) where
+
+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
+ src/System/Log/Simple/Monad.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}
+
+module System.Log.Simple.Monad (
+    withNoLog,
+    withLog,
+    log,
+    scope_,
+    scope,
+    scopeM_,
+    scopeM,
+    scoper,
+    scoperM,
+    ignoreError,
+    ignoreErrorM,
+    trace,
+    MonadLog(..)
+    ) where
+
+import Prelude hiding (log)
+
+import Control.Exception (SomeException)
+import Control.Concurrent.MSem
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Control.Monad.Error
+import Control.Monad.CatchIO as C
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time
+import System.Log.Simple.Base
+
+class (MonadCatchIO m) => MonadLog m where
+    askLog :: m Log
+
+instance (MonadCatchIO m) => MonadLog (ReaderT Log m) where
+    askLog = ask
+
+withNoLog :: ReaderT Log m a -> m a
+withNoLog act = runReaderT act noLog
+
+withLog :: Log -> ReaderT Log m a -> m a
+withLog l act = runReaderT act l
+
+log :: (MonadLog m) => Level -> Text -> m ()
+log l msg = do
+    (Log post _) <- askLog
+    tm <- liftIO getZonedTime
+    liftIO $ post $ PostMessage (Message tm l [] msg)
+
+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
+
+-- | 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
+
+-- | 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))
+
+-- | Scope with log exceptions from 'MonadError'
+-- | Workaround: we must explicitely post 'LeaveScope'
+scopeM :: (Error e, 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]
+
+-- | Scope with tracing result
+scoper :: (Show a, MonadLog m) => Text -> m a -> m a
+scoper s act = do
+    r <- scope s act
+    log Trace $ T.concat ["Scope ", s, " leaves with result: ", fromString . show $ r]
+    return r
+
+scoperM :: (Error e, Show e, Show a, MonadLog m, MonadError e m) => Text -> m a -> m a
+scoperM s act = do
+    r <- scopeM s act
+    log Trace $ T.concat ["Scope", s, " leaves with resul: ", 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 :: (Error e, MonadLog m, MonadError e m) => m () -> m ()
+ignoreErrorM act = catchError act onError where
+    onError :: (Error e, MonadLog m, MonadError e m) => e -> m ()
+    onError _ = return ()
+
+-- | Trace value
+trace :: (Show a, MonadLog m) => Text -> m a -> m a
+trace name act = do
+    v <- act
+    log Trace $ T.concat [name, " = ", fromString . show $ v]
+    return v
+ src/System/Log/Simple/Text.hs view
@@ -0,0 +1,30 @@+module System.Log.Simple.Text (
+    defaultTimeFormat,
+    textFmt, text
+    ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time
+import System.Locale
+import System.Log.Simple.Base
+
+-- | Default time format
+defaultTimeFormat :: String
+defaultTimeFormat = "%d/%m/%y %T %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"
+
+-- | Text log converter with default time format
+text :: Converter Text
+text = textFmt defaultTimeFormat
− src/System/Log/Text.hs 
@@ -1,30 +0,0 @@-module System.Log.Text (
-    defaultTimeFormat,
-    textFmt, text
-    ) where
-
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time
-import System.Locale
-import System.Log.Base
-
--- | Default time format
-defaultTimeFormat :: String
-defaultTimeFormat = "%d/%m/%y %T %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"
-
--- | Text log converter with default time format
-text :: Converter Text
-text = textFmt defaultTimeFormat