packages feed

simple-log 0.5.1 → 0.6.0

raw patch · 7 files changed

+112/−25 lines, 7 filesdep +data-defaultdep +hformatdep ~base

Dependencies added: data-default, hformat

Dependency ranges changed: base

Files

simple-log.cabal view
@@ -1,5 +1,5 @@ Name:                 simple-log
-Version:              0.5.1
+Version:              0.6.0
 Synopsis:             Simple log for Haskell
 Description:          Log library for Haskell with removing unnecessary traces
 License:              BSD3
@@ -22,10 +22,12 @@     base >= 4.0 && < 6,
     async >= 2.0 && < 3.0,
     containers >= 0.5 && < 0.6,
+    data-default == 0.7.*,
     deepseq >= 1.4 && < 1.5,
     directory >= 1.2 && < 1.4,
     exceptions >= 0.8 && < 0.9,
     filepath >= 1.4 && < 1.5,
+    hformat == 0.2.*,
     mtl >= 2.2 && < 2.3,
     SafeSemaphore >= 0.9.0 && < 1.0.0,
     text >= 0.11.0 && < 2.0.0,
@@ -35,6 +37,7 @@     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
src/System/Log/Simple.hs view
@@ -204,12 +204,39 @@     module System.Log.Simple.Monad,
     module System.Log.Simple.Text,
     module System.Log.Simple.Console,
-    module System.Log.Simple.File
+    module System.Log.Simple.File,
+
+    runConsoleLog, runLogMsgs, runLogTexts
     ) where
 
+import Control.Monad.IO.Class
+import Control.Concurrent
+import Data.Maybe
+import Data.Text (Text)
+
 import System.Log.Simple.Base hiding (entries, flatten, rules)
 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
+import System.Log.Simple.Chan
+
+runConsoleLog :: RulesLoad -> LogT IO a -> IO a
+runConsoleLog rs = runLog rs [logger 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)
+
+runLogMsgs :: MonadIO m => RulesLoad -> LogT m a -> m (a, [Message])
+runLogMsgs = runLogChan chan
+
+runLogTexts :: MonadIO m => RulesLoad -> LogT m a -> m (a, [Text])
+runLogTexts = runLogChan (logger text . chan)
src/System/Log/Simple/Base.hs view
@@ -33,6 +33,7 @@ import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
+import Data.Default
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe (catMaybes, isJust)
@@ -51,6 +52,9 @@     politicsHigh :: Level }
         deriving (Eq, Ord, Read, Show)
 
+instance Default Politics where
+    def = defaultPolitics
+
 -- | Default politics
 defaultPolitics :: Politics
 defaultPolitics = Politics Info Warning
@@ -236,14 +240,18 @@         uncommand :: [Command] -> [Command]
         uncommand = flatten . rules r [] . entries
 
+        fatalMsg :: String -> IO Message
+        fatalMsg s = do
+            tm <- getZonedTime
+            return $ Message tm Fatal ["*"] $ fromString s
+
+
         -- | 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
+            onError e = E.handle ignoreError $ fatalMsg ("Exception during logging message: " ++ show e) >>= logMsg
             ignoreError :: E.SomeException -> IO ()
             ignoreError _ = return ()
         tryLog _ (LeaveScope io) = io
+ src/System/Log/Simple/Chan.hs view
@@ -0,0 +1,10 @@+module System.Log.Simple.Chan (
+    chan
+    ) where
+
+import Control.Concurrent.Chan (Chan, writeChan)
+import System.Log.Simple.Base
+
+chan :: Chan a -> Consumer a
+chan ch = Consumer withChan where
+    withChan f = f (writeChan ch)
src/System/Log/Simple/Config.hs view
@@ -3,7 +3,8 @@ module System.Log.Simple.Config (
     parseRule, parseRules,
     parseRule_, parseRules_,
-    constant, mvar, fileCfg
+    rule_, rules_,
+    rulesCfg, mvarCfg, fileCfg
     ) where
 
 import Control.Arrow
@@ -61,13 +62,13 @@             ["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]
+            _ -> throwError $ "Unable to parse: " ++ T.unpack u
 
         value v = maybe noValue return $ lookup v values where
-            noValue = throwError $ concat ["Invalid value: ", T.unpack v]
+            noValue = throwError $ "Invalid value: " ++ T.unpack v
 
         predefined v = maybe noPredefined return $ lookup v predefineds where
-            noPredefined = throwError $ concat ["Invalid predefined: ", T.unpack v]
+            noPredefined = throwError $ "Invalid predefined: " ++ T.unpack v
 
 parseRules :: Text -> Writer [Text] Rules
 parseRules = mapM parseRule . filter (not . T.null . T.strip) . T.lines
@@ -80,6 +81,12 @@ parseRules_ :: Text -> Rules
 parseRules_ = fst . runWriter . parseRules
 
+rule_ :: Text -> Rule
+rule_ = parseRule_
+
+rules_ :: [Text] -> Rules
+rules_ = map rule_
+
 -- | Value names
 values :: [(Text, Level)]
 values = [
@@ -100,12 +107,12 @@     ("supress", supressPolitics)]
 
 -- | Constant rules
-constant :: Rules -> IO (IO Rules)
-constant = return . return
+rulesCfg :: Rules -> IO (IO Rules)
+rulesCfg = return . return
 
 -- | Rules from mvar
-mvar :: MVar Rules -> IO (IO Rules)
-mvar = return . readMVar
+mvarCfg :: MVar Rules -> IO (IO Rules)
+mvarCfg = return . readMVar
 
 -- | Rules from file
 fileCfg :: FilePath -> Int -> IO (IO Rules)
@@ -116,7 +123,7 @@         threadDelay (seconds * 1000000)
         rs' <- readRules
         void $ swapMVar var rs'
-    mvar var
+    mvarCfg var
     where
         readRules = do
             cts <- T.readFile f
src/System/Log/Simple/Monad.hs view
@@ -2,9 +2,9 @@ 
 module System.Log.Simple.Monad (
     LogT(..),
-    withNoLog,
-    withLog,
-    log,
+    withNoLog, withLog,
+    runLog, runNoLog,
+    log, sendLog,
     scope_,
     scope,
     scopeM_,
@@ -24,7 +24,9 @@ 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
@@ -42,12 +44,21 @@ 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
+
 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
 
@@ -57,11 +68,22 @@ 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
+
+runNoLog :: LogT m a -> m a
+runNoLog = withNoLog
+
 log :: (MonadLog m) => Level -> Text -> m ()
 log l msg = do
     (Log post _ _) <- askLog
     tm <- liftIO getZonedTime
     liftIO $ post $ PostMessage (Message tm l [] msg)
+
+sendLog :: MonadLog m => Level -> Text -> m ()
+sendLog = log
 
 scope_ :: (MonadLog m) => Text -> m a -> m a
 scope_ s act = do
src/System/Log/Simple/Text.hs view
@@ -1,22 +1,26 @@ module System.Log.Simple.Text (
     defaultTimeFormat,
-    textFmt, text
+    textFmt, text, shortText, msgOnly
     ) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
+import Text.Format
+
 import System.Log.Simple.Base
 
 -- | Default time format
 defaultTimeFormat :: String
-defaultTimeFormat = "%d/%m/%y %T %z"
+defaultTimeFormat = "%_Y-%m-%d %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]
+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"
@@ -26,4 +30,10 @@ 
 -- | Text log converter with default time format
 text :: Converter Text
-text = textFmt defaultTimeFormat
+text = textFmt defaultTimeFormat "{time}\t{level}\t{scope}> {message}"
+
+shortText :: Converter Text
+shortText = textFmt defaultTimeFormat "{level}: {message}"
+
+msgOnly :: Converter Text
+msgOnly = textFmt defaultTimeFormat "{message}"