dirty-haskell.org: Building an Extensible Framework for Specifying Compile-Time Configuration using Universal Quantification

It's not crazy — it's having fun with types.

When I write Universal Quantification I mean what is commonly referred to as existential quantification, which I think is a misnomer. To wit:

( \exists x \ldotp f(x) ) \to y is isomorphic to \forall x \ldotp (f(x) \to y) (I won´t try to back this claim up with actual category theory just now. You might want to nag me occasionally if this bothers you – I really should invest some more time into category theory). Since haskell does not support exists we´re required to use the forall-version, which really is universally quantified.

Printer Configuration

What we want is to have the user provide us with a set of specifications of how to interact with one printer each. Something like the following:

newtype PrinterMethod = PM { unPM :: Printout -> IO (Maybe PrintingError) }

data Printer = Printer
  { print :: PrinterMethod
  , queue :: TVar Queue
  }

The first step in refining this is necessitated by having the user provide the monad-transformer-stack to use at compile time. Thus we introduce our first universal quantification (in conjunction with polymorphic components) – this one is not isomorphic to an existential one:

newtype PrinterMethod = PM { unPm :: forall m. MonadResource m => Printout -> m (Maybe PrintingError) }

Since we don´t want to burden the user with the details of setting up TVar Queue we also introduce function to help with that:

printer :: MonadResource m => PrinterMethod -> m Printer
printer p = Printer p <$> liftIO (newTVarIO def)

We could at this point provide ways to set up PrinterMethods and have the user provide us with a list of them.

We, however, have numerous examples of printers which require some setup (such opening a file descriptor). The idiomatic way to handle this is to decorate that setup with some constraints and construct our list of printers in an Applicative fashion:

printer :: MonadResource m => m PrinterMethod -> m Printer
printer p = Printer <$> p <*> liftIO (newTVarIO def)

At this point a toy implementation of a printer we might provide looks like this:

debugPrint :: Applicative m => m PrinterMethod
debugPrint = pure . PM $ const return Nothing <=< liftIO . putStrLn . toString

toString :: Printout -> String
toString = undefined

Management of Printer Queues

We would like the user to be able to modify the printer queues we maintain in arbitrary ways. The motivation for this being various cleanup operations such as pruning all successful jobs older than a few minutes or limiting the size of history to an arbitrary number of entries.

A pattern for this type of modification of a value residing in a TVar might look like this:

modify :: TVar a -> StateT a STM () -> IO ()
modify q f = atomically $ writeTVar =<< runStateT f =<< readTVar q

A rather natural extension of this is to allow what we will henceforth call a QueueManager (currently StateT a STM ()) to return an indication of when it wants to be run again:

type QueueManager = StateT Queue STM Micro

runQM :: QueueManager -> TVar Queue -> IO ()
runQM qm q = sleep << qm'
  where
    qm' = atomically $ (\(a, s) -> a <$ writeTVar q s) =<< runStateT qm =<< readTVar q
	sleep (abs -> delay) = threadDelay (fromEnum delay) >> runQM qm q

It stands to reason that sometimes we don’t want to run the QueueManager ever again (probably causing the thread running it to terminate). For doing so we extend the real numbers as represented by Micro to Extended Micro:

type QueueManager = StateT Queue STM (Extended Micro)

runQM …
  where
    …
    sleep (abs -> delay)
      | (Finite d) <- delay = threadDelay (fromEnum d) >> runQM qm q
      | otherwise           = return ()

QueueManagers whose type effectively is Queue -> STM (Queue, Extended Micro) are certainly useful but can carry no state between invocations (which would be useful e.g. for limiting the rate at which we prune jobs).

Therefore we allow the user to provide an arbitrary monad functor (we use MFunctor from mmorph instead of Servant.Server.Internal.Enter because servant-server doesn’t provide all the tools we require for this) which can carry all the state we could ever want:

type QueueManager t = QueueManagerM t (Extended Micro)
type QueueManagerM t = ComposeT (StateT Queue) t STM -- 'ComposeT' is required since we need 'QueueManagerM' to have the form 't' STM' for some 't'' in order to be able to use 'lift'

runQM :: (MFunctor t, MonadTrans t, MonadIO (t IO), Monad (t STM)) => QueueManager t -> TVar Queue -> t IO ()
runQM … -- nearly identical except for a sprinkling of 'lift'

The final touches are to introduce a typeclass HasQueue for convenience:

class HasQueue a where
  extractQueue :: a -> TVar Queue

instance HasQueue (TVar Queue) where
  extractQueue = id

instance HasQueue Printer where
  extractQueue = queue

and provide some utility functions for composing QueueManagers:

intersection :: (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t
-- ^ Combine two 'QueueManager's keeping only 'QueueEntry's both managers decide to keep
--
-- Side effects propagate left to right

idQM :: Monad (QueueManagerM t) => QueueManager t
-- ^ Identity of 'intersect'

union :: (Foldable f, MonadState Queue (QueueManagerM t)) => f (QueueManager t) -> QueueManager t
-- ^ Combine two 'QueueManager's keeping all 'QueueEntry's either of the managers decides to keep
--
-- Side effects propagate left to right

nullQM :: MonadState Queue (QueueManagerM t) => QueueManager t
-- ^ Identity of 'union'

We merge the effects of two QueueManagers by converting the resulting Queues to Sets and using Set.union and Set.intersection with appropriate Ord and Eq instances.

Configuration of QueueManagers

A QueueManagers configuration shall be a QueueManager t associated with a specification of how to collapse its monad transformer t. Using universal quantification this is straightforward:

data QMConfig m = forall t. ( MonadTrans t
                            , MFunctor t
                            , Monad (t STM)
                            , MonadIO (t IO)
                            ) => QMConfig { manager  :: QueueManager t
                                          , collapse :: (t IO) :~> m
                                          }
										  
runQM' :: Printer -> QMConfig m -> m ()
runQM' printer (QMConfig qm nat) = unNat nat $ runQM qm printer