logger-0.1.0.0: src/System/Log/Logger/Priority.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Log.Logger.Handler
-- Copyright   :  (C) 2015 Flowbox
-- License     :  Apache-2.0
-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>
-- Stability   :  stable
-- Portability :  portable
-----------------------------------------------------------------------------

module System.Log.Logger.Priority where

import System.Log.Data           (MonadRecord, appendRecord, Lvl(Lvl), readData, LevelData(LevelData), LookupDataSet)
import System.Log.Logger.Handler (MonadLoggerHandler(addHandler))
import System.Log.Log            (MonadLogger, LogFormat)
import Control.Monad.State       (StateT, runStateT)
import Control.Monad.Trans       (MonadTrans, lift)
import Control.Monad.IO.Class    (MonadIO)
import Control.Applicative
import qualified Control.Monad.State as State

----------------------------------------------------------------------
-- MonadPriorityLogger
----------------------------------------------------------------------

class MonadPriorityLogger m where
    getPriority :: m Int
    setPriority :: Enum a => a -> m ()

----------------------------------------------------------------------
-- PriorityLoggerT
----------------------------------------------------------------------

newtype PriorityLoggerT m a = PriorityLoggerT { fromPriorityLoggerT :: StateT Int m a } deriving (Monad, MonadIO, Applicative, Functor, MonadTrans)
type instance LogFormat (PriorityLoggerT m) = LogFormat m

runPriorityLoggerT pri = fmap fst . flip runStateT (fromEnum pri) . fromPriorityLoggerT


-- === Instances ===

instance Monad m => MonadPriorityLogger (PriorityLoggerT m) where
    getPriority   = PriorityLoggerT State.get
    setPriority a = PriorityLoggerT . State.put $ fromEnum a

instance (MonadLogger m, MonadRecord d m, LookupDataSet Lvl d) => MonadRecord d (PriorityLoggerT m) where
    appendRecord d = do
        priLimit <- getPriority
        let LevelData pri _ = readData Lvl d
        if priLimit <= pri then lift $ appendRecord d
                           else return ()

instance (Monad m, MonadLoggerHandler h m) => MonadLoggerHandler h (PriorityLoggerT m)