git.iko.soy/squeal
on dev help sign in
mtl style PQ interface
3771b5fEitan Chatav
squeel-postgresql/squeel-postgresql.cabal+1−3
compare with dev
unifiedsplit
@@ -16,8 +16,6 @@ library
16 Squeel.PostgreSQL
16 Squeel.PostgreSQL
17 Squeel.PostgreSQL.PQ
17 Squeel.PostgreSQL.PQ
18 Squeel.PostgreSQL.Query
18 Squeel.PostgreSQL.Query
19− Squeel.PostgreSQL.Query.Expression
20− Squeel.PostgreSQL.Query.Relation
21 Squeel.PostgreSQL.Type
19 Squeel.PostgreSQL.Type
22 Squeel.PostgreSQL.Value
20 Squeel.PostgreSQL.Value
23 default-language: Haskell2010
21 default-language: Haskell2010
@@ -25,9 +23,9 @@ library
25 build-depends: base
23 build-depends: base
26 , aeson
24 , aeson
27 , bytestring
25 , bytestring
28− , indexed
29 , lifted-base
26 , lifted-base
30 , monad-control
27 , monad-control
28+ , mtl
31 , postgresql-binary
29 , postgresql-binary
32 , postgresql-libpq
30 , postgresql-libpq
33 , scientific
31 , scientific
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+92−84
@@ -1,26 +1,22 @@
1{-# LANGUAGE
1{-# LANGUAGE
2− DataKinds
3− , DeriveFunctor
2+ DeriveFunctor
4 , FlexibleContexts
3 , FlexibleContexts
5 , FlexibleInstances
4 , FlexibleInstances
6 , MultiParamTypeClasses
5 , MultiParamTypeClasses
7− , PolyKinds
8 , RankNTypes
6 , RankNTypes
9− , RecordWildCards
10 , ScopedTypeVariables
7 , ScopedTypeVariables
11 , TypeApplications
8 , TypeApplications
12 , TypeFamilies
9 , TypeFamilies
10+ , TypeInType
13 , TypeOperators
11 , TypeOperators
14 , UndecidableInstances
12 , UndecidableInstances
15#-}
13#-}
16
14
17module Squeel.PostgreSQL.PQ where
15module Squeel.PostgreSQL.PQ where
18
16
19−import Control.Arrow
20import Control.Exception.Lifted
17import Control.Exception.Lifted
21import Control.Monad.Base
18import Control.Monad.Base
22−import Control.Monad.Indexed
19+import Control.Monad.Trans
23−import Control.Monad.Indexed.Trans
24import Control.Monad.Trans.Control
20import Control.Monad.Trans.Control
25import Data.ByteString (ByteString)
21import Data.ByteString (ByteString)
26import Data.Proxy
22import Data.Proxy
@@ -36,57 +32,118 @@ import Squeel.PostgreSQL.Type
36
32
37newtype Connection db = Connection { unConnection :: LibPQ.Connection }
33newtype Connection db = Connection { unConnection :: LibPQ.Connection }
38
34
39−newtype PQ m db0 db1 x = PQ
35+newtype PQ (db0 :: [Table]) (db1 :: [Table]) m x = PQ
40 { runPQ :: Connection db0 -> m (x, Connection db1) }
36 { runPQ :: Connection db0 -> m (x, Connection db1) }
41 deriving Functor
37 deriving Functor
42
38
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
44evalPQ (PQ pq) = fmap fst . pq
40evalPQ (PQ pq) = fmap fst . pq
45
41
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)
47execPQ (PQ pq) = fmap snd . pq
43execPQ (PQ pq) = fmap snd . pq
48
44
49−instance Functor m => IxFunctor (PQ m) where
45+class MonadPQ pq where
50− imap f (PQ g) = PQ $ fmap (first f) . g
46+
51−
47+ pqAp
52−instance Applicative m => IxPointed (PQ m) where
48+ :: Monad m
53− ireturn x = PQ $ \ conn -> pure (x, conn)
49+ => pq db0 db1 m (x -> y)
54−
50+ -> pq db1 db2 m x
55−instance Monad m => IxApplicative (PQ m) where
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+
56− iap (PQ f) (PQ x) = PQ $ \ conn -> do
84+ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
57 (f', conn') <- f conn
85 (f', conn') <- f conn
58 (x', conn'') <- x conn'
86 (x', conn'') <- x conn'
59 return (f' x', conn'')
87 return (f' x', conn'')
60
88
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
67 (x', conn') <- x conn
90 (x', conn') <- x conn
68 runPQ (f x') conn'
91 runPQ (f x') conn'
69
92
70−instance Monad m => Monad (PQ m db db) where
93+ pqExec (Query q) = PQ $ \ (Connection conn) -> do
71− return = ireturn
94+ result <- liftBase $ LibPQ.exec conn q
72− (>>=) = flip ibind
95+ return (Result <$> result, Connection conn)
73
96
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+
74−instance IxMonadTrans PQ where
127+instance Monad m => Monad (PQ db db m) where
128+ return = pure
129+ (>>=) = flip pqBind
130+
131+instance MonadTrans (PQ db db) where
75− ilift m = PQ $ \ conn -> do
132+ lift m = PQ $ \ conn -> do
76 x <- m
133 x <- m
77 return (x, conn)
134 return (x, conn)
78
135
79−instance MonadBase b m => MonadBase b (PQ m db db) where
136+instance MonadBase b m => MonadBase b (PQ db db m) where
80− liftBase = ilift . liftBase
137+ liftBase = lift . liftBase
81
138
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)
83
140
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
85pqliftWith f = PQ $ \ conn ->
142pqliftWith f = PQ $ \ conn ->
86 fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
143 fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
87
144
88−instance MonadBaseControl b m => MonadBaseControl b (PQ m db db) where
145+instance MonadBaseControl b m => MonadBaseControl b (PQ db db m) where
89− type StM (PQ m db db) x = StM m (x, Connection db)
146+ type StM (PQ db db m) x = StM m (x, Connection db)
90 liftBaseWith f =
147 liftBaseWith f =
91 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
148 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
92 restoreM = PQ . const . restoreM
149 restoreM = PQ . const . restoreM
@@ -107,55 +164,6 @@ withConnection connString action =
107
164
108newtype Result xs = Result { unResult :: LibPQ.Result }
165newtype Result xs = Result { unResult :: LibPQ.Result }
109
166
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−
159newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
167newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
160
168
161newtype ColumnNumber cs c = ColumnNumber { unColumnNumber :: LibPQ.Column }
169newtype ColumnNumber cs c = ColumnNumber { unColumnNumber :: LibPQ.Column }