A complete overhaul

CHANGELOG.md

@@ -1,3 +1,15 @@
+# 0.6.0 - Major API overhaul
+* Removed the `Session` monad, opening a direct access to the connection pool, thus providing for a simpler compatibility with other libraries.
+* The connection timeout is now set using `Int` for simplicity.
+* There are no exceptions any more. All the error-reporting is typed and done explicitly, using `Either`.
+* The error types are now mostly backend-specific.
+* The transaction mode is now extended to support uncommitable transactions with the `TxWriteMode` type.
+* `Tx` now has a `MonadError` instance, which allows to handle errors while remaining in the transaction.
+* All `Tx` functions now have a "Tx" suffix.
+* There is no more `list` transaction. Instead there is `vectorTx`. 
+* The `Statement` type is renamed to `Stmt` and is now exported from the main API.
+* `RowParser` is now uninstantiable. This enforces the idiomatic usage of the library.
+
 # 0.5.0
 * Update the "list-t" and "monad-control" deps
 

hasql.cabal

@@ -1,7 +1,7 @@
 name:
   hasql
 version:
-  0.5.0
+  0.6.0
 synopsis:
   A minimalistic general high level API for relational databases
 description:
@@ -10,7 +10,7 @@ description:
   .
   Features:
   .
-  * Concise and crisp API. Just a few functions and two monads doing all the
+  * Concise and crisp API. Just a few functions and one monad doing all the
   boilerplate job for you.
   .
   * A powerful transaction abstraction, which provides 
@@ -31,7 +31,7 @@ description:
   * Automated management of resources related to connections, transactions and
   cursors.
   .
-  * A built-in connections pool.
+  * A built-in connection pool.
   .
   * Compile-time generation of templates. You just can't write a statement with an
   incorrect number of placeholders.
@@ -94,27 +94,21 @@ library
   exposed-modules:
     Hasql
   build-depends:
-    hasql-backend == 0.2.*,
+    -- 
-    -- template-haskell:
+    resource-pool == 0.2.*,
+    hasql-backend == 0.3.*,
+    -- 
     template-haskell >= 2.8 && < 2.10,
-    -- parsing:
+    -- 
     attoparsec >= 0.10 && < 0.13,
-    -- database:
+    -- 
-    ex-pool == 0.2.*,
-    -- data:
     vector < 0.11,
-    time >= 1.4 && < 1.6,
-    bytestring == 0.10.*,
     text >= 1.0 && < 1.3,
-    -- errors:
+    -- 
-    loch-th == 0.2.*,
+    either >= 4.3 && < 4.4,
-    placeholders == 0.1.*,
+    list-t >= 0.3.1 && < 0.5,
-    -- general:
-    safe == 0.3.*,
-    list-t >= 0.4 && < 0.5,
     mmorph == 1.0.*,
-    monad-control == 1.0.*,
+    mtl >= 2.1 && < 2.3,
-    transformers-base == 0.4.*,
     transformers >= 0.3 && < 0.5,
     base-prelude >= 0.1.3 && < 0.2,
     base >= 4.5 && < 4.8
@@ -138,10 +132,12 @@ test-suite hspec
   build-depends:
     -- 
     hasql,
-    hasql-backend == 0.2.*,
+    hasql-backend,
     -- 
     hspec == 2.1.*,
     -- 
+    vector,
+    -- 
     mtl-prelude < 3,
     base-prelude,
     base
@@ -165,7 +161,7 @@ test-suite hspec-postgres
   build-depends:
     -- 
     hasql,
-    hasql-postgres == 0.9.*,
+    hasql-postgres == 0.10.*,
     -- 
     slave-thread == 0.1.*,
     -- 
@@ -173,6 +169,8 @@ test-suite hspec-postgres
     -- 
     text,
     -- 
+    monad-control,
+    either,
     mtl-prelude < 3,
     base-prelude,
     base
@@ -197,7 +195,7 @@ benchmark demo
     Haskell2010
   build-depends:
     hasql,
-    hasql-postgres == 0.9.*,
+    hasql-postgres == 0.10.*,
     transformers >= 0.3 && < 0.5,
     base >= 4.5 && < 4.8
 

hspec-postgres/Main.hs

@@ -1,5 +1,7 @@
 import BasePrelude
 import MTLPrelude
+import Control.Monad.Trans.Either
+import Control.Monad.Trans.Control
 import Test.Hspec
 import Data.Text (Text)
 import qualified Hasql as H
@@ -15,17 +17,17 @@ main =
       context "Unhandled transaction conflict" $ do
 
         it "should not be" $ do
-          session $ H.tx Nothing $ do
+          session $ tx Nothing $ do
-            H.unit [H.q|DROP TABLE IF EXISTS artist|]
+            H.unitTx [H.q|DROP TABLE IF EXISTS artist|]
-            H.unit [H.q|DROP TABLE IF EXISTS artist_union|]
+            H.unitTx [H.q|DROP TABLE IF EXISTS artist_union|]
-            H.unit $
+            H.unitTx $
               [H.q|
                 CREATE TABLE "artist_union" (
                   "id" BIGSERIAL,
                   PRIMARY KEY ("id")
                 )
               |]
-            H.unit $
+            H.unitTx $
               [H.q|
                 CREATE TABLE "artist" (
                   "id" BIGSERIAL,
@@ -39,13 +41,13 @@ main =
           let 
             insertArtistUnion :: H.Tx HP.Postgres s Int64
             insertArtistUnion =
-              fmap (runIdentity . fromJust) $ H.single $
+              fmap (runIdentity . fromJust) $ H.maybeTx $
               [H.q| 
                 INSERT INTO artist_union DEFAULT VALUES RETURNING id
               |]
             insertArtist :: Int64 -> [Text] -> H.Tx HP.Postgres s Int64
             insertArtist unionID artistNames = 
-              fmap (runIdentity . fromJust) $ H.single $
+              fmap (runIdentity . fromJust) $ H.maybeTx $
               [H.q| 
                 INSERT INTO artist
                   (artist_union_id, 
@@ -58,7 +60,7 @@ main =
             process = 
                 SlaveThread.fork $ do
                   session $ replicateM_ 100 $ do 
-                    H.tx (Just (H.Serializable, True)) $ do
+                    tx (Just (H.Serializable, Just True)) $ do
                       unionID <- insertArtistUnion
                       insertArtist unionID ["a", "b", "c"]
                   signal
@@ -68,32 +70,25 @@ main =
     context "RowParser" $ do
 
       it "should fail on incorrect arity" $ do
-        flip shouldThrow (\case H.UnparsableRow _ -> True; _ -> False) $
+        flip shouldSatisfy (\case Left (H.UnparsableResult _) -> True; _ -> False) =<< do
           session $ do
-            H.tx Nothing $ do
+            tx Nothing $ do
-              H.unit [H.q|DROP TABLE IF EXISTS data|]
+              H.unitTx [H.q|DROP TABLE IF EXISTS data|]
-              H.unit [H.q|CREATE TABLE data (
+              H.unitTx [H.q|CREATE TABLE data (
                               field1    DECIMAL NOT NULL,
                               field2    BIGINT  NOT NULL,
                               PRIMARY KEY (field1)
                           )|]
-              H.unit [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|]
+              H.unitTx [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|]
             mrow :: Maybe (Double, Int64, String) <- 
-              H.tx Nothing $  
+              tx Nothing $  
-                H.single $ [H.q|SELECT * FROM data|]
+                H.maybeTx $ [H.q|SELECT * FROM data|]
             return ()
 
 
 -- * Helpers
 -------------------------
 
-session :: (forall s. H.Session HP.Postgres s IO r) -> IO r
-session =
-  H.session backendSettings poolSettings
-  where
-    backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"
-    poolSettings = fromJust $ H.sessionSettings 6 30
-
 newBatchGate :: Int -> IO (IO (), IO ())
 newBatchGate amount =
   do
@@ -102,3 +97,29 @@ newBatchGate amount =
       let signal = atomically $ readTVar counter >>= writeTVar counter . pred
           block = atomically $ readTVar counter >>= \x -> when (x > 0) retry
           in (signal, block)
+
+
+-- * Hasql utils
+-------------------------
+
+newtype HSession m r =
+  HSession (ReaderT (H.Pool HP.Postgres) (EitherT (H.TxError HP.Postgres) m) r)
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadTrans HSession where
+  lift = HSession . lift . lift
+
+tx :: MonadIO m => H.TxMode -> (forall s. H.Tx HP.Postgres s a) -> HSession m a
+tx mode m =
+  HSession $ ReaderT $ \p -> EitherT $ liftIO $ H.tx p mode m
+
+session :: MonadBaseControl IO m => HSession m r -> m (Either (H.TxError HP.Postgres) r)
+session (HSession m) =
+  control $ \unlift -> do
+    p <- H.acquirePool backendSettings poolSettings
+    r <- unlift $ runEitherT $ runReaderT m p
+    H.releasePool p
+    return r
+  where
+    backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"
+    poolSettings = fromJust $ H.poolSettings 6 30

hspec/Main.hs

@@ -2,21 +2,25 @@ import BasePrelude
 import Test.Hspec
 import qualified Hasql as H
 import qualified Hasql.Backend as HB
+import qualified Data.Vector as V
 
 
 data X
-instance HB.Backend X where
-  data StatementArgument X = 
-    StatementArgument String
-    deriving (Eq, Show)
-instance HB.Mapping X Char where
-  renderValue = StatementArgument . show
 
+data instance HB.StmtParam X = 
+  StmtParam String 
+  deriving (Eq, Show)
+
+deriving instance Show (HB.Stmt X)
+deriving instance Eq (HB.Stmt X)
+
+instance HB.CxValue X Char where
+  encodeValue = StmtParam . show
 
 main = 
   hspec $ do
     context "Quasi quoter" $ do
       it "generates a proper statement" $ do
         (flip shouldBe)
-          (" SELECT ? ", [HB.renderValue 'a'], True)
+          (HB.Stmt " SELECT (? + ?) " (V.fromList [HB.encodeValue 'a', HB.encodeValue 'b']) True)
-          ([H.q| SELECT ? |] 'a' :: HB.Statement X)
+          ([H.q| SELECT (? + ?) |] 'a' 'b' :: HB.Stmt X)

library/Hasql.hs

@@ -4,265 +4,236 @@
 -- For an introduction to the package 
 -- and links to more documentation please refer to 
 -- <../ the package's index page>.
+-- 
+-- This API is completely disinfected from exceptions. 
+-- All error-reporting is explicit and 
+-- is presented using the 'Either' type.
 module Hasql
 (
-  -- * Session
+  -- * Pool
-  Session,
+  Pool,
-  session,
+  acquirePool,
-  sessionUnlifter,
+  releasePool,
 
-  -- ** Session Settings
+  -- ** Pool Settings
-  SessionSettings,
+  PoolSettings,
-  sessionSettings,
+  poolSettings,
+
+  -- * Statement
+  Bknd.Stmt,
+  q,
+
+  -- ** Statement Execution
+  unitTx,
+  countTx,
+  maybeTx,
+  vectorTx,
+  streamTx,
 
   -- * Transaction
   Tx,
   tx,
 
   -- ** Transaction Settings
-  Mode,
+  Bknd.TxMode(..),
-  Backend.IsolationLevel(..),
+  Bknd.TxIsolationLevel(..),
+  Bknd.TxWriteMode(..),
 
-  -- * Statement Quasi-Quoter
+  -- ** Transaction Error
-  q,
+  TxError(..),
 
-  -- * Statement Execution
+  -- ** Result Stream
-  unit,
-  count,
-  single,
-  list,
-  stream,
-
-  -- * Results Stream
   TxListT,
 
-  -- * Row parser
+  -- * Row Parser
-  RowParser.RowParser(..),
+  RowParser.RowParser,
-  
-  -- * Error
-  Error(..),
 )
 where
 
-import Hasql.Prelude hiding (Error)
+import Hasql.Prelude
-import Hasql.Backend (Backend)
+import qualified Hasql.Backend as Bknd
-import Hasql.RowParser (RowParser)
-import qualified Hasql.Backend as Backend
 import qualified Hasql.RowParser as RowParser
 import qualified Hasql.QParser as QParser
 import qualified ListT
 import qualified Data.Pool as Pool
 import qualified Data.Vector as Vector
+import qualified Data.Vector.Mutable as MVector
 import qualified Language.Haskell.TH as TH
 import qualified Language.Haskell.TH.Quote as TH
 import qualified Hasql.TH as THUtil
 
 
--- * Session
+-- * Resources
 -------------------------
 
 -- |
--- A monad transformer,
+-- A connection pool. 
--- which executes transactions.
+newtype Pool c =
--- 
+  Pool (Pool.Pool (Either (Bknd.CxError c) c))
--- * @b@ is a backend.
--- 
--- * @s@ is an anonymous variable, 
--- used to associate 'sessionUnlifter' with a specific session. 
--- 
--- * @m@ is an inner (transformed) monad.
--- 
--- * @r@ is a result.
-newtype Session b s m r =
-  Session (ReaderT (Pool.Pool (Backend.Connection b)) m r)
-  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)
-
-instance MonadTransControl (Session b s) where
-  type StT (Session b s) a = a
-  liftWith onRunner =
-    Session $ ReaderT $ \e -> onRunner $ \(Session (ReaderT f)) -> f e
-  restoreT = 
-    Session . ReaderT . const
-
-instance (MonadBase IO m) => MonadBase IO (Session b s m) where
-  liftBase = Session . liftBase
-
-instance (MonadBaseControl IO m) => MonadBaseControl IO (Session b s m) where
-  type StM (Session b s m) a = ComposeSt (Session b s) m a
-  liftBaseWith = defaultLiftBaseWith
-  restoreM = defaultRestoreM
-
 
 -- |
--- Given backend settings, session settings, and a session monad transformer,
+-- Given backend-specific connection settings and pool settings, 
--- execute it in the inner monad.
+-- acquire a backend connection pool,
--- 
+-- which can then be used to work with the DB.
--- It uses the same trick as 'ST' with the anonymous @s@ type argument
+acquirePool :: Bknd.Cx c => Bknd.CxSettings c -> PoolSettings -> IO (Pool c)
--- to prohibit the use of the result of
+acquirePool cxSettings (PoolSettings size timeout) =
--- 'sessionUnlifter' outside of its creator session.
+  fmap Pool $
-session :: 
+  Pool.createPool (Bknd.acquireCx cxSettings) 
-  (Backend.Backend b, MonadBaseControl IO m) =>
+                  (either (const $ return ()) Bknd.releaseCx) 
-  b -> SessionSettings -> (forall s. Session b s m r) -> m r
+                  (1)
-session backend (SessionSettings size timeout) s =
+                  (fromIntegral timeout) 
-  control $ \runInIO ->
+                  (size)
-    mask $ \unmask -> do
-      p <- Pool.createPool (Backend.connect backend) Backend.disconnect 1 timeout size
-      r <- try $ unmask $ runInIO $ runSession p s
-      Pool.purgePool p
-      either (throwIO :: SomeException -> IO r) return r
 
 -- |
--- Get a session unlifting function, 
+-- Release all connections acquired by the pool.
--- which allows to execute a session in the inner monad
+releasePool :: Pool c -> IO ()
--- using the resources of the current session.
+releasePool (Pool p) =
--- 
+  Pool.destroyAllResources p
--- Using this function in combination with 'lift'
--- you can interleave 'Session' with other monad transformers.
--- 
--- This function has the following property:
--- 
--- > (sessionUnlifter >>= \unlift -> lift (unlift m)) ≡ m
-sessionUnlifter :: (MonadBaseControl IO m) => Session b s m (Session b s m r -> m r)
-sessionUnlifter =
-  Session $ ReaderT $ return . runSession
-
-runSession :: (MonadBaseControl IO m) => Pool.Pool (Backend.Connection b) -> Session b s m r -> m r
-runSession e (Session r) =
-  control $ \runInIO -> 
-    catch (runInIO (runReaderT r e)) $ \case
-      Backend.CantConnect t -> throwIO $ CantConnect t
-      Backend.ConnectionLost t -> throwIO $ ConnectionLost t
-      Backend.ErroneousResult t -> throwIO $ ErroneousResult t
-      Backend.UnexpectedResult t -> throwIO $ UnexpectedResult t
-      Backend.UnparsableTemplate t -> throwIO $ UnparsableTemplate t
-      Backend.TransactionConflict -> $bug "Unexpected TransactionConflict exception"
-      Backend.NotInTransaction -> throwIO $ NotInTransaction
 
 
--- ** Session Settings
+-- ** Pool Settings
 -------------------------
 
 -- |
--- Settings of a session.
+-- Settings of a pool.
-data SessionSettings =
+data PoolSettings =
-  SessionSettings !Word32 !NominalDiffTime
+  PoolSettings !Int !Int
 
 -- | 
--- A smart constructor for session settings.
+-- A smart constructor for pool settings.
-sessionSettings :: 
+poolSettings :: 
-  Word32
+  Int
   -- ^
   -- The maximum number of connections to keep open. 
   -- The smallest acceptable value is 1.
   -- Requests for connections will block if this limit is reached.
   -> 
-  NominalDiffTime
+  Int
   -- ^
-  -- The amount of time for which an unused connection is kept open. 
+  -- The amount of seconds for which an unused connection is kept open. 
-  -- The smallest acceptable value is 0.5 seconds.
+  -- The smallest acceptable value is 1.
   -> 
-  Maybe SessionSettings
+  Maybe PoolSettings
   -- ^
-  -- Maybe session settings, if they are correct.
+  -- Maybe pool settings, if they are correct.
-sessionSettings size timeout =
+poolSettings size timeout =
-  if size > 0 && timeout >= 0.5
+  if size > 0 && timeout >= 1
-    then Just $ SessionSettings size timeout
+    then Just $ PoolSettings size timeout
     else Nothing
 
 
--- ** Error
--------------------------
-
--- |
--- The only exception type that this API can raise.
-data Error =
-  -- |
-  -- Cannot connect to a server.
-  CantConnect Text |
-  -- |
-  -- The connection got interrupted.
-  ConnectionLost Text |
-  -- |
-  -- An error returned from the database.
-  ErroneousResult Text |
-  -- |
-  -- Unexpected result structure.
-  -- Indicates usage of inappropriate statement executor.
-  UnexpectedResult Text |
-  -- |
-  -- Incorrect statement template.
-  UnparsableTemplate Text |
-  -- |
-  -- An operation, 
-  -- which requires a database transaction was executed without one.
-  NotInTransaction |
-  -- |
-  -- Attempt to parse a row into an incompatible type.
-  -- Indicates either a mismatching schema or an incorrect query.
-  UnparsableRow Text
-  deriving (Show, Typeable, Eq, Ord)
-
-instance Exception Error
-
-
 -- * Transaction
 -------------------------
 
 -- |
--- A transaction specialized for a backend @b@, 
+-- A transaction specialized for a backend connection @c@, 
--- associated with its intermediate results using an anonymous type-argument @s@ (same as in 'ST')
+-- associated with its intermediate results using an anonymous type-argument @s@ (same trick as in 'ST')
 -- and producing a result @r@.
-newtype Tx b s r =
+-- 
-  Tx (ReaderT (Backend.Connection b) IO r)
+-- Running `IO` in `Tx` is prohibited. 
-  deriving (Functor, Applicative, Monad)
+-- The motivation is identical to `STM`: 
+-- the `Tx` block may get executed multiple times if any transaction conflicts arise. 
+-- This will result in your effectful `IO` code being executed 
+-- an unpredictable amount of times as well, 
+-- which, chances are, is not what you want.
+newtype Tx c s r =
+  Tx (EitherT (TxError c) (Bknd.Tx c) r)
+  deriving (Functor, Applicative, Monad, MonadError (TxError c))
+
+data TxError c =
+  -- |
+  -- A backend-specific connection acquisition error.
+  -- E.g., a failure to establish a connection.
+  BackendCxError (Bknd.CxError c) |
+  -- |
+  -- A backend-specific transaction error.
+  -- It should cover all possible failures related to an established connection,
+  -- including the loss of connection, query errors and database failures.
+  BackendTxError (Bknd.TxError c) |
+  -- |
+  -- Attempt to parse a result into an incompatible type.
+  -- Indicates either a mismatching schema or an incorrect query.
+  UnparsableResult Text
+
+deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (TxError c)
+deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (TxError c)
 
 -- |
--- A transaction mode defining how a transaction should be executed.
+-- Execute a transaction on a connection pool.
--- 
--- * @Just (isolationLevel, write)@ indicates that a database transaction
--- should be established with a specified isolation level and a boolean, 
--- defining, whether it would perform any modification operations.
--- 
--- * @Nothing@ indicates that there should be no database transaction established on
--- the backend and therefore it should be executed with no ACID guarantees,
--- but also without any induced overhead.
-type Mode =
-  Maybe (Backend.IsolationLevel, Bool)
-
--- |
--- Execute a transaction in a session.
 -- 
 -- This function ensures on the type level, 
 -- that it's impossible to return @'TxListT' s m r@ from it.
-tx :: 
+tx :: Bknd.CxTx c => Pool c -> Bknd.TxMode -> (forall s. Tx c s r) -> IO (Either (TxError c) r)
-  (Backend.Backend b, MonadBase IO m) =>
+tx (Pool pool) mode (Tx m) =
-  Mode -> (forall s. Tx b s r) -> Session b s m r
+  Pool.withResource pool $ \e ->
-tx m t =
+    runEitherT $ do
-  Session $ ReaderT $ \p -> liftBase $ Pool.withResource p $ \c -> runTx c m t
+      c <- hoistEither $ mapLeft BackendCxError e
-  where
-    runTx ::
-      Backend b => 
-      Backend.Connection b -> Mode -> (forall s. Tx b s r) -> IO r
-    runTx connection mode (Tx reader) =
-      maybe (const id) inTransaction mode connection (runReaderT reader connection)
-      where
-        inTransaction ::
-          Backend b => 
-          Backend.TransactionMode -> Backend.Connection b -> IO r -> IO r
-        inTransaction mode c io =
       let
-            io' = 
+        attempt =
-              Backend.beginTransaction mode c *> io <* Backend.finishTransaction True c
+          do
-            in
+            r <- EitherT $ fmap (either (Left . BackendTxError) Right) $ 
-              try io' >>= \case
+                 Bknd.runTx c mode $ runEitherT m
-                Left Backend.TransactionConflict -> do
+            maybe attempt hoistEither r
-                  Backend.finishTransaction False c
+        in attempt
-                  inTransaction mode c io
-                Left e -> throwIO e
-                Right r -> return r
 
 
--- * Results Stream
+-- * Statements execution
+-------------------------
+
+-- |
+-- Execute a statement without processing the result.
+unitTx :: Bknd.Stmt c -> Tx c s ()
+unitTx = 
+  Tx . lift . Bknd.unitTx
+
+-- |
+-- Execute a statement and count the amount of affected rows.
+-- Useful for resolving how many rows were updated or deleted.
+countTx :: Bknd.CxValue c Word64 => Bknd.Stmt c -> Tx c s Word64
+countTx =
+  Tx . lift . Bknd.countTx
+
+-- |
+-- Execute a statement,
+-- which produces a single result row.
+-- E.g., 
+-- a @SELECT@ 
+-- or an @INSERT@, which produces a generated value (e.g., an auto-incremented id),
+-- or an @UPDATE@ or @DELETE@, counting the affected rows.
+maybeTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Maybe r)
+maybeTx s =
+  Tx $ do
+    r <- lift $ Bknd.maybeTx s
+    EitherT $ return $ traverse ((mapLeft UnparsableResult) . RowParser.parseRow) $ r
+
+-- |
+-- Execute a @SELECT@ statement,
+-- and produce a vector of results.
+vectorTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Vector r)
+vectorTx s =
+  Tx $ do
+    r <- lift $ Bknd.vectorTx s
+    EitherT $ return $ traverse ((mapLeft UnparsableResult) . RowParser.parseRow) $ r
+
+-- |
+-- Execute a @SELECT@ statement with a cursor,
+-- and produce a result stream.
+-- 
+-- Cursor allows you to fetch virtually limitless results in a constant memory
+-- at a cost of a small overhead.
+-- Note that in most databases cursors require establishing a database transaction,
+-- so depending on a backend the transaction may result in an error,
+-- if you run it improperly.
+streamTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (TxListT s (Tx c s) r)
+streamTx s =
+  Tx $ do
+    r <- lift $ Bknd.streamTx s
+    return $ TxListT $ do
+      row <- hoist (Tx . lift) r
+      lift $ Tx $ EitherT $ return $ mapLeft UnparsableResult $ RowParser.parseRow $ row
+
+
+-- * Result Stream
 -------------------------
 
 -- |
@@ -273,7 +244,7 @@ tx m t =
 -- which uses the same trick as the 'ST' monad to associate with the
 -- context transaction and become impossible to be used outside of it.
 -- This lets the library ensure that it is safe to automatically
--- release all the resources associated with this stream.
+-- release all the connections associated with this stream.
 -- 
 -- All the functions of the \"list-t\" library are applicable to this type,
 -- amongst which are 'ListT.head', 'ListT.toList', 'ListT.fold', 'ListT.traverse_'.
@@ -289,69 +260,18 @@ instance ListT.MonadTransUncons (TxListT s) where
     (unsafeCoerce :: TxListT s m r -> ListT.ListT m r)
 
 
--- * Statements execution
--------------------------
-
--- |
--- Execute a statement, which produces no result.
-unit :: Backend b => Backend.Statement b -> Tx b s ()
-unit s =
-  Tx $ ReaderT $ Backend.execute s
-
--- |
--- Execute a statement and count the amount of affected rows.
--- Useful for resolving how many rows were updated or deleted.
-count :: (Backend b, Backend.Mapping b Word64) => Backend.Statement b -> Tx b s Word64
-count s =
-  Tx $ ReaderT $ Backend.executeAndCountEffects s
-
--- |
--- Execute a statement,
--- which produces a single result row: 
--- a @SELECT@ 
--- or an @INSERT@, which produces a generated value (e.g., an auto-incremented id).
-single :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s (Maybe r)
-single s =
-  headMay <$> list s
-
--- |
--- Execute a @SELECT@ statement,
--- and produce a list of results.
-list :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s [r]
-list s =
-  Tx $ ReaderT $ \c -> do
-    m <- Backend.executeAndGetMatrix s c
-    traverse (either (throwIO . UnparsableRow) return . RowParser.parseRow) $ Vector.toList m
-
--- |
--- Execute a @SELECT@ statement with a cursor,
--- and produce a results stream.
--- 
--- Cursor allows you to fetch virtually limitless results in a constant memory
--- at a cost of a small overhead.
--- Note that in most databases cursors require establishing a database transaction,
--- so a 'NotInTransaction' error will be raised if you run it improperly.
-stream :: (Backend b, RowParser b r) => Backend.Statement b -> TxListT s (Tx b s) r
-stream s =
-  do
-    s <- lift $ Tx $ ReaderT $ \c -> Backend.executeAndStream s c
-    TxListT $ hoist (Tx . lift) $ do
-      row <- s
-      either (lift . throwIO . UnparsableRow) return $ RowParser.parseRow row
-
-
 -- * Statements quasi-quotation
 -------------------------
 
 -- |
 -- Produces a lambda-expression, 
 -- which takes as many parameters as there are placeholders in the quoted text
--- and results in a 'Backend.Statement'. 
+-- and results in a 'Bknd.Stmt'. 
 -- 
 -- E.g.:
 -- 
--- >selectFive :: Statement b
+-- >selectSum :: Int -> Int -> Stmt c
--- >selectFive = [q|SELECT (? + ?)|] 2 3
+-- >selectSum = [q|SELECT (? + ?)|]
 -- 
 q :: TH.QuasiQuoter
 q = 
@@ -364,18 +284,17 @@ q =
     parseExp s =
       do
         n <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))
-        return $ statementF s n
+        return $ statementF s (fromIntegral n)
     statementF s n =
       TH.LamE
         (map TH.VarP argNames)
-        (THUtil.purify [|(,,) $(pure statementE) $(pure argsE) True|])
+        (THUtil.purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|])
       where
         argNames = 
           map (TH.mkName . ('_' :) . show) [1 .. n]
         statementE = 
           TH.LitE (TH.StringL s)
         argsE =
-          TH.ListE $ flip map argNames $ \x ->
+          THUtil.vectorE $
-            THUtil.purify
+          map (\x -> THUtil.purify [| Bknd.encodeValue $(TH.varE x) |]) $
-            [| Backend.renderValue $(TH.varE x) |]
+          argNames
-        

library/Hasql/Prelude.hs

@@ -1,15 +1,13 @@
 module Hasql.Prelude
 ( 
   module Exports,
-  bug,
-  bottom,
 )
 where
 
 
 -- base-prelude
 -------------------------
-import BasePrelude as Exports
+import BasePrelude as Exports hiding (left, right, isLeft, isRight)
 
 -- transformers
 -------------------------
@@ -19,21 +17,18 @@ import Control.Monad.Trans.Class as Exports
 import Control.Monad.IO.Class as Exports
 import Data.Functor.Identity as Exports
 
+-- mtl
+-------------------------
+import Control.Monad.Error.Class as Exports
+
 -- mmorph
 -------------------------
 import Control.Monad.Morph as Exports
 
--- monad-control
+-- either
 -------------------------
-import Control.Monad.Trans.Control as Exports hiding (embed, embed_)
+import Control.Monad.Trans.Either as Exports
-
+import Data.Either.Combinators as Exports
--- transformers-base
--------------------------
-import Control.Monad.Base as Exports
-
--- safe
--------------------------
-import Safe as Exports
 
 -- list-t
 -------------------------
@@ -46,26 +41,3 @@ import Data.Vector as Exports (Vector)
 -- text
 -------------------------
 import Data.Text as Exports (Text)
-
--- bytestring
--------------------------
-import Data.ByteString as Exports (ByteString)
-
--- time
--------------------------
-import Data.Time as Exports
-
--- placeholders
--------------------------
-import Development.Placeholders as Exports
-
--- custom
--------------------------
-import qualified Debug.Trace.LocationTH
-
-
-bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]
-  where
-    msg = "A \"hasql\" package bug: " :: String
-
-bottom = [e| $bug "Bottom evaluated" |]

library/Hasql/RowParser.hs

@@ -2,23 +2,26 @@ module Hasql.RowParser where
 
 import Hasql.Prelude
 import Language.Haskell.TH
-import qualified Hasql.Backend as Backend
+import qualified Hasql.Backend as Bknd
 import qualified Data.Vector as Vector
 import qualified Hasql.TH as THUtil
 
 
-class RowParser b r where
+-- |
-  parseRow :: Vector.Vector (Backend.Result b) -> Either Text r
+-- This class is only intended to be used with the supplied instances,
+-- which should be enough to cover all use cases.
+class RowParser c r where
+  parseRow :: Bknd.ResultRow c -> Either Text r
 
