21747db · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

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

21747dbEitan Chatav8 years ago

README.md+5−5

compare with dev

unifiedsplit

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

81```Haskell

82>>> import Control.Monad (void)

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

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

84>>> import Data.Int (Int32)

85>>> import Data.Text (Text)

86>>> import Squeal.PostgreSQL

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

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

129

130Next, 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`

132has two type parameters, corresponding to the schema

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

134Here 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.

138>>> :{

139let

140 setup :: Definition '[] Schema

141− setup =

141+ setup =

142 createTable #users

143 ( serial `as` #id :*

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

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

254>>> :{

255let

256 users :: [User]

257− users =

257+ users =

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

259 , User "Bob" Nothing

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

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

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

281 usersResult <- runQuery getUsers

282 usersRows <- getRows usersResult

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

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

284in

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

286 define setup

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

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

12module Main (main, main2) where

14import Control.Monad (void)

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

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

16import Data.Int (Int16, Int32)

17import Data.Monoid ((<>))

18import Data.Text (Text)

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

84instance SOP.HasDatatypeInfo User

86users :: [User]

87−users =

87+users =

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

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

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

91 ]

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

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

94session = do

95− liftBase $ Char8.putStrLn "manipulating"

95+ liftIO $ Char8.putStrLn "manipulating"

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

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

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

99− liftBase $ Char8.putStrLn "querying"

99+ liftIO $ Char8.putStrLn "querying"

100 usersResult <- runQuery getUsers

101 usersRows <- getRows usersResult

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

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

103

104main :: IO ()

105main = do

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

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

43 , bytestring-strict-builder >= 0.4.5

44 , deepseq >= 1.4.3.0

45 , generics-sop >= 0.3.2.0

46− , lifted-base >= 0.2.3.12

47 , mmorph >= 1.1.1

46 , mmorph >= 1.1.1

48− , monad-control >= 1.0.2.3

49 , mtl >= 2.2.2

47 , mtl >= 2.2.2

50 , network-ip >= 0.3.0.2

48 , network-ip >= 0.3.0.2

51 , postgresql-binary >= 0.12.1

49 , postgresql-binary >= 0.12.1

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

56 , text >= 1.2.3.0

54 , text >= 1.2.3.0

57 , time >= 1.8.0.2

55 , time >= 1.8.0.2

58 , transformers >= 0.5.2.0

56 , transformers >= 0.5.2.0

59− , transformers-base >= 0.4.4

57+ , unliftio >= 0.2.10

58+ , unliftio-pool >= 0.2.1.0

60 , uuid-types >= 1.0.3

59 , uuid-types >= 1.0.3

61 , vector >= 0.12.0.1

60 , vector >= 0.12.0.1

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

85 , squeal-postgresql

84 , squeal-postgresql

86 , text >= 1.2.2.2

85 , text >= 1.2.2.2

87 , transformers >= 0.5.2.0

86 , transformers >= 0.5.2.0

88− , transformers-base >= 0.4.4

89 , vector >= 0.12.0.1

87 , vector >= 0.12.0.1

91executable squeal-postgresql-example

89executable squeal-postgresql-example

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

101 , squeal-postgresql

99 , squeal-postgresql

102 , text >= 1.2.2.2

100 , text >= 1.2.2.2

103 , transformers >= 0.5.2.0

101 , transformers >= 0.5.2.0

104− , transformers-base >= 0.4.4

105 , vector >= 0.12.0.1

102 , vector >= 0.12.0.1

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

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

17We'll need some imports.

19>>> import Control.Monad (void)

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

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

21>>> import Data.Int (Int32)

22>>> import Data.Text (Text)

23>>> import Squeal.PostgreSQL

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

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

62Next, 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`

64has two type parameters, corresponding to the schema

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

66Here 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.

69>>> :{

70let

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

72− setup =

72+ setup =

73 createTable #users

74 ( serial `as` #id :*

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

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

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

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

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

122−

122+

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

124>>> instance SOP.Generic User

125>>> instance SOP.HasDatatypeInfo User

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

162>>> :{

163let

164 users :: [User]

165− users =

165+ users =

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

167 , User "Bob" Nothing

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

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

184 _ <- traversePrepared_ insertUser users

185 usersResult <- runQuery getUsers

186 usersRows <- getRows usersResult

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

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

188in

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

190 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

16>>> import Data.Int (Int16)

17>>> import Data.Text (Text)

18>>> import Control.Monad (void)

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

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

20>>> import Squeal.PostgreSQL

22Define 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.

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

43 result <- runQueryParams roundTrip input

44 Just output <- firstRow result

45− liftBase . print $ input == output

45+ liftIO . print $ input == output

46:}

47True

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

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

82 result <- runQueryParams roundTrip input

83 Just output <- firstRow result

84− liftBase . print $ input == output

84+ liftIO . print $ input == output

85:}

86True

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

168 session = do

169 result <- runQueryParams roundTrip input

170 Just output <- firstRow result

171− liftBase . print $ input == output

171+ liftIO . print $ input == output

172in

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

174 define setup

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

723@Money { cents = 200020 }@.

724

725>>> import Control.Monad (void)

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

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

727>>> import Squeal.PostgreSQL

728>>> :{

729let

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

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

738 result <- runQueryParams roundTrip input

739 Just output <- firstRow result

740− liftBase . print $ input == output

740+ liftIO . print $ input == output

741:}

742True

743-}

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

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

73 numMigrations = do

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

75 num <- ntuples result

76− liftBase $ print num

76+ liftIO $ print num

77:}

79>>> :{

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

115 ) where

116

117import Control.Monad

118−import Control.Monad.Base

119−import Control.Monad.Trans.Control

120import Data.ByteString (ByteString)

118import Data.ByteString (ByteString)

121import Data.Foldable (traverse_)

119import Data.Foldable (traverse_)

122import Data.Function ((&))

120import Data.Function ((&))

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

129import qualified GHC.Generics as GHC

127import qualified GHC.Generics as GHC

130import Squeal.PostgreSQL

128import Squeal.PostgreSQL

131import System.Environment

129import System.Environment

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

132

131

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

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

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

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

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

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

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

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

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

146migrateUp

145migrateUp

147− :: MonadBaseControl IO io

146+ :: MonadUnliftIO io

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

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

149 -> PQ

148 -> PQ

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

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

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

157 where

156 where

158

157

159 upMigrations

158 upMigrations

160− :: MonadBaseControl IO io

159+ :: MonadUnliftIO io

161 => AlignedList (Migration io) schemas0 schemas1

160 => AlignedList (Migration io) schemas0 schemas1

162 -> PQ

161 -> PQ

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

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

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

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

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

169

168

170 upMigration

169 upMigration

171− :: MonadBase IO io

170+ :: MonadIO io

172 => Migration io schemas0 schemas1 -> PQ

171 => Migration io schemas0 schemas1 -> PQ

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

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

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

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

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

185 & pqBind okResult)

184 & pqBind okResult)

186

185

187 queryExecuted

186 queryExecuted

188− :: MonadBase IO io

187+ :: MonadIO io

189 => Migration io schemas0 schemas1 -> PQ

188 => Migration io schemas0 schemas1 -> PQ

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

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

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

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

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

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

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

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

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

202migrateDown

201migrateDown

203− :: MonadBaseControl IO io

202+ :: MonadUnliftIO io

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

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

205 -> PQ

204 -> PQ

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

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

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

213 where

212 where

214

213

215 downMigrations

214 downMigrations

216− :: MonadBaseControl IO io

215+ :: MonadUnliftIO io

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

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

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

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

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

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

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

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

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

224

223

225 downMigration

224 downMigration

226− :: MonadBase IO io

225+ :: MonadIO io

227 => Migration io schemas0 schemas1 -> PQ

226 => Migration io schemas0 schemas1 -> PQ

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

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

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

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

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

240 & pqBind okResult)

239 & pqBind okResult)

241

240

242 queryExecuted

241 queryExecuted

243− :: MonadBase IO io

242+ :: MonadIO io

244 => Migration io schemas0 schemas1 -> PQ

243 => Migration io schemas0 schemas1 -> PQ

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

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

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

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

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

250 okResult result

249 okResult result

251 ntuples result

250 ntuples result

252

251

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

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

254okResult result = do

253okResult result = do

255 status <- resultStatus result

254 status <- resultStatus result

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

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

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

355

354

356type RunMigrationName = Text

355type RunMigrationName = Text

357

356

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

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

359getRunMigrationNames =

358getRunMigrationNames =

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

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

361

360

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

388 runNames <- getRunMigrationNames

387 runNames <- getRunMigrationNames

389 let names = extractList name migrations

388 let names = extractList name migrations

390 unrunNames = names \\ runNames

389 unrunNames = names \\ runNames

391− liftBase $ displayRunned runNames >> displayUnrunned unrunNames

390+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames

392performCommand connectTo migrations AllUp =

391performCommand connectTo migrations AllUp =

393 withConnection connectTo (migrateUp migrations)

392 withConnection connectTo (migrateUp migrations)

394 >> performCommand connectTo migrations Display

393 >> performCommand connectTo migrations Display

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

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

24 , FunctionalDependencies

25 , FlexibleContexts

26 , FlexibleInstances

27+ , InstanceSigs

27 , OverloadedStrings

28 , OverloadedStrings

28 , RankNTypes

29 , RankNTypes

29 , ScopedTypeVariables

30 , ScopedTypeVariables

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

69 , handleSqueal

70 , handleSqueal

70 ) where

71 ) where

72−import Control.Exception.Lifted

73+import Control.Exception (Exception, throw)

73−import Control.Monad.Base

74import Control.Monad.Except

75import Control.Monad.Morph

76−import Control.Monad.Trans.Control

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

77import Data.ByteString (ByteString)

78import Data.Foldable

79import Data.Function ((&))

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

132-}

133connectdb

134 :: forall schemas io

135− . MonadBase IO io

135+ . MonadIO io

136 => ByteString -- ^ conninfo

137 -> io (K LibPQ.Connection schemas)

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

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

139

140-- | Closes the connection to the server.

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

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

142−finish = liftBase . LibPQ.finish . unK

142+finish = liftIO . LibPQ.finish . unK

143

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

145withConnection

146 :: forall schemas0 schemas1 io x

147− . MonadBaseControl IO io

147+ . MonadUnliftIO io

148 => ByteString

149 -> PQ schemas0 schemas1 io x

150 -> io x

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

253 --

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

255 define

256− :: MonadBase IO io

256+ :: MonadIO io

257 => Definition schemas0 schemas1

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

259

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

273 return $ K x

274

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

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

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

277 case resultMaybe of

278 Nothing -> throw $ ResultException

279 "define: LibPQ.exec returned no results"

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

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

393 liftPQ = lift . liftPQ

394

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

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

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

397

398 manipulateParams

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

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

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

405 q' = q <> ";"

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

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

407 case resultMaybe of

408 Nothing -> throw $ ResultException

409 "manipulateParams: LibPQ.execParams returned no results"

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

413

414 traversePrepared

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

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

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

417 let temp = "temporary_statement"

418 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

419 case prepResultMaybe of

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

440

441 traversePrepared_

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

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

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

444 let temp = "temporary_statement"

445 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

446 case prepResultMaybe of

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

464 return (K ())

465

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

467− y <- liftBase $ pq conn

467+ y <- liftIO $ pq conn

468 return (K y)

469

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

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

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

506 evalPQ (f (pq conn)) conn

507

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

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

510− liftBase = lift . liftBase

511−

512instance (MonadIO m, schema0 ~ schema1)

508instance (MonadIO m, schema0 ~ schema1)

513 => MonadIO (PQ schema0 schema1 m) where

509 => MonadIO (PQ schema0 schema1 m) where

514 liftIO = lift . liftIO

510 liftIO = lift . liftIO

515

511

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+

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

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

517type PQRun schemas =

522type PQRun schemas =

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

523 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

522pqliftWith f = PQ $ \ conn ->

527pqliftWith f = PQ $ \ conn ->

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

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

524

529

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−

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

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

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

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

534getRow

532getRow

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

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

536 => LibPQ.Row

534 => LibPQ.Row

537 -- ^ row number

535 -- ^ row number

538 -> K LibPQ.Result columns

536 -> K LibPQ.Result columns

539 -- ^ result

537 -- ^ result

540 -> io y

538 -> io y

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

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

542 numRows <- LibPQ.ntuples result

540 numRows <- LibPQ.ntuples result

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

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

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

542 "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

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

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

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

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

558nextRow

556nextRow

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

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

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

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

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

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

562 -> LibPQ.Row -- ^ row number

560 -> LibPQ.Row -- ^ row number

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

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

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

562nextRow 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

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

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

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

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

568 case fromList row' of

566 case fromList row' of

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

573

571

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

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

575getRows

573getRows

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

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

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

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

578 -> io [y]

576 -> io [y]

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

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

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

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

581 numRows <- LibPQ.ntuples result

579 numRows <- LibPQ.ntuples result

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

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

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

589

587

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

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

591firstRow

589firstRow

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

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

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

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

594 -> io (Maybe y)

592 -> io (Maybe y)

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

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

596 numRows <- LibPQ.ntuples result

594 numRows <- LibPQ.ntuples result

597 if numRows <= 0 then return Nothing else do

595 if numRows <= 0 then return Nothing else do

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

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

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

605

603

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

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

607liftResult

605liftResult

608− :: MonadBase IO io

606+ :: MonadIO io

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

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

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

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

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

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

612

610

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

611-- | 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

615ntuples = liftResult LibPQ.ntuples

613ntuples = liftResult LibPQ.ntuples

616

614

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

615-- | 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

619resultStatus = liftResult LibPQ.resultStatus

617resultStatus = liftResult LibPQ.resultStatus

620

618

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

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

622-- on the connection.

620-- on the connection.

623resultErrorMessage

621resultErrorMessage

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

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

625resultErrorMessage = liftResult LibPQ.resultErrorMessage

623resultErrorMessage = liftResult LibPQ.resultErrorMessage

626

624

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

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

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

629--

627--

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

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

631resultErrorCode

629resultErrorCode

632− :: MonadBase IO io

630+ :: MonadIO io

633 => K LibPQ.Result results

631 => K LibPQ.Result results

634 -> io (Maybe ByteString)

632 -> io (Maybe ByteString)

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

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

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

648instance Exception SquealException

646instance Exception SquealException

649

647

650tryResult

648tryResult

651− :: MonadBase IO io

649+ :: MonadIO io

652 => LibPQ.Result

650 => LibPQ.Result

653 -> io ()

651 -> io ()

654−tryResult result = liftBase $ do

652+tryResult result = liftIO $ do

655 status <- LibPQ.resultStatus result

653 status <- LibPQ.resultStatus result

656 case status of

654 case status of

657 LibPQ.CommandOk -> return ()

655 LibPQ.CommandOk -> return ()

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

663

661

664-- | Catch `SquealException`s.

662-- | Catch `SquealException`s.

665catchSqueal

663catchSqueal

666− :: MonadBaseControl IO io

664+ :: MonadUnliftIO io

667 => io a

665 => io a

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

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

669 -> io a

667 -> io a

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

671

669

672-- | Handle `SquealException`s.

670-- | Handle `SquealException`s.

673handleSqueal

671handleSqueal

674− :: MonadBaseControl IO io

672+ :: MonadUnliftIO io

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

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

676 -> io a -> io a

674 -> io a -> io a

677handleSqueal = handle

675handleSqueal = handle

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

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

12 DeriveFunctor

13 , FlexibleContexts

14 , FlexibleInstances

15+ , InstanceSigs

15 , MultiParamTypeClasses

16 , MultiParamTypeClasses

16 , RankNTypes

17 , RankNTypes

17 , ScopedTypeVariables

18 , ScopedTypeVariables

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

30 , poolpqliftWith

31 , poolpqliftWith

31 ) where

32 ) where

33−import Control.Monad.Base

34import Control.Monad.Trans

35−import Control.Monad.Trans.Control

36import Data.ByteString

35import Data.ByteString

37−import Data.Pool

38import Data.Time

36import Data.Time

39import Generics.SOP (K(..))

37import Generics.SOP (K(..))

38+import UnliftIO (MonadUnliftIO (..))

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

41import qualified Control.Monad.Fail as Fail

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

72-- | Create a striped pool of connections.

73-- 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.

74createConnectionPool

75− :: MonadBase IO io

75+ :: MonadUnliftIO io

76 => ByteString

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

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

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

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

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

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

92−createConnectionPool conninfo stripes idle maxResrc = liftBase $

92+createConnectionPool conninfo stripes idle maxResrc =

93 createPool (connectdb conninfo) finish stripes idle maxResrc

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

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

115instance MonadTrans (PoolPQ schemas) where

116 lift m = PoolPQ $ \ _pool -> m

117

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

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

120− liftBase = lift . liftBase

121−

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

118-- | `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

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

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

125 withResource pool $ \ conn -> do

121 withResource pool $ \ conn -> do

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

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

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

142 liftPQ m

138 liftPQ m

143 return result

139 return result

144

140

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+

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

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

146type PoolPQRun schemas =

157type PoolPQRun schemas =

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

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

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

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

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

151poolpqliftWith f = PoolPQ $ \ pool ->

162poolpqliftWith f = PoolPQ $ \ pool ->

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

163 (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

38 , printSQL

39 ) where

41−import Control.Monad.Base

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

42import Data.ByteString (ByteString)

43import Data.Maybe (catMaybes)

44import Data.Monoid ((<>))

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

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

127

128-- | Print SQL.

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

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

130−printSQL = liftBase . Char8.putStrLn . renderSQL

130+printSQL = liftIO . Char8.putStrLn . renderSQL

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

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

34 , DeferrableMode (..)

35 ) where

37−import Control.Exception.Lifted

38−import Control.Monad.Base

39−import Control.Monad.Trans.Control

40import Generics.SOP

37import Generics.SOP

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

42import qualified Database.PostgreSQL.LibPQ as LibPQ

40import qualified Database.PostgreSQL.LibPQ as LibPQ

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

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

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

50transactionally

48transactionally

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

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

52 => TransactionMode

50 => TransactionMode

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

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

54 -> tx x

52 -> tx x

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

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

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

62transactionally_

60transactionally_

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

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

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

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

65 -> tx x

63 -> tx x

66transactionally_ = transactionally defaultMode

64transactionally_ = transactionally defaultMode

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

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

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

82transactionallySchema

80transactionallySchema

83− :: MonadBaseControl IO io

81+ :: MonadUnliftIO io

84 => TransactionMode

82 => TransactionMode

85 -> PQ schemas0 schemas1 io x

83 -> PQ schemas0 schemas1 io x

86 -> PQ schemas0 schemas1 io x

84 -> PQ schemas0 schemas1 io x

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

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

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

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

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

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

90 x <- restore (unPQ u conn)

88 x <- restore (unPQ u conn)

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

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

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

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

93 return x

91 return x

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

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

96transactionallySchema_

94transactionallySchema_

97− :: MonadBaseControl IO io

95+ :: MonadUnliftIO io

98 => PQ schemas0 schemas1 io x

96 => PQ schemas0 schemas1 io x

99 -> PQ schemas0 schemas1 io x

97 -> PQ schemas0 schemas1 io x

100transactionallySchema_ = transactionallySchema defaultMode

98transactionallySchema_ = transactionallySchema defaultMode

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

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

16where

18import Control.Monad (void)

19−import Control.Monad.Base (MonadBase)

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

20import qualified Data.ByteString.Char8 as Char8

21import Data.Int (Int16)

22import Data.Text (Text)

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

103testUser :: User

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

105

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

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

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

108

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

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

110insertUserTwice = newUser testUser >> newUser testUser

111

112specs :: SpecWith ()

stack.yaml+3

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

1resolver: lts-13.8

2packages:

3- squeal-postgresql

5+extra-deps:

6+- unliftio-pool-0.2.1.0