{-# 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


-- |The 'SomeHandler' type is the root of the handler type hierarchy.
-- It holds the real 'Handler' instance
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


-- |A type class that abstracts the characteristics of a 'Handler'
--
-- Note: Locking is not necessary, because 'GHC.IO.Handle' has done it on
-- handle operations.
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