-instance RowParser b () where
+instance RowParser c () where
   parseRow row = 
     if Vector.null row
       then Right ()
       else Left "Not an empty row"
 
-instance Backend.Mapping b v => RowParser b (Identity v) where
+instance Bknd.CxValue c v => RowParser c (Identity v) where
   parseRow row = do
-    Identity <$> Backend.parseResult (Vector.unsafeHead row)
+    Identity <$> Bknd.decodeValue (Vector.unsafeHead row)
 
 -- Generate tuple instaces using Template Haskell:
 return $ flip map [2 .. 24] $ \arity ->
@@ -28,9 +31,9 @@ return $ flip map [2 .. 24] $ \arity ->
     varTypes =
       map VarT varNames
     connectionType =
-      VarT (mkName "b")
+      VarT (mkName "c")
     constraints =
-      map (\t -> ClassP ''Backend.Mapping [connectionType, t]) varTypes
+      map (\t -> ClassP ''Bknd.CxValue [connectionType, t]) varTypes
     head =
       AppT (AppT (ConT ''RowParser) connectionType) (foldl AppT (TupleT arity) varTypes)
     parseRowDec =
@@ -54,7 +57,7 @@ return $ flip map [2 .. 24] $ \arity ->
               i <- [0 .. pred arity]
               return $ THUtil.purify $
                 [|
-                  Backend.parseResult
+                  Bknd.decodeValue
                     (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) )
                 |]
     in InstanceD constraints head [parseRowDec]

