diff options
| -rw-r--r-- | server/src/Thermoprint/Server/Queue.hs | 16 |
1 files changed, 15 insertions, 1 deletions
diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs index cfe0970..68dc7a9 100644 --- a/server/src/Thermoprint/Server/Queue.hs +++ b/server/src/Thermoprint/Server/Queue.hs | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | {-# LANGUAGE FlexibleInstances #-} | 1 | {-# LANGUAGE FlexibleInstances #-} |
| 2 | {-# LANGUAGE ViewPatterns #-} | 2 | {-# LANGUAGE ViewPatterns #-} |
| 3 | {-# LANGUAGE RecordWildCards #-} | ||
| 3 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} | 4 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} |
| 4 | {-# LANGUAGE ExistentialQuantification #-} | 5 | {-# LANGUAGE ExistentialQuantification #-} |
| 5 | 6 | ||
| @@ -14,7 +15,7 @@ import qualified Thermoprint.API as API (JobStatus(..)) | |||
| 14 | 15 | ||
| 15 | import Thermoprint.Server.Database | 16 | import Thermoprint.Server.Database |
| 16 | 17 | ||
| 17 | import Data.Sequence (Seq) | 18 | import Data.Sequence (Seq, ViewL(..), viewl) |
| 18 | import qualified Data.Sequence as Seq | 19 | import qualified Data.Sequence as Seq |
| 19 | 20 | ||
| 20 | import Data.Time | 21 | import Data.Time |
| @@ -33,6 +34,8 @@ import Data.Default.Class | |||
| 33 | import Control.Monad.Morph | 34 | import Control.Monad.Morph |
| 34 | import Control.Monad.Trans.Compose | 35 | import Control.Monad.Trans.Compose |
| 35 | 36 | ||
| 37 | import Data.Monoid | ||
| 38 | |||
| 36 | -- | Zipper for 'Seq QueueEntry' with additional support for 'PrintingError' in the section after point | 39 | -- | Zipper for 'Seq QueueEntry' with additional support for 'PrintingError' in the section after point |
| 37 | data Queue = Queue | 40 | data Queue = Queue |
| 38 | { pending :: Seq QueueEntry -- ^ Pending jobs, closest last | 41 | { pending :: Seq QueueEntry -- ^ Pending jobs, closest last |
| @@ -41,6 +44,17 @@ data Queue = Queue | |||
| 41 | } | 44 | } |
| 42 | deriving (Typeable, Generic, NFData) | 45 | deriving (Typeable, Generic, NFData) |
| 43 | 46 | ||
| 47 | toSeq :: Queue -> Seq (Bool, QueueEntry, Maybe PrintingError) | ||
| 48 | 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 | ||
| 49 | |||
| 50 | fromSeq :: Seq (Bool, QueueEntry, Maybe PrintingError) -> Queue | ||
| 51 | fromSeq s = Queue pending' current' history' | ||
| 52 | where | ||
| 53 | (fmap (\(_, x, _) -> x) -> pending', pending'') = Seq.breakl (\(c, _, _) -> c) s | ||
| 54 | (current', history') = case viewl pending'' of | ||
| 55 | EmptyL -> (Nothing, Seq.empty) | ||
| 56 | (_, a, _) :< as -> (Just a, fmap (\(_, x, p) -> (x, p)) as) | ||
| 57 | |||
| 44 | class HasQueue a where | 58 | class HasQueue a where |
| 45 | extractQueue :: a -> TVar Queue | 59 | extractQueue :: a -> TVar Queue |
| 46 | 60 | ||
