{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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, ViewL(..), viewl)
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

import           Data.Monoid

-- | 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)

toSeq :: Queue -> Seq (Bool, QueueEntry, Maybe PrintingError)
toSeq Queue{..} = fmap (\x -> (False, x, Nothing)) pending <> maybe Seq.empty (\c -> Seq.singleton (True, c, Nothing)) current <> fmap (\(x, p) -> (False, x, p)) history

fromSeq :: Seq (Bool, QueueEntry, Maybe PrintingError) -> Queue
fromSeq s = Queue pending' current' history'
  where
    (fmap (\(_, x, _) -> x) -> pending', pending'') = Seq.breakl (\(c, _, _) -> c) s
    (current', history') = case viewl pending'' of
      EmptyL -> (Nothing, Seq.empty)
      (_, a, _) :< as -> (Just a, fmap (\(_, x, p) -> (x, p)) as)

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)

-- | A queue manager periodically modifies a 'Queue', e.g. for cleanup of old jobs
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 ()
-- ^ Periodically modify a 'Queue'
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