53c57f8 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

IndexedMonadTransPQ

53c57f8Eitan Chatav9 years ago

squeal-postgresql/exe/Example.hs+1−1

compare with dev

unifiedsplit

@@ -125,4 +125,4 @@ main2 =

125 void . withConnection "host=localhost port=5432 dbname=exampledb" $

126 define setup

127 & pqThen session

128− & thenDefine teardown

128+ & pqThen (define teardown)

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+107−79

@@ -36,17 +36,13 @@ module Squeal.PostgreSQL.PQ

36 connectdb

37 , finish

38 , withConnection

39+ , lowerConnection

39 -- * PQ

40 -- * PQ

40− , PQ (PQ, runPQ)

41+ , PQ (PQ, unPQ)

42+ , runPQ

41 , execPQ

43 , execPQ

42− , pqEmbed

44+ , evalPQ

43− , pqAp

45+ , IndexedMonadTransPQ (..)

44− , pqBind

45− , pqJoin

46− , pqThen

47− , define

48− , thenDefine

49− -- * MonadPQ

50 , MonadPQ (..)

46 , MonadPQ (..)

51 , PQRun

47 , PQRun

52 , pqliftWith

48 , pqliftWith

@@ -149,9 +145,15 @@ withConnection

149 -> PQ schema0 schema1 io x

145 -> PQ schema0 schema1 io x

150 -> io x

146 -> io x

151withConnection connString action = do

147withConnection connString action = do

152− K x <- bracket (connectdb connString) finish (runPQ action)

148+ K x <- bracket (connectdb connString) finish (unPQ action)

153 return x

149 return x

154

150

151+-- | Safely `lowerConnection` to a smaller schema.

152+lowerConnection

