Further work on QMConfig tools

4 files changed, 69 insertions, 49 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 49f3e82..c2a4972 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -89,7 +89,7 @@ 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 m
+                       , queueManagers :: API.PrinterId -> QMConfig
                        }
 
 instance MonadIO m => Default (Config m) where
@@ -99,7 +99,7 @@ instance MonadIO m => Default (Config m) where
                , queueManagers = const def
                }
 
-withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m)
+withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig)] -> 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 +140,7 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
           gcChan <- liftIO newTChanIO
           fork tMgr $ jobGC gcChan
           let
-            runQM' = runQM gcChan . queueManagers
+            runQM' = liftIO . runQM gcChan . queueManagers
           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
index 8f08faf..7255c8c 100644
--- a/server/src/Thermoprint/Server/QMConfig.hs
+++ b/server/src/Thermoprint/Server/QMConfig.hs
@@ -4,6 +4,12 @@
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE ViewPatterns       #-}
+{-# LANGUAGE ConstraintKinds    #-}
+{-# LANGUAGE MultiParamTypeClasses       #-}
+{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE FlexibleInstances       #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE IncoherentInstances       #-}
 
 module Thermoprint.Server.QMConfig
        ( QMConfig(..)
@@ -21,9 +27,13 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Monad.IO.Class
 import Control.Monad.Morph
+import Control.Monad.Trans.Compose
 import Control.Monad.State
 import Control.Category
-import Servant.Server.Internal.Enter (enter, (:~>)(..))
+import Servant.Server.Internal.Enter
+
+import Data.Constraint
+import Data.Constraint.Forall
 
 import Data.Default.Class
 
@@ -37,52 +47,60 @@ import Control.Concurrent.STM
 import Thermoprint.Server.Queue hiding (idQM, intersection, nullQM, union, runQM)
 import qualified Thermoprint.Server.Queue as Q
 
+import Thermoprint.Server.Database (JobId)
+
 import Prelude hiding (length, maximum, id, (.))
 
-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)
-                                , Monad (QueueManagerM t)
-                                ) => QueueManager t
-                    ) -> QMConfig m
-
-instance MonadIO m => Default (QMConfig m) where
+type QMTrans t = ( MonadTrans t
+                 , MFunctor t
+                 , Monad (t STM)
+                 , MonadIO (t IO)
+                 , Monad (QueueManagerM t)
+                 , MonadState Queue (QueueManagerM t)
+                 )
+
+class QMTrans1 (t :: (* -> *) -> * -> *) (t' :: (* -> *) -> * -> *)
+instance QMTrans (ComposeT t t') => QMTrans1 t t'
+
+type QMTrans' t = (QMTrans t, Forall (QMTrans1 t))
+
+data QMConfig where
+  QMConfig :: QMTrans' t => QueueManager t -> (forall m. (t m) :~> m) -> QMConfig
+  QMConfig' :: ( forall t . QMTrans' t => QueueManager t
+               ) -> QMConfig
+
+instance Default QMConfig where
   def = idQM
 
-intersection :: (Functor f, Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m
+intersection :: Foldable f => f QMConfig -> QMConfig
 intersection = foldr' (qmCombine Q.intersection) idQM
 
-idQM :: MonadIO m => QMConfig m
+idQM :: QMConfig
 idQM = QMConfig' Q.idQM
 
-union :: (Foldable f, MonadIO m) => f (QMConfig m) -> QMConfig m
+union :: Foldable f => f QMConfig -> QMConfig
 union = foldr' (qmCombine Q.union) idQM
   
-nullQM :: MonadIO m => QMConfig m
+nullQM :: QMConfig
 nullQM = QMConfig' Q.nullQM
 
-qmCombine :: ([QueueManager t] -> QueueManager t) -> QMConfig m -> QMConfig m -> QMConfig m
-qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = undefined
+qmCombine :: (forall f t. (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t) -> QMConfig -> QMConfig -> QMConfig
+qmCombine qmCombine' (QMConfig a natA) (QMConfig b natB) = (QMConfig (qmCombine' [a', b']) (natComp natA natB)) \\ (inst :: Forall (QMTrans1 t) :- QMTrans (ComposeT t t'))
   where
-    natA :: t IO :~> m
-    natB :: t' IO :~> m
-    ---
-    hoistNat natB :: t (t' IO) :~> t m
-    -- 
-    ? :: t m :~> m
-    natAB :: ComposeT t t' IO :~> m
-
-runQM :: ( HasQueue q ) => TChan JobId -> QMConfig m -> q -> t IO ()
-runQM gcChan (QMConfig qm nat) q = unNat nat $ runQM gcChan qm q
-runQM gcChan (QMConfig' qm) q = hoist liftIO $ runQM gcChan qm q
+    a' = mapComposeT (hoist $ ComposeT . hoist lift) a
+    b' = mapComposeT (hoist $ ComposeT . lift) b
+    
+natComp :: (forall m. t m :~> m)
+           -> (forall m. t' m :~> m)
+           -> (forall m. (MFunctor t
+                         , Monad (t' m)
+                         ) => ComposeT t t' m :~> m
+              )
+natComp natA natB = natA . hoistNat natB . Nat getComposeT
+
+runQM :: ( HasQueue q ) => TChan JobId -> QMConfig -> q -> IO ()
+runQM gcChan (QMConfig qm nat) q = unNat nat $ Q.runQM gcChan qm q
+runQM gcChan (QMConfig' qm) q = runIdentityT $ Q.runQM gcChan qm q
 
 standardSleep :: Monad (QueueManagerM t) => QueueManager t
 -- ^ Instruct 'runQM' to sleep some standard amount of time
@@ -90,15 +108,15 @@ standardSleep :: Monad (QueueManagerM t) => QueueManager t
 -- /TODO/: Investigate implementing a smarter algorithm (PID-controller)
 standardSleep = return $ 20
 
-limitHistorySize :: MonadIO m => Int -> QMConfig m
+limitHistorySize :: Int -> QMConfig
 -- ^ Limit a 'Queue's 'history's size to some number of 'QueueEntry's
 limitHistorySize max = QMConfig' $ modify' limitSize >> standardSleep
   where
     limitSize :: Queue -> Queue
     limitSize q@Queue{..} = q { history = Seq.take max history }
 
-limitHistoryAge :: MonadIO m => NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
-                -> QMConfig m
+limitHistoryAge :: NominalDiffTime -- ^ Maximum age relative to the youngest 'QueueEntry'
+                -> QMConfig
 -- ^ Limit a 'Queue's 'history's contents to 'QueueEntry's below a certain age
 limitHistoryAge  maxAge = QMConfig' $ modify' limitAge >> standardSleep
   where
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 2fa04c5..0a5690e 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -66,6 +66,7 @@ library
                      , wai-websockets >=3.0.0 && <4
                      , wai >=3.0.5 && <4
                      , network-uri >=2.6.0 && <3
+                     , constraints >=0.8 && <1
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 6ff8b10..ff8ebd4 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,7 +1,7 @@
 { mkDerivation, async, base, binary, bytestring, conduit
-, containers, data-default-class, deepseq, dyre, either, encoding
-, exceptions, extended-reals, filelock, hspec, mmorph
-, monad-control, monad-logger, mtl, network-uri, persistent
+, constraints, containers, data-default-class, deepseq, dyre
+, either, encoding, exceptions, extended-reals, filelock, hspec
+, mmorph, monad-control, monad-logger, mtl, network-uri, persistent
 , persistent-sqlite, persistent-template, QuickCheck
 , quickcheck-instances, resourcet, servant, servant-server, stdenv
 , stm, temporary, text, thermoprint-client, thermoprint-spec, time
@@ -14,12 +14,13 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base binary bytestring conduit containers data-default-class
-    deepseq dyre either encoding exceptions extended-reals filelock
-    mmorph monad-control monad-logger mtl network-uri persistent
-    persistent-template QuickCheck quickcheck-instances resourcet
-    servant servant-server stm text thermoprint-spec time transformers
-    wai wai-websockets warp websockets
+    base binary bytestring conduit constraints containers
+    data-default-class deepseq dyre either encoding exceptions
+    extended-reals filelock mmorph monad-control monad-logger mtl
+    network-uri persistent persistent-template QuickCheck
+    quickcheck-instances resourcet servant servant-server stm text
+    thermoprint-spec time transformers wai wai-websockets warp
+    websockets
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet