@@ -0,0 +1,61 @@
1+{-# LANGUAGE
2+ DeriveFunctor
3+ , FlexibleContexts
4+ , FlexibleInstances
5+ , MultiParamTypeClasses
6+ , ScopedTypeVariables
7+ , UndecidableInstances
8+#-}
9+
10+module Squeal.PostgreSQL.Pool where
11+
12+import Control.Monad.Base
13+import Control.Monad.Trans
14+import Control.Monad.Trans.Control
15+import Data.Pool
16+
17+import Squeal.PostgreSQL.PQ
18+
19+newtype PoolPQ schema m x = PoolPQ { runPoolPQ :: Pool (Connection schema) -> m x }
20+ deriving Functor
21+
22+instance Monad m => Applicative (PoolPQ schema m) where
23+ pure x = PoolPQ $ \ _ -> pure x
24+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
25+ f' <- f pool
26+ x' <- x pool
27+ return $ f' x'
28+
29+instance Monad m => Monad (PoolPQ schema m) where
30+ return = pure
31+ PoolPQ x >>= f = PoolPQ $ \ pool -> do
32+ x' <- x pool
33+ runPoolPQ (f x') pool
34+
35+instance MonadTrans (PoolPQ schema) where
36+ lift m = PoolPQ $ \ _pool -> m
37+
38+instance MonadBase b m => MonadBase b (PoolPQ schema m) where
39+ liftBase = lift . liftBase
40+
41+instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
42+ manipulateParams manipulation params = PoolPQ $ \ pool -> do
43+ withResource pool $ \ conn -> do
44+ (result, _ :: Connection schema) <- flip runPQ conn $
45+ manipulateParams manipulation params
46+ return result
47+ traversePrepared manipulation params = PoolPQ $ \ pool ->
48+ withResource pool $ \ conn -> do
49+ (result, _ :: Connection schema) <- flip runPQ conn $
50+ traversePrepared manipulation params
51+ return result
52+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
53+ withResource pool $ \ conn -> do
54+ (_, _ :: Connection schema) <- flip runPQ conn $
55+ traversePrepared_ manipulation params
56+ return ()
57+ liftPQ m = PoolPQ $ \ pool ->
58+ withResource pool $ \ conn -> do
59+ (result, _ :: Connection schema) <- flip runPQ conn $
60+ liftPQ m
61+ return result