@@ -3,7 +3,9 @@
33 , FlexibleContexts
44 , FlexibleInstances
55 , MultiParamTypeClasses
6+ , RankNTypes
67 , ScopedTypeVariables
8+ , TypeFamilies
79 , UndecidableInstances
810#-}
911
@@ -59,3 +61,18 @@ instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
5961 (result, _ :: Connection schema) <- flip runPQ conn $
6062 liftPQ m
6163 return result
64+
65+-- | A snapshot of the state of a `PoolPQ` computation.
66+type PoolPQRun schema =
67+ forall m x. Monad m => PoolPQ schema m x -> m x
68+
69+-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.
70+poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a
71+poolpqliftWith f = PoolPQ $ \ pool ->
72+ (f $ \ pq -> runPoolPQ pq pool)
73+
74+instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where
75+ type StM (PoolPQ schema m) x = StM m x
76+ liftBaseWith f =
77+ poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
78+ restoreM = PoolPQ . const . restoreM