packages feed

monad-log (empty) → 0.1.0.0

raw patch · 8 files changed

+612/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, exceptions, fast-logger, lifted-base, monad-control, template-haskell, text, text-show, transformers

Files

+ Control/Monad/Log.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}++module Control.Monad.Log (+    -- * parametrized 'Logger' type+      Level(..)+    , levelDebug+    , levelInfo+    , levelWarning+    , levelError+    , levelCritical+    , Logger(..)+    , envLens+    , makeLogger+    , makeDefaultLogger+    , makeDefaultJSONLogger+    , defaultFormatter+    , defaultJSONFormatter+    -- * re-export from fast-logger+    , module X+    , LogStr+    , toLogStr+    , LogType(..)+    -- * 'MonadLog' class+    , MonadLog(..)+    , localEnv+    , withFilterLevel+    , withEnv+    -- * LogT, a concrete monad transformaer+    , LogT(..)+    , runLogTSafe+    , runLogTSafeBase+    , runLogT'+    -- * re-export from text-show+    , module TextShow+    -- logging functions+    , debug+    , info+    , warning+    , error+    , critical+    , debug'+    , info'+    , warning'+    , error'+    , critical'+    ) where++import Control.Monad (when, liftM, ap)+import Control.Monad.Catch (MonadMask, finally)+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Control.Exception.Lifted as Lifted++import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Cont as Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, mapRWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, mapRWST)+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict++import System.Log.FastLogger+import System.Log.FastLogger.Date as X+import System.Log.FastLogger.File as X+import Prelude hiding (log, error)++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Builder as BB+import TextShow (TextShow, showt, showb)++import qualified Data.Aeson as JSON+import Data.Aeson (ToJSON, fromEncoding, (.=))+import Data.Monoid ((<>))++-----------------------------------------------------------------------------------------++-- | a newtype wrapper arounded 'Int' for GHC unpacking, with following 'TextShow' instance:+--+-- > showb (Level 0) = "DEBUG"+-- > showb (Level 1) = "INFO"+-- > showb (Level 2) = "WARNING"+-- > showb (Level 3) = "ERROR"+-- > showb (Level 4) = "CRITICAL"+-- > showb (Level x) = "OTHER:" <> showb x+newtype Level = Level Int deriving (Eq, Ord, Bounded, Show, Read)++instance TextShow Level where+    showb (Level 0) = "DEBUG"+    showb (Level 1) = "INFO"+    showb (Level 2) = "WARNING"+    showb (Level 3) = "ERROR"+    showb (Level 4) = "CRITICAL"+    showb (Level x) = "OTHER:" <> showb x+    {-# inline showb #-}++-- | Alias for @Level 0@+levelDebug :: Level+levelDebug = Level 0++-- | Alias for @Level 1@+levelInfo :: Level+levelInfo = Level 1++-- | Alias for @Level 2@+levelWarning :: Level+levelWarning = Level 2++-- | Alias for @Level 3@+levelError :: Level+levelError = Level 3++-- | Alias for @Level 4@+levelCritical :: Level+levelCritical = Level 4++-- | A logger type parametrized by an extra environment type.+data Logger env = Logger {+        filterLevel  :: {-# UNPACK #-} !Level  -- ^ filter level, equal or above it will be logged.+    ,   environment  :: env                    -- ^ parametrized logging environment.+    ,   formatter    :: Level -> FormattedTime -> env -> Text -> LogStr -- ^ formatter function.+    ,   timeCache    :: IO FormattedTime       -- ^ a time cache to avoid cost of frequently formatting time.+    ,   logger       :: LogStr -> IO ()        -- ^ a 'FastLogger' log function.+    ,   cleanUp      :: IO ()                  -- ^ clean up action(flushing/closing file...).+    }++-- | Lens for 'environment'.+envLens :: (Functor f) => (env -> f env) -> Logger env -> f (Logger env)+envLens f (Logger fltr e fmt t l c) = fmap (\ e' -> Logger fltr e' fmt t l c) (f e)++-- | make a 'Logger' based on 'FastLogger'.+makeLogger :: (MonadIO m)+    => (Level -> FormattedTime -> env -> Text -> LogStr)+    -> TimeFormat+    -> LogType+    -> Level+    -> env+    -> m (Logger env)+makeLogger fmt tfmt typ fltr env = liftIO $ do+    tc <- newTimeCache tfmt+    (fl, cl) <- newFastLogger typ+    return $ Logger fltr env fmt tc fl cl++-- | make a 'Logger' with 'defaultFormatter'.+makeDefaultLogger :: (MonadIO m, TextShow env)+    => TimeFormat+    -> LogType+    -> Level+    -> env+    -> m (Logger env)+makeDefaultLogger = makeLogger defaultFormatter++-- | make a 'Logger' with 'defaultJSONFormatter'.+makeDefaultJSONLogger :: (MonadIO m, ToJSON env)+    => TimeFormat+    -> LogType+    -> Level+    -> env+    -> m (Logger env)+makeDefaultJSONLogger = makeLogger defaultJSONFormatter++-- | a default formatter with following format:+--+-- @[LEVEL] [TIME] [ENV] LOG MESSAGE\\n@+defaultFormatter :: (TextShow env) => Level -> FormattedTime -> env -> Text -> LogStr+defaultFormatter lvl time env msg = toLogStr . T.concat $+    [ "[" , showt lvl, "] [", T.decodeUtf8 time,  "] [",  showt env, "] " , msg , "\n" ]++-- | a default JSON formatter with following format:+--+-- @{"level": LEVEL, "time": TIME, "env": ENV, msg: LOG MESSAGE }\\n@+defaultJSONFormatter :: (ToJSON env) => Level -> FormattedTime -> env -> Text -> LogStr+defaultJSONFormatter lvl time env msg = toLogStr . BB.toLazyByteString $+    ( fromEncoding . JSON.pairs $+        "level" .= showt lvl+        <> "time" .=  T.decodeUtf8 time+        <> "env" .= env+        <> "msg" .= msg+    ) <> "\n"++-----------------------------------------------------------------------------------------++-- | This is the main class for using logging function in this package.+--+-- provide an instance for 'MonadLog' to log within your monad stack+-- a concrete transformmer 'LogT' is also provided.+class (MonadIO m) => MonadLog env m | m -> env where+    askLogger :: m (Logger env)+    localLogger :: (Logger env -> Logger env) -> m a -> m a++instance MonadLog env m => MonadLog env (ContT r m) where+    askLogger   = lift askLogger+    localLogger = Cont.liftLocal askLogger localLogger++instance MonadLog env m => MonadLog env (ExceptT e m) where+    askLogger   = lift askLogger+    localLogger = mapExceptT . localLogger++instance MonadLog env m => MonadLog env (IdentityT m) where+    askLogger   = lift askLogger+    localLogger = mapIdentityT . localLogger++instance MonadLog env m => MonadLog env (ListT m) where+    askLogger   = lift askLogger+    localLogger = mapListT . localLogger++instance MonadLog env m => MonadLog env (MaybeT m) where+    askLogger   = lift askLogger+    localLogger = mapMaybeT . localLogger++instance MonadLog env m => MonadLog env (ReaderT r m) where+    askLogger   = lift askLogger+    localLogger = mapReaderT . localLogger++instance MonadLog env m => MonadLog env (Lazy.StateT s m) where+    askLogger   = lift askLogger+    localLogger = Lazy.mapStateT . localLogger++instance MonadLog env m => MonadLog env (Strict.StateT s m) where+    askLogger   = lift askLogger+    localLogger = Strict.mapStateT . localLogger++instance (Monoid w, MonadLog env m) => MonadLog env (Lazy.WriterT w m) where+    askLogger   = lift askLogger+    localLogger = Lazy.mapWriterT . localLogger++instance (Monoid w, MonadLog env m) => MonadLog env (Strict.WriterT w m) where+    askLogger   = lift askLogger+    localLogger = Strict.mapWriterT . localLogger++instance (MonadLog env m, Monoid w) => MonadLog env (LazyRWS.RWST r w s m) where+    askLogger   = lift askLogger+    localLogger = LazyRWS.mapRWST . localLogger++instance (MonadLog env m, Monoid w) => MonadLog env (StrictRWS.RWST r w s m) where+    askLogger   = lift askLogger+    localLogger = StrictRWS.mapRWST . localLogger++-- | run 'MonadLog' within a new 'FilterLevel'.+withFilterLevel :: (MonadLog env m) => Level -> m a -> m a+withFilterLevel level = localLogger (\ lgr -> lgr{ filterLevel = level})++-- | run 'MonadLog' within a new environment.+withEnv :: (MonadLog env m) => env -> m a -> m a+withEnv env = localLogger (\ lgr -> lgr{ environment = env })++-- | run 'MonadLog' within a modified environment.+localEnv :: (MonadLog env m) => (env -> env) -> m a -> m a+localEnv f = localLogger $ \ lgr -> lgr { environment = f (environment lgr) }++-----------------------------------------------------------------------------------------++-- | A simple 'MonadLog' instance.+--+-- a reader monad which embed a 'Logger'.+newtype LogT env m a = LogT { runLogT :: Logger env -> m a }++instance Monad m => Functor (LogT env m) where+    fmap = liftM+    {-# INLINE fmap #-}++instance Monad m => Applicative (LogT env m) where+    pure = return+    {-# INLINE pure #-}+    (<*>) = ap+    {-# INLINE (<*>) #-}++instance Monad m => Monad (LogT env m) where+    return = LogT . const . return+    {-# INLINE return #-}+    LogT ma >>= f = LogT $ \lgr -> do+        a <- ma lgr+        let LogT f' = f a+        f' lgr+    {-# INLINE (>>=) #-}++instance (MonadFix m) => MonadFix (LogT r m) where+    mfix f = LogT $ \ r -> mfix $ \ a -> runLogT (f a) r+    {-# INLINE mfix #-}++instance MonadTrans (LogT env) where+    lift = LogT . const+    {-# INLINE lift #-}++instance MonadIO m => MonadIO (LogT env m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++instance MonadIO m => MonadLog env (LogT env m) where+    askLogger = LogT return+    {-# INLINE askLogger #-}+    localLogger f ma = LogT $ \ r -> runLogT ma (f r)+    {-# INLINE localLogger #-}++-- | safely run 'LogT' inside 'MonadMask'. Logs are guaranteed to be flushed on exceptions.+runLogTSafe :: (MonadIO m, MonadMask m) => Logger env -> LogT env m a -> m a+runLogTSafe lgr m = finally (runLogT m lgr) (liftIO $ cleanUp lgr)++-- | safely run 'LogT' inside 'MonadBaseControl IO m'. Logs are guaranteed to be flushed on exceptions.+runLogTSafeBase :: (MonadBaseControl IO m, MonadIO m) => Logger env -> LogT env m a -> m a+runLogTSafeBase lgr m = Lifted.finally (runLogT m lgr) (liftIO $ cleanUp lgr)++-- | @runLogT' = flip runLogT@, run 'LogT' without clean up.+-- usually used inside different threads so that an exception won't clean up 'Logger'.+runLogT' :: (MonadIO m) => Logger env -> LogT env m a -> m a+runLogT' = flip runLogT++-----------------------------------------------------------------------------------------++log :: (MonadLog env m) => Level -> Text -> m ()+log lvl msg = do+    (Logger fltr env fmt tc wrt _) <- askLogger+    when (lvl >= fltr) $ liftIO $+        tc >>= \ t -> (wrt . toLogStr) (fmt lvl t env msg)+{-# INLINE log #-}++log' :: (MonadLog env m) => Level -> env -> Text -> m ()+log' lvl env msg = do+    (Logger fltr _ fmt tc wrt _) <- askLogger+    when (lvl >= fltr) $ liftIO $+        tc >>= \ t -> (wrt . toLogStr) (fmt lvl t env msg)+{-# INLINE log' #-}++debug :: (MonadLog env m) => Text -> m ()+debug = log levelDebug++info :: (MonadLog env m) => Text -> m ()+info = log levelInfo++warning :: (MonadLog env m) => Text -> m ()+warning = log levelWarning++error :: (MonadLog env m) => Text -> m ()+error = log levelError++critical :: (MonadLog env m) => Text -> m ()+critical = log levelCritical++debug' :: (MonadLog env m) => env -> Text -> m ()+debug' = log' levelDebug++info' :: (MonadLog env m) => env -> Text -> m ()+info' = log' levelInfo++warning' :: (MonadLog env m) => env -> Text -> m ()+warning' = log' levelWarning++error' :: (MonadLog env m) => env -> Text -> m ()+error' = log' levelError++critical' :: (MonadLog env m) => env -> Text -> m ()+critical' = log' levelCritical
+ Control/Monad/Log/Label.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Log.Label where++import Control.Monad.Log+import Data.Aeson+import Data.Text (Text)+import Data.Text.Internal.Builder (fromText)++-- | Simple 'Label' environment for labelled logging.+--+-- @+-- showt (Label "foo") = "foo"+-- toJSON (Label "foo") = "foo"+-- @+data Label = Label Text deriving (Show, Eq, Ord)++instance TextShow Label where+    showb (Label t) = fromText t++instance ToJSON Label where+    toJSON (Label t) = toJSON t+    toEncoding (Label t) = toEncoding t++instance FromJSON Label where+    parseJSON t = Label <$> parseJSON t++-- | 'withEnv' specialized for 'Label'+withLabel :: (MonadLog Label m) => Label -> m a -> m a+withLabel = withEnv
+ Control/Monad/Log/LogLoc.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Log.LogLoc where++import Control.Monad.Log+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Internal.Builder (fromText)+import Data.Aeson+import Data.Monoid ((<>))++import Language.Haskell.TH.Syntax (Q, Exp)+import qualified Language.Haskell.TH.Syntax as TH++-- | source location information.+--+-- @+-- showt (LogLoc "package" "Module" "file.hs" 122) = "package Module file.hs 122"+-- toJSON (LogLoc "package" "Module" "file.hs" 122) =+--     '{"package":"package","module":"module","filename":"file.hs","line":122}'+-- @+data LogLoc = LogLoc {+        package  :: Text+    ,   module'  :: Text+    ,   filename :: Text+    ,   line     :: Int+    } deriving (Show, Eq, Ord)++instance TextShow LogLoc where+    showb (LogLoc p m f l) = fromText (T.intercalate " " [p, m, f, showt l])++instance ToJSON LogLoc where+    toJSON (LogLoc p m f l) =+        object ["filename" .= f, "module" .= m, "package" .= p, "line" .= l]+    toEncoding (LogLoc p m f l) =+        pairs ("filename" .= f <> "module" .= m <> "package" .= p <> "line" .= l)++instance FromJSON LogLoc where+    parseJSON (Object v) = LogLoc <$>+        v .: "package" <*>+        v .: "module" <*>+        v .: "filename" <*>+        v .: "line"+    parseJSON _ = fail "LogLoc should be an object"++-- | Lift a location into an Exp.+liftLogLoc :: TH.Loc -> Q Exp+liftLogLoc (TH.Loc f p m (l, _) _) = [|LogLoc+    (T.pack $(TH.lift p))+    (T.pack $(TH.lift m))+    (T.pack $(TH.lift f))+    $(TH.lift l)+    |]++-- | Get current 'LogLoc'.+myLogLoc :: Q Exp+myLogLoc = [| $(TH.location >>= liftLogLoc) |]++-- | 'withEnv' specialized for 'LogLoc'+withLogLoc :: (MonadLog LogLoc m) => LogLoc -> m a -> m a+withLogLoc = withEnv
+ Control/Monad/Log/LogThreadId.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Log.LogThreadId where++import Control.Monad.Log+import Control.Monad.IO.Class+import Control.Concurrent+import Data.Aeson+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Internal.Builder (fromText)++-- | a formatted 'LogThreadId'.+--+-- @+-- showt (LogThreadId "LogThreadId x") = "LogThreadId x"+-- toJSON (LogThreadId "LogThreadId x") = "LogThreadId x"+-- @+newtype LogThreadId = LogThreadId Text deriving (Show, Eq, Ord)++instance TextShow LogThreadId where+    showb (LogThreadId t) = fromText t++instance ToJSON LogThreadId where+    toJSON (LogThreadId t) = toJSON t+    toEncoding (LogThreadId t) = toEncoding t++instance FromJSON LogThreadId where+    parseJSON t = LogThreadId <$> parseJSON t++-- | Get current 'LogThreadId'.+myLogThreadId :: (MonadIO m) => m LogThreadId+myLogThreadId = liftIO $ fmap (LogThreadId . T.pack . show) myThreadId++-- | 'withEnv' specialized for 'LogThreadId'+withLogThreadId :: (MonadLog LogThreadId m) => LogThreadId -> m a -> m a+withLogThreadId = withEnv++-- | obtain 'LogThreadId' and change logging environment.+withMyLogThreadId :: (MonadLog LogThreadId m) => m a -> m a+withMyLogThreadId ma = do+    tid <-  myLogThreadId+    withLogThreadId tid ma
+ Control/Monad/Log/NameSpace.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Log.NameSpace where++import Control.Monad.Log+import Data.Aeson+import Data.Text (Text)+import qualified Data.Text as T++-- | A newtype around a list of names from children to root.+--+-- This reversed order is choosen becasue '(:)' is faster.+--+-- @+-- showt (NameSpace ["subSub", "sub", "root"]) = "subSub<<sub<<root"+-- toJSON (NameSpace ["subSub", "sub", "root"]) = '["subSub", "sub", "root"]'+-- @+newtype NameSpace = NameSpace { getNameSpace :: [Text] } deriving (Show, Eq, Ord)++-- | push a 'Text' name to the front of 'NameSpace'.+pushNameSpace :: Text -> NameSpace -> NameSpace+pushNameSpace n (NameSpace ns) = NameSpace (n : ns)++instance TextShow NameSpace where+    showb (NameSpace names) = showb $ T.intercalate "<<" names++instance ToJSON NameSpace where+    toJSON (NameSpace t) = toJSON t+    toEncoding (NameSpace t) = toEncoding t++instance FromJSON NameSpace where+    parseJSON t = NameSpace <$> parseJSON t++-- | use a new 'NameSpace' within m.+withNameSpace :: (MonadLog NameSpace m) => NameSpace -> m a -> m a+withNameSpace = withEnv++-- | push a 'Text' name to the front of m's 'NameSpace'.+subNameSpace :: (MonadLog NameSpace m) => Text -> m a -> m a+subNameSpace sub = localEnv (pushNameSpace sub)
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 winterland1989++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ monad-log.cabal view
@@ -0,0 +1,44 @@+-- Initial monad-log.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                monad-log+version:             0.1.0.0+synopsis:            A simple and fast logging monad+description:         A simple and fast logging monad+license:             MIT+license-file:        LICENSE+author:              winterland1989+maintainer:          winterland1989@gmail.com+-- copyright:           +category:            Development+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  ghc-options:          -Wall+  exposed-modules:      Control.Monad.Log+                    ,   Control.Monad.Log.Label+                    ,   Control.Monad.Log.LogLoc+                    ,   Control.Monad.Log.NameSpace+                    ,   Control.Monad.Log.LogThreadId+  -- other-modules:       +  -- other-extensions:    +  build-depends:        base >=4.8 && <4.9+                    ,   fast-logger >=2.4.5 && <2.5+                    ,   monad-control >=0.3 && <1.1+                    ,   lifted-base +                    ,   exceptions >=0.6 && <0.9+                    ,   bytestring+                    ,   text+                    ,   text-show+                    ,   transformers >=0.2 && <0.5+                    ,   aeson        >= 0.10 && <0.12+                    ,   template-haskell ++  -- hs-source-dirs:      +  default-language:    Haskell2010++source-repository head+  type:                 git+  location:             https://github.com/winterland1989/monad-log