{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE ExistentialQuantification #-}

module Thermoprint.Server.Queue
       ( Queue(..), QueueEntry(..)
       , HasQueue(..)
       , QueueManager(..), runQM
       ) where

import           Thermoprint.API (PrintingError(..), Printout)
import qualified Thermoprint.API as API (JobStatus(..))

import           Thermoprint.Server.Database

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

import           Data.Time
import           Data.Time.Clock

import           Control.DeepSeq (NFData)
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Monad.State

import           Data.Default.Class

import           Control.Monad.Morph
import           Control.Monad.Trans.Compose

-- | Zipper for 'Seq QueueEntry' with additional support for 'PrintingError' in the section after point
data Queue = Queue
  { pending :: Seq QueueEntry -- ^ Pending jobs, closest last
  , current :: Maybe QueueEntry
  , history :: Seq (QueueEntry, Maybe PrintingError) -- ^ Completed jobs, closest first
  }
  deriving (Typeable, Generic, NFData)

class HasQueue a where
  extractQueue :: a -> TVar Queue

instance HasQueue (TVar Queue) where
  extractQueue = id

instance Default Queue where
  def = Queue
    { pending = Seq.empty
    , current = Nothing
    , history = Seq.empty
    }

data QueueEntry = QueueEntry
  { jobId :: JobId
  , created :: UTCTime
  }
  deriving (Typeable, Generic, NFData)

type QueueManager t = ComposeT (StateT Queue) t STM DiffTime

runQM :: ( HasQueue q
         , MFunctor t
         , MonadTrans t
         , MonadIO (t IO)
         , Monad (t STM)
         ) => QueueManager t -> q -> t IO ()
runQM qm (extractQueue -> q) = forever $ liftIO . threadDelay . toMicro =<< qm'
  where
    qm' = hoist atomically $ (\(a, s) -> lift (writeTVar q s) >> return a) =<< runStateT (getComposeT qm) =<< lift (readTVar q)
    toMicro = (`div` 10^6) . fromEnum