From 409e212bb4ef76784e6da1ef854e2cb85bebc0af Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 4 Feb 2016 23:00:38 +0000
Subject: More appropriate morphism for later use

---
 server/src/Thermoprint/Server/Queue.hs | 40 +++++++++++++++++++++++++---------
 1 file changed, 30 insertions(+), 10 deletions(-)

(limited to 'server/src')

diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs
index 68dc7a9..17865b6 100644
--- a/server/src/Thermoprint/Server/Queue.hs
+++ b/server/src/Thermoprint/Server/Queue.hs
@@ -15,9 +15,12 @@ import qualified Thermoprint.API as API (JobStatus(..))
 
 import           Thermoprint.Server.Database
 
-import           Data.Sequence (Seq, ViewL(..), viewl)
+import           Data.Sequence (Seq, ViewL(..), viewl, (|>), (<|))
 import qualified Data.Sequence as Seq
 
+import           Data.Set (Set)
+import qualified Data.Set as Set
+
 import           Data.Time
 import           Data.Time.Clock
 
@@ -34,6 +37,7 @@ import           Data.Default.Class
 import           Control.Monad.Morph
 import           Control.Monad.Trans.Compose
 
+import           Data.Foldable
 import           Data.Monoid
 
 -- | Zipper for 'Seq QueueEntry' with additional support for 'PrintingError' in the section after point
@@ -44,16 +48,32 @@ 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
+data QueueElem = Pending QueueEntry | Current QueueEntry | History QueueEntry (Maybe PrintingError)
+
+instance Eq QueueElem where
+  (Pending a) == (Pending b) = a == b
+  (Current a) == (Current b) = a == b
+  (History a _) == (History b _) = a == b
+  _ == _ = False
+
+instance Ord QueueElem where
+  (Pending _) <= _ = True
+  (Current _) <= (Pending _) = False
+  (Current _) <= _ = True
+  (History _ _) <= (History _ _) = True
+  (History _ _) <= _ = False
 
-fromSeq :: Seq (Bool, QueueEntry, Maybe PrintingError) -> Queue
-fromSeq s = Queue pending' current' history'
+toSeq :: Queue -> Set (Int, QueueElem)
+toSeq Queue{..} = fromSeq $ fmap Pending pending <> maybe Seq.empty (Seq.singleton . Current) current <> fmap (uncurry History) 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)
+    fromSeq = Set.fromAscList . toList . Seq.mapWithIndex ((,))
+
+fromSeq :: Set (Int, QueueElem) -> Queue
+fromSeq = foldr' (insert . snd) def
+  where
+    insert (Pending e) q@(Queue{..}) = q { pending = pending |> e }
+    insert (Current e) q = q { current = Just e }
+    insert (History e p) q@(Queue{..}) = q { history = history |> (e, p) }
 
 class HasQueue a where
   extractQueue :: a -> TVar Queue
@@ -72,7 +92,7 @@ data QueueEntry = QueueEntry
   { jobId :: JobId
   , created :: UTCTime
   }
-  deriving (Typeable, Generic, NFData)
+  deriving (Typeable, Generic, NFData, Eq)
 
 -- | A queue manager periodically modifies a 'Queue', e.g. for cleanup of old jobs
 type QueueManager t = ComposeT (StateT Queue) t STM DiffTime
-- 
cgit v1.2.3