{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
module Logging.Types.Class.Handler ( SomeHandler(..), Handler(..) ) where
import Control.Lens (set, view)
import Control.Monad (when)
import Data.Generics.Product.Typed
import Data.Typeable
import Prelude hiding (filter)
import Text.Format
import Logging.Types.Class.Filterable
import Logging.Types.Filter
import Logging.Types.Level
import Logging.Types.Record
data SomeHandler where
SomeHandler :: Handler h => h -> SomeHandler
instance {-# OVERLAPPING #-} HasType Level SomeHandler where
getTyped (SomeHandler h) = view (typed @Level) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Level) v h
instance {-# OVERLAPPING #-} HasType Filterer SomeHandler where
getTyped (SomeHandler h) = view (typed @Filterer) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Filterer) v h
instance {-# OVERLAPPING #-} HasType Format1 SomeHandler where
getTyped (SomeHandler h) = view (typed @Format1) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Format1) v h
instance Eq SomeHandler where
(SomeHandler h1) == h2 = Just h1 == fromHandler h2
instance Handler SomeHandler where
open (SomeHandler h) = open h
emit (SomeHandler h) = emit h
close (SomeHandler h) = close h
handle (SomeHandler h) = handle h
fromHandler = Just . id
toHandler = id
class ( HasType Level a
, HasType Filterer a
, HasType Format1 a
, Typeable a
, Eq a
) => Handler a where
open :: a -> IO ()
open _ = return ()
emit :: a -> LogRecord -> IO ()
close :: a -> IO ()
close _ = return ()
handle :: a -> LogRecord -> IO Bool
handle hdl rcd = do
let rv = filter (view (typed @Filterer) hdl) rcd
when rv $ emit hdl rcd
return rv
fromHandler :: SomeHandler -> Maybe a
fromHandler (SomeHandler h) = cast h
toHandler :: a -> SomeHandler
toHandler = SomeHandler