content: {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- 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.Handler where
  
  import           Data.Monoid
  import           Control.Applicative
  import           System.Log.Data               (MonadRecord(appendRecord), LogBuilder, LookupDataSet, Msg, Lvl)
  import           System.Log.Filter             (Filter, runFilter)
  import           Control.Lens                  hiding (children)
  import           System.Log.Log                (Log, MonadLogger(appendLog), LogFormat, LogFormat)
  import           Control.Monad.Trans           (MonadTrans, lift)
  import           Control.Monad.Trans.Except
  import           Control.Monad.Trans.List
  import           Control.Monad.Trans.Maybe
  import           Control.Monad.Trans.Reader
  import           Control.Monad.Trans.RWS
  import           Control.Monad.Trans.State
  import           Control.Monad.Trans.Writer
  import           Control.Monad.State           (StateT, runStateT)
  import qualified Control.Monad.State           as State
  import           Control.Monad.IO.Class        (MonadIO, liftIO)
  import           System.Log.Format             (Formatter, runFormatter, defaultFormatter)
  import qualified System.IO                     as IO
  import           Text.PrettyPrint.ANSI.Leijen  (Doc, putDoc, hPutDoc)
  
  ----------------------------------------------------------------------
  -- MonadLoggerHandler
  ----------------------------------------------------------------------
  
  class MonadLoggerHandler n m | m -> n where
      addHandler :: Handler n (LogFormat m) -> m ()
  
      default addHandler :: (Monad m, MonadTrans t) => Handler n (LogFormat m) -> t m ()
      addHandler = lift . addHandler
  
  instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (ExceptT e m)
  instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (ListT m)
  instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (MaybeT m)
  instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (ReaderT r m)
  instance (Monad m, Monoid w, MonadLoggerHandler n m) => MonadLoggerHandler n (RWST r w s m)
  instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (StateT s m)
  instance (Monad m, Monoid w, MonadLoggerHandler n m) => MonadLoggerHandler n (WriterT w m)
  
  ----------------------------------------------------------------------
  -- Handler
  ----------------------------------------------------------------------
  
  -- !!! dorobic formattery i filtracje do handlerow!
  
  data Handler m l = Handler { _name      :: String
                             , _action    :: Doc -> Log l -> m ()
                             , _children  :: [Handler m l]
                             , _formatter :: Maybe (Formatter l)
                             , _filters   :: [Filter l]
                             }
  makeLenses ''Handler
  
  type Handler' m = Handler m (LogFormat m)
  
  instance Show (Handler m l) where
      show (Handler n _ _ _ _) = "Handler " <> n
  
  mkHandler :: String -> (Doc -> Log l -> m ()) -> Maybe (Formatter l) -> Handler m l
  mkHandler name f fmt = Handler name f [] fmt []
  addChildHandler h ph = ph & children %~ (h:)
  
  addFilter :: Filter l -> Handler m l -> Handler m l
  addFilter f = filters %~ (f:)
  
  setFormatter :: Formatter l -> Handler m l -> Handler m l
  setFormatter f = formatter .~ (Just f)
  
  -- === Handlers ===
  
  topHandler :: Monad m => Formatter l -> Handler m l
  topHandler fmt = mkHandler "TopHandler" (\_ _ -> return ()) Nothing
                 & formatter .~ (Just fmt)
  
  printHandler :: MonadIO m => Maybe (Formatter l) -> Handler m l
  printHandler = mkHandler "PrintHandler" handle where
      handle defDoc l = liftIO $ putDoc defDoc *> putStrLn ""
  
  fileHandler :: MonadIO m => IO.Handle -> Maybe (Formatter l) -> Handler m l
  fileHandler h = mkHandler "FileHandler" (handle h) where
      handle h defDoc l = liftIO $ hPutDoc h defDoc *> IO.hPutStrLn h ""
  
  ----------------------------------------------------------------------
  -- HandlerLoggerT
  ----------------------------------------------------------------------
  
  newtype HandlerLoggerT m a = HandlerLoggerT { fromHandlerLogger :: StateT (Handler' (HandlerLoggerT m)) m a } deriving (Monad, MonadIO, Applicative, Functor)
  
  type instance LogFormat (HandlerLoggerT m) = LogFormat m
  
  instance MonadTrans HandlerLoggerT where
      lift = HandlerLoggerT . lift
  
  runHandlerLoggerT :: (Functor m, Monad m) => Formatter (LogFormat m) -> HandlerLoggerT m b -> m b
  runHandlerLoggerT fmt = fmap fst . flip runStateT (topHandler fmt) . fromHandlerLogger
  
  
  runHandler :: (Applicative m, Monad m) => Doc -> Log (LogFormat m) -> Handler' m -> m ()
  runHandler defDoc l h = act <* mapM (runHandler doc l) (h^.children) where
      flt = runFilters h l
      fmt = h^.formatter
      act = if flt then (h^.action) doc l
                   else return ()
      doc = case fmt of
          Nothing -> defDoc
          Just f  -> runFormatter f l
      runFilters h l = foldr (&&) True $ fmap (\f -> runFilter f l) (h^.filters)
  
  
  getTopHandler :: Monad m => HandlerLoggerT m (Handler (HandlerLoggerT m) (LogFormat m))
  getTopHandler = HandlerLoggerT State.get
  
  putTopHandler :: Monad m => Handler (HandlerLoggerT m) (LogFormat m) -> HandlerLoggerT m ()
  putTopHandler = HandlerLoggerT . State.put
  
  -- === Instances ===
  
  instance (MonadLogger m, Functor m, l~LogFormat m, LookupDataSet Msg l, LookupDataSet Lvl l)
        => MonadLogger (HandlerLoggerT m) where
      appendLog l =  (runHandler defDoc l =<< getTopHandler)
                  *> lift (appendLog l)
          where defDoc = runFormatter defaultFormatter l
  
  instance (Monad m, Functor m) => MonadLoggerHandler (HandlerLoggerT m) (HandlerLoggerT m) where
      addHandler h = do
          topH <- getTopHandler
          putTopHandler $ addChildHandler h topH
  
  instance (Functor m, MonadLogger m, l~LogFormat m, LogBuilder d (HandlerLoggerT m), LookupDataSet Msg l, LookupDataSet Lvl l)
        => MonadRecord d (HandlerLoggerT m)
  