@@ -3,20 +3,25 @@
33 , DeriveFunctor
44 , FlexibleContexts
55 , FlexibleInstances
6+ , MultiParamTypeClasses
67 , PolyKinds
8+ , RankNTypes
79 , RecordWildCards
810 , ScopedTypeVariables
911 , TypeApplications
1012 , TypeFamilies
1113 , TypeOperators
14+ , UndecidableInstances
1215#-}
1316
1417module Squeel.PostgreSQL.PQ where
1518
1619import Control.Arrow
20+import Control.Exception.Lifted
21+import Control.Monad.Base
1722import Control.Monad.Indexed
1823import Control.Monad.Indexed.Trans
19−import Control.Monad.IO.Class
24+import Control.Monad.Trans.Control
2025import Data.ByteString (ByteString)
2126import Data.Proxy
2227import Data.Text (Text)
@@ -35,6 +40,12 @@ newtype PQ m db0 db1 x = PQ
3540 { runPQ :: Connection db0 -> m (x, Connection db1) }
3641 deriving Functor
3742
43+evalPQ :: Functor m => PQ m db0 db1 x -> Connection db0 -> m x
44+evalPQ (PQ pq) = fmap fst . pq
45+
46+execPQ :: Functor m => PQ m db0 db1 x -> Connection db0 -> m (Connection db1)
47+execPQ (PQ pq) = fmap snd . pq
48+
3849instance Functor m => IxFunctor (PQ m) where
3950 imap f (PQ g) = PQ $ fmap (first f) . g
4051
@@ -65,33 +76,47 @@ instance IxMonadTrans PQ where
6576 x <- m
6677 return (x, conn)
6778
68−instance MonadIO io => MonadIO (PQ io db db) where
69− liftIO = ilift . liftIO
79+instance MonadBase b m => MonadBase b (PQ m db db) where
80+ liftBase = ilift . liftBase
81+
82+type PQRun db = forall n b. Monad n => PQ n db db b -> n (b, Connection db)
7083
71−connectdb :: MonadIO io => ByteString -> io (Connection db)
72−connectdb = fmap Connection . liftIO . LibPQ.connectdb
84+pqliftWith :: Functor m => (PQRun db -> m a) -> PQ m db db a
85+pqliftWith f = PQ $ \ conn ->
86+ fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
7387
74−connectStart :: MonadIO io => ByteString -> io (Connection db)
75−connectStart = fmap Connection . liftIO . LibPQ.connectStart
88+instance MonadBaseControl b m => MonadBaseControl b (PQ m db db) where
89+ type StM (PQ m db db) x = StM m (x, Connection db)
90+ liftBaseWith f =
91+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
92+ restoreM = PQ . const . restoreM
7693
77−newNullConnection :: MonadIO io => io (Connection db)
78−newNullConnection = Connection <$> liftIO LibPQ.newNullConnection
94+connectdb :: MonadBase IO io => ByteString -> io (Connection db)
95+connectdb = fmap Connection . liftBase . LibPQ.connectdb
7996
80−finish :: MonadIO io => Connection db -> io ()
81−finish = liftIO . LibPQ.finish . unConnection
97+finish :: MonadBase IO io => Connection db -> io ()
98+finish = liftBase . LibPQ.finish . unConnection
99+
100+withConnection
101+ :: MonadBaseControl IO io
102+ => ByteString
103+ -> (Connection db -> io x)
104+ -> io x
105+withConnection connString action =
106+ bracket (connectdb connString) finish action
82107
83108newtype Result xs = Result { unResult :: LibPQ.Result }
84109
85110exec
86− :: MonadIO io
111+ :: MonadBase IO io
87112 => Query db0 db1 '[] xs
88113 -> PQ io db0 db1 (Maybe (Result xs))
89114exec (Query q) = PQ $ \ (Connection conn) -> do
90− result <- liftIO $ LibPQ.exec conn q
115+ result <- liftBase $ LibPQ.exec conn q
91116 return (Result <$> result, Connection conn)
92117
93118execParams
94− :: (MonadIO io, ToValues xs ps, ToOids ps)
119+ :: (MonadBase IO io, ToValues xs ps, ToOids ps)
95120 => Query db0 db1 ps ys
96121 -> Rec Identity xs
97122 -> PQ io db0 db1 (Maybe (Result ys))
@@ -103,22 +128,22 @@ execParams (Query q :: Query db0 db1 ps ys) params =
103128 | (oid, param) <-
104129 zip (toOids (Proxy @ps)) (toValues (Proxy @ps) params)
105130 ]
106− result <- liftIO $ LibPQ.execParams conn q params' LibPQ.Binary
131+ result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
107132 return (Result <$> result, Connection conn)
108133
109134prepare
110− :: (MonadIO io, ToOids ps)
135+ :: (MonadBase IO io, ToOids ps)
111136 => ByteString
112137 -> Query db0 db1 ps xs
113138 -> PQ io db0 db0 (Maybe (Result []), PreparedQuery db0 db1 ps xs)
114139prepare statementName (Query q :: Query db0 db1 ps ys) =
115140 PQ $ \ (Connection conn) -> do
116− result <- liftIO $
141+ result <- liftBase $
117142 LibPQ.prepare conn statementName q (Just (toOids (Proxy @ps)))
118143 return ((Result <$> result,PreparedQuery statementName), Connection conn)
119144
120145execPrepared
121− :: (MonadIO io, ToValues xs ps)
146+ :: (MonadBase IO io, ToValues xs ps)
122147 => PreparedQuery db0 db1 ps ys
123148 -> Rec Identity xs
124149 -> PQ io db0 db1 (Maybe (Result ys))
@@ -127,7 +152,7 @@ execPrepared (PreparedQuery q :: PreparedQuery db0 db1 ps ys) params =
127152 let
128153 params' =
129154 [Just (param, LibPQ.Binary) | param <- toValues (Proxy @ps) params]
130− result <- liftIO $
155+ result <- liftBase $
131156 LibPQ.execPrepared conn q params' LibPQ.Binary
132157 return (Result <$> result, Connection conn)
133158
@@ -151,11 +176,11 @@ colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4
151176colNum4 = ColumnNumber 4
152177
153178getvalue
154− :: (FromValue x y, MonadIO io)
179+ :: (FromValue x y, MonadBase IO io)
155180 => Proxy x
156181 -> Result xs
157182 -> RowNumber
158183 -> ColumnNumber xs x
159184 -> io (Maybe (Either Text y))
160−getvalue proxy (Result result) (RowNumber r) (ColumnNumber c) = liftIO $
185+getvalue proxy (Result result) (RowNumber r) (ColumnNumber c) = liftBase $
161186 fmap (fmap (decodeValue proxy)) (LibPQ.getvalue result r c)