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

module Thermoprint.Server.Printer
       ( Printer(..), printer
       , IsPrinter(..), PrinterSpec(..)
       , 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

import Data.Default.Class

import Prelude hiding (print)

class IsPrinter a where
  toMethod :: forall m. (MonadResource m) => a -> (forall m1. (MonadResource m1) => m (Printout -> m1 (Maybe PrintingError)))

instance (MonadResource m) => IsPrinter (Printer m) where
  toMethod Printer{..} = return print

instance (MonadResource m) => IsPrinter (PrinterSpec m) where
  toMethod (PS p) = toMethod p

data PrinterSpec m = forall p. IsPrinter p => PS p 

data Printer m = Printer
  { print :: 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)

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

printer :: (MonadResource m, MonadResource m1, IsPrinter p) => p -> m (Printer m1)
-- ^ Version of 'Printer' handling the initialisation of the 'TVar'
printer p = Printer <$> toMethod p <*> liftIO (newTVarIO def)

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

runPrinter :: ( MonadReader ConnectionPool m
              , MonadLogger m
              , MonadResource m
              , MonadBaseControl IO m
              ) => Printer m -> 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)