21747db · squeal · git.iko.soy

git.iko.soy/squeal

Merge pull request #116 from Holmusk/chshersh/109-monadunliftio

[#109] Move from MonadBaseControl to MonadUnliftIO

commit21747dbf0ab500d40dabc4169d5b01c46731eb95 authorEitan Chatav <eitan.chatav@gmail.com> dateWed 27 Mar 2019, 07:05 (8 years ago) parent6aec0cc 41b0c5e

12 files changed+118−119

compare with dev

unifiedsplit

README.md+5−5 squeal-postgresql/exe/Example.hs+6−6 squeal-postgresql/squeal-postgresql.cabal+2−5 squeal-postgresql/src/Squeal/PostgreSQL.hs+6−6 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+6−6 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+13−14 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+42−44 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+21−17 squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+3−3 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+8−10 squeal-postgresql/test/Specs/ExceptionHandling.hs+3−3 stack.yaml+3

README.md+5−5

@@ -80,7 +80,7 @@ We'll need some imports.

8080

8181```Haskell

8282>>> import Control.Monad (void)

83−>>> import Control.Monad.Base (liftBase)

83+>>> import Control.Monad.IO.Class (liftIO)

8484>>> import Data.Int (Int32)

8585>>> import Data.Text (Text)

8686>>> import Squeal.PostgreSQL

@@ -128,7 +128,7 @@ yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,

128128yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator

129129

130130Next, we'll write `Definition`s to set up and tear down the schema. In

131−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

131+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

132132has two type parameters, corresponding to the schema

133133before being run and the schema after. We can compose definitions using `>>>`.

134134Here and in the rest of our commands we make use of overloaded

@@ -138,7 +138,7 @@ labels to refer to named tables and columns in our schema.

138138>>> :{

139139let

140140 setup :: Definition '[] Schema

141− setup =

141+ setup =

142142 createTable #users

143143 ( serial `as` #id :*

144144 (text & notNullable) `as` #name )

@@ -254,7 +254,7 @@ Let's also create some users to add to the database.

254254>>> :{

255255let

256256 users :: [User]

257− users =

257+ users =

258258 [ User "Alice" (Just "alice@gmail.com")

259259 , User "Bob" Nothing

260260 , User "Carole" (Just "carole@hotmail.com")

@@ -280,7 +280,7 @@ let

280280 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))

281281 usersResult <- runQuery getUsers

282282 usersRows <- getRows usersResult

283− liftBase $ print (usersRows :: [User])

283+ liftIO $ print (usersRows :: [User])

284284in

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

286286 define setup

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

@@ -12,7 +12,7 @@

1212module Main (main, main2) where

1313

1414import Control.Monad (void)

15−import Control.Monad.Base (liftBase, MonadBase)

15+import Control.Monad.IO.Class (MonadIO (..))

1616import Data.Int (Int16, Int32)

1717import Data.Monoid ((<>))

1818import Data.Text (Text)

@@ -84,22 +84,22 @@ instance SOP.Generic User

8484instance SOP.HasDatatypeInfo User

8585

8686users :: [User]

87−users =

87+users =

8888 [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])

8989 , User "Bob" Nothing (VarArray [Just 2, Nothing])

9090 , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])

9191 ]

9292

93−session :: (MonadBase IO pq, MonadPQ Schemas pq) => pq ()

93+session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()

9494session = do

95− liftBase $ Char8.putStrLn "manipulating"

95+ liftIO $ Char8.putStrLn "manipulating"

9696 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])

9797 ids <- traverse (fmap fromOnly . getRow 0) idResults

9898 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))

99− liftBase $ Char8.putStrLn "querying"

99+ liftIO $ Char8.putStrLn "querying"

100100 usersResult <- runQuery getUsers

101101 usersRows <- getRows usersResult

102− liftBase $ print (usersRows :: [User])

102+ liftIO $ print (usersRows :: [User])

103103

104104main :: IO ()

105105main = do

squeal-postgresql/squeal-postgresql.cabal+2−5

@@ -43,9 +43,7 @@ library

4343 , bytestring-strict-builder >= 0.4.5

4444 , deepseq >= 1.4.3.0

4545 , generics-sop >= 0.3.2.0

46− , lifted-base >= 0.2.3.12

4746 , mmorph >= 1.1.1

48− , monad-control >= 1.0.2.3

4947 , mtl >= 2.2.2

5048 , network-ip >= 0.3.0.2

5149 , postgresql-binary >= 0.12.1

@@ -56,7 +54,8 @@ library

5654 , text >= 1.2.3.0

5755 , time >= 1.8.0.2

5856 , transformers >= 0.5.2.0

59− , transformers-base >= 0.4.4

57+ , unliftio >= 0.2.10

58+ , unliftio-pool >= 0.2.1.0

6059 , uuid-types >= 1.0.3

6160 , vector >= 0.12.0.1

6261

@@ -85,7 +84,6 @@ test-suite squeal-postgresql-specs

8584 , squeal-postgresql

8685 , text >= 1.2.2.2

8786 , transformers >= 0.5.2.0

88− , transformers-base >= 0.4.4

8987 , vector >= 0.12.0.1

9088

9189executable squeal-postgresql-example

@@ -101,5 +99,4 @@ executable squeal-postgresql-example

10199 , squeal-postgresql

102100 , text >= 1.2.2.2

103101 , transformers >= 0.5.2.0

104− , transformers-base >= 0.4.4

105102 , vector >= 0.12.0.1

squeal-postgresql/src/Squeal/PostgreSQL.hs+6−6

@@ -17,7 +17,7 @@ features.

1717We'll need some imports.

1818

1919>>> import Control.Monad (void)

20−>>> import Control.Monad.Base (liftBase)

20+>>> import Control.Monad.IO.Class (liftIO)

2121>>> import Data.Int (Int32)

2222>>> import Data.Text (Text)

2323>>> import Squeal.PostgreSQL

@@ -60,7 +60,7 @@ yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,

6060yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator

6161

6262Next, we'll write `Definition`s to set up and tear down the schema. In

63−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

63+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

6464has two type parameters, corresponding to the schema

6565before being run and the schema after. We can compose definitions using `>>>`.

6666Here and in the rest of our commands we make use of overloaded

@@ -69,7 +69,7 @@ labels to refer to named tables and columns in our schema.

6969>>> :{

7070let

7171 setup :: Definition (Public '[]) Schemas

72− setup =

72+ setup =

7373 createTable #users

7474 ( serial `as` #id :*

7575 (text & notNullable) `as` #name )

@@ -119,7 +119,7 @@ We'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and

119119`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows

120120we receive when we run @getUsers@. Notice that the record fields of the

121121@User@ type match the column names of @getUsers@.

122−

122+

123123>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)

