{-# LANGUAGE GADTs              #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators      #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE ViewPatterns       #-}

module Thermoprint.Server.QMConfig
       ( QMConfig(..)
       , nullQM
       , idQM
       , standardSleep
       , limitHistorySize
       , limitHistoryAge
       ) where

import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Control.Monad.Trans.Identity
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Monad.State
import Control.Category
import Servant.Server.Internal.Enter (enter, (:~>)(..))

import Data.Default.Class

import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Time
import Data.Foldable

import Control.Concurrent.STM

import Thermoprint.Server.Queue hiding (idQM, intersection, nullQM, union, runQM)
import qualified Thermoprint.Server.Queue as Q

import Prelude hiding (length, maximum, id, (.))

data QMConfig m where
  QMConfig :: ( MonadTrans t
              , MFunctor t
              , Monad (t STM)
              , MonadIO (t IO)
              ) => QueueManager t -> (t IO) :~> m -> QMConfig m
  QMConfig' :: ( MonadIO m
               ) => ( forall t. ( MonadTrans t
                                , MFunctor t
                                , Monad (t STM)
                                , MonadIO (t IO)
                                , Monad (QueueManagerM t)
                                ) => QueueManager t
                    ) -> QMConfig m

instance MonadIO m => Default (QMConfig m) where
  def = idQM

intersection :: (Functor f, Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m
intersection = foldr' (qmCombine Q.intersection) idQM

idQM :: MonadIO m => QMConfig m
idQM = QMConfig' Q.idQM

union :: (Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m
union = foldr' (qmCombine Q.union) idQM
  
nullQM :: MonadIO m => QMConfig m
nullQM = QMConfig' Q.nullQM

qmCombine :: ([QueueManager t] -> QueueManager t) -> QMConfig m -> QMConfig m -> QMConfig m
qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = undefined
  where
    natA :: t IO :~> m
    natB :: t' IO :~> m
    ---
    hoistNat natB :: t (t' IO) :~> t m
    -- 
    ? :: t m :~> m
    natAB :: ComposeT t t' IO :~> m

runQM :: ( HasQueue q ) => TChan JobId -> QMConfig m -> q -> t IO ()
runQM gcChan (QMConfig qm nat) q = unNat nat $ runQM gcChan qm q
runQM gcChan (QMConfig' qm) q = hoist liftIO $ runQM gcChan qm q

standardSleep :: Monad (QueueManagerM t) => QueueManager t
-- ^ Instruct 'runQM' to sleep some standard amount of time
--
-- /TODO/: Investigate implementing a smarter algorithm (PID-controller)
standardSleep = return $ 20

limitHistorySize :: MonadIO m => Int -> QMConfig m
-- ^ Limit a 'Queue's 'history's size to some number of 'QueueEntry's
limitHistorySize max = QMConfig' $ modify' limitSize >> standardSleep
  where
    limitSize :: Queue -> Queue
    limitSize q@Queue{..} = q { history = Seq.take max history }

limitHistoryAge :: MonadIO m => NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
                -> QMConfig m
-- ^ Limit a 'Queue's 'history's contents to 'QueueEntry's below a certain age
limitHistoryAge  maxAge = QMConfig' $ modify' limitAge >> standardSleep
  where
    limitAge :: Queue -> Queue
    limitAge q@Queue{..} = q { history = Seq.filter (filterAge . created . fst) history}
      where
        youngest :: UTCTime
        youngest = maximum $ created . fst <$> history
        filterAge :: UTCTime -> Bool
        filterAge time = not $ (youngest `diffUTCTime` time) > maxAge