{-# LANGUAGE GADTs              #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators      #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE ViewPatterns       #-}
{-# LANGUAGE ConstraintKinds    #-}
{-# LANGUAGE MultiParamTypeClasses       #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE IncoherentInstances       #-}

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.Trans.Compose
import Control.Monad.State
import Control.Category
import Servant.Server.Internal.Enter

import Data.Constraint
import Data.Constraint.Forall

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 Thermoprint.Server.Database (JobId)

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

type QMTrans t = ( MonadTrans t
                 , MFunctor t
                 , Monad (t STM)
                 , MonadIO (t IO)
                 , Monad (QueueManagerM t)
                 , MonadState Queue (QueueManagerM t)
                 )

class QMTrans1 (t :: (* -> *) -> * -> *) (t' :: (* -> *) -> * -> *)
instance QMTrans (ComposeT t t') => QMTrans1 t t'

type QMTrans' t = (QMTrans t, Forall (QMTrans1 t))

data QMConfig where
  QMConfig :: QMTrans' t => QueueManager t -> (forall m. (t m) :~> m) -> QMConfig
  QMConfig' :: ( forall t . QMTrans' t => QueueManager t
               ) -> QMConfig

instance Default QMConfig where
  def = idQM

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

idQM :: QMConfig
idQM = QMConfig' Q.idQM

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

qmCombine :: (forall f t. (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t) -> QMConfig -> QMConfig -> QMConfig
qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = (QMConfig (qmCombine' [a', b']) (natComp natA natB)) \\ (inst :: Forall (QMTrans1 t) :- QMTrans (ComposeT t t'))
  where
    a' = mapComposeT (hoist $ ComposeT . hoist lift) a
    b' = mapComposeT (hoist $ ComposeT . lift) b
    
natComp :: (forall m. t m :~> m)
           -> (forall m. t' m :~> m)
           -> (forall m. (MFunctor t
                         , Monad (t' m)
                         ) => ComposeT t t' m :~> m
              )
natComp natA natB = natA . hoistNat natB . Nat getComposeT

runQM :: ( HasQueue q ) => TChan JobId -> QMConfig -> q -> IO ()
runQM gcChan (QMConfig qm nat) q = unNat nat $ Q.runQM gcChan qm q
runQM gcChan (QMConfig' qm) q = runIdentityT $ Q.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 :: Int -> QMConfig
-- ^ 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 :: NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
                -> QMConfig
-- ^ 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