Revert work on QMConfig & associated tools

This reverts commit f64e26726ce5468069093aa86fe973ad4be4816c.

5 files changed, 27 insertions, 150 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
diff --git a/server/src/Thermoprint/Server/QMConfig.hs b/server/src/Thermoprint/Server/QMConfig.hs
deleted file mode 100644
index 7255c8c..0000000
--- a/server/src/Thermoprint/Server/QMConfig.hs
+++ /dev/null
@@ -1,129 +0,0 @@
-{-# LANGUAGE GADTs              #-}
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-{-# LANGUAGE TypeOperators      #-}
-{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE ViewPatterns       #-}
-{-# LANGUAGE ConstraintKinds    #-}
-{-# LANGUAGE MultiParamTypeClasses       #-}
-{-# LANGUAGE KindSignatures       #-}
-{-# LANGUAGE FlexibleInstances       #-}
-{-# LANGUAGE UndecidableInstances       #-}
-{-# LANGUAGE IncoherentInstances       #-}
-
-module Thermoprint.Server.QMConfig
-       ( QMConfig(..)
-       , nullQM
-       , idQM
-       , standardSleep
-       , limitHistorySize
-       , limitHistoryAge
-       ) 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.Monad.Trans.Compose
-import Control.Monad.State
-import Control.Category
-import Servant.Server.Internal.Enter
-
-import Data.Constraint
-import Data.Constraint.Forall
-
-import Data.Default.Class
-
-import           Data.Sequence (Seq)
-import qualified Data.Sequence as Seq
-import Data.Time
-import Data.Foldable
-
-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, (.))
-
-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 :: Foldable f => f QMConfig -> QMConfig
-intersection = foldr' (qmCombine Q.intersection) idQM
-
-idQM :: QMConfig
-idQM = QMConfig' Q.idQM
-
-union :: Foldable f => f QMConfig -> QMConfig
-union = foldr' (qmCombine Q.union) idQM
-  
-nullQM :: QMConfig
-nullQM = QMConfig' Q.nullQM
-
-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
-    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
---
--- /TODO/: Investigate implementing a smarter algorithm (PID-controller)
-standardSleep = return $ 20
-
-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 :: 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
-    limitAge :: Queue -> Queue
-    limitAge q@Queue{..} = q { history = Seq.filter (filterAge . created . fst) history}
-      where
-        youngest :: UTCTime
-        youngest = maximum $ created . fst <$> history
-        filterAge :: UTCTime -> Bool
-        filterAge time = not $ (youngest `diffUTCTime` time) > maxAge
diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs
index 6407c3c..028ba2d 100644
--- a/server/test/Thermoprint/ServerSpec.hs
+++ b/server/test/Thermoprint/ServerSpec.hs
@@ -13,8 +13,7 @@ import qualified Test.Hspec as Hspec
 import           Test.QuickCheck
 
 import           Thermoprint.API
-import qualified Thermoprint.Server as S hiding (intersection, idQM, union, nullQM)
-import qualified Thermoprint.Server.Queue as S
+import qualified Thermoprint.Server as S
 import           Thermoprint.Client
 
 import           Data.Monoid
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 0a5690e..3f0f832 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -18,7 +18,6 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     Thermoprint.Server
-                     , Thermoprint.Server.QMConfig
                      , Thermoprint.Server.Fork
                      , Thermoprint.Server.Database
                      , Thermoprint.Server.API
@@ -66,7 +65,6 @@ 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 ff8ebd4..6ff8b10 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,7 +1,7 @@
 { mkDerivation, async, base, binary, bytestring, conduit
-, constraints, containers, data-default-class, deepseq, dyre
-, either, encoding, exceptions, extended-reals, filelock, hspec
-, mmorph, monad-control, monad-logger, mtl, network-uri, persistent
+, 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,13 +14,12 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    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
+    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
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet