1393a44 · squeal · git.iko.soy

git.iko.soy/squeal

unliftio

commit1393a44f0f389e4145b35c8b517f80bf79a6c2a0 authorEitan Chatav <eitan@Eitans-MacBook-Pro.local> dateWed 27 Mar 2019, 09:04 (8 years ago) parentaadced8 21747db

12 files changed+118−109

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−4 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−4

@@ -63,7 +63,16 @@ Now that we have a couple migrations we can chain them together.

6363

6464>>> let migrations = makeUsers :>> makeEmails :>> Done

6565

66−Finally, we can run the migration and even roll it back.

66+>>> :{

67+let

68+ numMigrations

69+ :: Has "migrations" schemas MigrationsSchema

70+ => PQ schemas schemas IO ()

71+ numMigrations = do

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

73+ num <- ntuples result

74+ liftIO $ print num

75+:}

6776

6877>>> import Control.Monad.IO.Class

6978>>> :{

@@ -145,7 +154,6 @@ module Squeal.PostgreSQL.Migration

145154

146155import Control.Category

147156import Control.Monad

148−import Control.Monad.Base

149157import Data.ByteString (ByteString)

150158import Data.Foldable (traverse_)

151159import Data.Function ((&))

@@ -159,6 +167,7 @@ import qualified GHC.Generics as GHC

159167import Prelude hiding ((.), id)

160168import Squeal.PostgreSQL

161169import System.Environment

170+import UnliftIO (MonadIO (..))

162171

163172-- | A `Migration` is a named "isomorphism" over a given category.

164173-- It should contain an inverse pair of `up` and `down`

@@ -382,7 +391,7 @@ defaultMain connectTo migrations = do

382391 runNames <- getRunMigrationNames

383392 let names = extractList name migrations

384393 unrunNames = names \\ runNames

385− liftBase $ displayRunned runNames >> displayUnrunned unrunNames

394+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames

386395

387396 suppressNotices :: PQ schema schema IO ()

388397 suppressNotices = void . manipulate $

@@ -402,7 +411,7 @@ defaultMain connectTo migrations = do

402411 putStrLn "rollback to rollback all available migrations"

403412 putStrLn "status to display migrations run and migrations left to run"

404413

405− getRunMigrationNames :: (MonadBase IO m) => PQ db0 db0 m [Text]

414+ getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]

406415 getRunMigrationNames =

407416 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)

408417

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

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

246246 --

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

248248 define

249− :: MonadBase IO io

249+ :: MonadIO io

250250 => Definition schemas0 schemas1

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

252252

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

262262 unPQ (f x') (K (unK conn))

263263

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

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

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

266266 case resultMaybe of

267267 Nothing -> throw $ ResultException

268268 "define: LibPQ.exec returned no results"

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

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

382382 liftPQ = lift . liftPQ

383383

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

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

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

386386

387387 manipulateParams

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

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

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

394394 q' = q <> ";"

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

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

396396 case resultMaybe of

397397 Nothing -> throw $ ResultException

398398 "manipulateParams: LibPQ.execParams returned no results"

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

402402

403403 traversePrepared

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

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

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

406406 let temp = "temporary_statement"

407407 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

408408 case prepResultMaybe of

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

429429

430430 traversePrepared_

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

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

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

433433 let temp = "temporary_statement"

434434 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

435435 case prepResultMaybe of

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

453453 return (K ())

454454

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

456− y <- liftBase $ pq conn

456+ y <- liftIO $ pq conn

457457 return (K y)

458458

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

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

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

495495 evalPQ (f (pq conn)) conn

496496

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

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

499− liftBase = lift . liftBase

500−

501497instance (MonadIO m, schema0 ~ schema1)

502498 => MonadIO (PQ schema0 schema1 m) where

503499 liftIO = lift . liftIO

504500

501+instance (MonadUnliftIO m, schemas0 ~ schemas1)

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

503+ withRunInIO

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

505+ -> PQ schemas0 schema1 m b

506+ withRunInIO inner = PQ $ \conn ->

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

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

509+

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

506511type PQRun schemas =

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

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

511516pqliftWith f = PQ $ \ conn ->

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

513518

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

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

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

517− liftBaseWith f =

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

519− restoreM = PQ . const . restoreM

520−

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

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

523521getRow

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

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

525523 => LibPQ.Row

526524 -- ^ row number

527525 -> K LibPQ.Result columns

528526 -- ^ result

529527 -> io y

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

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

531529 numRows <- LibPQ.ntuples result

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

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

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

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

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

547545nextRow

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

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

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

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

551549 -> LibPQ.Row -- ^ row number

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

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

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

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

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

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

557555 case fromList row' of

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

562560

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

564562getRows

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

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

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

567565 -> io [y]

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

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

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

570568 numRows <- LibPQ.ntuples result

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

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

578576

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

580578firstRow

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

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

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

583581 -> io (Maybe y)

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

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

585583 numRows <- LibPQ.ntuples result

586584 if numRows <= 0 then return Nothing else do

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

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

594592

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

596594liftResult

597− :: MonadBase IO io

595+ :: MonadIO io

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

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

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

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

601599

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

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

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

604602ntuples = liftResult LibPQ.ntuples

605603

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

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

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

608606resultStatus = liftResult LibPQ.resultStatus

609607

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

611609-- on the connection.

612610resultErrorMessage

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

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

614612resultErrorMessage = liftResult LibPQ.resultErrorMessage

615613

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

@@ -618,7 +616,7 @@ resultErrorMessage = liftResult LibPQ.resultErrorMessage

618616--

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

620618resultErrorCode

621− :: MonadBase IO io

619+ :: MonadIO io

622620 => K LibPQ.Result results

623621 -> io (Maybe ByteString)

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

@@ -637,10 +635,10 @@ data SquealException

637635instance Exception SquealException

638636

639637tryResult

640− :: MonadBase IO io

638+ :: MonadIO io

641639 => LibPQ.Result

642640 -> io ()

643−tryResult result = liftBase $ do

641+tryResult result = liftIO $ do

644642 status <- LibPQ.resultStatus result

645643 case status of

646644 LibPQ.CommandOk -> return ()

@@ -652,7 +650,7 @@ tryResult result = liftBase $ do

652650

653651-- | Catch `SquealException`s.

654652catchSqueal

655− :: MonadBaseControl IO io

653+ :: MonadUnliftIO io

656654 => io a

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

658656 -> io a

@@ -660,7 +658,7 @@ catchSqueal = catch

660658

661659-- | Handle `SquealException`s.

662660handleSqueal

663− :: MonadBaseControl IO io

661+ :: MonadUnliftIO io

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

665663 -> io a -> io a

666664handleSqueal = 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