library/Hasql/TH.hs

@@ -4,6 +4,8 @@ module Hasql.TH where
 
 import Hasql.Prelude
 import Language.Haskell.TH
+import qualified Data.Vector as Vector
+import qualified Data.Vector.Mutable as MVector
 
 
 applicativeE :: Exp -> [Exp] -> Exp
@@ -18,7 +20,50 @@ applicativeE head =
           \case
             e : o : t -> UInfixE e o (reduce t)
             e : [] -> e
-            _ -> $bug $ "Unexpected queue size. Exps: " <> show exps
+            _ -> error $ "Unexpected queue size. Exps: " <> show exps
 
 purify :: Q a -> a
 purify = unsafePerformIO . runQ
+
+-- |
+-- Produce a lambda expression of a given arity,
+-- which efficiently constructs a vector of a size equal to the arity.
+vectorLamE :: Int -> Exp
+vectorLamE arity =
+  LamE (map VarP argNames) body
+  where
+    argNames = 
+      map (mkName . ('_' :) . show) [1 .. arity]
+    body =
+      vectorE $ map VarE argNames
+
+vectorE :: [Exp] -> Exp
+vectorE cellExps =
+  AppE (VarE 'runST) $ DoE $ 
+    pure vectorDeclarationStmt <> cellAssignmentStmts <> pure freezingStmt
+  where
+    vectorVarName =
+      mkName "v"
+    vectorDeclarationStmt =
+      (BindS 
+        (VarP vectorVarName) 
+        (AppE 
+          (VarE 'MVector.unsafeNew) 
+          (LitE (IntegerL (fromIntegral (length cellExps))))))
+    cellAssignmentStmts =
+      map (NoBindS . uncurry cellAssignmentExp) $ zip [0..] cellExps
+      where
+        cellAssignmentExp index exp =
+          (AppE
+            (AppE
+              (AppE
+                (VarE 'MVector.unsafeWrite)
+                (VarE vectorVarName))
+              (LitE (IntegerL (fromIntegral index))))
+            (exp))
+    freezingStmt =
+      (NoBindS
+        (AppE
+          (VarE 'Vector.unsafeFreeze)
+          (VarE vectorVarName)))
+