@@ -36,17 +36,13 @@ module Squeal.PostgreSQL.PQ
3636 connectdb
3737 , finish
3838 , withConnection
39+ , lowerConnection
3940 -- * PQ
40− , PQ (PQ, runPQ)
41+ , PQ (PQ, unPQ)
42+ , runPQ
4143 , execPQ
42− , pqEmbed
43− , pqAp
44− , pqBind
45− , pqJoin
46− , pqThen
47− , define
48− , thenDefine
49− -- * MonadPQ
44+ , evalPQ
45+ , IndexedMonadTransPQ (..)
5046 , MonadPQ (..)
5147 , PQRun
5248 , pqliftWith
@@ -149,9 +145,15 @@ withConnection
149145 -> PQ schema0 schema1 io x
150146 -> io x
151147withConnection connString action = do
152− K x <- bracket (connectdb connString) finish (runPQ action)
148+ K x <- bracket (connectdb connString) finish (unPQ action)
153149 return x
154150
151+-- | Safely `lowerConnection` to a smaller schema.
152+lowerConnection
153+ :: K LibPQ.Connection (table ': schema)
154+ -> K LibPQ.Connection schema
155+lowerConnection (K conn) = K conn
156+
155157-- | We keep track of the schema via an Atkey indexed state monad transformer,
156158-- `PQ`.
157159newtype PQ
@@ -159,87 +161,113 @@ newtype PQ
159161 (schema1 :: TablesType)
160162 (m :: Type -> Type)
161163 (x :: Type) =
162− PQ { runPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
164+ PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
163165
164166instance Monad m => Functor (PQ schema0 schema1 m) where
165167 fmap f (PQ pq) = PQ $ \ conn -> do
166168 K x <- pq conn
167169 return $ K (f x)
168170
169−-- | Run a `PQ` and discard the result but keep the `Connection`.
171+-- | Run a `PQ` and keep the result and the `Connection`.
172+runPQ
173+ :: Functor m
174+ => PQ schema0 schema1 m x
175+ -> K LibPQ.Connection schema0
176+ -> m (x, K LibPQ.Connection schema1)
177+runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
178+ -- K x <- pq conn
179+ -- return (x, K (unK conn))
180+
181+-- | Execute a `PQ` and discard the result but keep the `Connection`.
170182execPQ
171183 :: Functor m
172184 => PQ schema0 schema1 m x
173185 -> K LibPQ.Connection schema0
174186 -> m (K LibPQ.Connection schema1)
175−execPQ (PQ pq) conn = fmap (mapKK (\ _ -> unK conn)) $ pq conn
187+execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
176188
177−-- | Safely embed a `PQ` computation in a larger schema.
178−pqEmbed
179− :: Monad m
189+-- | Evaluate a `PQ` and discard the `Connection` but keep the result.
190+evalPQ
191+ :: Functor m
180192 => PQ schema0 schema1 m x
181− -> PQ (table ': schema0) (table : schema1) m x
182−pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
183− K x <- pq (K conn)
184− return $ K x
185−
186−-- | indexed analog of `<*>`
187−pqAp
188− :: Monad m
189− => PQ schema0 schema1 m (x -> y)
190− -> PQ schema1 schema2 m x
191− -> PQ schema0 schema2 m y
192−pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
193− K f' <- f conn
194− K x' <- x (K (unK conn))
195− return $ K (f' x')
196−
197−-- | indexed analog of `join`
198−pqJoin
199− :: Monad m
200− => PQ schema0 schema1 m (PQ schema1 schema2 m y)
201− -> PQ schema0 schema2 m y
202−pqJoin pq = pq & pqBind id
203−
204−-- | indexed analog of `=<<`
205−pqBind
206− :: Monad m
207− => (x -> PQ schema1 schema2 m y)
208− -> PQ schema0 schema1 m x
209− -> PQ schema0 schema2 m y
210−pqBind f (PQ x) = PQ $ \ conn -> do
211− K x' <- x conn
212− runPQ (f x') (K (unK conn))
213−
214−-- | indexed analog of flipped `>>`
215−pqThen
216− :: Monad m
217− => PQ schema1 schema2 m y
218− -> PQ schema0 schema1 m x
219− -> PQ schema0 schema2 m y
220−pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
221−
222−-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
223−--
224−-- @define statement1 & thenDefine statement2 = define (statement1 >>> statement2)@
225−define
226− :: MonadBase IO io
227− => Definition schema0 schema1
228− -> PQ schema0 schema1 io (K LibPQ.Result '[])
229−define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
230− resultMaybe <- liftBase $ LibPQ.exec conn q
231− case resultMaybe of
232− Nothing -> error
233− "define: LibPQ.exec returned no results"
234− Just result -> return $ K (K result)
235−
236−-- | Chain together `define` actions.
237−thenDefine
238− :: MonadBase IO io
239− => Definition schema1 schema2
240− -> PQ schema0 schema1 io x
241− -> PQ schema0 schema2 io (K LibPQ.Result '[])
242−thenDefine = pqThen . define
193+ -> K LibPQ.Connection schema0
194+ -> m x
195+evalPQ (PQ pq) conn = unK <$> pq conn
196+
197+-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`
198+-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
199+-- An indexed monad transformer transforms a `Monad` into an indexed monad.
200+-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
201+-- support running `Definition`s using `define` and embedding a computation
202+-- in a larger schema using `pqEmbed`.
203+class IndexedMonadTransPQ pq where
204+
205+ -- | Safely embed a computation in a larger schema.
206+ pqEmbed
207+ :: Monad m
208+ => pq schema0 schema1 m x
209+ -> pq (table ': schema0) (table : schema1) m x
210+
211+ -- | indexed analog of `<*>`
212+ pqAp
213+ :: Monad m
214+ => pq schema0 schema1 m (x -> y)
215+ -> pq schema1 schema2 m x
216+ -> pq schema0 schema2 m y
217+
218+ -- | indexed analog of `join`
219+ pqJoin
220+ :: Monad m
221+ => pq schema0 schema1 m (pq schema1 schema2 m y)
222+ -> pq schema0 schema2 m y
223+
224+ -- | indexed analog of `=<<`
225+ pqBind
226+ :: Monad m
227+ => (x -> pq schema1 schema2 m y)
228+ -> pq schema0 schema1 m x
229+ -> pq schema0 schema2 m y
230+
231+ -- | indexed analog of flipped `>>`
232+ pqThen
233+ :: Monad m
234+ => pq schema1 schema2 m y
235+ -> pq schema0 schema1 m x
236+ -> pq schema0 schema2 m y
237+
238+ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
239+ --
240+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
241+ define
242+ :: MonadBase IO io
243+ => Definition schema0 schema1
244+ -> pq schema0 schema1 io (K LibPQ.Result '[])
245+
246+instance IndexedMonadTransPQ PQ where
247+
248+ pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
249+ K x <- pq (K conn)
250+ return $ K x
251+
252+ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
253+ K f' <- f conn
254+ K x' <- x (K (unK conn))
255+ return $ K (f' x')
256+
257+ pqJoin pq = pq & pqBind id
258+
259+ pqBind f (PQ x) = PQ $ \ conn -> do
260+ K x' <- x conn
261+ unPQ (f x') (K (unK conn))
262+
263+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
264+
265+ define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
266+ resultMaybe <- liftBase $ LibPQ.exec conn q
267+ case resultMaybe of
268+ Nothing -> error
269+ "define: LibPQ.exec returned no results"
270+ Just result -> return $ K (K result)
243271
244272{- | `MonadPQ` is an `mtl` style constraint, similar to
245273`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
@@ -468,7 +496,7 @@ type PQRun schema =
468496-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
469497pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
470498pqliftWith f = PQ $ \ conn ->
471− fmap K (f $ \ pq -> runPQ pq conn)
499+ fmap K (f $ \ pq -> unPQ pq conn)
472500
473501instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
474502 type StM (PQ schema schema m) x = StM m (K x schema)