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