@@ -1,6 +1,7 @@
11{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
22{-# LANGUAGE
33 DataKinds
4+ , DefaultSignatures
45 , FunctionalDependencies
56 , PolyKinds
67 , DeriveFunctor
@@ -38,87 +39,85 @@ import Squeel.PostgreSQL.Binary
3839import Squeel.PostgreSQL.Statement
3940import Squeel.PostgreSQL.Schema
4041
41−newtype Connection (db :: [(Symbol,[(Symbol,ColumnType)])]) =
42+newtype Connection (schema :: [(Symbol,[(Symbol,ColumnType)])]) =
4243 Connection { unConnection :: LibPQ.Connection }
4344
4445newtype PQ
45− (db0 :: [(Symbol,[(Symbol,ColumnType)])])
46− (db1 :: [(Symbol,[(Symbol,ColumnType)])])
46+ (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
47+ (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
4748 (m :: * -> *)
4849 (x :: *) =
49− PQ { runPQ :: Connection db0 -> m (x, Connection db1) }
50+ PQ { unPQ :: Connection schema0 -> m (x, Connection schema1) }
5051 deriving Functor
5152
52−evalPQ :: Functor m => PQ db0 db1 m x -> Connection db0 -> m x
53−evalPQ (PQ pq) = fmap fst . pq
54−
55−execPQ :: Functor m => PQ db0 db1 m x -> Connection db0 -> m (Connection db1)
56−execPQ (PQ pq) = fmap snd . pq
57−
58−class AtkeyPQ pq where
59−
60− pqAp
61− :: Monad m
62− => pq db0 db1 m (x -> y)
63− -> pq db1 db2 m x
64− -> pq db0 db2 m y
65−
66− pqBind
67− :: Monad m
68− => (x -> pq db1 db2 m y)
69− -> pq db0 db1 m x
70− -> pq db0 db2 m y
71−
72− pqThen
73− :: Monad m
74− => pq db1 db2 m y
75− -> pq db0 db1 m x
76− -> pq db0 db2 m y
77− pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
78−
79− pqExec
80− :: MonadBase IO io
81− => Definition db0 db1
82− -> pq db0 db1 io (Maybe (Result '[]))
83−
84− pqThenExec
85− :: MonadBase IO io
86− => Definition db1 db2
87− -> pq db0 db1 io x
88− -> pq db0 db2 io (Maybe (Result '[]))
89− pqThenExec = pqThen . pqExec
90−
91−class MonadPQ db m | m -> db where
53+evalPQ :: Functor m => Connection schema0 -> PQ schema0 schema1 m x -> m x
54+evalPQ conn (PQ pq) = fmap fst $ pq conn
55+
56+runPQ
57+ :: Functor m
58+ => Connection schema0
59+ -> PQ schema0 schema1 m x
60+ -> m (Connection schema1)
61+runPQ conn (PQ pq) = fmap snd $ pq conn
62+
63+pqAp
64+ :: Monad m
65+ => PQ schema0 schema1 m (x -> y)
66+ -> PQ schema1 schema2 m x
67+ -> PQ schema0 schema2 m y
68+pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
69+ (f', conn') <- f conn
70+ (x', conn'') <- x conn'
71+ return (f' x', conn'')
72+
73+pqBind
74+ :: Monad m
75+ => (x -> PQ schema1 schema2 m y)
76+ -> PQ schema0 schema1 m x
77+ -> PQ schema0 schema2 m y
78+pqBind f (PQ x) = PQ $ \ conn -> do
79+ (x', conn') <- x conn
80+ unPQ (f x') conn'
81+
82+pqThen
83+ :: Monad m
84+ => PQ schema1 schema2 m y
85+ -> PQ schema0 schema1 m x
86+ -> PQ schema0 schema2 m y
87+pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
88+
89+pqExec
90+ :: MonadBase IO io
91+ => Definition schema0 schema1
92+ -> PQ schema0 schema1 io (Maybe (Result '[]))
93+pqExec (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
94+ result <- liftBase $ LibPQ.exec conn q
95+ return (Result <$> result, Connection conn)
96+
97+pqThenExec
98+ :: MonadBase IO io
99+ => Definition schema1 schema2
100+ -> PQ schema0 schema1 io x
101+ -> PQ schema0 schema2 io (Maybe (Result '[]))
102+pqThenExec = pqThen . pqExec
103+
104+class Monad m => MonadPQ schema m | m -> schema where
92105
93106 pqExecParams
94107 :: (ToOids ps, AllZip HasEncoding ps xs)
95− => Manipulation db ps ys
96− -> NP I xs
97− -> m (Maybe (Result ys))
98−
99− pqExecNil
100− :: Manipulation db '[] ys
101− -> m (Maybe (Result ys))
108+ => Manipulation schema ps ys -> NP I xs -> m (Maybe (Result ys))
109+ default pqExecParams
110+ :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)
111+ => (ToOids ps, AllZip HasEncoding ps xs)
112+ => Manipulation schema ps ys -> NP I xs -> m (Maybe (Result ys))
113+ pqExecParams manipulation params = lift $ pqExecParams manipulation params
114+
115+ pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))
102116 pqExecNil statement = pqExecParams statement Nil
103117
104−instance AtkeyPQ PQ where
105−
106− pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
107− (f', conn') <- f conn
108− (x', conn'') <- x conn'
109− return (f' x', conn'')
110−
111− pqBind f (PQ x) = PQ $ \ conn -> do
112− (x', conn') <- x conn
113− runPQ (f x') conn'
114−
115− pqExec (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
116− result <- liftBase $ LibPQ.exec conn q
117− return (Result <$> result, Connection conn)
118−
119−instance MonadBase IO io => MonadPQ db (PQ db db io) where
118+instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
120119
121− pqExecParams (UnsafeManipulation q :: Manipulation db ps ys) params =
120+ pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) params =
122121 PQ $ \ (Connection conn) -> do
123122 let
124123 paramValues = encodings (Proxy :: Proxy ps) params
@@ -130,44 +129,45 @@ instance MonadBase IO io => MonadPQ db (PQ db db io) where
130129 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
131130 return (Result <$> result, Connection conn)
132131
133−instance Monad m => Applicative (PQ db db m) where
132+instance Monad m => Applicative (PQ schema schema m) where
134133 pure x = PQ $ \ conn -> pure (x, conn)
135134 (<*>) = pqAp
136135
137−instance Monad m => Monad (PQ db db m) where
136+instance Monad m => Monad (PQ schema schema m) where
138137 return = pure
139138 (>>=) = flip pqBind
140139
141−instance MonadTrans (PQ db db) where
140+instance MonadTrans (PQ schema schema) where
142141 lift m = PQ $ \ conn -> do
143142 x <- m
144143 return (x, conn)
145144
146−instance MonadBase b m => MonadBase b (PQ db db m) where
145+instance MonadBase b m => MonadBase b (PQ schema schema m) where
147146 liftBase = lift . liftBase
148147
149−type PQRun db = forall m x. Monad m => PQ db db m x -> m (x, Connection db)
148+type PQRun schema =
149+ forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
150150
151−pqliftWith :: Functor m => (PQRun db -> m a) -> PQ db db m a
151+pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
152152pqliftWith f = PQ $ \ conn ->
153− fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
153+ fmap (\ x -> (x, conn)) (f $ \ pq -> unPQ pq conn)
154154
155−instance MonadBaseControl b m => MonadBaseControl b (PQ db db m) where
156− type StM (PQ db db m) x = StM m (x, Connection db)
155+instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
156+ type StM (PQ schema schema m) x = StM m (x, Connection schema)
157157 liftBaseWith f =
158158 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
159159 restoreM = PQ . const . restoreM
160160
161−connectdb :: MonadBase IO io => ByteString -> io (Connection db)
161+connectdb :: MonadBase IO io => ByteString -> io (Connection schema)
162162connectdb = fmap Connection . liftBase . LibPQ.connectdb
163163
164−finish :: MonadBase IO io => Connection db -> io ()
164+finish :: MonadBase IO io => Connection schema -> io ()
165165finish = liftBase . LibPQ.finish . unConnection
166166
167167withConnection
168168 :: MonadBaseControl IO io
169169 => ByteString
170− -> (Connection db -> io x)
170+ -> (Connection schema -> io x)
171171 -> io x
172172withConnection connString action =
173173 bracket (connectdb connString) finish action