124124>>> instance SOP.Generic User

125125>>> instance SOP.HasDatatypeInfo User

@@ -162,7 +162,7 @@ Let's create some users to add to the database.

162162>>> :{

163163let

164164 users :: [User]

165− users =

165+ users =

166166 [ User "Alice" (Just "alice@gmail.com")

167167 , User "Bob" Nothing

168168 , User "Carole" (Just "carole@hotmail.com")

@@ -184,7 +184,7 @@ let

184184 _ <- traversePrepared_ insertUser users

185185 usersResult <- runQuery getUsers

186186 usersRows <- getRows usersResult

187− liftBase $ print (usersRows :: [User])

187+ liftIO $ print (usersRows :: [User])

188188in

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

190190 define setup

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+6−6

@@ -16,7 +16,7 @@ Let's see some examples. We'll need some imports

1616>>> import Data.Int (Int16)

1717>>> import Data.Text (Text)

1818>>> import Control.Monad (void)

19−>>> import Control.Monad.Base (liftBase)

19+>>> import Control.Monad.IO.Class (liftIO)

2020>>> import Squeal.PostgreSQL

2121

2222Define a Haskell datatype @Row@ that will serve as both the input and output of a simple

@@ -42,7 +42,7 @@ the input and output should be equal.

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

4343 result <- runQueryParams roundTrip input

4444 Just output <- firstRow result

45− liftBase . print $ input == output

45+ liftIO . print $ input == output

4646:}

4747True

4848

@@ -81,7 +81,7 @@ let

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

8282 result <- runQueryParams roundTrip input

8383 Just output <- firstRow result

84− liftBase . print $ input == output

84+ liftIO . print $ input == output

8585:}

8686True

8787

@@ -168,7 +168,7 @@ let

168168 session = do

169169 result <- runQueryParams roundTrip input

170170 Just output <- firstRow result

171− liftBase . print $ input == output

171+ liftIO . print $ input == output

172172in

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

174174 define setup

@@ -723,7 +723,7 @@ of the number of cents, i.e. @$2,000.20@ would be expressed as

723723@Money { cents = 200020 }@.

724724

725725>>> import Control.Monad (void)

726−>>> import Control.Monad.Base (liftBase)

726+>>> import Control.Monad.IO.Class (liftIO)

727727>>> import Squeal.PostgreSQL

728728>>> :{

729729let

@@ -737,7 +737,7 @@ let

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

738738 result <- runQueryParams roundTrip input

739739 Just output <- firstRow result

740− liftBase . print $ input == output

740+ liftIO . print $ input == output

741741:}

742742True

743743-}

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+13−14

@@ -73,7 +73,7 @@ let

7373 numMigrations = do

7474 result <- runQuery (select Star (from (table (#migrations ! #schema_migrations `as` #m))))

7575 num <- ntuples result

76− liftBase $ print num

76+ liftIO $ print num

7777:}

7878

7979>>> :{

@@ -115,8 +115,6 @@ module Squeal.PostgreSQL.Migration

115115 ) where

116116

117117import Control.Monad

118−import Control.Monad.Base

119−import Control.Monad.Trans.Control

120118import Data.ByteString (ByteString)

121119import Data.Foldable (traverse_)

122120import Data.Function ((&))

@@ -129,6 +127,7 @@ import qualified Generics.SOP as SOP

129127import qualified GHC.Generics as GHC

130128import Squeal.PostgreSQL

131129import System.Environment

130+import UnliftIO (MonadUnliftIO, MonadIO (..))

132131

133132-- | A `Migration` should contain an inverse pair of

134133-- `up` and `down` instructions and a unique `name`.

@@ -144,7 +143,7 @@ data Migration io schemas0 schemas1 = Migration

144143-- query to see if the `Migration` is executed. If not, then

145144-- execute the `Migration` and insert its row in the `MigrationsTable`.

146145migrateUp

147− :: MonadBaseControl IO io

146+ :: MonadUnliftIO io

148147 => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run

149148 -> PQ

150149 ("migrations" ::: MigrationsSchema ': schemas0)

@@ -157,7 +156,7 @@ migrateUp migration =

157156 where

158157

159158 upMigrations

160− :: MonadBaseControl IO io

159+ :: MonadUnliftIO io

161160 => AlignedList (Migration io) schemas0 schemas1

162161 -> PQ

163162 ("migrations" ::: MigrationsSchema ': schemas0)

@@ -168,7 +167,7 @@ migrateUp migration =

168167 step :>> steps -> upMigration step & pqThen (upMigrations steps)

169168

170169 upMigration

171− :: MonadBase IO io

170+ :: MonadIO io

172171 => Migration io schemas0 schemas1 -> PQ

173172 ("migrations" ::: MigrationsSchema ': schemas0)

174173 ("migrations" ::: MigrationsSchema ': schemas1)

@@ -185,7 +184,7 @@ migrateUp migration =

185184 & pqBind okResult)

186185

187186 queryExecuted

188− :: MonadBase IO io

187+ :: MonadIO io

189188 => Migration io schemas0 schemas1 -> PQ

190189 ("migrations" ::: MigrationsSchema ': schemas0)

191190 ("migrations" ::: MigrationsSchema ': schemas0)

@@ -200,7 +199,7 @@ migrateUp migration =

200199-- query to see if the `Migration` is executed. If it is, then

201200-- rewind the `Migration` and delete its row in the `MigrationsTable`.

202201migrateDown

203− :: MonadBaseControl IO io

202+ :: MonadUnliftIO io

204203 => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind

205204 -> PQ

206205 ("migrations" ::: MigrationsSchema ': schemas1)

@@ -213,7 +212,7 @@ migrateDown migrations =

213212 where

214213

215214 downMigrations

216− :: MonadBaseControl IO io

215+ :: MonadUnliftIO io

217216 => AlignedList (Migration io) schemas0 schemas1 -> PQ

218217 ("migrations" ::: MigrationsSchema ': schemas1)

219218 ("migrations" ::: MigrationsSchema ': schemas0)

@@ -223,7 +222,7 @@ migrateDown migrations =

223222 step :>> steps -> downMigrations steps & pqThen (downMigration step)

224223

225224 downMigration

226− :: MonadBase IO io

225+ :: MonadIO io

227226 => Migration io schemas0 schemas1 -> PQ

228227 ("migrations" ::: MigrationsSchema ': schemas1)

229228 ("migrations" ::: MigrationsSchema ': schemas0)

@@ -240,7 +239,7 @@ migrateDown migrations =

240239 & pqBind okResult)

241240

242241 queryExecuted

243− :: MonadBase IO io

242+ :: MonadIO io

244243 => Migration io schemas0 schemas1 -> PQ

245244 ("migrations" ::: MigrationsSchema ': schemas1)

246245 ("migrations" ::: MigrationsSchema ': schemas1)

@@ -250,7 +249,7 @@ migrateDown migrations =

250249 okResult result

251250 ntuples result

252251

253−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()

252+okResult :: MonadIO io => K Result results -> PQ schema schema io ()

254253okResult result = do

255254 status <- resultStatus result

256255 when (not (status `elem` [CommandOk, TuplesOk])) $ do

@@ -355,7 +354,7 @@ displayUsage = do

355354

356355type RunMigrationName = Text

357356

358−getRunMigrationNames :: (MonadBase IO m) => PQ db0 db0 m [RunMigrationName]

357+getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [RunMigrationName]

359358getRunMigrationNames =

360359 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery fetchAllMigrations)) >>= getRows)

361360

@@ -388,7 +387,7 @@ performCommand connectTo migrations Display =

388387 runNames <- getRunMigrationNames

389388 let names = extractList name migrations

390389 unrunNames = names \\ runNames

391− liftBase $ displayRunned runNames >> displayUnrunned unrunNames

390+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames

392391performCommand connectTo migrations AllUp =

393392 withConnection connectTo (migrateUp migrations)

394393 >> performCommand connectTo migrations Display

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+42−44

@@ -24,6 +24,7 @@ of executing Squeal commands.

2424 , FunctionalDependencies

2525 , FlexibleContexts

2626 , FlexibleInstances

27+ , InstanceSigs

2728 , OverloadedStrings

2829 , RankNTypes

2930 , ScopedTypeVariables

@@ -69,11 +70,10 @@ module Squeal.PostgreSQL.PQ

6970 , handleSqueal

7071 ) where

7172

72−import Control.Exception.Lifted

73−import Control.Monad.Base

73+import Control.Exception (Exception, throw)

7474import Control.Monad.Except

7575import Control.Monad.Morph

76−import Control.Monad.Trans.Control

76+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle)

7777import Data.ByteString (ByteString)

7878import Data.Foldable

7979import Data.Function ((&))

@@ -132,19 +132,19 @@ with the wrong schema!

132132-}

133133connectdb

134134 :: forall schemas io

135− . MonadBase IO io

135+ . MonadIO io

136136 => ByteString -- ^ conninfo

137137 -> io (K LibPQ.Connection schemas)

138−connectdb = fmap K . liftBase . LibPQ.connectdb

138+connectdb = fmap K . liftIO . LibPQ.connectdb

139139

140140-- | Closes the connection to the server.

141−finish :: MonadBase IO io => K LibPQ.Connection schemas -> io ()

142−finish = liftBase . LibPQ.finish . unK

141+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()

142+finish = liftIO . LibPQ.finish . unK

143143

144144-- | Do `connectdb` and `finish` before and after a computation.

145145withConnection

146146 :: forall schemas0 schemas1 io x

147− . MonadBaseControl IO io

147+ . MonadUnliftIO io

148148 => ByteString

149149 -> PQ schemas0 schemas1 io x

150150 -> io x

@@ -253,7 +253,7 @@ class IndexedMonadTransPQ pq where

253253 --

254254 -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

255255 define

256− :: MonadBase IO io

256+ :: MonadIO io

257257 => Definition schemas0 schemas1

258258 -> pq schemas0 schemas1 io (K LibPQ.Result '[])

259259

@@ -273,7 +273,7 @@ instance IndexedMonadTransPQ PQ where

273273 return $ K x

274274

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

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

276+ resultMaybe <- liftIO $ LibPQ.exec conn q

277277 case resultMaybe of

278278 Nothing -> throw $ ResultException

279279 "define: LibPQ.exec returned no results"

@@ -392,7 +392,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

392392 => (LibPQ.Connection -> IO a) -> pq a

393393 liftPQ = lift . liftPQ

394394

395−instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)

395+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

396396 => MonadPQ schemas (PQ schemas0 schemas1 io) where

397397

398398 manipulateParams

@@ -403,7 +403,7 @@ instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)

403403 (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)

404404 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

405405 q' = q <> ";"

406− resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary

406+ resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary

407407 case resultMaybe of

408408 Nothing -> throw $ ResultException

409409 "manipulateParams: LibPQ.execParams returned no results"

@@ -413,7 +413,7 @@ instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)

413413

414414 traversePrepared

415415 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =

416− PQ $ \ (K conn) -> liftBase $ do

416+ PQ $ \ (K conn) -> liftIO $ do

417417 let temp = "temporary_statement"

418418 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

419419 case prepResultMaybe of

@@ -440,7 +440,7 @@ instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)

440440

441441 traversePrepared_

442442 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =

443− PQ $ \ (K conn) -> liftBase $ do

443+ PQ $ \ (K conn) -> liftIO $ do

444444 let temp = "temporary_statement"

445445 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

446446 case prepResultMaybe of

@@ -464,7 +464,7 @@ instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)

464464 return (K ())

465465

466466 liftPQ pq = PQ $ \ (K conn) -> do

467− y <- liftBase $ pq conn

467+ y <- liftIO $ pq conn

468468 return (K y)

469469

470470instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)

@@ -505,14 +505,19 @@ instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where

505505 embed f (PQ pq) = PQ $ \ conn -> do

506506 evalPQ (f (pq conn)) conn

507507

508−instance (MonadBase b m, schemas0 ~ schemas1)

509− => MonadBase b (PQ schemas0 schemas1 m) where

510− liftBase = lift . liftBase

511−

512508instance (MonadIO m, schema0 ~ schema1)

513509 => MonadIO (PQ schema0 schema1 m) where

514510 liftIO = lift . liftIO

515511

512+instance (MonadUnliftIO m, schemas0 ~ schemas1)

513+ => MonadUnliftIO (PQ schemas0 schemas1 m) where

514+ withRunInIO

515+ :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)

516+ -> PQ schemas0 schema1 m b

517+ withRunInIO inner = PQ $ \conn ->

518+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->

519+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn)

520+

516521-- | A snapshot of the state of a `PQ` computation.

517522type PQRun schemas =

518523 forall m x. Monad m => PQ schemas schemas m x -> m (K x schemas)

@@ -522,23 +527,16 @@ pqliftWith :: Functor m => (PQRun schemas -> m a) -> PQ schemas schemas m a

522527pqliftWith f = PQ $ \ conn ->

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

524529

525−instance (MonadBaseControl b m, schemas0 ~ schemas1)

526− => MonadBaseControl b (PQ schemas0 schemas1 m) where

527− type StM (PQ schemas0 schemas1 m) x = StM m (K x schemas0)

528− liftBaseWith f =

529− pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

530− restoreM = PQ . const . restoreM

531−

532530-- | Get a row corresponding to a given row number from a `LibPQ.Result`,

533531-- throwing an exception if the row number is out of bounds.

534532getRow

535− :: (FromRow columns y, MonadBase IO io)

533+ :: (FromRow columns y, MonadIO io)

536534 => LibPQ.Row

537535 -- ^ row number

538536 -> K LibPQ.Result columns

539537 -- ^ result

540538 -> io y

541−getRow r (K result :: K LibPQ.Result columns) = liftBase $ do

539+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do

542540 numRows <- LibPQ.ntuples result

543541 when (numRows < r) $ throw $ ResultException $

544542 "getRow: expected at least " <> pack (show r) <> "rows but only saw "

@@ -556,13 +554,13 @@ getRow r (K result :: K LibPQ.Result columns) = liftBase $ do

556554-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,

557555-- otherwise returning the row along with the next row number.

558556nextRow

559− :: (FromRow columns y, MonadBase IO io)

557+ :: (FromRow columns y, MonadIO io)

560558 => LibPQ.Row -- ^ total number of rows

561559 -> K LibPQ.Result columns -- ^ result

562560 -> LibPQ.Row -- ^ row number

563561 -> io (Maybe (LibPQ.Row,y))

564562nextRow total (K result :: K LibPQ.Result columns) r

565− = liftBase $ if r >= total then return Nothing else do

563+ = liftIO $ if r >= total then return Nothing else do

566564 let len = fromIntegral (lengthSList (Proxy @columns))

567565 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

568566 case fromList row' of

@@ -573,10 +571,10 @@ nextRow total (K result :: K LibPQ.Result columns) r

573571

574572-- | Get all rows from a `LibPQ.Result`.

575573getRows

576− :: (FromRow columns y, MonadBase IO io)

574+ :: (FromRow columns y, MonadIO io)

577575 => K LibPQ.Result columns -- ^ result

578576 -> io [y]

579−getRows (K result :: K LibPQ.Result columns) = liftBase $ do

577+getRows (K result :: K LibPQ.Result columns) = liftIO $ do

580578 let len = fromIntegral (lengthSList (Proxy @columns))

581579 numRows <- LibPQ.ntuples result

582580 for [0 .. numRows - 1] $ \ r -> do

@@ -589,10 +587,10 @@ getRows (K result :: K LibPQ.Result columns) = liftBase $ do

589587

590588-- | Get the first row if possible from a `LibPQ.Result`.

591589firstRow

592− :: (FromRow columns y, MonadBase IO io)

590+ :: (FromRow columns y, MonadIO io)

593591 => K LibPQ.Result columns -- ^ result

594592 -> io (Maybe y)

595−firstRow (K result :: K LibPQ.Result columns) = liftBase $ do

593+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do

596594 numRows <- LibPQ.ntuples result

597595 if numRows <= 0 then return Nothing else do

598596 let len = fromIntegral (lengthSList (Proxy @columns))

@@ -605,23 +603,23 @@ firstRow (K result :: K LibPQ.Result columns) = liftBase $ do

605603

606604-- | Lifts actions on results from @LibPQ@.

607605liftResult

608− :: MonadBase IO io

606+ :: MonadIO io

609607 => (LibPQ.Result -> IO x)

610608 -> K LibPQ.Result results -> io x

611−liftResult f (K result) = liftBase $ f result

609+liftResult f (K result) = liftIO $ f result

612610

613611-- | Returns the number of rows (tuples) in the query result.

614−ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row

612+ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row

615613ntuples = liftResult LibPQ.ntuples

616614

617615-- | Returns the result status of the command.

618−resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus

616+resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus

619617resultStatus = liftResult LibPQ.resultStatus

620618

621619-- | Returns the error message most recently generated by an operation

622620-- on the connection.

623621resultErrorMessage

624− :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)

622+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)

625623resultErrorMessage = liftResult LibPQ.resultErrorMessage

626624

627625-- | Returns the error code most recently generated by an operation

@@ -629,7 +627,7 @@ resultErrorMessage = liftResult LibPQ.resultErrorMessage

629627--

630628-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html

631629resultErrorCode

632− :: MonadBase IO io

630+ :: MonadIO io

633631 => K LibPQ.Result results

634632 -> io (Maybe ByteString)

635633resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)

@@ -648,10 +646,10 @@ data SquealException

648646instance Exception SquealException

649647

650648tryResult

651− :: MonadBase IO io

649+ :: MonadIO io

652650 => LibPQ.Result

653651 -> io ()

654−tryResult result = liftBase $ do

652+tryResult result = liftIO $ do

655653 status <- LibPQ.resultStatus result

656654 case status of

657655 LibPQ.CommandOk -> return ()

@@ -663,7 +661,7 @@ tryResult result = liftBase $ do

663661

664662-- | Catch `SquealException`s.

665663catchSqueal

666− :: MonadBaseControl IO io

664+ :: MonadUnliftIO io

667665 => io a

668666 -> (SquealException -> io a) -- ^ handler

669667 -> io a

@@ -671,7 +669,7 @@ catchSqueal = catch

671669

672670-- | Handle `SquealException`s.

673671handleSqueal

674− :: MonadBaseControl IO io

672+ :: MonadUnliftIO io

675673 => (SquealException -> io a) -- ^ handler

676674 -> io a -> io a

677675handleSqueal = handle

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+21−17

@@ -12,6 +12,7 @@ A `MonadPQ` for pooled connections.

1212 DeriveFunctor

1313 , FlexibleContexts

1414 , FlexibleInstances

15+ , InstanceSigs

1516 , MultiParamTypeClasses

1617 , RankNTypes

1718 , ScopedTypeVariables

@@ -30,13 +31,12 @@ module Squeal.PostgreSQL.Pool

3031 , poolpqliftWith

3132 ) where

3233

33−import Control.Monad.Base

3434import Control.Monad.Trans

35−import Control.Monad.Trans.Control

3635import Data.ByteString

37−import Data.Pool

3836import Data.Time

3937import Generics.SOP (K(..))

38+import UnliftIO (MonadUnliftIO (..))

39+import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)

4040

4141import qualified Control.Monad.Fail as Fail

4242

@@ -72,7 +72,7 @@ newtype PoolPQ (schemas :: SchemasType) m x =

7272-- | Create a striped pool of connections.

7373-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.

7474createConnectionPool

75− :: MonadBase IO io

75+ :: MonadUnliftIO io

7676 => ByteString

7777 -- ^ The passed string can be empty to use all default parameters, or it can

7878 -- contain one or more parameter settings separated by whitespace.

@@ -89,7 +89,7 @@ createConnectionPool

8989 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.

9090 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.

9191 -> io (Pool (K Connection schemas))

92−createConnectionPool conninfo stripes idle maxResrc = liftBase $

92+createConnectionPool conninfo stripes idle maxResrc =

9393 createPool (connectdb conninfo) finish stripes idle maxResrc

9494

9595-- | `Applicative` instance for `PoolPQ`.

@@ -115,12 +115,8 @@ instance Monad m => Fail.MonadFail (PoolPQ schemas m) where

115115instance MonadTrans (PoolPQ schemas) where

116116 lift m = PoolPQ $ \ _pool -> m

117117

118−-- | `MonadBase` instance for `PoolPQ`.

119−instance MonadBase b m => MonadBase b (PoolPQ schemas m) where

120− liftBase = lift . liftBase

121−

122118-- | `MonadPQ` instance for `PoolPQ`.

123−instance MonadBaseControl IO io => MonadPQ schemas (PoolPQ schemas io) where

119+instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where

124120 manipulateParams manipulation params = PoolPQ $ \ pool -> do

125121 withResource pool $ \ conn -> do

126122 (K result :: K (K Result ys) schemas) <- flip unPQ conn $

@@ -142,6 +138,21 @@ instance MonadBaseControl IO io => MonadPQ schemas (PoolPQ schemas io) where

142138 liftPQ m

143139 return result

144140

141+-- | 'MonadIO' instance for 'PoolPQ'.

142+instance (MonadIO m)

143+ => MonadIO (PoolPQ schemas m) where

144+ liftIO = lift . liftIO

145+

146+-- | 'MonadUnliftIO' instance for 'PoolPQ'.

147+instance (MonadUnliftIO m)

148+ => MonadUnliftIO (PoolPQ schemas m) where

149+ withRunInIO

150+ :: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)

151+ -> PoolPQ schemas m b

152+ withRunInIO inner = PoolPQ $ \pool ->

153+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->

154+ inner (\poolpq -> run $ runPoolPQ poolpq pool)

155+

145156-- | A snapshot of the state of a `PoolPQ` computation.

146157type PoolPQRun schemas =

147158 forall m x. Monad m => PoolPQ schemas m x -> m x

@@ -150,10 +161,3 @@ type PoolPQRun schemas =

150161poolpqliftWith :: Functor m => (PoolPQRun schemas -> m a) -> PoolPQ schemas m a

151162poolpqliftWith f = PoolPQ $ \ pool ->

152163 (f $ \ pq -> runPoolPQ pq pool)

153−

154−-- | `MonadBaseControl` instance for `PoolPQ`.

155−instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schemas m) where

156− type StM (PoolPQ schemas m) x = StM m x

157− liftBaseWith f =

158− poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

159− restoreM = PoolPQ . const . restoreM

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+3−3

@@ -38,7 +38,7 @@ module Squeal.PostgreSQL.Render

3838 , printSQL

3939 ) where

4040

41−import Control.Monad.Base

41+import Control.Monad.IO.Class (MonadIO (..))

4242import Data.ByteString (ByteString)

4343import Data.Maybe (catMaybes)

4444import Data.Monoid ((<>))

@@ -126,5 +126,5 @@ renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))

126126class RenderSQL sql where renderSQL :: sql -> ByteString

127127

128128-- | Print SQL.

129−printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io ()

130−printSQL = liftBase . Char8.putStrLn . renderSQL

129+printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()

130+printSQL = liftIO . Char8.putStrLn . renderSQL

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+8−10

@@ -34,10 +34,8 @@ module Squeal.PostgreSQL.Transaction

3434 , DeferrableMode (..)

3535 ) where

3636

37−import Control.Exception.Lifted

38−import Control.Monad.Base

39−import Control.Monad.Trans.Control

4037import Generics.SOP

38+import UnliftIO (MonadUnliftIO, liftIO, mask, onException)

4139

4240import qualified Database.PostgreSQL.LibPQ as LibPQ

4341

@@ -48,7 +46,7 @@ import Squeal.PostgreSQL.Schema

4846

4947-- | Run a schema invariant computation `transactionally`.

5048transactionally

51− :: (MonadBaseControl IO tx, MonadPQ schemas tx)

49+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

5250 => TransactionMode

5351 -> tx x -- ^ run inside a transaction

5452 -> tx x

@@ -60,7 +58,7 @@ transactionally mode tx = mask $ \restore -> do

6058

6159-- | Run a schema invariant computation `transactionally_` in `defaultMode`.

6260transactionally_

63− :: (MonadBaseControl IO tx, MonadPQ schemas tx)

61+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

6462 => tx x -- ^ run inside a transaction

6563 -> tx x

6664transactionally_ = transactionally defaultMode

@@ -80,21 +78,21 @@ rollback = manipulate $ UnsafeManipulation "ROLLBACK;"

8078

8179-- | Run a schema changing computation `transactionallySchema`.

8280transactionallySchema

83− :: MonadBaseControl IO io

81+ :: MonadUnliftIO io

8482 => TransactionMode

8583 -> PQ schemas0 schemas1 io x

8684 -> PQ schemas0 schemas1 io x

8785transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do

88− _ <- liftBase . LibPQ.exec (unK conn) $

86+ _ <- liftIO . LibPQ.exec (unK conn) $

8987 "BEGIN" <+> renderSQL mode <> ";"

9088 x <- restore (unPQ u conn)

91− `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))

92− _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"

89+ `onException` (liftIO (LibPQ.exec (unK conn) "ROLLBACK"))

90+ _ <- liftIO $ LibPQ.exec (unK conn) "COMMIT"

9391 return x

9492

9593-- | Run a schema changing computation `transactionallySchema_` in `defaultMode`.

9694transactionallySchema_

97− :: MonadBaseControl IO io

95+ :: MonadUnliftIO io

9896 => PQ schemas0 schemas1 io x

9997 -> PQ schemas0 schemas1 io x

10098transactionallySchema_ = transactionallySchema defaultMode

squeal-postgresql/test/Specs/ExceptionHandling.hs+3−3

@@ -16,7 +16,7 @@ module ExceptionHandling

1616where

1717

1818import Control.Monad (void)

19−import Control.Monad.Base (MonadBase)

19+import Control.Monad.IO.Class (MonadIO (..))

2020import qualified Data.ByteString.Char8 as Char8

2121import Data.Int (Int16)

2222import Data.Text (Text)

@@ -103,10 +103,10 @@ connectionString = "host=localhost port=5432 dbname=exampledb"

103103testUser :: User

104104testUser = User "TestUser" Nothing (VarArray [])

105105

106−newUser :: (MonadBase IO m, MonadPQ Schemas m) => User -> m ()

106+newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()

107107newUser u = void $ manipulateParams insertUser (userName u, userVec u)

108108

109−insertUserTwice :: (MonadBase IO m, MonadPQ Schemas m) => m ()

109+insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()

110110insertUserTwice = newUser testUser >> newUser testUser

111111

112112specs :: SpecWith ()

stack.yaml+3

@@ -1,3 +1,6 @@

11resolver: lts-13.8

22packages:

33- squeal-postgresql

5+extra-deps:

6+- unliftio-pool-0.2.1.0