1 files changed, 17 insertions, 7 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index c2a4972..446c63e 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeOperators             #-}
 {-# LANGUAGE FlexibleContexts          #-}
 {-# LANGUAGE ImpredicativeTypes        #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ViewPatterns              #-}
 {-# LANGUAGE DataKinds                 #-}
 
@@ -14,8 +15,7 @@ module Thermoprint.Server
        , module Data.Default.Class
        , module Servant.Server.Internal.Enter
        , module Thermoprint.Server.Printer
-       , module Thermoprint.Server.QMConfig
-       , Queue(..), QueueEntry(..)
+       , module Thermoprint.Server.Queue
        ) where
 
 import Data.Default.Class
@@ -78,8 +78,7 @@ import Thermoprint.Server.Push
 
 import Thermoprint.Server.Database
 import Thermoprint.Server.Printer
-import Thermoprint.Server.Queue hiding (intersection, idQM, union, nullQM, runQM)
-import Thermoprint.Server.QMConfig
+import Thermoprint.Server.Queue
 import qualified Thermoprint.Server.API as API (thermoprintServer)
 import Thermoprint.Server.API hiding (thermoprintServer)
 
@@ -89,9 +88,17 @@ import Debug.Trace
 data Config m = Config { dyreError     :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error
                        , warpSettings  :: Warp.Settings -- ^ Configure 'Warp's behaviour
                        , printers      :: Map API.PrinterId Printer
-                       , queueManagers :: API.PrinterId -> QMConfig
+                       , queueManagers :: API.PrinterId -> QMConfig m
                        }
 
+data QMConfig m = forall t. ( MonadTrans t
+                            , MFunctor t
+                            , Monad (t STM)
+                            , MonadIO (t IO)
+                            ) => QMConfig { manager  :: QueueManager t
+                                          , collapse :: (t IO) :~> m
+                                          }
+  
 instance MonadIO m => Default (Config m) where
   def = Config { dyreError     = Nothing
                , warpSettings  = Warp.defaultSettings
@@ -99,7 +106,10 @@ instance MonadIO m => Default (Config m) where
                , queueManagers = const def
                }
 
-withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig)] -> m (Config m)
+instance MonadIO m => Default (QMConfig m) where
+  def = QMConfig idQM $ Nat (liftIO . runIdentityT)
+
+withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m)
 -- ^ Add a list of printers to a 'Config'
 withPrinters cfg = fmap updateCfg . foldlM mapInsert (Map.mapWithKey (\k a -> (a, queueManagers cfg k)) $ printers cfg)
   where
@@ -140,7 +150,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
           gcChan <- liftIO newTChanIO
           fork tMgr $ jobGC gcChan
           let
-            runQM' = liftIO . runQM gcChan . queueManagers
+            runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
           mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
           nChan <- liftIO $ newBroadcastTChanIO
           let