From 04e26a5b118155c5dffb817b523bc8eada952b55 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 4 Feb 2016 22:29:18 +0000 Subject: Morphism Seq _ <-> Queue --- server/src/Thermoprint/Server/Queue.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) (limited to 'server/src') 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 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} {-# LANGUAGE ExistentialQuantification #-} @@ -14,7 +15,7 @@ import qualified Thermoprint.API as API (JobStatus(..)) import Thermoprint.Server.Database -import Data.Sequence (Seq) +import Data.Sequence (Seq, ViewL(..), viewl) import qualified Data.Sequence as Seq import Data.Time @@ -33,6 +34,8 @@ 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 @@ -41,6 +44,17 @@ data Queue = Queue } 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 -- cgit v1.2.3