{-# LANGUAGE RankNTypes                    #-}
{-# LANGUAGE MultiParamTypeClasses         #-}
{-# LANGUAGE FlexibleContexts              #-}
{-# LANGUAGE RecordWildCards               #-}
{-# LANGUAGE OverloadedStrings             #-}
{-# LANGUAGE TemplateHaskell               #-}
{-# LANGUAGE StandaloneDeriving            #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

module Thermoprint.Server.Printer
       ( Printer(..), printer
       , Queue(..)
       , runPrinter
       ) where

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

import Thermoprint.Server.Database

import Database.Persist
import Database.Persist.Sql

import Data.Sequence (Seq, ViewL(..), viewl, (<|))
import qualified Data.Sequence as Seq
import Data.Map (Map)
import qualified Data.Map as Map

import qualified Data.Text as T (pack)

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

import Control.Monad.Trans.Resource
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader

import Control.Monad (forever)

import Control.Concurrent.STM

data Printer = Printer
  { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)
  , queue :: TVar Queue
  }

-- | Zipper for 'Seq JobId'
data Queue = Queue
  { pending :: Seq JobId -- ^ Pending jobs, closest first
  , current :: Maybe JobId
  , history :: Seq (JobId, Maybe PrintingError) -- ^ Completed jobs, closest first
  }
  deriving (Typeable, Generic, NFData)

printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer
printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty)

atomically' :: MonadIO m => STM a -> m a
atomically' = liftIO . atomically

runPrinter :: ( MonadReader ConnectionPool m
              , MonadIO m
              , MonadLogger m
              , MonadBaseControl IO m
              ) => Printer -> m ()
-- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
runPrinter Printer{..} = forever $ do
  jobId <- atomically' $ do
    (Queue queuePending Nothing history) <- readTVar queue
    case viewl queuePending of
      EmptyL               -> retry
      (jobId :< remaining) -> do
        writeTVar queue $!! Queue remaining (Just jobId) history
        return jobId
  job <- runSqlPool (get jobId) =<< ask
  case job of
    Nothing  -> $(logWarn) "Nonexistent job id in printer queue"
    Just job -> do
      printReturn <- print (jobContent job)
      maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show jobId ++ ": ") ++) . show) $ printReturn
      atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history)