Split QMConfig into own module

2 files changed, 45 insertions, 12 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 446c63e..cd3a4ed 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE TypeOperators             #-}
 {-# LANGUAGE FlexibleContexts          #-}
 {-# LANGUAGE ImpredicativeTypes        #-}
-{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ViewPatterns              #-}
 {-# LANGUAGE DataKinds                 #-}
 
@@ -16,6 +15,7 @@ module Thermoprint.Server
        , module Servant.Server.Internal.Enter
        , module Thermoprint.Server.Printer
        , module Thermoprint.Server.Queue
+       , module Thermoprint.Server.QMConfig
        ) where
 
 import Data.Default.Class
@@ -79,6 +79,7 @@ import Thermoprint.Server.Push
 import Thermoprint.Server.Database
 import Thermoprint.Server.Printer
 import Thermoprint.Server.Queue
+import Thermoprint.Server.QMConfig
 import qualified Thermoprint.Server.API as API (thermoprintServer)
 import Thermoprint.Server.API hiding (thermoprintServer)
 
@@ -91,14 +92,6 @@ data Config m = Config { dyreError     :: Maybe String -- ^ Set by 'Dyre' -- sen
                        , 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
@@ -106,9 +99,6 @@ instance MonadIO m => Default (Config m) where
                , queueManagers = const def
                }
 
-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)
@@ -151,6 +141,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
           fork tMgr $ jobGC gcChan
           let
             runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
+            runQM' (queueManagers -> QMConfig' qm) printer = hoist liftIO $ runQM gcChan qm printer
           mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
           nChan <- liftIO $ newBroadcastTChanIO
           let
diff --git a/server/src/Thermoprint/Server/QMConfig.hs b/server/src/Thermoprint/Server/QMConfig.hs
new file mode 100644
index 0000000..0cf7beb
--- /dev/null
+++ b/server/src/Thermoprint/Server/QMConfig.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeOperators      #-}
+
+module Thermoprint.Server.QMConfig
+       ( QMConfig(..)
+       ) where
+
+import Control.Monad.Trans.Resource
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Identity
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.IO.Class
+import Control.Monad.Morph
+import Control.Category
+import Prelude hiding (id, (.))
+import Servant.Server.Internal.Enter (enter, (:~>)(..))
+
+import Data.Default.Class
+
+import Control.Concurrent.STM
+
+import Thermoprint.Server.Queue
+
+data QMConfig m where
+  QMConfig :: ( MonadTrans t
+              , MFunctor t
+              , Monad (t STM)
+              , MonadIO (t IO)
+              ) => QueueManager t -> (t IO) :~> m -> QMConfig m
+  QMConfig' :: ( MonadIO m
+               ) => ( forall t. ( MonadTrans t
+                                , MFunctor t
+                                , Monad (t STM)
+                                , MonadIO (t IO)
+                                ) => QueueManager t
+                    ) -> QMConfig m
+
+instance MonadIO m => Default (QMConfig m) where
+  def = QMConfig idQM $ Nat (liftIO . runIdentityT)