153+ :: K LibPQ.Connection (table ': schema)

154+ -> K LibPQ.Connection schema

155+lowerConnection (K conn) = K conn

156+

155-- | We keep track of the schema via an Atkey indexed state monad transformer,

157-- | We keep track of the schema via an Atkey indexed state monad transformer,

156-- `PQ`.

158-- `PQ`.

157newtype PQ

159newtype PQ

@@ -159,87 +161,113 @@ newtype PQ

159 (schema1 :: TablesType)

161 (schema1 :: TablesType)

160 (m :: Type -> Type)

162 (m :: Type -> Type)

161 (x :: Type) =

163 (x :: Type) =

162− PQ { runPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

164+ PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

163

165

164instance Monad m => Functor (PQ schema0 schema1 m) where

166instance Monad m => Functor (PQ schema0 schema1 m) where

165 fmap f (PQ pq) = PQ $ \ conn -> do

167 fmap f (PQ pq) = PQ $ \ conn -> do

166 K x <- pq conn

168 K x <- pq conn

167 return $ K (f x)

169 return $ K (f x)

168

170

171+-- | Run a `PQ` and keep the result and the `Connection`.

172+runPQ

173+ :: Functor m

174+ => PQ schema0 schema1 m x

175+ -> K LibPQ.Connection schema0

176+ -> m (x, K LibPQ.Connection schema1)

177+runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

178+ -- K x <- pq conn

179+ -- return (x, K (unK conn))

180+

169−-- | Run a `PQ` and discard the result but keep the `Connection`.

181+-- | Execute a `PQ` and discard the result but keep the `Connection`.

170execPQ

182execPQ

171 :: Functor m

183 :: Functor m

172 => PQ schema0 schema1 m x

184 => PQ schema0 schema1 m x

173 -> K LibPQ.Connection schema0

185 -> K LibPQ.Connection schema0

174 -> m (K LibPQ.Connection schema1)

186 -> m (K LibPQ.Connection schema1)

175−execPQ (PQ pq) conn = fmap (mapKK (\ _ -> unK conn)) $ pq conn

187+execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn

176

188

177−-- | Safely embed a `PQ` computation in a larger schema.

189+-- | Evaluate a `PQ` and discard the `Connection` but keep the result.

178−pqEmbed

190+evalPQ

179− :: Monad m

191+ :: Functor m

180 => PQ schema0 schema1 m x

192 => PQ schema0 schema1 m x

181− -> PQ (table ': schema0) (table : schema1) m x

193+ -> K LibPQ.Connection schema0

182−pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

194+ -> m x

183− K x <- pq (K conn)

195+evalPQ (PQ pq) conn = unK <$> pq conn

184− return $ K x

196+

185−

197+-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`

198+-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).

199+-- An indexed monad transformer transforms a `Monad` into an indexed monad.

200+-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that

201+-- support running `Definition`s using `define` and embedding a computation

202+-- in a larger schema using `pqEmbed`.

203+class IndexedMonadTransPQ pq where

204+

205+ -- | Safely embed a computation in a larger schema.

206+ pqEmbed

207+ :: Monad m

208+ => pq schema0 schema1 m x

209+ -> pq (table ': schema0) (table : schema1) m x

210+

186−-- | indexed analog of `<*>`

211+ -- | indexed analog of `<*>`

187−pqAp

212+ pqAp

188− :: Monad m

213+ :: Monad m

189− => PQ schema0 schema1 m (x -> y)

214+ => pq schema0 schema1 m (x -> y)

190− -> PQ schema1 schema2 m x

215+ -> pq schema1 schema2 m x

191− -> PQ schema0 schema2 m y

216+ -> pq schema0 schema2 m y

192−pqAp (PQ f) (PQ x) = PQ $ \ conn -> do

217+

193− K f' <- f conn

194− K x' <- x (K (unK conn))

195− return $ K (f' x')

196−

197−-- | indexed analog of `join`

218+ -- | indexed analog of `join`

198−pqJoin

219+ pqJoin

199− :: Monad m

220+ :: Monad m

200− => PQ schema0 schema1 m (PQ schema1 schema2 m y)

221+ => pq schema0 schema1 m (pq schema1 schema2 m y)

201− -> PQ schema0 schema2 m y

222+ -> pq schema0 schema2 m y

202−pqJoin pq = pq & pqBind id

223+

203−

204−-- | indexed analog of `=<<`

224+ -- | indexed analog of `=<<`

205−pqBind

225+ pqBind

206− :: Monad m

226+ :: Monad m

207− => (x -> PQ schema1 schema2 m y)

227+ => (x -> pq schema1 schema2 m y)

208− -> PQ schema0 schema1 m x

228+ -> pq schema0 schema1 m x

209− -> PQ schema0 schema2 m y

229+ -> pq schema0 schema2 m y

210−pqBind f (PQ x) = PQ $ \ conn -> do

230+

211− K x' <- x conn

212− runPQ (f x') (K (unK conn))

213−

214−-- | indexed analog of flipped `>>`

231+ -- | indexed analog of flipped `>>`

215−pqThen

232+ pqThen

216− :: Monad m

233+ :: Monad m

217− => PQ schema1 schema2 m y

234+ => pq schema1 schema2 m y

218− -> PQ schema0 schema1 m x

235+ -> pq schema0 schema1 m x

219− -> PQ schema0 schema2 m y

236+ -> pq schema0 schema2 m y

220−pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

237+

221−

222−-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

238+ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

223−--

239+ --

224−-- @define statement1 & thenDefine statement2 = define (statement1 >>> statement2)@

240+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

225−define

241+ define

226− :: MonadBase IO io

242+ :: MonadBase IO io

227− => Definition schema0 schema1

243+ => Definition schema0 schema1

228− -> PQ schema0 schema1 io (K LibPQ.Result '[])

244+ -> pq schema0 schema1 io (K LibPQ.Result '[])

245+

246+instance IndexedMonadTransPQ PQ where

247+

248+ pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

249+ K x <- pq (K conn)

250+ return $ K x

251+

252+ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do

253+ K f' <- f conn

254+ K x' <- x (K (unK conn))

255+ return $ K (f' x')

256+

257+ pqJoin pq = pq & pqBind id

258+

259+ pqBind f (PQ x) = PQ $ \ conn -> do

260+ K x' <- x conn

261+ unPQ (f x') (K (unK conn))

262+

263+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

264+

229−define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

265+ define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

230− resultMaybe <- liftBase $ LibPQ.exec conn q

266+ resultMaybe <- liftBase $ LibPQ.exec conn q

231− case resultMaybe of

267+ case resultMaybe of

232− Nothing -> error

268+ Nothing -> error

233− "define: LibPQ.exec returned no results"

269+ "define: LibPQ.exec returned no results"

234− Just result -> return $ K (K result)

270+ Just result -> return $ K (K result)

235−

236−-- | Chain together `define` actions.

237−thenDefine

238− :: MonadBase IO io

239− => Definition schema1 schema2

240− -> PQ schema0 schema1 io x

241− -> PQ schema0 schema2 io (K LibPQ.Result '[])

242−thenDefine = pqThen . define

243

271

244{- | `MonadPQ` is an `mtl` style constraint, similar to

272{- | `MonadPQ` is an `mtl` style constraint, similar to

245`Control.Monad.State.Class.MonadState`, for using `LibPQ` to

273`Control.Monad.State.Class.MonadState`, for using `LibPQ` to

@@ -468,7 +496,7 @@ type PQRun schema =

468-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

496-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

469pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

497pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

470pqliftWith f = PQ $ \ conn ->

498pqliftWith f = PQ $ \ conn ->

471− fmap K (f $ \ pq -> runPQ pq conn)

499+ fmap K (f $ \ pq -> unPQ pq conn)

472

500

473instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where

501instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where

474 type StM (PQ schema schema m) x = StM m (K x schema)

502 type StM (PQ schema schema m) x = StM m (K x schema)