git.iko.soy/squeal
on dev help sign in
monad control
f9f4eb0Eitan Chatav
squeel-postgresql/squeel-postgresql.cabal+3
compare with dev
unifiedsplit
@@ -26,11 +26,14 @@ library
26 , aeson
26 , aeson
27 , bytestring
27 , bytestring
28 , indexed
28 , indexed
29+ , lifted-base
30+ , monad-control
29 , postgresql-binary
31 , postgresql-binary
30 , postgresql-libpq
32 , postgresql-libpq
31 , scientific
33 , scientific
32 , text
34 , text
33 , time
35 , time
36+ , transformers-base
34 , uuid
37 , uuid
35 , vinyl
38 , vinyl
36
39
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+46−21
@@ -3,20 +3,25 @@
3 , DeriveFunctor
3 , DeriveFunctor
4 , FlexibleContexts
4 , FlexibleContexts
5 , FlexibleInstances
5 , FlexibleInstances
6+ , MultiParamTypeClasses
6 , PolyKinds
7 , PolyKinds
8+ , RankNTypes
7 , RecordWildCards
9 , RecordWildCards
8 , ScopedTypeVariables
10 , ScopedTypeVariables
9 , TypeApplications
11 , TypeApplications
10 , TypeFamilies
12 , TypeFamilies
11 , TypeOperators
13 , TypeOperators
14+ , UndecidableInstances
12#-}
15#-}
13
16
14module Squeel.PostgreSQL.PQ where
17module Squeel.PostgreSQL.PQ where
15
18
16import Control.Arrow
19import Control.Arrow
20+import Control.Exception.Lifted
21+import Control.Monad.Base
17import Control.Monad.Indexed
22import Control.Monad.Indexed
18import Control.Monad.Indexed.Trans
23import Control.Monad.Indexed.Trans
19−import Control.Monad.IO.Class
24+import Control.Monad.Trans.Control
20import Data.ByteString (ByteString)
25import Data.ByteString (ByteString)
21import Data.Proxy
26import Data.Proxy
22import Data.Text (Text)
27import Data.Text (Text)
@@ -35,6 +40,12 @@ newtype PQ m db0 db1 x = PQ
35 { runPQ :: Connection db0 -> m (x, Connection db1) }
40 { runPQ :: Connection db0 -> m (x, Connection db1) }
36 deriving Functor
41 deriving Functor
37
42
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+
38instance Functor m => IxFunctor (PQ m) where
49instance Functor m => IxFunctor (PQ m) where
39 imap f (PQ g) = PQ $ fmap (first f) . g
50 imap f (PQ g) = PQ $ fmap (first f) . g
40
51
@@ -65,33 +76,47 @@ instance IxMonadTrans PQ where
65 x <- m
76 x <- m
66 return (x, conn)
77 return (x, conn)
67
78
68−instance MonadIO io => MonadIO (PQ io db db) where
79+instance MonadBase b m => MonadBase b (PQ m db db) where
69− liftIO = ilift . liftIO
80+ liftBase = ilift . liftBase
81+
82+type PQRun db = forall n b. Monad n => PQ n db db b -> n (b, Connection db)
70
83
71−connectdb :: MonadIO io => ByteString -> io (Connection db)
84+pqliftWith :: Functor m => (PQRun db -> m a) -> PQ m db db a
72−connectdb = fmap Connection . liftIO . LibPQ.connectdb
85+pqliftWith f = PQ $ \ conn ->
86+ fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
73
87
74−connectStart :: MonadIO io => ByteString -> io (Connection db)
88+instance MonadBaseControl b m => MonadBaseControl b (PQ m db db) where
75−connectStart = fmap Connection . liftIO . LibPQ.connectStart
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
76
93
77−newNullConnection :: MonadIO io => io (Connection db)
94+connectdb :: MonadBase IO io => ByteString -> io (Connection db)
78−newNullConnection = Connection <$> liftIO LibPQ.newNullConnection
95+connectdb = fmap Connection . liftBase . LibPQ.connectdb
79
96
80−finish :: MonadIO io => Connection db -> io ()
97+finish :: MonadBase IO io => Connection db -> io ()
81−finish = liftIO . LibPQ.finish . unConnection
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
82
107
83newtype Result xs = Result { unResult :: LibPQ.Result }
108newtype Result xs = Result { unResult :: LibPQ.Result }
84
109
85exec
110exec
86− :: MonadIO io
111+ :: MonadBase IO io
87 => Query db0 db1 '[] xs
112 => Query db0 db1 '[] xs
88 -> PQ io db0 db1 (Maybe (Result xs))
113 -> PQ io db0 db1 (Maybe (Result xs))
89exec (Query q) = PQ $ \ (Connection conn) -> do
114exec (Query q) = PQ $ \ (Connection conn) -> do
90− result <- liftIO $ LibPQ.exec conn q
115+ result <- liftBase $ LibPQ.exec conn q
91 return (Result <$> result, Connection conn)
116 return (Result <$> result, Connection conn)
92
117
93execParams
118execParams
94− :: (MonadIO io, ToValues xs ps, ToOids ps)
119+ :: (MonadBase IO io, ToValues xs ps, ToOids ps)
95 => Query db0 db1 ps ys
120 => Query db0 db1 ps ys
96 -> Rec Identity xs
121 -> Rec Identity xs
97 -> PQ io db0 db1 (Maybe (Result ys))
122 -> PQ io db0 db1 (Maybe (Result ys))
@@ -103,22 +128,22 @@ execParams (Query q :: Query db0 db1 ps ys) params =
103 | (oid, param) <-
128 | (oid, param) <-
104 zip (toOids (Proxy @ps)) (toValues (Proxy @ps) params)
129 zip (toOids (Proxy @ps)) (toValues (Proxy @ps) params)
105 ]
130 ]
106− result <- liftIO $ LibPQ.execParams conn q params' LibPQ.Binary
131+ result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
107 return (Result <$> result, Connection conn)
132 return (Result <$> result, Connection conn)
108
133
109prepare
134prepare
110− :: (MonadIO io, ToOids ps)
135+ :: (MonadBase IO io, ToOids ps)
111 => ByteString
136 => ByteString
112 -> Query db0 db1 ps xs
137 -> Query db0 db1 ps xs
113 -> PQ io db0 db0 (Maybe (Result []), PreparedQuery db0 db1 ps xs)
138 -> PQ io db0 db0 (Maybe (Result []), PreparedQuery db0 db1 ps xs)
114prepare statementName (Query q :: Query db0 db1 ps ys) =
139prepare statementName (Query q :: Query db0 db1 ps ys) =
115 PQ $ \ (Connection conn) -> do
140 PQ $ \ (Connection conn) -> do
116− result <- liftIO $
141+ result <- liftBase $
117 LibPQ.prepare conn statementName q (Just (toOids (Proxy @ps)))
142 LibPQ.prepare conn statementName q (Just (toOids (Proxy @ps)))
118 return ((Result <$> result,PreparedQuery statementName), Connection conn)
143 return ((Result <$> result,PreparedQuery statementName), Connection conn)
119
144
120execPrepared
145execPrepared
121− :: (MonadIO io, ToValues xs ps)
146+ :: (MonadBase IO io, ToValues xs ps)
122 => PreparedQuery db0 db1 ps ys
147 => PreparedQuery db0 db1 ps ys
123 -> Rec Identity xs
148 -> Rec Identity xs
124 -> PQ io db0 db1 (Maybe (Result ys))
149 -> PQ io db0 db1 (Maybe (Result ys))
@@ -127,7 +152,7 @@ execPrepared (PreparedQuery q :: PreparedQuery db0 db1 ps ys) params =
127 let
152 let
128 params' =
153 params' =
129 [Just (param, LibPQ.Binary) | param <- toValues (Proxy @ps) params]
154 [Just (param, LibPQ.Binary) | param <- toValues (Proxy @ps) params]
130− result <- liftIO $
155+ result <- liftBase $
131 LibPQ.execPrepared conn q params' LibPQ.Binary
156 LibPQ.execPrepared conn q params' LibPQ.Binary
132 return (Result <$> result, Connection conn)
157 return (Result <$> result, Connection conn)
133
158
@@ -151,11 +176,11 @@ colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4
151colNum4 = ColumnNumber 4
176colNum4 = ColumnNumber 4
152
177
153getvalue
178getvalue
154− :: (FromValue x y, MonadIO io)
179+ :: (FromValue x y, MonadBase IO io)
155 => Proxy x
180 => Proxy x
156 -> Result xs
181 -> Result xs
157 -> RowNumber
182 -> RowNumber
158 -> ColumnNumber xs x
183 -> ColumnNumber xs x
159 -> io (Maybe (Either Text y))
184 -> 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 $
161 fmap (fmap (decodeValue proxy)) (LibPQ.getvalue result r c)
186 fmap (fmap (decodeValue proxy)) (LibPQ.getvalue result r c)