{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
module Logging.Class.Handler ( SomeHandler(..), Handler(..) ) where
import Control.Exception (SomeException, catch)
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.Class.Filterable
import Logging.Filter
import Logging.Level
import Logging.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@LogRecord{level=level', message=message}
| level' < view (typed @Level) hdl = return False
| not (filter (view (typed @Filterer) hdl) rcd) = return False
| otherwise = catch (emit hdl rcd >> return True) handleError
where
handleError :: SomeException -> IO Bool
handleError e = do
putStrLn "--- Logging error ---"
putStrLn $ show e
putStrLn $ "Message: " ++ message
return False
fromHandler :: SomeHandler -> Maybe a
fromHandler (SomeHandler h) = cast h
toHandler :: a -> SomeHandler
toHandler = SomeHandler