@@ -1,26 +1,22 @@
11{-# LANGUAGE
2− DataKinds
3− , DeriveFunctor
2+ DeriveFunctor
43 , FlexibleContexts
54 , FlexibleInstances
65 , MultiParamTypeClasses
7− , PolyKinds
86 , RankNTypes
9− , RecordWildCards
107 , ScopedTypeVariables
118 , TypeApplications
129 , TypeFamilies
10+ , TypeInType
1311 , TypeOperators
1412 , UndecidableInstances
1513#-}
1614
1715module Squeel.PostgreSQL.PQ where
1816
19−import Control.Arrow
2017import Control.Exception.Lifted
2118import Control.Monad.Base
22−import Control.Monad.Indexed
23−import Control.Monad.Indexed.Trans
19+import Control.Monad.Trans
2420import Control.Monad.Trans.Control
2521import Data.ByteString (ByteString)
2622import Data.Proxy
@@ -36,57 +32,118 @@ import Squeel.PostgreSQL.Type
3632
3733newtype Connection db = Connection { unConnection :: LibPQ.Connection }
3834
39−newtype PQ m db0 db1 x = PQ
35+newtype PQ (db0 :: [Table]) (db1 :: [Table]) m x = PQ
4036 { runPQ :: Connection db0 -> m (x, Connection db1) }
4137 deriving Functor
4238
43−evalPQ :: Functor m => PQ m db0 db1 x -> Connection db0 -> m x
39+evalPQ :: Functor m => PQ db0 db1 m x -> Connection db0 -> m x
4440evalPQ (PQ pq) = fmap fst . pq
4541
46−execPQ :: Functor m => PQ m db0 db1 x -> Connection db0 -> m (Connection db1)
42+execPQ :: Functor m => PQ db0 db1 m x -> Connection db0 -> m (Connection db1)
4743execPQ (PQ pq) = fmap snd . pq
4844
49−instance Functor m => IxFunctor (PQ m) where
50− imap f (PQ g) = PQ $ fmap (first f) . g
51−
52−instance Applicative m => IxPointed (PQ m) where
53− ireturn x = PQ $ \ conn -> pure (x, conn)
54−
55−instance Monad m => IxApplicative (PQ m) where
56− iap (PQ f) (PQ x) = PQ $ \ conn -> do
45+class MonadPQ pq where
46+
47+ pqAp
48+ :: Monad m
49+ => pq db0 db1 m (x -> y)
50+ -> pq db1 db2 m x
51+ -> pq db0 db2 m y
52+
53+ pqBind
54+ :: Monad m
55+ => (x -> pq db1 db2 m y)
56+ -> pq db0 db1 m x
57+ -> pq db0 db2 m y
58+
59+ pqExec
60+ :: MonadBase IO io
61+ => Query db0 db1 '[] xs
62+ -> pq db0 db1 io (Maybe (Result xs))
63+
64+ pqExecParams
65+ :: (MonadBase IO io, ToValues xs ps, ToOids ps)
66+ => Query db0 db1 ps ys
67+ -> Rec Identity xs
68+ -> pq db0 db1 io (Maybe (Result ys))
69+
70+ pqPrepare
71+ :: (MonadBase IO io, ToOids ps)
72+ => ByteString
73+ -> Query db0 db1 ps xs
74+ -> pq db0 db1 io (Maybe (Result []), PreparedQuery db0 db1 ps xs)
75+
76+ pqExecPrepared
77+ :: (MonadBase IO io, ToValues xs ps)
78+ => PreparedQuery db0 db1 ps ys
79+ -> Rec Identity xs
80+ -> pq db0 db1 io (Maybe (Result ys))
81+
82+instance MonadPQ PQ where
83+
84+ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
5785 (f', conn') <- f conn
5886 (x', conn'') <- x conn'
5987 return (f' x', conn'')
6088
61−instance Monad m => Applicative (PQ m db db) where
62− pure = ireturn
63− (<*>) = iap
64−
65−instance Monad m => IxMonad (PQ m) where
66− ibind f (PQ x) = PQ $ \ conn -> do
89+ pqBind f (PQ x) = PQ $ \ conn -> do
6790 (x', conn') <- x conn
6891 runPQ (f x') conn'
6992
70−instance Monad m => Monad (PQ m db db) where
71− return = ireturn
72− (>>=) = flip ibind
93+ pqExec (Query q) = PQ $ \ (Connection conn) -> do
94+ result <- liftBase $ LibPQ.exec conn q
95+ return (Result <$> result, Connection conn)
7396
74−instance IxMonadTrans PQ where
75− ilift m = PQ $ \ conn -> do
97+ pqExecParams (Query q :: Query db0 db1 ps ys) params =
98+ PQ $ \ (Connection conn) -> do
99+ let
100+ params' =
101+ [ Just (oid, param, LibPQ.Binary)
102+ | (oid, param) <-
103+ zip (toOids (Proxy @ps)) (toValues (Proxy @ps) params)
104+ ]
105+ result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
106+ return (Result <$> result, Connection conn)
107+
108+ pqPrepare statementName (Query q :: Query db0 db1 ps ys) =
109+ PQ $ \ (Connection conn) -> do
110+ result <- liftBase $
111+ LibPQ.prepare conn statementName q (Just (toOids (Proxy @ps)))
112+ return ((Result <$> result,PreparedQuery statementName), Connection conn)
113+
114+ pqExecPrepared (PreparedQuery q :: PreparedQuery db0 db1 ps ys) params =
115+ PQ $ \ (Connection conn) -> do
116+ let
117+ params' =
118+ [Just (param, LibPQ.Binary) | param <- toValues (Proxy @ps) params]
119+ result <- liftBase $
120+ LibPQ.execPrepared conn q params' LibPQ.Binary
121+ return (Result <$> result, Connection conn)
122+
123+instance Monad m => Applicative (PQ db db m) where
124+ pure x = PQ $ \ conn -> pure (x, conn)
125+ (<*>) = pqAp
126+
127+instance Monad m => Monad (PQ db db m) where
128+ return = pure
129+ (>>=) = flip pqBind
130+
131+instance MonadTrans (PQ db db) where
132+ lift m = PQ $ \ conn -> do
76133 x <- m
77134 return (x, conn)
78135
79−instance MonadBase b m => MonadBase b (PQ m db db) where
80− liftBase = ilift . liftBase
136+instance MonadBase b m => MonadBase b (PQ db db m) where
137+ liftBase = lift . liftBase
81138
82−type PQRun db = forall m x. Monad m => PQ m db db x -> m (x, Connection db)
139+type PQRun db = forall m x. Monad m => PQ db db m x -> m (x, Connection db)
83140
84−pqliftWith :: Functor m => (PQRun db -> m a) -> PQ m db db a
141+pqliftWith :: Functor m => (PQRun db -> m a) -> PQ db db m a
85142pqliftWith f = PQ $ \ conn ->
86143 fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
87144
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)
145+instance MonadBaseControl b m => MonadBaseControl b (PQ db db m) where
146+ type StM (PQ db db m) x = StM m (x, Connection db)
90147 liftBaseWith f =
91148 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
92149 restoreM = PQ . const . restoreM
@@ -107,55 +164,6 @@ withConnection connString action =
107164
108165newtype Result xs = Result { unResult :: LibPQ.Result }
109166
110−exec
111− :: MonadBase IO io
112− => Query db0 db1 '[] xs
113− -> PQ io db0 db1 (Maybe (Result xs))
114−exec (Query q) = PQ $ \ (Connection conn) -> do
115− result <- liftBase $ LibPQ.exec conn q
116− return (Result <$> result, Connection conn)
117−
118−execParams
119− :: (MonadBase IO io, ToValues xs ps, ToOids ps)
120− => Query db0 db1 ps ys
121− -> Rec Identity xs
122− -> PQ io db0 db1 (Maybe (Result ys))
123−execParams (Query q :: Query db0 db1 ps ys) params =
124− PQ $ \ (Connection conn) -> do
125− let
126− params' =
127− [ Just (oid, param, LibPQ.Binary)
128− | (oid, param) <-
129− zip (toOids (Proxy @ps)) (toValues (Proxy @ps) params)
130− ]
131− result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
132− return (Result <$> result, Connection conn)
133−
134−prepare
135− :: (MonadBase IO io, ToOids ps)
136− => ByteString
137− -> Query db0 db1 ps xs
138− -> PQ io db0 db0 (Maybe (Result []), PreparedQuery db0 db1 ps xs)
139−prepare statementName (Query q :: Query db0 db1 ps ys) =
140− PQ $ \ (Connection conn) -> do
141− result <- liftBase $
142− LibPQ.prepare conn statementName q (Just (toOids (Proxy @ps)))
143− return ((Result <$> result,PreparedQuery statementName), Connection conn)
144−
145−execPrepared
146− :: (MonadBase IO io, ToValues xs ps)
147− => PreparedQuery db0 db1 ps ys
148− -> Rec Identity xs
149− -> PQ io db0 db1 (Maybe (Result ys))
150−execPrepared (PreparedQuery q :: PreparedQuery db0 db1 ps ys) params =
151− PQ $ \ (Connection conn) -> do
152− let
153− params' =
154− [Just (param, LibPQ.Binary) | param <- toValues (Proxy @ps) params]
155− result <- liftBase $
156− LibPQ.execPrepared conn q params' LibPQ.Binary
157− return (Result <$> result, Connection conn)
158−
159167newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
160168
161169newtype ColumnNumber cs c = ColumnNumber { unColumnNumber :: LibPQ.Column }