@@ -9,6 +9,7 @@
99 , FlexibleInstances
1010 , MagicHash
1111 , MultiParamTypeClasses
12+ , OverloadedStrings
1213 , RankNTypes
1314 , ScopedTypeVariables
1415 , TypeApplications
@@ -24,7 +25,10 @@ import Control.Monad.Base
2425import Control.Monad.Except
2526import Control.Monad.Trans.Control
2627import Data.ByteString (ByteString)
28+import Data.Foldable
2729import Data.Function ((&))
30+import Data.Monoid
31+import Data.Traversable
2832import Generics.SOP
2933import GHC.Exts hiding (fromList)
3034import GHC.TypeLits
@@ -43,18 +47,18 @@ newtype PQ
4347 (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
4448 (m :: * -> *)
4549 (x :: *) =
46− PQ { unPQ :: Connection schema0 -> m (x, Connection schema1) }
50+ PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
4751 deriving Functor
4852
49−evalPQ :: Functor m => Connection schema0 -> PQ schema0 schema1 m x -> m x
50−evalPQ conn (PQ pq) = fmap fst $ pq conn
53+evalPQ :: Functor m => PQ schema0 schema1 m x -> Connection schema0 -> m x
54+evalPQ (PQ pq) = fmap fst . pq
5155
52−runPQ
56+execPQ
5357 :: Functor m
54− => Connection schema0
55− -> PQ schema0 schema1 m x
58+ => PQ schema0 schema1 m x
59+ -> Connection schema0
5660 -> m (Connection schema1)
57−runPQ conn (PQ pq) = fmap snd $ pq conn
61+execPQ (PQ pq) = fmap snd . pq
5862
5963pqAp
6064 :: Monad m
@@ -73,7 +77,7 @@ pqBind
7377 -> PQ schema0 schema2 m y
7478pqBind f (PQ x) = PQ $ \ conn -> do
7579 (x', conn') <- x conn
76− unPQ (f x') conn'
80+ runPQ (f x') conn'
7781
7882pqThen
7983 :: Monad m
@@ -82,44 +86,116 @@ pqThen
8286 -> PQ schema0 schema2 m y
8387pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
8488
85−pqExec
89+define
8690 :: MonadBase IO io
8791 => Definition schema0 schema1
8892 -> PQ schema0 schema1 io (Maybe (Result '[]))
89−pqExec (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
93+define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
9094 result <- liftBase $ LibPQ.exec conn q
9195 return (Result <$> result, Connection conn)
9296
93−pqThenExec
97+pqThenDefine
9498 :: MonadBase IO io
9599 => Definition schema1 schema2
96100 -> PQ schema0 schema1 io x
97101 -> PQ schema0 schema2 io (Maybe (Result '[]))
98−pqThenExec = pqThen . pqExec
102+pqThenDefine = pqThen . define
99103
100−class Monad m => MonadPQ schema m | m -> schema where
104+class Monad pq => MonadPQ schema pq | pq -> schema where
101105
102− pqExecParams
106+ manipulateParams
103107 :: ToParams x params
104− => Manipulation schema params ys -> x -> m (Maybe (Result ys))
105− default pqExecParams
106− :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)
108+ => Manipulation schema params ys -> x -> pq (Maybe (Result ys))
109+ default manipulateParams
110+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
107111 => ToParams x params
108− => Manipulation schema params ys -> x -> m (Maybe (Result ys))
109− pqExecParams manipulation params = lift $ pqExecParams manipulation params
112+ => Manipulation schema params ys -> x -> pq (Maybe (Result ys))
113+ manipulateParams manipulation params = lift $
114+ manipulateParams manipulation params
115+
116+ manipulate :: Manipulation schema '[] ys -> pq (Maybe (Result ys))
117+ manipulate statement = manipulateParams statement ()
110118
111− pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))
112− pqExecNil statement = pqExecParams statement ()
119+ queryParams
120+ :: ToParams x params
121+ => Query schema params ys -> x -> pq (Maybe (Result ys))
122+ queryParams = manipulateParams . queryStatement
123+
124+ query :: Query schema '[] ys -> pq (Maybe (Result ys))
125+ query q = queryParams q ()
126+
127+ traversePrepared
128+ :: (ToParams x params, Traversable list)
129+ => Manipulation schema params ys -> list x -> pq (list (Maybe (Result ys)))
130+ default traversePrepared
131+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
132+ => (ToParams x params, Traversable list)
133+ => Manipulation schema params ys -> list x -> pq (list (Maybe (Result ys)))
134+ traversePrepared manipulation params = lift $
135+ traversePrepared manipulation params
136+
137+ forPrepared
138+ :: (ToParams x params, Traversable list)
139+ => list x -> Manipulation schema params ys -> pq (list (Maybe (Result ys)))
140+ forPrepared = flip traversePrepared
141+
142+ traversePrepared_
143+ :: (ToParams x params, Foldable list)
144+ => Manipulation schema params ys -> list x -> pq ()
145+ default traversePrepared_
146+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
147+ => (ToParams x params, Foldable list)
148+ => Manipulation schema params ys -> list x -> pq ()
149+ traversePrepared_ manipulation params = lift $
150+ traversePrepared_ manipulation params
151+
152+ forPrepared_
153+ :: (ToParams x params, Traversable list)
154+ => list x -> Manipulation schema params ys -> pq ()
155+ forPrepared_ = flip traversePrepared_
113156
114157instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
115158
116− pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
117− PQ $ \ (Connection conn) -> do
118− let
119− toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
120− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
121− result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
122− return (Result <$> result, Connection conn)
159+ manipulateParams
160+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
161+ PQ $ \ (Connection conn) -> do
162+ let
163+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
164+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
165+ result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
166+ return (Result <$> result, Connection conn)
167+
168+ traversePrepared
169+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
170+ PQ $ \ (Connection conn) -> do
171+ let temp = "temporary_statement"
172+ _prepResult <- liftBase $ LibPQ.prepare conn temp q Nothing
173+ results <- for list $ \ params -> do
174+ let
175+ toParam' bytes = (bytes,LibPQ.Binary)
176+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
177+ result <- liftBase $
178+ LibPQ.execPrepared conn temp params' LibPQ.Binary
179+ return $ Result <$> result
180+ _deallocResult <- liftBase $
181+ LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
182+ return (results, Connection conn)
183+
184+ traversePrepared_
185+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
186+ PQ $ \ (Connection conn) -> do
187+ let temp = "temporary_statement"
188+ _prepResult <- liftBase $ LibPQ.prepare conn temp q Nothing
189+ for_ list $ \ params -> do
190+ let
191+ toParam' bytes = (bytes,LibPQ.Binary)
192+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
193+ _result <- liftBase $
194+ LibPQ.execPrepared conn temp params' LibPQ.Binary
195+ return ()
196+ _deallocResult <- liftBase $
197+ LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
198+ return ((), Connection conn)
123199
124200instance Monad m => Applicative (PQ schema schema m) where
125201 pure x = PQ $ \ conn -> pure (x, conn)
@@ -142,7 +218,7 @@ type PQRun schema =
142218
143219pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
144220pqliftWith f = PQ $ \ conn ->
145− fmap (\ x -> (x, conn)) (f $ \ pq -> unPQ pq conn)
221+ fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
146222
147223instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
148224 type StM (PQ schema schema m) x = StM m (x, Connection schema)