@@ -33,13 +33,13 @@ a `MonadPQ` constraint for running a `Manipulation` or `Query`.
3333
3434module Squeal.PostgreSQL.PQ
3535 ( -- * Connection
36− Connection (Connection, unConnection)
37− , connectdb
36+ connectdb
3837 , finish
3938 , withConnection
4039 -- * PQ
4140 , PQ (PQ, runPQ)
4241 , execPQ
42+ , pqEmbed
4343 , pqAp
4444 , pqBind
4545 , pqJoin
@@ -51,7 +51,6 @@ module Squeal.PostgreSQL.PQ
5151 , PQRun
5252 , pqliftWith
5353 -- * Result
54− , Result (Result, unResult)
5554 , RowNumber (RowNumber, unRowNumber)
5655 , ColumnNumber (UnsafeColumnNumber, getColumnNumber)
5756 , HasColumnNumber (columnNumber)
@@ -62,6 +61,9 @@ module Squeal.PostgreSQL.PQ
6261 , nextRow
6362 , firstRow
6463 , liftResult
64+ -- * Re-export
65+ , LibPQ.Connection
66+ , LibPQ.Result
6567 ) where
6668
6769import Control.Exception.Lifted
@@ -100,11 +102,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict
100102import qualified Control.Monad.Trans.RWS.Lazy as Lazy
101103import qualified Control.Monad.Trans.RWS.Strict as Strict
102104
103−-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`
104−-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`
105−newtype Connection (schema :: TablesType) =
106− Connection { unConnection :: LibPQ.Connection }
107−
108105{- | Makes a new connection to the database server.
109106
110107This function opens a new database connection using the parameters taken
@@ -134,19 +131,19 @@ connectdb
134131 :: forall schema io
135132 . MonadBase IO io
136133 => ByteString -- ^ conninfo
137− -> io (Connection schema)
138−connectdb = fmap Connection . liftBase . LibPQ.connectdb
134+ -> io (K LibPQ.Connection schema)
135+connectdb = fmap K . liftBase . LibPQ.connectdb
139136
140137-- | Closes the connection to the server.
141−finish :: MonadBase IO io => Connection schema -> io ()
142−finish = liftBase . LibPQ.finish . unConnection
138+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()
139+finish = liftBase . LibPQ.finish . unK
143140
144141-- | Do `connectdb` and `finish` before and after a computation.
145142withConnection
146143 :: forall schema0 schema1 io x
147144 . MonadBaseControl IO io
148145 => ByteString
149− -> (Connection schema0 -> io (x, Connection schema1))
146+ -> (K LibPQ.Connection schema0 -> io (x, K LibPQ.Connection schema1))
150147 -> io x
151148withConnection connString action = do
152149 (x, _conn) <- bracket (connectdb connString) finish action
@@ -159,16 +156,28 @@ newtype PQ
159156 (schema1 :: TablesType)
160157 (m :: Type -> Type)
161158 (x :: Type) =
162− PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
163− deriving Functor
159+ PQ { runPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
160+
161+instance Monad m => Functor (PQ schema0 schema1 m) where
162+ fmap f (PQ pq) = PQ $ \ conn -> do
163+ K x <- pq conn
164+ return $ K (f x)
164165
165166-- | Run a `PQ` and discard the result but keep the `Connection`.
166167execPQ
167168 :: Functor m
168169 => PQ schema0 schema1 m x
169− -> Connection schema0
170− -> m (Connection schema1)
171−execPQ (PQ pq) = fmap snd . pq
170+ -> K LibPQ.Connection schema0
171+ -> m (K LibPQ.Connection schema1)
172+execPQ (PQ pq) conn = fmap (mapKK (\ _ -> unK conn)) $ pq conn
173+
174+pqEmbed
175+ :: Monad m
176+ => PQ schema0 schema1 m x
177+ -> PQ (table ': schema0) (table : schema1) m x
178+pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
179+ K x <- pq (K conn)
180+ return $ K x
172181
173182-- | indexed analog of `<*>`
174183pqAp
@@ -177,9 +186,9 @@ pqAp
177186 -> PQ schema1 schema2 m x
178187 -> PQ schema0 schema2 m y
179188pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
180− (f', conn') <- f conn
181− (x', conn'') <- x conn'
182− return (f' x', conn'')
189+ K f' <- f conn
190+ K x' <- x (K (unK conn))
191+ return $ K (f' x')
183192
184193-- | indexed analog of `join`
185194pqJoin
@@ -194,8 +203,8 @@ pqBind
194203 -> PQ schema0 schema1 m x
195204 -> PQ schema0 schema2 m y
196205pqBind f (PQ x) = PQ $ \ conn -> do
197− (x', conn') <- x conn
198− runPQ (f x') conn'
206+ K x' <- x conn
207+ runPQ (f x') (K (unK conn))
199208
200209-- | indexed analog of flipped `>>`
201210pqThen
@@ -211,20 +220,20 @@ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
211220define
212221 :: MonadBase IO io
213222 => Definition schema0 schema1
214− -> PQ schema0 schema1 io (Result '[])
215−define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
223+ -> PQ schema0 schema1 io (K LibPQ.Result '[])
224+define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
216225 resultMaybe <- liftBase $ LibPQ.exec conn q
217226 case resultMaybe of
218227 Nothing -> error
219228 "define: LibPQ.exec returned no results"
220− Just result -> return (Result result, Connection conn)
229+ Just result -> return $ K (K result)
221230
222231-- | Chain together `define` actions.
223232thenDefine
224233 :: MonadBase IO io
225234 => Definition schema1 schema2
226235 -> PQ schema0 schema1 io x
227− -> PQ schema0 schema2 io (Result '[])
236+ -> PQ schema0 schema2 io (K LibPQ.Result '[])
228237thenDefine = pqThen . define
229238
230239{- | `MonadPQ` is an `mtl` style constraint, similar to
@@ -264,41 +273,41 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
264273 :: ToParams x params
265274 => Manipulation schema params ys
266275 -- ^ `insertInto`, `update` or `deleteFrom`
267− -> x -> pq (Result ys)
276+ -> x -> pq (K LibPQ.Result ys)
268277 default manipulateParams
269278 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
270279 => ToParams x params
271280 => Manipulation schema params ys
272281 -- ^ `insertInto`, `update` or `deleteFrom`
273− -> x -> pq (Result ys)
282+ -> x -> pq (K LibPQ.Result ys)
274283 manipulateParams manipulation params = lift $
275284 manipulateParams manipulation params
276285
277− manipulate :: Manipulation schema '[] ys -> pq (Result ys)
286+ manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)
278287 manipulate statement = manipulateParams statement ()
279288
280289 runQueryParams
281290 :: ToParams x params
282291 => Query schema params ys
283292 -- ^ `select` and friends
284− -> x -> pq (Result ys)
293+ -> x -> pq (K LibPQ.Result ys)
285294 runQueryParams = manipulateParams . queryStatement
286295
287296 runQuery
288297 :: Query schema '[] ys
289298 -- ^ `select` and friends
290− -> pq (Result ys)
299+ -> pq (K LibPQ.Result ys)
291300 runQuery q = runQueryParams q ()
292301
293302 traversePrepared
294303 :: (ToParams x params, Traversable list)
295304 => Manipulation schema params ys
296305 -- ^ `insertInto`, `update` or `deleteFrom`
297− -> list x -> pq (list (Result ys))
306+ -> list x -> pq (list (K LibPQ.Result ys))
298307 default traversePrepared
299308 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
300309 => (ToParams x params, Traversable list)
301− => Manipulation schema params ys -> list x -> pq (list (Result ys))
310+ => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))
302311 traversePrepared manipulation params = lift $
303312 traversePrepared manipulation params
304313
@@ -307,7 +316,7 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
307316 => list x
308317 -> Manipulation schema params ys
309318 -- ^ `insertInto`, `update` or `deleteFrom`
310− -> pq (list (Result ys))
319+ -> pq (list (K LibPQ.Result ys))
311320 forPrepared = flip traversePrepared
312321
313322 traversePrepared_
@@ -342,7 +351,7 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
342351
343352 manipulateParams
344353 (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
345− PQ $ \ (Connection conn) -> do
354+ PQ $ \ (K conn) -> do
346355 let
347356 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
348357 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
@@ -350,11 +359,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
350359 case resultMaybe of
351360 Nothing -> error
352361 "manipulateParams: LibPQ.execParams returned no results"
353− Just result -> return (Result result, Connection conn)
362+ Just result -> return $ K (K result)
354363
355364 traversePrepared
356365 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
357− PQ $ \ (Connection conn) -> liftBase $ do
366+ PQ $ \ (K conn) -> liftBase $ do
358367 let temp = "temporary_statement"
359368 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
360369 case prepResultMaybe of
@@ -372,7 +381,7 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
372381 case resultMaybe of
373382 Nothing -> error
374383 "traversePrepared: LibPQ.execParams returned no results"
375− Just result -> return $ Result result
384+ Just result -> return $ K result
376385 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
377386 case deallocResultMaybe of
378387 Nothing -> error
@@ -381,11 +390,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
381390 status <- LibPQ.resultStatus deallocResult
382391 unless (status == LibPQ.CommandOk) . error $
383392 "traversePrepared: DEALLOCATE status " <> show status
384− return (results, Connection conn)
393+ return (K results)
385394
386395 traversePrepared_
387396 (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
388− PQ $ \ (Connection conn) -> liftBase $ do
397+ PQ $ \ (K conn) -> liftBase $ do
389398 let temp = "temporary_statement"
390399 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
391400 case prepResultMaybe of
@@ -412,11 +421,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
412421 status <- LibPQ.resultStatus deallocResult
413422 unless (status == LibPQ.CommandOk) . error $
414423 "traversePrepared: DEALLOCATE status " <> show status
415− return ((), Connection conn)
424+ return (K ())
416425
417− liftPQ pq = PQ $ \ (Connection conn) -> do
426+ liftPQ pq = PQ $ \ (K conn) -> do
418427 y <- liftBase $ pq conn
419− return (y, Connection conn)
428+ return (K y)
420429
421430instance MonadPQ schema m => MonadPQ schema (IdentityT m)
422431instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
@@ -432,7 +441,7 @@ instance MonadPQ schema m => MonadPQ schema (ContT r m)
432441instance MonadPQ schema m => MonadPQ schema (ListT m)
433442
434443instance Monad m => Applicative (PQ schema schema m) where
435− pure x = PQ $ \ conn -> pure (x, conn)
444+ pure x = PQ $ \ _conn -> pure (K x)
436445 (<*>) = pqAp
437446
438447instance Monad m => Monad (PQ schema schema m) where
@@ -440,34 +449,28 @@ instance Monad m => Monad (PQ schema schema m) where
440449 (>>=) = flip pqBind
441450
442451instance MonadTrans (PQ schema schema) where
443− lift m = PQ $ \ conn -> do
452+ lift m = PQ $ \ _conn -> do
444453 x <- m
445− return (x, conn)
454+ return (K x)
446455
447456instance MonadBase b m => MonadBase b (PQ schema schema m) where
448457 liftBase = lift . liftBase
449458
450459-- | A snapshot of the state of a `PQ` computation.
451460type PQRun schema =
452− forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
461+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)
453462
454463-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
455464pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
456465pqliftWith f = PQ $ \ conn ->
457− fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
466+ fmap K (f $ \ pq -> runPQ pq conn)
458467
459468instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
460− type StM (PQ schema schema m) x = StM m (x, Connection schema)
469+ type StM (PQ schema schema m) x = StM m (K x schema)
461470 liftBaseWith f =
462471 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
463472 restoreM = PQ . const . restoreM
464473
465−-- | Encapsulates the result of a squeal command run by @LibPQ@.
466−-- `Result`s are parameterized by a `ColumnsType` describing the column names
467−-- and their types.
468−newtype Result (columns :: RelationType)
469− = Result { unResult :: LibPQ.Result }
470−
471474-- | Just newtypes around a `CInt`
472475newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
473476
@@ -494,12 +497,12 @@ getValue
494497 :: (FromColumnValue colty y, MonadBase IO io)
495498 => RowNumber -- ^ row
496499 -> ColumnNumber n columns colty -- ^ col
497− -> Result columns -- ^ result
500+ -> K LibPQ.Result columns -- ^ result
498501 -> io y
499502getValue
500503 (RowNumber r)
501504 (UnsafeColumnNumber c :: ColumnNumber n columns colty)
502− (Result result)
505+ (K result)
503506 = fmap (fromColumnValue @colty . K) $ liftBase $ do
504507 numRows <- LibPQ.ntuples result
505508 when (numRows < r) $ error $
@@ -512,10 +515,10 @@ getRow
512515 :: (FromRow columns y, MonadBase IO io)
513516 => RowNumber
514517 -- ^ row
515− -> Result columns
518+ -> K LibPQ.Result columns
516519 -- ^ result
517520 -> io y
518−getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do
521+getRow (RowNumber r) (K result :: K LibPQ.Result columns) = liftBase $ do
519522 numRows <- LibPQ.ntuples result
520523 when (numRows < r) $ error $
521524 "getRow: expected at least " <> show r <> "rows but only saw "
@@ -527,8 +530,8 @@ getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do
527530 Just row -> return $ fromRow @columns row
528531
529532-- | Returns the number of rows (tuples) in the query result.
530−ntuples :: MonadBase IO io => Result columns -> io RowNumber
531−ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result
533+ntuples :: MonadBase IO io => K LibPQ.Result columns -> io RowNumber
534+ntuples (K result) = liftBase $ RowNumber <$> LibPQ.ntuples result
532535
533536-- | Intended to be used for unfolding in streaming libraries, `nextRow`
534537-- takes a total number of rows (which can be found with `ntuples`)
@@ -537,10 +540,10 @@ ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result
537540nextRow
538541 :: (FromRow columns y, MonadBase IO io)
539542 => RowNumber -- ^ total number of rows
540− -> Result columns -- ^ result
543+ -> K LibPQ.Result columns -- ^ result
541544 -> RowNumber -- ^ row number
542545 -> io (Maybe (RowNumber,y))
543−nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
546+nextRow (RowNumber total) (K result :: K LibPQ.Result columns) (RowNumber r)
544547 = liftBase $ if r >= total then return Nothing else do
545548 let len = fromIntegral (lengthSList (Proxy @columns))
546549 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
@@ -551,9 +554,9 @@ nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
551554-- | Get all rows from a `Result`.
552555getRows
553556 :: (FromRow columns y, MonadBase IO io)
554− => Result columns -- ^ result
557+ => K LibPQ.Result columns -- ^ result
555558 -> io [y]
556−getRows (Result result :: Result columns) = liftBase $ do
559+getRows (K result :: K LibPQ.Result columns) = liftBase $ do
557560 let len = fromIntegral (lengthSList (Proxy @columns))
558561 numRows <- LibPQ.ntuples result
559562 for [0 .. numRows - 1] $ \ r -> do
@@ -565,9 +568,9 @@ getRows (Result result :: Result columns) = liftBase $ do
565568-- | Get the first row if possible from a `Result`.
566569firstRow
567570 :: (FromRow columns y, MonadBase IO io)
568− => Result columns -- ^ result
571+ => K LibPQ.Result columns -- ^ result
569572 -> io (Maybe y)
570−firstRow (Result result :: Result columns) = liftBase $ do
573+firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
571574 numRows <- LibPQ.ntuples result
572575 if numRows <= 0 then return Nothing else do
573576 let len = fromIntegral (lengthSList (Proxy @columns))
@@ -580,5 +583,5 @@ firstRow (Result result :: Result columns) = liftBase $ do
580583liftResult
581584 :: MonadBase IO io
582585 => (LibPQ.Result -> IO x)
583− -> Result results -> io x
584−liftResult f (Result result) = liftBase $ f result
586+ -> K LibPQ.Result results -> io x
587+liftResult f (K result) = liftBase $ f result