Complete reimplementation

CHANGELOG.md

@@ -1,36 +0,0 @@
-# 0.7.3.1
-* Attoparsec-0.13 support
-
-# 0.7.3
-* GHC 7.10 support
-
-# 0.7.2
-* Implement support for free variables by the quasi-quoter
-
-# 0.7.1
-* Relaxed the dependency on "monad-control"
-
-# 0.7.0 - Refinements and minor updates
-* Streaming now is parameterized by the size of a chunk
-* Introduced a new type `Ex`
-* Changed the suffix of statement execution functions to `Ex`
-
-# 0.6.0 - Major API overhaul
-* The connection pool acquisition is now explicit and is no longer handled by the `Session` monad. This should provide for a simpler integration with other libraries.
-* The `Session` monad is now merely a convenience thing for providing a context to multiple transactions. One can run it as many times as he wants - it won't reestablish any resources any more.
-* 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 uncommittable transactions with the `TxWriteMode` type.
-* All `Tx` functions are now appended with a "Tx" suffix.
-* Added `vectorTx` and `maybeTx` and updated the semantics of `singleTx`.
-* `q` statement quasi-quoter is now renamed to more meaningful `stmt`.
-* 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.
-* Statement templates now support UTF-8.
-
-# 0.5.0
-* Update the "list-t" and "monad-control" deps
-
-# 0.4.1
-* Fix the transaction conflicts bug

README.md

@@ -1,123 +0,0 @@
-# Hasql [![Build Status](https://travis-ci.org/nikita-volkov/hasql.svg?branch=master)](https://travis-ci.org/nikita-volkov/hasql)
-
-
-Hasql provides a robust and concise yet powerful API for communication with arbitrary relational databases using SQL. 
-
-Currently the only backend available is for PostgreSQL ([which can yield great performance improvements](https://nikita-volkov.github.io/hasql-benchmarks/) over HDBC or postgresql-simple).
-
-The code used here file is the [demo found in the repository](https://github.com/nikita-volkov/hasql/blob/master/demo/Main.hs)
-
-## Openning a connection
-
-For greater convenience the Hasql has a built-in connection pool. All interactions with the database backend are done within the context of such a pool. 
-
-So we have functions to create a pool and one to release all resources held by the pool:
-
-```haskell
-H.acquirePool
-  :: Hasql.Backend.Cx c =>
-     Hasql.Backend.CxSettings c -> H.PoolSettings -> IO (H.Pool c)
-```
-
-and
-
-```haskell
-H.releasePool :: H.Pool c -> IO ()
-```
-
-To create the pool we need to pass the connection settings (which are backend dependent) and the pool settings. The code sample below will open a connection to a PostgreSQL database.
-
-```haskell
-{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
-
--- Import the API from the "hasql" library
-import qualified Hasql as H
-
--- Import the backend API from the "hasql-postgres" library
-import qualified Hasql.Postgres as HP
-let postgresSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"
-
--- Prepare the pool settings with a smart constructor,
--- which checks the inputted values on correctness.
--- Set the connection pool size to 6 and the timeout to 30 seconds.
-poolSettings <- maybe (fail "Improper session settings") return $ 
-                  H.poolSettings 6 30
-
--- Acquire the database connections pool.
--- Gotta help the compiler with the type signature of the pool a bit.
-pool :: H.Pool HP.Postgres 
-       <- H.acquirePool postgresSettings poolSettings
-```
-
-## Executing a statement
-
-To execute statements we will use a ```Session```, which is just a wrapper for the ```ReaderT``` monad.
-This allow us to use the pool for all our session sub-computations.
-
-So the ```session``` function, is a wrapper for the ```runReaderT```, and besides a parameter with the pool, 
-we need to pass a function with the return type in ```H.Session``` monad. And as the return we get 
-either a ```SessionError``` or the result of our function. 
-
-The function we will use to actually execute the transactions is the ```tx```
-which conveniently enough receives a transaction mode, the transactions we want to execute (along with their session context) 
-and returns the type ```H.Session c m r```.
-
-It is **important** to notice that running ```IO``` in ```Tx``` is prohibited. 
-
-let's take a look at the signatures proceding:
-
-```haskell
-H.session
-  :: H.Pool c -> H.Session c m a -> m (Either (H.SessionError c) a)
-
-H.tx
-  :: (Control.Monad.Trans.Control.MonadBaseControl IO m,
-      Hasql.Backend.CxTx c) =>
-     H.TxMode -> (forall s. H.Tx c s r) -> H.Session c m r
-```
-
-The following code excerpt shows us how the demo code uses these functions to open a 
-session and start a transaction to create a new table:
-
-```haskell
--- Provide a context for execution of transactions.
--- 'Session' is merely a convenience wrapper around 'ReaderT'.
-H.session pool $ do
-
-  -- Execute a group of statements without any locking and ACID guarantees:
-  H.tx Nothing $ do
-    H.unitEx [H.stmt|DROP TABLE IF EXISTS a|]
-    H.unitEx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]
-```
-
-## Transactions (isolation levels and transaction modes)
-
-You have probably noticed that the first parameter of ```tx``` belongs to the type ```TxMode```.
-This parameter deserves some consideration, for it will determine the behaviour of our transaction.
-Let's take a look at its type definition:
-
-```haskell
-type TxMode = Maybe (TxIsolationLevel, TxWriteMode)
-
-data TxIsolationLevel =
-  RepeatableReads |
-  Serializable    |
-  ReadCommitted   |
-  ReadUncommitted
-
-type TxWriteMode = Maybe Bool
-```
-
-So when the ```mode``` is ```Nothing```, no transaction is explicitly estabilished on the server.
-In PostgreSQL's case this means all commands be commited immediatly after execution 
-and their isolation level will be *Read Committed*.
-
-If we pass the tuple, the first element will be the transaction isolation level, you can read more about 
-[transaction isolation levels on wikipedia](https://en.wikipedia.org/wiki/Isolation_(database_systems)#Isolation_levels).
-
-The second element is the write mode, which will be interpreted as:
-
- * ```Nothing``` indicates a "read" mode.
- * ```Just True``` indicates a "write" mode.
- * ```Just False``` indicates a "write" mode without committing (can be useful for testing purposes).
-

Setup.hs

@@ -0,0 +1,42 @@
+-- The code is mostly ripped from
+-- https://github.com/ekmett/lens/blob/697582fb9a980f273dbf8496253c5bbefedd0a8b/Setup.lhs
+import Data.List ( nub )
+import Data.Version ( showVersion )
+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )
+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )
+import Distribution.Simple.BuildPaths ( autogenModulesDir )
+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))
+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
+import Distribution.Text ( display )
+import Distribution.Verbosity ( Verbosity, normal )
+import System.FilePath ( (</>) )
+
+main :: IO ()
+main = defaultMainWithHooks simpleUserHooks
+  { buildHook = \pkg lbi hooks flags -> do
+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
+     buildHook simpleUserHooks pkg lbi hooks flags
+  }
+
+generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
+generateBuildModule verbosity pkg lbi = do
+  let dir = autogenModulesDir lbi
+  createDirectoryIfMissingVerbose verbosity True dir
+  withLibLBI pkg lbi $ \_ libcfg -> do
+    withTestLBI pkg lbi $ \suite suitecfg -> do
+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
+        [ "module Build_" ++ testName suite ++ " where"
+        , "import Prelude"
+        , "deps :: [String]"
+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
+        ]
+  where
+    formatdeps = map (formatone . snd)
+    formatone p = case packageName p of
+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
+
+testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+

demo/Main.hs

@@ -1,77 +1,122 @@
--- You can execute this file with 'cabal bench demo'.
-{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
+module Main where
 
-import Control.Monad hiding (forM_, mapM_, forM, mapM)
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Data.Functor.Identity
-import Data.Foldable
-
--- Import the API from the "hasql" library
-import qualified Hasql as H
-
--- Import the backend API from the "hasql-postgres" library
-import qualified Hasql.Postgres as HP
+import BasePrelude hiding (assert, isRight, isLeft)
+import Data.Text (Text)
+import Data.ByteString (ByteString)
+import Data.Functor.Contravariant
+import Data.Default.Class
+import Contravariant.Extras
+import qualified Hasql.Query as Query;
+import qualified Hasql.Serialization as S
+import qualified Hasql.Deserialization as D
+import qualified Hasql.Connection as Connection
 
 
-main = do
-
-  let postgresSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"
-
-  -- Prepare the pool settings with a smart constructor,
-  -- which checks the inputted values on correctness.
-  -- Set the connection pool size to 6 and the timeout to 30 seconds.
-  poolSettings <- maybe (fail "Improper session settings") return $ 
-                  H.poolSettings 6 30
-
-  -- Acquire the database connections pool.
-  -- Gotta help the compiler with the type signature of the pool a bit.
-  pool :: H.Pool HP.Postgres 
-       <- H.acquirePool postgresSettings poolSettings
-
-  -- Provide a context for execution of transactions.
-  -- 'Session' is merely a convenience wrapper around 'ReaderT'.
-  H.session pool $ do
-
-    -- Execute a group of statements without any locking and ACID guarantees:
-    H.tx Nothing $ do
-      H.unitEx [H.stmt|DROP TABLE IF EXISTS a|]
-      H.unitEx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]
-      -- Insert three rows:
-      replicateM_ 3 $ do 
-        H.unitEx [H.stmt|INSERT INTO a (balance) VALUES (0)|]
-
-    -- Declare a list of transfer settings, which we'll later use.
-    -- The tuple structure is: 
-    -- @(withdrawalAccountID, arrivalAccountID, amount)@
-    let transfers :: [(Int, Int, Int)] = 
-          [(1, 2, 20), (2, 1, 30), (2, 3, 100)]
-
-    forM_ transfers $ \(id1, id2, amount) -> do
-      -- Run a transaction with ACID guarantees.
-      -- Hasql will automatically roll it back and retry it in case of conflicts.
-      H.tx (Just (H.Serializable, (Just True))) $ do
-        -- Use MaybeT to handle empty results:
-        runMaybeT $ do
-          -- To distinguish results rows containing just one column, 
-          -- we use 'Identity' as a sort of a single element tuple.
-          Identity balance1 <- MaybeT $ H.maybeEx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id1
-          Identity balance2 <- MaybeT $ H.maybeEx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id2
-          lift $ H.unitEx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1
-          lift $ H.unitEx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance2 + amount) id2
-
-    -- Output all the updated rows:
-    do
-      -- Unfortunately in this case there's no way to infer the type of the results,
-      -- so we need to specify it explicitly:
-      rows <- H.tx Nothing $ H.vectorEx $ [H.stmt|SELECT * FROM a|]
-      forM_ rows $ \(id :: Int, amount :: Int) -> do
-        liftIO $ putStrLn $ "ID: " ++ show id ++ ", Amount: " ++ show amount
-
-  -- Release all previously acquired resources. Just for fun.
-  H.releasePool pool
+main =
+  do
+    connectionEither <- Connection.acquire settings
+    case connectionEither of
+      Left e -> print e
+      Right connection -> do
+        result <- Connection.executeParametricQuery connection sumParametricQuery (1, 2)
+        print result
+  where
+    settings =
+      Connection.ParametricSettings "localhost" 5432 "postgres" "" "postgres"
+    sumParametricQuery =
+      (,,,) template serializer deserializer True
+      where
+        template =
+          "SELECT $1 + $2"
+        serializer =
+          contramap fst (S.value S.int8) <>
+          contramap snd (S.value S.int8)
+        deserializer =
+          D.result (D.singleRow (D.value D.int8))
 
 
 
+-- * Model
+-------------------------
+
+
+data Account =
+  Account { 
+    email :: Text , 
+    password :: ByteString , 
+    firstName :: Text , 
+    lastName :: Text
+  }
+
+
+-- * Queries
+-------------------------
+
+
+updateMenu :: Query.ParametricQuery (Text, Int64) Int64
+updateMenu =
+  (,,,) template serializer deserializer True
+  where
+    template =
+      "UPDATE menu SET title = $1 WHERE id = $2"
+    serializer =
+      contrazip2 (S.value S.text)
+                 (S.value S.int8)
+    deserializer =
+      D.result (D.rowsAffected)
+
+accountByEmail :: Query.ParametricQuery Text (Maybe (Int64, Account))
+accountByEmail =
+  (,,,) template serializer deserializer True
+  where
+    template =
+      "SELECT id, email, password, first_name, last_name \
+      \FROM account WHERE email = $1"
+    serializer =
+      S.value S.text
+    deserializer =
+      D.result (D.maybeRow (identifiedDeserializer accountDeserializer))
+
+insertAccount :: Query.ParametricQuery Account Int64
+insertAccount =
+  (,,,) template serializer deserializer True
+  where
+    template =
+      "INSERT INTO account (email, password, first_name, last_name) \
+      \VALUES ($1, $2, $3, $4) \
+      \RETURNING id"
+    serializer =
+      accountSerializer
+    deserializer =
+      D.result (D.singleRow idDeserializer)
+
+
+-- * Deserializers
+-------------------------
+
+
+idDeserializer :: D.Row Int64
+idDeserializer =
+  D.value D.int8
+
+accountDeserializer :: D.Row Account
+accountDeserializer =
+  liftM4 Account (D.value def) (D.value def) (D.value def) (D.value def)
+
+identifiedDeserializer :: D.Row a -> D.Row ( Int64 , a )
+identifiedDeserializer aDeserializer =
+  liftM2 (,) idDeserializer aDeserializer
+
+
+-- * Serializers
+-------------------------
+
+
+accountSerializer :: S.Params Account
+accountSerializer =
+  contramap (\(Account a b c d) -> (a, b, c, d)) $
+  contrazip4 (S.value S.text)
+             (S.value S.bytea)
+             (S.value S.text)
+             (S.value S.text)
 

doctest/Main.hs

@@ -0,0 +1,66 @@
+-- The code is mostly ripped from
+-- https://github.com/ekmett/lens/blob/d1d97469f0e93c1d3535308954a060e8a04e37aa/tests/doctests.hsc
+import BasePrelude
+import System.Directory
+import System.FilePath
+import Test.DocTest
+import Build_doctest (deps)
+
+main :: IO ()
+main = do
+  sources <- getSources
+  doctest $ dfltParams ++ map ("-package="++) deps ++ sources
+  where
+    dfltParams = 
+      [
+        "-isrc",
+        "-idist/build/autogen",
+        "-optP-include",
+        "-optPdist/build/autogen/cabal_macros.h",
+        "-XArrows",
+        "-XBangPatterns",
+        "-XConstraintKinds",
+        "-XDataKinds",
+        "-XDefaultSignatures",
+        "-XDeriveDataTypeable",
+        "-XDeriveFunctor",
+        "-XDeriveGeneric",
+        "-XEmptyDataDecls",
+        "-XFlexibleContexts",
+        "-XFlexibleInstances",
+        "-XFunctionalDependencies",
+        "-XGADTs",
+        "-XGeneralizedNewtypeDeriving",
+        "-XImpredicativeTypes",
+        "-XLambdaCase",
+        "-XLiberalTypeSynonyms",
+        "-XMultiParamTypeClasses",
+        "-XMultiWayIf",
+        "-XNoImplicitPrelude",
+        "-XNoMonomorphismRestriction",
+        "-XOverloadedStrings",
+        "-XPatternGuards",
+        "-XParallelListComp",
+        "-XQuasiQuotes",
+        "-XRankNTypes",
+        "-XRecordWildCards",
+        "-XScopedTypeVariables",
+        "-XStandaloneDeriving",
+        "-XTemplateHaskell",
+        "-XTupleSections",
+        "-XTypeFamilies",
+        "-XTypeOperators",
+        "-hide-all-packages"
+      ]
+
+getSources :: IO [FilePath]
+getSources = filter (isSuffixOf ".hs") <$> go "library"
+  where
+    go dir = do
+      (dirs, files) <- getFilesAndDirectories dir
+      (files ++) . concat <$> mapM go dirs
+
+getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
+getFilesAndDirectories dir = do
+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

hasql.cabal

@@ -1,53 +1,13 @@
 name:
   hasql
 version:
-  0.7.4
-synopsis:
-  A minimalistic general high level API for relational databases
-description:
-  A robust and concise yet powerful API for communication with arbitrary
-  relational databases using SQL.
-  .
-  Features:
-  .
-  * Concise and crisp API. Just a few functions and two monads doing all the
-  boilerplate job for you.
-  .
-  * A powerful transaction abstraction, which provides 
-  an automated resolution of conflicts.
-  The API ensures that you're only able to perform a specific
-  set of actions in the transaction context,
-  which allows Hasql to safely resolve conflicting transactions 
-  by automatically retrying them.
-  This is much inspired by STM and ST.
-  .
-  * Support for cursors. Allows to fetch virtually limitless result sets in a
-  constant memory using streaming.
-  .
-  * Employment of prepared statements. 
-  Every statement you emit gets prepared and cached. 
-  This raises the performance of the backend.
-  .
-  * Automated management of resources related to connections, transactions and
-  cursors.
-  .
-  * A built-in connection pool.
-  .
-  * Compile-time generation of templates. You just can't write a statement with an
-  incorrect number of placeholders.
-  .
-  * Ability to map to any types actually supported by the backend.
-  .
-  Links:
-  .
-  * <http://nikita-volkov.github.io/hasql-benchmarks/ Benchmarks analysis>.
-  .
-  * <https://github.com/nikita-volkov/hasql/blob/master/demo/Main.hs Basic tutorial-demo>.
-  .
-  * <http://hackage.haskell.org/package/hasql-postgres PostgreSQL backend>.
-  .
+  1
 category:
-  Database
+  Hasql, Database, PostgreSQL
+synopsis:
+  A very efficient PostgreSQL driver and a flexible mapping API
+description:
+  This package is the root of the \"hasql\" ecosystem.
 homepage:
   https://github.com/nikita-volkov/hasql 
 bug-reports:
@@ -63,11 +23,9 @@ license:
 license-file:
   LICENSE
 build-type:
-  Simple
+  Custom
 cabal-version:
   >=1.10
-extra-source-files:
-  CHANGELOG.md
 
 
 source-repository head
@@ -81,123 +39,127 @@ library
   hs-source-dirs:
     library
   ghc-options:
-    -funbox-strict-fields
   default-extensions:
     Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
   default-language:
     Haskell2010
   other-modules:
     Hasql.Prelude
-    Hasql.QQ.Parser
-    Hasql.CxRow
-    Hasql.TH
-    Hasql.QQ
+    Hasql.PTI
+    Hasql.IO
+    Hasql.Settings
+    Hasql.Commands
+    Hasql.Deserialization.Array
+    Hasql.Deserialization.Composite
+    Hasql.Deserialization.Value
+    Hasql.Deserialization.Row
+    Hasql.Deserialization.Result
+    Hasql.Deserialization.Results
+    Hasql.Serialization.Array
+    Hasql.Serialization.Value
+    Hasql.Serialization.Params
+    Hasql.PreparedStatementRegistry
   exposed-modules:
-    Hasql
+    Hasql.Query
+    Hasql.Deserialization
+    Hasql.Serialization
+    Hasql.Connection
   build-depends:
-    -- 
-    resource-pool == 0.2.*,
-    hasql-backend == 0.4.*,
-    -- 
-    template-haskell >= 2.8 && < 2.11,
-    -- 
+    -- parsing:
     attoparsec >= 0.10 && < 0.14,
-    -- 
-    vector < 0.12,
-    text >= 1.0 && < 1.3,
-    -- 
-    either >= 4.3 && < 5,
-    list-t >= 0.3.1 && < 0.5,
-    mmorph == 1.0.*,
-    mtl >= 2.1 && < 2.3,
-    monad-control >= 0.3 && < 1.1,
-    transformers-base == 0.4.*,
+    -- database:
+    postgresql-binary >= 0.7.2 && < 0.8,
+    postgresql-libpq == 0.9.*,
+    -- data:
+    dlist >= 0.7 && < 0.8,
+    aeson >= 0.7 && < 0.11,
+    uuid == 1.3.*,
+    vector >= 0.10 && < 0.12,
+    time >= 1.4 && < 1.6,
+    hashtables >= 1.1 && < 1.3,
+    scientific >= 0.2 && < 0.4,
+    text >= 1 && < 1.3,
+    bytestring >= 0.10 && < 0.11,
+    hashable >= 1.2 && < 1.3,
+    -- control:
+    data-default-class >= 0.0.1 && < 0.1,
+    profunctors >= 5.1 && < 6,
+    contravariant-extras == 0.1.*,
+    contravariant >= 1.3 && < 2,
+    either >= 4.4.1 && < 5,
     transformers >= 0.3 && < 0.5,
-    base-prelude >= 0.1.3 && < 0.2,
-    base >= 4.6 && < 4.9
+    -- errors:
+    loch-th == 0.2.*,
+    placeholders == 0.1.*,
+    -- general:
+    base-prelude >= 0.1.19 && < 0.2,
+    base >= 4.6 && < 5
 
 
-test-suite hspec
-  type:             
-    exitcode-stdio-1.0
-  hs-source-dirs:   
-    hspec
-  main-is:          
-    Main.hs
-  ghc-options:
-    -threaded
-    "-with-rtsopts=-N"
-    -funbox-strict-fields
-  default-extensions:
-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
-  default-language:
-    Haskell2010
-  build-depends:
-    -- 
-    hasql,
-    hasql-backend,
-    -- 
-    hspec == 2.1.*,
-    -- 
-    vector,
-    -- 
-    mtl-prelude < 3,
-    base-prelude
-
-
-test-suite hspec-postgres
+test-suite doctest
   type:
     exitcode-stdio-1.0
   hs-source-dirs:
-    hspec-postgres
+    doctest
+  main-is:
+    Main.hs
+  ghc-options:
+    -threaded
+    "-with-rtsopts=-N"
+  build-depends:
+    doctest == 0.10.*,
+    directory == 1.2.*,
+    filepath >= 1.3 && < 1.5,
+    base-prelude >= 0.1.19 && < 0.2,
+    base
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language:
+    Haskell2010
+
+
+test-suite hspec
+  type:
+    exitcode-stdio-1.0
+  hs-source-dirs:
+    hspec
   main-is:
     Main.hs
   ghc-options:
     -threaded
     "-with-rtsopts=-N"
-    -funbox-strict-fields
   default-extensions:
     Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
   default-language:
     Haskell2010
   build-depends:
-    -- 
+    -- database:
     hasql,
-    hasql-postgres == 0.10.*,
-    -- 
-    slave-thread == 0.1.*,
-    -- 
-    hspec == 2.1.*,
-    -- 
-    text,
-    -- 
-    monad-control,
-    either,
-    mtl-prelude < 3,
-    base-prelude
+    -- testing:
+    hspec >= 2.2.0 && < 2.3,
+    quickcheck-instances >= 0.3.11 && < 0.4,
+    QuickCheck >= 2.8.1 && < 2.9,
+    -- general:
+    base-prelude >= 0.1.19 && < 0.2
 
 
--- Well, it's not a benchmark actually, 
--- but in Cabal there's no better way to specify an executable, 
--- which is not intended for distribution.
-benchmark demo
-  type: 
-    exitcode-stdio-1.0
+executable demo
   hs-source-dirs:
     demo
   main-is:
     Main.hs
   ghc-options:
-    -O2
     -threaded
     "-with-rtsopts=-N"
-    -funbox-strict-fields
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
   default-language:
     Haskell2010
   build-depends:
+    data-default-class,
+    contravariant-extras,
+    contravariant,
     hasql,
-    hasql-postgres == 0.10.*,
-    transformers >= 0.3 && < 0.5,
-    base
-
-
+    text,
+    bytestring,
+    base-prelude

hspec-postgres/Main.hs

@@ -1,149 +0,0 @@
-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
-import qualified Hasql.Postgres as HP
-import qualified SlaveThread
-
-
-main = 
-  hspec $ do
-
-    context "Multivalue clauses" $ do
-      -- See http://www.postgresql.org/docs/current/interactive/functions-comparisons.html
-
-      it "contains" $ do
-        flip shouldBe (Right True) =<< do
-          session $ 
-            fmap runIdentity $ H.tx Nothing $ H.singleEx $ [H.stmt|SELECT 2 = ANY (?)|] [1,2,3 :: Int]
-
-      it "contains not" $ do
-        flip shouldBe (Right False) =<< do
-          session $ 
-            fmap runIdentity $ H.tx Nothing $ H.singleEx $ [H.stmt|SELECT 2 != ALL (?)|] [1,2,3 :: Int]
-
-    context "Tx" $ do
-
-      it "does not commit if in uncommitting mode" $ do
-        flip shouldBe (Right (Nothing :: Maybe (Identity Int))) =<< do
-          session $ do
-            H.tx Nothing $ do
-              H.unitEx $ [H.stmt|DROP TABLE IF EXISTS a|]
-              H.unitEx $ [H.stmt|CREATE TABLE a (x INT8 NOT NULL, PRIMARY KEY (x))|]
-            H.tx (Just (H.Serializable, Just False)) $ do
-              H.unitEx $ [H.stmt|INSERT INTO a (x) VALUES (2)|]
-            H.tx Nothing $ do
-              H.maybeEx $ [H.stmt|SELECT x FROM a WHERE x = 2|]
-
-    context "UTF-8 templates" $ do
-
-      it "encode properly" $ do
-        flip shouldBe (Right (Just (Identity ("Ёжик" :: Text)))) =<< do
-          session $ H.tx Nothing $ H.maybeEx $ [H.stmt| SELECT 'Ёжик' |]
-
-    context "Bug" $ do
-
-      context "Unhandled transaction conflict" $ do
-
-        it "should not be" $ do
-          session $ H.tx Nothing $ do
-            H.unitEx [H.stmt|DROP TABLE IF EXISTS artist|]
-            H.unitEx [H.stmt|DROP TABLE IF EXISTS artist_union|]
-            H.unitEx $
-              [H.stmt|
-                CREATE TABLE "artist_union" (
-                  "id" BIGSERIAL,
-                  PRIMARY KEY ("id")
-                )
-              |]
-            H.unitEx $
-              [H.stmt|
-                CREATE TABLE "artist" (
-                  "id" BIGSERIAL,
-                  "artist_union_id" INT8 NOT NULL,
-                  "names" TEXT[] NOT NULL,
-                  PRIMARY KEY ("id"),
-                  FOREIGN KEY ("artist_union_id") REFERENCES "artist_union" ("id") ON DELETE CASCADE
-                )
-              |]
-          (signal, block) <- newBatchGate 6
-          let 
-            insertArtistUnion :: H.Tx HP.Postgres s Int64
-            insertArtistUnion =
-              fmap (runIdentity . fromJust) $ H.maybeEx $
-              [H.stmt| 
-                INSERT INTO artist_union DEFAULT VALUES RETURNING id
-              |]
-            insertArtist :: Int64 -> [Text] -> H.Tx HP.Postgres s Int64
-            insertArtist unionID artistNames = 
-              fmap (runIdentity . fromJust) $ H.maybeEx $
-              [H.stmt| 
-                INSERT INTO artist
-                  (artist_union_id, 
-                   names)
-                  VALUES (?, ?)
-                  RETURNING id 
-              |]
-                unionID
-                artistNames
-            process = 
-                SlaveThread.fork $ do
-                  session $ replicateM_ 100 $ do 
-                    H.tx (Just (H.Serializable, Just True)) $ do
-                      unionID <- insertArtistUnion
-                      insertArtist unionID ["a", "b", "c"]
-                  signal
-          replicateM_ 6 process
-          block
-
-    context "CxRow" $ do
-
-      it "should fail on incorrect arity" $ do
-        flip shouldSatisfy (\case Left (H.ResultError _) -> True; _ -> False) =<< do
-          session $ do
-            H.tx Nothing $ do
-              H.unitEx [H.stmt|DROP TABLE IF EXISTS data|]
-              H.unitEx [H.stmt|CREATE TABLE data (
-                                   field1    DECIMAL NOT NULL,
-                                   field2    BIGINT  NOT NULL,
-                                   PRIMARY KEY (field1)
-                               )|]
-              H.unitEx [H.stmt|INSERT INTO data (field1, field2) VALUES (0, 0)|]
-            mrow :: Maybe (Double, Int64, String) <- 
-              H.tx Nothing $  
-                H.maybeEx $ [H.stmt|SELECT * FROM data|]
-            return ()
-
-
--- * Helpers
--------------------------
-
-newBatchGate :: Int -> IO (IO (), IO ())
-newBatchGate amount =
-  do
-    counter <- atomically $ newTVar amount
-    return $
-      let signal = atomically $ readTVar counter >>= writeTVar counter . pred
-          block = atomically $ readTVar counter >>= \x -> when (x > 0) retry
-          in (signal, block)
-
-
--- * Hasql utils
--------------------------
-
-type Session m =
-  H.Session HP.Postgres m
-
-session :: MonadBaseControl IO m => Session m r -> m (Either (H.SessionError HP.Postgres) r)
-session m =
-  control $ \unlift -> do
-    p <- H.acquirePool backendSettings poolSettings
-    r <- unlift $ H.session p m
-    H.releasePool p
-    return r
-  where
-    backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"
-    poolSettings = fromJust $ H.poolSettings 6 30

hspec/Main.hs

@@ -1,51 +1,10 @@
-import BasePrelude
+module Main where
+
+import BasePrelude hiding (assert, isRight, isLeft)
 import Test.Hspec
-import qualified Hasql as H
-import qualified Hasql.Backend as HB
-import qualified Data.Vector as V
+import Test.QuickCheck
+import Test.QuickCheck.Instances
 
 
-data X
-
-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 "supports free variables" $ do
-        let a = 'a'
-            b = 'b'
-            in
-              (flip shouldBe)
-                (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue a, HB.encodeValue b]) True)
-                ([H.stmt| SELECT ($a + $b) |] :: HB.Stmt X)
-      it "supports ordered placeholders" $ do
-        (flip shouldBe)
-          (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue 'a', HB.encodeValue 'b']) True)
-          ([H.stmt| SELECT (? + ?) |] 'a' 'b' :: HB.Stmt X)
-      it "does not drop quotes" $ do
-        let 
-          HB.Stmt t _ _ =
-            [H.stmt| SELECT "a", 'b' |]
-        (flip shouldBe)
-          "SELECT \"a\", 'b'"
-          t
-      it "cleans whitespace" $ do
-        let 
-          HB.Stmt t _ _ =
-            [H.stmt| CREATE TABLE data (
-                       field1    DECIMAL NOT NULL,
-                       field2    BIGINT  NOT NULL,
-                       PRIMARY KEY (field1)
-                     ) |]
-        (flip shouldBe)
-          "CREATE TABLE data ( field1 DECIMAL NOT NULL, field2 BIGINT NOT NULL, PRIMARY KEY (field1) )"
-          t
+  error "TODO"

library/Hasql.hs

@@ -1,387 +0,0 @@
-{-# LANGUAGE UndecidableInstances, CPP #-}
--- |
--- This is the API of the \"hasql\" library.
--- 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
-(
-  -- * Pool
-  Pool,
-  acquirePool,
-  releasePool,
-
-  -- ** Pool Settings
-  PoolSettings,
-  poolSettings,
-
-  -- * Session
-  Session,
-  session,
-
-  -- ** Session Error
-  SessionError(..),
-
-  -- * Statement
-  Bknd.Stmt,
-  QQ.stmt,
-
-  -- * Statement Execution
-  Ex,
-  unitEx,
-  countEx,
-  singleEx,
-  maybeEx,
-  listEx,
-  vectorEx,
-  streamEx,
-
-  -- * Transaction
-  Tx,
-  tx,
-
-  -- ** Transaction Settings
-  Bknd.TxMode(..),
-  Bknd.TxIsolationLevel(..),
-  Bknd.TxWriteMode(..),
-
-  -- ** Result Stream
-  TxStream,
-  TxStreamListT,
-
-  -- * Row Parser
-  CxRow.CxRow,
-)
-where
-
-import Hasql.Prelude
-import qualified Hasql.Backend as Bknd
-import qualified Hasql.CxRow as CxRow
-import qualified Hasql.QQ as QQ
-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.Syntax as TH
-
-
--- * Resources
--------------------------
-
--- |
--- A connection pool. 
-newtype Pool c =
-  Pool (Pool.Pool (Either (Bknd.CxError c) c))
-
--- |
--- Given backend-specific connection settings and pool settings, 
--- acquire a backend connection pool,
--- which can then be used to work with the DB.
--- 
--- When combining Hasql with other libraries, 
--- which throw exceptions it makes sence to utilize 
--- @Control.Exception.'bracket'@
--- like this:
--- 
--- >bracket (acquirePool bkndStngs poolStngs) (releasePool) $ \pool -> do
--- >  session pool $ do
--- >    ...
--- >  ... any other IO code
-acquirePool :: Bknd.Cx c => Bknd.CxSettings c -> PoolSettings -> IO (Pool c)
-acquirePool cxSettings (PoolSettings size timeout) =
-  fmap Pool $
-  Pool.createPool (Bknd.acquireCx cxSettings) 
-                  (either (const $ return ()) Bknd.releaseCx) 
-                  (1)
-                  (fromIntegral timeout) 
-                  (size)
-
--- |
--- Release all connections acquired by the pool.
-releasePool :: Pool c -> IO ()
-releasePool (Pool p) =
-  Pool.destroyAllResources p
-
-
--- ** Pool Settings
--------------------------
-
--- |
--- Settings of a pool.
-data PoolSettings =
-  PoolSettings !Int !Int
-  deriving (Show)
-
-instance TH.Lift PoolSettings where
-  lift (PoolSettings a b) = 
-    [|PoolSettings a b|]
-    
-
--- | 
--- A smart constructor for pool settings.
-poolSettings :: 
-  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.
-  -> 
-  Int
-  -- ^
-  -- The amount of seconds for which an unused connection is kept open. 
-  -- The smallest acceptable value is 1.
-  -> 
-  Maybe PoolSettings
-  -- ^
-  -- Maybe pool settings, if they are correct.
-poolSettings size timeout =
-  if size > 0 && timeout >= 1
-    then Just $ PoolSettings size timeout
-    else Nothing
-
-
--- * Session
--------------------------
-
--- |
--- A convenience wrapper around 'ReaderT', 
--- which provides a shared context for execution and error-handling of transactions.
-newtype Session c m r =
-  Session (ReaderT (Pool c) (EitherT (SessionError c) m) r)
-  deriving (Functor, Applicative, Monad, MonadIO, MonadError (SessionError c))
-
-instance MonadTrans (Session c) where
-  lift = Session . lift . lift
-
-deriving instance MonadBase IO m => MonadBase IO (Session c m)
-
-instance MFunctor (Session c) where
-  hoist f (Session m) = 
-    Session $ ReaderT $ \e ->
-      EitherT $ f $ runEitherT $ flip runReaderT e $ m
-
-
-#if MIN_VERSION_monad_control(1,0,0)
-
-instance MonadTransControl (Session c) where
-  type StT (Session c) a = Either (SessionError c) a
-  liftWith onUnlift =
-    Session $ ReaderT $ \e -> 
-      lift $ onUnlift $ \(Session m) -> 
-        runEitherT $ flip runReaderT e $ m
-  restoreT = 
-    Session . ReaderT . const . EitherT
-
-instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where
-  type StM (Session c m) a = ComposeSt (Session c) m a
-  liftBaseWith = defaultLiftBaseWith
-  restoreM = defaultRestoreM
-
-#else
-
-instance MonadTransControl (Session c) where
-  newtype StT (Session c) a = 
-    SessionStT (Either (SessionError c) a)
-  liftWith onUnlift =
-    Session $ ReaderT $ \e -> 
-      lift $ onUnlift $ \(Session m) -> 
-        liftM SessionStT $ runEitherT $ flip runReaderT e $ m
-  restoreT = 
-    Session . ReaderT . const . EitherT . liftM (\(SessionStT a) -> a)
-
-instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where
-  newtype StM (Session c m) a = 
-    SessionStM (ComposeSt (Session c) m a)
-  liftBaseWith = 
-    defaultLiftBaseWith SessionStM
-  restoreM = 
-    defaultRestoreM $ \(SessionStM a) -> a
-   
-#endif
-
--- |
--- Execute a session using an established connection pool.
--- 
--- This is merely a wrapper around 'runReaderT',
--- so you can run it around every transaction,
--- if you want.
-session :: Pool c -> Session c m a -> m (Either (SessionError c) a)
-session pool m =
-  runEitherT $ flip runReaderT pool $ case m of Session m -> m
-
-
--- * Transaction
--------------------------
-
--- |
--- A transaction specialized for a backend connection @c@, 
--- associated with its intermediate results using an anonymous type-argument @s@ (same trick as in 'ST')
--- and producing a result @r@.
--- 
--- Running `IO` in `Tx` is prohibited. 
--- 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 { unwrapTx :: EitherT (SessionError c) (Bknd.Tx c) r }
-  deriving (Functor, Applicative, Monad)
-
-
-data SessionError c =
-  -- |
-  -- A backend-specific connection acquisition error.
-  -- E.g., a failure to establish a connection.
-  CxError (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.
-  TxError (Bknd.TxError c) |
-  -- |
-  -- Attempt to parse a result into an incompatible type.
-  -- Indicates either a mismatching schema or an incorrect query.
-  ResultError Text
-
-deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (SessionError c)
-deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (SessionError c)
-
--- |
--- Execute a transaction in a session.
--- 
--- This function ensures on the type level, 
--- that it's impossible to return @'TxStreamListT' s m r@ from it.
-tx :: (Bknd.CxTx c, MonadBaseControl IO m) => Bknd.TxMode -> (forall s. Tx c s r) -> Session c m r
-tx mode (Tx m) =
-  Session $ ReaderT $ \(Pool pool) ->
-    Pool.withResource pool $ \e -> do
-      c <- hoistEither $ mapLeft CxError e
-      let
-        attempt =
-          do
-            r <- EitherT $ liftBase $ fmap (either (Left . TxError) Right) $ 
-                 Bknd.runTx c mode $ runEitherT m
-            maybe attempt hoistEither r
-        in attempt
-
-
--- * Statements execution
--------------------------
-
--- |
--- Statement executor.
--- 
--- Just an alias to a function, which executes a statement in 'Tx'.
-type Ex c s r =
-  Bknd.Stmt c -> Tx c s r
-
--- |
--- Execute a statement without processing the result.
-unitEx :: Ex c s ()
-unitEx = 
-  Tx . lift . Bknd.unitTx
-
--- |
--- Execute a statement and count the amount of affected rows.
--- Useful for resolving how many rows were updated or deleted.
-countEx :: Bknd.CxValue c Word64 => Ex c s Word64
-countEx =
-  Tx . lift . Bknd.countTx
-
--- |
--- Execute a statement,
--- which produces exactly one result row.
--- E.g., @INSERT@, which returns an autoincremented identifier,
--- or @SELECT COUNT@, or @SELECT EXISTS@.
--- 
--- Please note that using this executor for selecting rows is conceptually wrong, 
--- since in that case the results are always optional. 
--- Use 'maybeEx', 'listEx' or 'vectorEx' instead.
--- 
--- If the result is empty this executor will raise 'ResultError'.
-singleEx :: CxRow.CxRow c r => Ex c s r
-singleEx =
-  join . fmap (maybe (Tx $ left $ ResultError "No rows on 'singleEx'") return) .
-  maybeEx
-
--- |
--- Execute a statement,
--- which optionally produces a single result row.
-maybeEx :: CxRow.CxRow c r => Ex c s (Maybe r)
-maybeEx =
-  fmap (fmap Vector.unsafeHead . mfilter (not . Vector.null) . Just) . vectorEx
-
--- |
--- Execute a statement,
--- and produce a list of results.
-listEx :: CxRow.CxRow c r => Ex c s [r]
-listEx =
-  fmap toList . vectorEx
-
--- |
--- Execute a statement,
--- and produce a vector of results.
-vectorEx :: CxRow.CxRow c r => Ex c s (Vector r)
-vectorEx s =
-  Tx $ do
-    r <- lift $ Bknd.vectorTx s
-    EitherT $ return $ traverse ((mapLeft ResultError) . CxRow.parseRow) $ r
-
--- |
--- Given a batch size, execute a statement with a cursor,
--- and produce a result stream.
--- 
--- The cursor allows you to fetch virtually limitless results in a constant memory
--- at a cost of a small overhead.
--- 
--- The batch size parameter controls how many rows will be fetched 
--- during every roundtrip to the database. 
--- A minimum value of 256 seems to be sane.
--- 
--- 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.
-streamEx :: CxRow.CxRow c r => Int -> Ex c s (TxStream c s r)
-streamEx n s =
-  Tx $ do
-    r <- lift $ Bknd.streamTx n s
-    return $ TxStreamListT $ do
-      row <- hoist (Tx . lift) r
-      lift $ Tx $ EitherT $ return $ mapLeft ResultError $ CxRow.parseRow $ row
-
-
--- * Result Stream
--------------------------
-
--- |
--- A stream of results, 
--- which fetches approximately only those that you reach.
-type TxStream c s =
-  TxStreamListT s (Tx c s)
-
--- |
--- A wrapper around 'ListT.ListT', 
--- which uses the same trick as the 'ST' monad to associate with the
--- context monad and become impossible to be returned from it,
--- using the anonymous type parameter @s@.
--- This lets the library ensure that it is safe to automatically
--- 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_'.
-newtype TxStreamListT s m r =
-  TxStreamListT (ListT.ListT m r)
-  deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus, 
-            Monoid, ListT.MonadCons)
-
-instance ListT.MonadTransUncons (TxStreamListT s) where
-  uncons = 
-    (liftM . fmap . fmap) (unsafeCoerce :: ListT.ListT m r -> TxStreamListT s m r) .
-    ListT.uncons . 
-    (unsafeCoerce :: TxStreamListT s m r -> ListT.ListT m r)
-

library/Hasql/Commands.hs

@@ -0,0 +1,33 @@
+module Hasql.Commands
+(
+  Commands,
+  asBytes,
+  setEncodingToUTF8,
+  setMinClientMessagesToWarning,
+)
+where
+
+import Hasql.Prelude
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Builder as BB
+import qualified Data.ByteString.Lazy.Builder.ASCII as BB
+import qualified Data.ByteString.Lazy as BL
+
+
+newtype Commands =
+  Commands ( DList BB.Builder )
+  deriving ( Monoid )
+
+asBytes :: Commands -> ByteString
+asBytes (Commands list) =
+  BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list
+
+setEncodingToUTF8 :: Commands
+setEncodingToUTF8 =
+  Commands (pure "SET client_encoding = 'UTF8'")
+
+setMinClientMessagesToWarning :: Commands
+setMinClientMessagesToWarning =
+  Commands (pure "SET client_min_messages TO WARNING")
+
+

library/Hasql/Connection.hs

@@ -0,0 +1,129 @@
+module Hasql.Connection
+(
+  Connection,
+  Settings.Settings(..),
+  acquire,
+  release,
+  executeParametricQuery,
+  -- * Errors
+  AcquisitionError(..),
+  ResultsError(..),
+  ResultError(..),
+  RowError(..),
+)
+where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Query as Query
+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry
+import qualified Hasql.Deserialization.Results as ResultsDeserialization
+import qualified Hasql.Deserialization as Deserialization
+import qualified Hasql.Serialization.Params as ParamsSerialization
+import qualified Hasql.Serialization as Serialization
+import qualified Hasql.Settings as Settings
+import qualified Hasql.IO as IO
+
+
+-- |
+-- A single connection to the database.
+data Connection =
+  Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry
+
+data ResultsError =
+  -- |
+  -- An error on the client-side,
+  -- with a message generated by the \"libpq\" library.
+  -- Usually indicates problems with connection.
+  ClientError !( Maybe ByteString ) |
+  ResultError !ResultError
+  deriving ( Show )
+
+data ResultError =
+  -- | 
+  -- An error reported by the DB. Code, message, details, hint.
+  -- 
+  -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; 
+  -- it can be used by front-end applications to perform specific operations (such as error handling) 
+  -- in response to a particular database error. 
+  -- For a list of the possible SQLSTATE codes, see Appendix A.
+  -- This field is not localizable, and is always present.
+  -- 
+  -- * The primary human-readable error message (typically one line). Always present.
+  -- 
+  -- * Detail: an optional secondary error message carrying more detail about the problem. 
+  -- Might run to multiple lines.
+  -- 
+  -- * Hint: an optional suggestion what to do about the problem. 
+  -- This is intended to differ from detail in that it offers advice (potentially inappropriate) 
+  -- rather than hard facts. Might run to multiple lines.
+  ServerError !ByteString !ByteString !( Maybe ByteString ) !( Maybe ByteString ) |
+  -- |
+  -- The database returned an unexpected result.
+  -- Indicates an improper statement or a schema mismatch.
+  UnexpectedResult !Text |
+  -- |
+  -- An error of the row reader, preceded by the index of the row.
+  RowError !Int !RowError |
+  -- |
+  -- An unexpected amount of rows.
+  UnexpectedAmountOfRows !Int
+  deriving ( Show )
+
+data RowError =
+  EndOfInput |
+  UnexpectedNull |
+  ValueError !Text
+  deriving ( Show )
+
+-- |
+-- A connection acquistion error.
+data AcquisitionError =
+  -- | Some errors during connection.
+  BadConnectionStatus !( Maybe ByteString ) |
+  -- | The server is running a too old version of Postgres.
+  UnsupportedVersion !Int
+  deriving ( Show )
+
+-- |
+-- Acquire a connection using the provided settings.
+acquire :: Settings.Settings -> IO ( Either AcquisitionError Connection )
+acquire settings =
+  runEitherT $ do
+    pqConnection <- lift (IO.acquireConnection settings)
+    lift (IO.checkConnectionStatus pqConnection) >>= traverse (left . BadConnectionStatus)
+    lift (IO.checkServerVersion pqConnection) >>= traverse (left . UnsupportedVersion)
+    lift (IO.initConnection pqConnection)
+    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)
+    registry <- lift (IO.acquirePreparedStatementRegistry)
+    pure (Connection pqConnection integerDatetimes registry)
+
+-- |
+-- Release the connection.
+release :: Connection -> IO ()
+release (Connection pqConnection _ _) =
+  LibPQ.finish pqConnection
+
+-- |
+-- Execute a query, producing either a deserialization failure or a successful result.
+executeParametricQuery :: Connection -> Query.ParametricQuery a b -> a -> IO ( Either ResultsError b )
+executeParametricQuery (Connection pqConnection integerDatetimes registry) (template, serializer, deserializer, preparable) params =
+  fmap (mapLeft coerceResultsError) $ runEitherT $ do
+    EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceSerializer serializer) preparable params
+    EitherT $ IO.getResults pqConnection integerDatetimes (coerceDeserializer deserializer)
+
+-- |
+-- WARNING: We need to take special care that the structure of
+-- the "ResultsDeserialization.Error" type in the public API is an exact copy of
+-- "Error", since we're using coercion.
+coerceResultsError :: ResultsDeserialization.Error -> ResultsError
+coerceResultsError =
+  unsafeCoerce
+
+coerceDeserializer :: Deserialization.Results a -> ResultsDeserialization.Results a
+coerceDeserializer =
+  unsafeCoerce
+
+coerceSerializer :: Serialization.Params a -> ParamsSerialization.Params a
+coerceSerializer =
+  unsafeCoerce

library/Hasql/CxRow.hs

@@ -1,64 +0,0 @@
-module Hasql.CxRow where
-
-import Hasql.Prelude
-import Language.Haskell.TH
-import qualified Hasql.Backend as Bknd
-import qualified Data.Vector as Vector
-import qualified Hasql.TH as THUtil
-
-
--- |
--- This class is only intended to be used with the supplied instances,
--- which should be enough to cover all use cases.
-class CxRow c r where
-  parseRow :: Bknd.ResultRow c -> Either Text r
-
-instance CxRow c () where
-  parseRow row = 
-    if Vector.null row
-      then Right ()
-      else Left "Not an empty row"
-
-instance Bknd.CxValue c v => CxRow c (Identity v) where
-  parseRow row = do
-    Identity <$> Bknd.decodeValue (Vector.unsafeHead row)
-
--- Generate tuple instaces using Template Haskell:
-return $ flip map [2 .. 24] $ \arity ->
-  let 
-    varNames =
-      [1 .. arity] >>= \i -> return (mkName ('v' : show i))
-    varTypes =
-      map VarT varNames
-    connectionType =
-      VarT (mkName "c")
-    constraints =
-      map (\t -> THUtil.classP ''Bknd.CxValue [connectionType, t]) varTypes
-    head =
-      AppT (AppT (ConT ''CxRow) connectionType) (foldl AppT (TupleT arity) varTypes)
-    parseRowDec =
-      FunD 'parseRow [Clause [VarP rowVarName] (NormalB e) []]
-      where
-        rowVarName = mkName "row"
-        e =
-          THUtil.purify $
-            [|
-              let actualLength = Vector.length $(varE rowVarName)
-                  expectedLength = $(litE (IntegerL $ fromIntegral arity))
-                  in if actualLength == expectedLength
-                    then $(pure $ THUtil.applicativeE (ConE (tupleDataName arity)) lookups)
-                    else Left $ fromString $ ($ "") $
-                           showString "Inappropriate row length: " . shows actualLength .
-                           showString ", expecting: " . shows expectedLength . 
-                           showString " instead"
-            |]
-          where
-            lookups = do
-              i <- [0 .. pred arity]
-              return $ THUtil.purify $
-                [|
-                  Bknd.decodeValue
-                    (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) )
-                |]
-    in InstanceD constraints head [parseRowDec]
-

library/Hasql/Deserialization.hs

@@ -0,0 +1,732 @@
+-- |
+-- A DSL for creating result deserializers.
+module Hasql.Deserialization
+(
+  -- * Results
+  Results,
+  result,
+  -- * Result
+  Result,
+  noResult,
+  rowsAffected,
+  singleRow,
+  -- ** Specialized multi-row results
+  maybeRow,
+  rowsVector,
+  rowsList,
+  -- ** Multi-row traversers
+  foldlRows,
+  foldrRows,
+  generateRows,
+  -- * Row
+  Row,
+  value,
+  nullableValue,
+  -- * Value
+  Value,
+  bool,
+  int2,
+  int4,
+  int8,
+  float4,
+  float8,
+  numeric,
+  char,
+  text,
+  bytea,
+  date,
+  timestamp,
+  timestamptz,
+  time,
+  timetz,
+  interval,
+  uuid,
+  json,
+  array,
+  composite,
+  hstore,
+  -- * Array
+  Array,
+  arrayDimension,
+  arrayValue,
+  arrayNullableValue,
+  -- * Composite
+  Composite,
+  compositeValue,
+  compositeNullableValue,
+)
+where
+
+import Hasql.Prelude hiding (maybe, bool)
+import qualified Data.Aeson as Aeson
+import qualified Data.Vector as Vector
+import qualified PostgreSQL.Binary.Decoder as Decoder
+import qualified Hasql.Deserialization.Results as Results
+import qualified Hasql.Deserialization.Result as Result
+import qualified Hasql.Deserialization.Row as Row
+import qualified Hasql.Deserialization.Value as Value
+import qualified Hasql.Deserialization.Array as Array
+import qualified Hasql.Deserialization.Composite as Composite
+import qualified Hasql.Prelude as Prelude
+
+
+-- * Results
+-------------------------
+
+-- |
+-- Deserializer of possibly multiple results of a single query.
+-- 
+-- Multiple results get produced by non-parametric queries with multiple statements.
+-- 
+-- Parametric queries always produce exactly one result,
+-- so don't confuse this with a multi-row result.
+-- 
+newtype Results a =
+  Results (Results.Results a)
+  deriving (Functor, Applicative, Monad)
+
+-- |
+-- Lift an individual result deserializer to
+-- a deserializer of multiple results.
+{-# INLINABLE result #-}
+result :: Result a -> Results a
+result (Result result) =
+  Results (Results.single result)
+
+-- ** Instances
+-------------------------
+
+-- | Maps to @(result 'noResult')@.
+instance Default (Results ()) where
+  {-# INLINE def #-}
+  def =
+    result noResult
+
+-- | Maps to @(result 'rowsAffected')@.
+instance Default (Results Int64) where
+  {-# INLINE def #-}
+  def =
+    result rowsAffected
+
+-- | Maps to @(result ('maybeRow' def))@.
+instance Default (Row a) => Default (Results (Maybe a)) where
+  {-# INLINE def #-}
+  def =
+    result (maybeRow def)
+
+-- | Maps to @(result ('rowsVector' def))@.
+instance Default (Row a) => Default (Results (Vector a)) where
+  {-# INLINE def #-}
+  def =
+    result (rowsVector def)
+
+-- | Maps to @(result ('rowsList' def))@.
+instance Default (Row a) => Default (Results ([] a)) where
+  {-# INLINE def #-}
+  def =
+    result (rowsList def)
+
+-- | Maps to @(result (fmap Identity ('singleRow' def)))@.
+instance Default (Row a) => Default (Results (Identity a)) where
+  {-# INLINE def #-}
+  def =
+    result (fmap Identity (singleRow def))
+
+
+-- * Result
+-------------------------
+
+-- |
+-- Deserializer of an individual result.
+-- 
+newtype Result a =
+  Result (Result.Result a)
+  deriving (Functor)
+
+-- |
+-- Deserialize no value from the result.
+-- 
+-- Useful for statements like @INSERT@ or @CREATE@.
+-- 
+{-# INLINABLE noResult #-}
+noResult :: Result ()
+noResult =
+  Result Result.unit
+
+-- |
+-- Get the amount of rows affected by such statements as
+-- @UPDATE@ or @DELETE@.
+-- 
+{-# INLINABLE rowsAffected #-}
+rowsAffected :: Result Int64
+rowsAffected =
+  Result Result.rowsAffected
+
+-- |
+-- Exactly one row.
+-- Will raise the 'Hasql.Connection.UnexpectedAmountOfRows' error if it's any other.
+-- 
+{-# INLINABLE singleRow #-}
+singleRow :: Row a -> Result a
+singleRow (Row row) =
+  Result (Result.single row)
+
+-- ** Multi-row traversers
+-------------------------
+
+-- |
+-- Given a function like 'Vector.generateM' packs multiple results accordingly.
+-- 
+{-# INLINABLE generateRows #-}
+generateRows :: (forall m. Monad m => Int -> (Int -> m a) -> m b) -> Row a -> Result b
+generateRows generateM (Row row) =
+  Result (Result.generate generateM row)
+
+-- |
+-- Foldl multiple rows.
+-- 
+{-# INLINABLE foldlRows #-}
+foldlRows :: (a -> b -> a) -> a -> Row b -> Result a
+foldlRows step init (Row row) =
+  Result (Result.foldl step init row)
+
+-- |
+-- Foldr multiple rows.
+-- 
+{-# INLINABLE foldrRows #-}
+foldrRows :: (b -> a -> a) -> a -> Row b -> Result a
+foldrRows step init (Row row) =
+  Result (Result.foldr step init row)
+
+-- ** Specialized multi-row results
+-------------------------
+
+-- |
+-- Maybe one row or none.
+-- 
+{-# INLINABLE maybeRow #-}
+maybeRow :: Row a -> Result (Maybe a)
+maybeRow (Row row) =
+  Result (Result.maybe row)
+
+-- |
+-- Zero or more rows packed into the vector.
+-- 
+{-# INLINABLE rowsVector #-}
+rowsVector :: Row a -> Result (Vector a)
+rowsVector (Row row) =
+  Result (Result.generate Vector.generateM row)
+
+-- |
+-- Zero or more rows packed into the list.
+-- 
+{-# INLINABLE rowsList #-}
+rowsList :: Row a -> Result [ a ]
+rowsList (Row row) =
+  Result (Result.foldr (:) [] row)
+
+
+-- ** Instances
+-------------------------
+
+-- | Maps to 'noResult'.
+instance Default (Result ()) where
+  {-# INLINE def #-}
+  def =
+    noResult
+
+-- | Maps to 'rowsAffected'.
+instance Default (Result Int64) where
+  {-# INLINE def #-}
+  def =
+    rowsAffected
+
+-- | Maps to @('maybeRow' def)@.
+instance Default (Row a) => Default (Result (Maybe a)) where
+  {-# INLINE def #-}
+  def =
+    maybeRow def
+
+-- | Maps to @('rowsVector' def)@.
+instance Default (Row a) => Default (Result (Vector a)) where
+  {-# INLINE def #-}
+  def =
+    rowsVector def
+
+-- | Maps to @('rowsList' def)@.
+instance Default (Row a) => Default (Result ([] a)) where
+  {-# INLINE def #-}
+  def =
+    rowsList def
+
+-- | Maps to @(fmap Identity ('singleRow' def)@.
+instance Default (Row a) => Default (Result (Identity a)) where
+  {-# INLINE def #-}
+  def =
+    fmap Identity (singleRow def)
+
+
+-- * Row
+-------------------------
+
+-- |
+-- Deserializer of an individual row,
+-- which gets composed of column value deserializers.
+-- 
+-- E.g.:
+-- 
+-- >x :: Row (Maybe Int64, Text, TimeOfDay)
+-- >x =
+-- >  (,,) <$> nullableValue int8 <*> value text <*> value time
+-- 
+newtype Row a =
+  Row (Row.Row a)
+  deriving (Functor, Applicative, Monad)
+
+-- |
+-- Lift an individual non-nullable value deserializer to a composable row deserializer.
+-- 
+{-# INLINABLE value #-}
+value :: Value a -> Row a
+value (Value imp) =
+  Row (Row.nonNullValue imp)
+
+-- |
+-- Lift an individual nullable value deserializer to a composable row deserializer.
+-- 
+{-# INLINABLE nullableValue #-}
+nullableValue :: Value a -> Row (Maybe a)
+nullableValue (Value imp) =
+  Row (Row.value imp)
+
+
+-- ** Instances
+-------------------------
+
+instance Default (Value a) => Default (Row (Identity a)) where
+  {-# INLINE def #-}
+  def =
+    fmap Identity (value def)
+
+instance Default (Value a) => Default (Row (Maybe a)) where
+  {-# INLINE def #-}
+  def =
+    nullableValue def
+
+instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where
+  {-# INLINE def #-}
+  def =
+    ap (fmap (,) (value def)) (value def)
+
+
+-- * Value
+-------------------------
+
+-- |
+-- Deserializer of an individual value.
+-- 
+newtype Value a =
+  Value (Value.Value a)
+  deriving (Functor)
+
+
+-- ** Plain value deserializers
+-------------------------
+
+-- |
+-- Deserializer of the @BOOL@ values.
+-- 
+{-# INLINABLE bool #-}
+bool :: Value Bool
+bool =
+  Value (Value.decoder (const Decoder.bool))
+
+-- |
+-- Deserializer of the @INT2@ values.
+-- 
+{-# INLINABLE int2 #-}
+int2 :: Value Int16
+int2 =
+  Value (Value.decoder (const Decoder.int))
+
+-- |
+-- Deserializer of the @INT4@ values.
+-- 
+{-# INLINABLE int4 #-}
+int4 :: Value Int32
+int4 =
+  Value (Value.decoder (const Decoder.int))
+
+-- |
+-- Deserializer of the @INT8@ values.
+-- 
+{-# INLINABLE int8 #-}
+int8 :: Value Int64
+int8 =
+  Value (Value.decoder (const Decoder.int))
+
+-- |
+-- Deserializer of the @FLOAT4@ values.
+-- 
+{-# INLINABLE float4 #-}
+float4 :: Value Float
+float4 =
+  Value (Value.decoder (const Decoder.float4))
+
+-- |
+-- Deserializer of the @FLOAT8@ values.
+-- 
+{-# INLINABLE float8 #-}
+float8 :: Value Double
+float8 =
+  Value (Value.decoder (const Decoder.float8))
+
+-- |
+-- Deserializer of the @NUMERIC@ values.
+-- 
+{-# INLINABLE numeric #-}
+numeric :: Value Scientific
+numeric =
+  Value (Value.decoder (const Decoder.numeric))
+
+-- |
+-- Deserializer of the @CHAR@ values.
+-- Note that it supports UTF-8 values.
+{-# INLINABLE char #-}
+char :: Value Char
+char =
+  Value (Value.decoder (const Decoder.char))
+
+-- |
+-- Deserializer of the @TEXT@ values.
+-- 
+{-# INLINABLE text #-}
+text :: Value Text
+text =
+  Value (Value.decoder (const Decoder.text_strict))
+
+-- |
+-- Deserializer of the @BYTEA@ values.
+-- 
+{-# INLINABLE bytea #-}
+bytea :: Value ByteString
+bytea =
+  Value (Value.decoder (const Decoder.bytea_strict))
+
+-- |
+-- Deserializer of the @DATE@ values.
+-- 
+{-# INLINABLE date #-}
+date :: Value Day
+date =
+  Value (Value.decoder (const Decoder.date))
+
+-- |
+-- Deserializer of the @TIMESTAMP@ values.
+-- 
+{-# INLINABLE timestamp #-}
+timestamp :: Value LocalTime
+timestamp =
+  Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int))
+
+-- |
+-- Deserializer of the @TIMESTAMPTZ@ values.
+-- 
+-- /NOTICE/
+-- 
+-- Postgres does not store the timezone information of @TIMESTAMPTZ@.
+-- Instead it stores a UTC value and performs silent conversions
+-- to the currently set timezone, when dealt with in the text format.
+-- However this library bypasses the silent conversions
+-- and communicates with Postgres using the UTC values directly.
+{-# INLINABLE timestamptz #-}
+timestamptz :: Value UTCTime
+timestamptz =
+  Value (Value.decoder (Prelude.bool Decoder.timestamptz_float Decoder.timestamptz_int))
+
+-- |
+-- Deserializer of the @TIME@ values.
+-- 
+{-# INLINABLE time #-}
+time :: Value TimeOfDay
+time =
+  Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int))
+
+-- |
+-- Deserializer of the @TIMETZ@ values.
+-- 
+-- Unlike in case of @TIMESTAMPTZ@, 
+-- Postgres does store the timezone information for @TIMETZ@.
+-- However the Haskell's \"time\" library does not contain any composite type,
+-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'
+-- to represent a value on the Haskell's side.
+{-# INLINABLE timetz #-}
+timetz :: Value (TimeOfDay, TimeZone)
+timetz =
+  Value (Value.decoder (Prelude.bool Decoder.timetz_float Decoder.timetz_int))
+
+-- |
+-- Deserializer of the @INTERVAL@ values.
+-- 
+{-# INLINABLE interval #-}
+interval :: Value DiffTime
+interval =
+  Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int))
+
+-- |
+-- Deserializer of the @UUID@ values.
+-- 
+{-# INLINABLE uuid #-}
+uuid :: Value UUID
+uuid =
+  Value (Value.decoder (const Decoder.uuid))
+
+-- |
+-- Deserializer of the @JSON@ values.
+-- 
+{-# INLINABLE json #-}
+json :: Value Aeson.Value
+json =
+  Value (Value.decoder (const Decoder.json))
+
+
+-- ** Composite value deserializers
+-------------------------
+
+-- |
+-- Lifts the 'Array' deserializer to the 'Value' deserializer.
+-- 
+{-# INLINABLE array #-}
+array :: Array a -> Value a
+array (Array imp) =
+  Value (Value.decoder (Array.run imp))
+
+-- |
+-- Lifts the 'Composite' deserializer to the 'Value' deserializer.
+-- 
+{-# INLINABLE composite #-}
+composite :: Composite a -> Value a
+composite (Composite imp) =
+  Value (Value.decoder (Composite.run imp))
+
+-- |
+-- A generic deserializer of @HSTORE@ values.
+-- 
+-- Here's how you can use it to construct a specific value:
+-- 
+-- @
+-- x :: Value [(Text, Maybe Text)]
+-- x =
+--   hstore 'replicateM'
+-- @
+-- 
+{-# INLINABLE hstore #-}
+hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a
+hstore replicateM =
+  Value (Value.decoder (const (Decoder.hstore replicateM Decoder.text_strict Decoder.text_strict)))
+
+
+-- ** Instances
+-------------------------
+
+-- |
+-- Maps to 'bool'.
+instance Default (Value Bool) where
+  {-# INLINE def #-}
+  def =
+    bool
+
+-- |
+-- Maps to 'int2'.
+instance Default (Value Int16) where
+  {-# INLINE def #-}
+  def =
+    int2
+
+-- |
+-- Maps to 'int4'.
+instance Default (Value Int32) where
+  {-# INLINE def #-}
+  def =
+    int4
+
+-- |
+-- Maps to 'int8'.
+instance Default (Value Int64) where
+  {-# INLINE def #-}
+  def =
+    int8
+
+-- |
+-- Maps to 'float4'.
+instance Default (Value Float) where
+  {-# INLINE def #-}
+  def =
+    float4
+
+-- |
+-- Maps to 'float8'.
+instance Default (Value Double) where
+  {-# INLINE def #-}
+  def =
+    float8
+
+-- |
+-- Maps to 'numeric'.
+instance Default (Value Scientific) where
+  {-# INLINE def #-}
+  def =
+    numeric
+
+-- |
+-- Maps to 'char'.
+instance Default (Value Char) where
+  {-# INLINE def #-}
+  def =
+    char
+
+-- |
+-- Maps to 'text'.
+instance Default (Value Text) where
+  {-# INLINE def #-}
+  def =
+    text
+
+-- |
+-- Maps to 'bytea'.
+instance Default (Value ByteString) where
+  {-# INLINE def #-}
+  def =
+    bytea
+
+-- |
+-- Maps to 'date'.
+instance Default (Value Day) where
+  {-# INLINE def #-}
+  def =
+    date
+
+-- |
+-- Maps to 'timestamp'.
+instance Default (Value LocalTime) where
+  {-# INLINE def #-}
+  def =
+    timestamp
+
+-- |
+-- Maps to 'timestamptz'.
+instance Default (Value UTCTime) where
+  {-# INLINE def #-}
+  def =
+    timestamptz
+
+-- |
+-- Maps to 'time'.
+instance Default (Value TimeOfDay) where
+  {-# INLINE def #-}
+  def =
+    time
+
+-- |
+-- Maps to 'timetz'.
+instance Default (Value (TimeOfDay, TimeZone)) where
+  {-# INLINE def #-}
+  def =
+    timetz
+
+-- |
+-- Maps to 'interval'.
+instance Default (Value DiffTime) where
+  {-# INLINE def #-}
+  def =
+    interval
+
+-- |
+-- Maps to 'uuid'.
+instance Default (Value UUID) where
+  {-# INLINE def #-}
+  def =
+    uuid
+
+-- |
+-- Maps to 'json'.
+instance Default (Value Aeson.Value) where
+  {-# INLINE def #-}
+  def =
+    json
+
+
+-- * Array deserializers
+-------------------------
+
+-- |
+-- A generic array deserializer.
+-- 
+-- Here's how you can use it to produce a specific array value deserializer:
+-- 
+-- @
+-- x :: Value [[Text]]
+-- x =
+--   array (arrayDimension 'replicateM' (arrayDimension 'replicateM' (arrayValue text)))
+-- @
+-- 
+newtype Array a =
+  Array (Array.Array a)
+  deriving (Functor)
+
+-- |
+-- A function for parsing a dimension of an array.
+-- Provides support for multi-dimensional arrays.
+-- 
+-- Accepts:
+-- 
+-- * An implementation of the @replicateM@ function
+-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),
+-- which determines the output value.
+-- 
+-- * A deserializer of its components, which can be either another 'arrayDimension',
+-- 'arrayValue' or 'arrayNullableValue'.
+-- 
+{-# INLINABLE arrayDimension #-}
+arrayDimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b
+arrayDimension replicateM (Array imp) =
+  Array (Array.dimension replicateM imp)
+
+-- |
+-- Lift a 'Value' deserializer into an 'Array' deserializer for parsing of non-nullable leaf values.
+{-# INLINABLE arrayValue #-}
+arrayValue :: Value a -> Array a
+arrayValue (Value imp) =
+  Array (Array.nonNullValue (Value.run imp))
+
+-- |
+-- Lift a 'Value' deserializer into an 'Array' deserializer for parsing of nullable leaf values.
+{-# INLINABLE arrayNullableValue #-}
+arrayNullableValue :: Value a -> Array (Maybe a)
+arrayNullableValue (Value imp) =
+  Array (Array.value (Value.run imp))
+
+
+-- * Composite deserializers
+-------------------------
+
+-- |
+-- Composable deserializer of composite values (rows, records).
+newtype Composite a =
+  Composite (Composite.Composite a)
+  deriving (Functor, Applicative, Monad)
+
+-- |
+-- Lift a 'Value' deserializer into an 'Composite' deserializer for parsing of non-nullable leaf values.
+{-# INLINABLE compositeValue #-}
+compositeValue :: Value a -> Composite a
+compositeValue (Value imp) =
+  Composite (Composite.nonNullValue (Value.run imp))
+
+-- |
+-- Lift a 'Value' deserializer into an 'Composite' deserializer for parsing of nullable leaf values.
+{-# INLINABLE compositeNullableValue #-}
+compositeNullableValue :: Value a -> Composite (Maybe a)
+compositeNullableValue (Value imp) =
+  Composite (Composite.value (Value.run imp))
+

library/Hasql/Deserialization/Array.hs

@@ -0,0 +1,31 @@
+module Hasql.Deserialization.Array where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Decoder as Decoder
+
+
+newtype Array a =
+  Array (ReaderT Bool Decoder.ArrayDecoder a)
+  deriving (Functor)
+
+{-# INLINE run #-}
+run :: Array a -> Bool -> Decoder.Decoder a
+run (Array imp) env =
+  Decoder.array (runReaderT imp env)
+
+{-# INLINE dimension #-}
+dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b
+dimension replicateM (Array imp) =
+  Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env)
+
+{-# INLINE value #-}
+value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a)
+value decoder' =
+  Array $ ReaderT $ Decoder.arrayValue . decoder'
+
+{-# INLINE nonNullValue #-}
+nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a
+nonNullValue decoder' =
+  Array $ ReaderT $ Decoder.arrayNonNullValue . decoder'
+

library/Hasql/Deserialization/Composite.hs

@@ -0,0 +1,26 @@
+module Hasql.Deserialization.Composite where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Decoder as Decoder
+
+
+newtype Composite a =
+  Composite (ReaderT Bool Decoder.CompositeDecoder a)
+  deriving (Functor, Applicative, Monad)
+
+{-# INLINE run #-}
+run :: Composite a -> Bool -> Decoder.Decoder a
+run (Composite imp) env =
+  Decoder.composite (runReaderT imp env)
+
+{-# INLINE value #-}
+value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a)
+value decoder' =
+  Composite $ ReaderT $ Decoder.compositeValue . decoder'
+
+{-# INLINE nonNullValue #-}
+nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a
+nonNullValue decoder' =
+  Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder'
+

library/Hasql/Deserialization/Result.hs

@@ -0,0 +1,207 @@
+module Hasql.Deserialization.Result where
+
+import Hasql.Prelude hiding (maybe, many)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Deserialization.Row as Row
+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
+import qualified Data.ByteString as ByteString
+import qualified Hasql.Prelude as Prelude
+
+
+newtype Result a =
+  Result ( ReaderT ( Bool , LibPQ.Result ) ( EitherT Error IO ) a )
+  deriving ( Functor , Applicative , Monad )
+
+data Error =
+  -- | 
+  -- An error reported by the DB. Code, message, details, hint.
+  -- 
+  -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; 
+  -- it can be used by front-end applications to perform specific operations (such as error handling) 
+  -- in response to a particular database error. 
+  -- For a list of the possible SQLSTATE codes, see Appendix A.
+  -- This field is not localizable, and is always present.
+  -- 
+  -- * The primary human-readable error message (typically one line). Always present.
+  -- 
+  -- * Detail: an optional secondary error message carrying more detail about the problem. 
+  -- Might run to multiple lines.
+  -- 
+  -- * Hint: an optional suggestion what to do about the problem. 
+  -- This is intended to differ from detail in that it offers advice (potentially inappropriate) 
+  -- rather than hard facts. Might run to multiple lines.
+  ServerError !ByteString !ByteString !( Maybe ByteString ) !( Maybe ByteString ) |
+  -- |
+  -- The database returned an unexpected result.
+  -- Indicates an improper statement or a schema mismatch.
+  UnexpectedResult !Text |
+  -- |
+  -- An error of the row reader, preceded by the index of the row.
+  RowError !Int !Row.Error |
+  -- |
+  -- An unexpected amount of rows.
+  UnexpectedAmountOfRows !Int
+  deriving ( Show )
+
+run :: Result a -> ( Bool , LibPQ.Result ) -> IO ( Either Error a )
+run (Result reader) env =
+  runEitherT (runReaderT reader env)
+
+unit :: Result ()
+unit =
+  checkExecStatus $ \case
+    LibPQ.CommandOk -> True
+    LibPQ.TuplesOk -> True
+    _ -> False
+
+rowsAffected :: Result Int64
+rowsAffected =
+  do
+    checkExecStatus $ \case
+      LibPQ.CommandOk -> True
+      _ -> False
+    Result $ ReaderT $ \(_, result) -> EitherT $
+      LibPQ.cmdTuples result & fmap cmdTuplesReader
+  where
+    cmdTuplesReader =
+      notNothing >=> notEmpty >=> decimal
+      where
+        notNothing =
+          Prelude.maybe (Left (UnexpectedResult "No bytes")) Right
+        notEmpty bytes =
+          if ByteString.null bytes
+            then Left (UnexpectedResult "Empty bytes")
+            else Right bytes
+        decimal bytes =
+          mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $
+          Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
+
+checkExecStatus :: ( LibPQ.ExecStatus -> Bool ) -> Result ()
+checkExecStatus predicate =
+  do
+    status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result
+    unless (predicate status) $ do
+      case status of
+        LibPQ.BadResponse   -> serverError
+        LibPQ.NonfatalError -> serverError
+        LibPQ.FatalError    -> serverError
+        _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)
+
+serverError :: Result ()
+serverError =
+  Result $ ReaderT $ \(_, result) -> EitherT $ do
+    code <- 
+      fmap (fromMaybe ($bug "No code")) $
+      LibPQ.resultErrorField result LibPQ.DiagSqlstate
+    message <- 
+      fmap (fromMaybe ($bug "No message")) $
+      LibPQ.resultErrorField result LibPQ.DiagMessagePrimary
+    detail <- 
+      LibPQ.resultErrorField result LibPQ.DiagMessageDetail
+    hint <- 
+      LibPQ.resultErrorField result LibPQ.DiagMessageHint
+    pure $ Left $ ServerError code message detail hint
+
+maybe :: Row.Row a -> Result ( Maybe a )
+maybe rowDes =
+  do
+    checkExecStatus $ \case
+      LibPQ.TuplesOk -> True
+      _ -> False
+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do
+      maxRows <- LibPQ.ntuples result
+      case maxRows of
+        0 -> return (Right Nothing)
+        1 -> do
+          maxCols <- LibPQ.nfields result
+          fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDes (result, 0, maxCols, integerDatetimes)
+        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
+  where
+    rowToInt (LibPQ.Row n) =
+      fromIntegral n
+    intToRow =
+      LibPQ.Row . fromIntegral
+
+single :: Row.Row a -> Result a
+single rowDes =
+  do
+    checkExecStatus $ \case
+      LibPQ.TuplesOk -> True
+      _ -> False
+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do
+      maxRows <- LibPQ.ntuples result
+      case maxRows of
+        1 -> do
+          maxCols <- LibPQ.nfields result
+          fmap (mapLeft (RowError 0)) $ Row.run rowDes (result, 0, maxCols, integerDatetimes)
+        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
+  where
+    rowToInt (LibPQ.Row n) =
+      fromIntegral n
+    intToRow =
+      LibPQ.Row . fromIntegral
+
+generate :: ( forall m. Monad m => Int -> ( Int -> m a ) -> m b ) -> Row.Row a -> Result b
+generate generateM rowDes =
+  do
+    checkExecStatus $ \case
+      LibPQ.TuplesOk -> True
+      _ -> False
+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do
+      maxRows <- LibPQ.ntuples result
+      maxCols <- LibPQ.nfields result
+      runEitherT $ generateM (rowToInt maxRows) $ \row ->
+        EitherT $ fmap (mapLeft (RowError row)) $ 
+        Row.run rowDes (result, intToRow row, maxCols, integerDatetimes)
+  where
+    rowToInt (LibPQ.Row n) =
+      fromIntegral n
+    intToRow =
+      LibPQ.Row . fromIntegral
+
+foldl :: ( a -> b -> a ) -> a -> Row.Row b -> Result a
+foldl step init rowDes =
+  do
+    checkExecStatus $ \case
+      LibPQ.TuplesOk -> True
+      _ -> False
+    Result $ ReaderT $ \(integerDatetimes, result) -> do
+      maxRows <- lift $ LibPQ.ntuples result
+      maxCols <- lift $ LibPQ.nfields result
+      ref <- lift $ newIORef init
+      forM_ [0 .. pred (rowToInt maxRows)] $ \rowIndex -> do
+        row <- 
+          EitherT $ fmap (mapLeft (RowError rowIndex)) $ 
+          Row.run rowDes (result, intToRow rowIndex, maxCols, integerDatetimes)
+        lift $ modifyIORef ref (\acc -> step acc row)
+      lift $ readIORef ref
+  where
+    rowToInt (LibPQ.Row n) =
+      fromIntegral n
+    intToRow =
+      LibPQ.Row . fromIntegral
+
+foldr :: ( b -> a -> a ) -> a -> Row.Row b -> Result a
+foldr step init rowDes =
+  do
+    checkExecStatus $ \case
+      LibPQ.TuplesOk -> True
+      _ -> False
+    Result $ ReaderT $ \(integerDatetimes, result) -> do
+      maxRows <- lift $ LibPQ.ntuples result
+      maxCols <- lift $ LibPQ.nfields result
+      ref <- lift $ newIORef init
+      forM_ (enumToZero (rowToInt maxRows)) $ \rowIndex -> do
+        row <- 
+          EitherT $ fmap (mapLeft (RowError rowIndex)) $ 
+          Row.run rowDes (result, intToRow rowIndex, maxCols, integerDatetimes)
+        lift $ modifyIORef ref (\acc -> step row acc)
+      lift $ readIORef ref
+  where
+    enumToZero n =
+      iterate pred (pred n) & take n
+    rowToInt (LibPQ.Row n) =
+      fromIntegral n
+    intToRow =
+      LibPQ.Row . fromIntegral
+

library/Hasql/Deserialization/Results.hs

@@ -0,0 +1,76 @@
+-- |
+-- An API for retrieval of multiple results.
+-- Can be used to handle:
+-- 
+-- * A single result,
+-- 
+-- * Individual results of a multi-statement query
+-- with the help of "Applicative" and "Monad",
+-- 
+-- * Row-by-row fetching.
+-- 
+module Hasql.Deserialization.Results where
+
+import Hasql.Prelude hiding (maybe, many)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Prelude as Prelude
+import qualified Hasql.Deserialization.Result as Result
+import qualified Hasql.Deserialization.Row as Row
+
+
+newtype Results a =
+  Results ( ReaderT ( Bool , LibPQ.Connection ) ( EitherT Error IO ) a )
+  deriving ( Functor , Applicative , Monad )
+
+data Error =
+  -- |
+  -- An error on the client-side,
+  -- with a message generated by the \"libpq\" library.
+  -- Usually indicates problems with the connection.
+  ClientError !(Maybe ByteString) |
+  ResultError !Result.Error
+
+{-# INLINE run #-}
+run :: Results a -> ( Bool , LibPQ.Connection ) -> IO ( Either Error a )
+run (Results stack) env =
+  runEitherT (runReaderT stack env)
+
+clientError :: Results a
+clientError =
+  Results $ ReaderT $ \(_, connection) -> EitherT $
+  fmap (Left . ClientError) (LibPQ.errorMessage connection)
+
+-- |
+-- Parse a single result.
+{-# INLINABLE single #-}
+single :: Result.Result a -> Results a
+single resultDes =
+  Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do
+    resultMaybe <- LibPQ.getResult connection
+    case resultMaybe of
+      Just result ->
+        fmap (mapLeft ResultError) (Result.run resultDes (integerDatetimes, result))
+      Nothing ->
+        fmap (Left . ClientError) (LibPQ.errorMessage connection)
+
+-- |
+-- Fetch a single result.
+{-# INLINABLE getResult #-}
+getResult :: Results LibPQ.Result
+getResult =
+  Results $ ReaderT $ \(_, connection) -> EitherT $ do
+    resultMaybe <- LibPQ.getResult connection
+    case resultMaybe of
+      Just result -> pure (Right result)
+      Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)
+
+-- |
+-- Fetch a single result.
+{-# INLINABLE getResultMaybe #-}
+getResultMaybe :: Results ( Maybe LibPQ.Result )
+getResultMaybe =
+  Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection
+
+cancel :: Results ()
+cancel =
+  undefined

library/Hasql/Deserialization/Row.hs

@@ -0,0 +1,50 @@
+module Hasql.Deserialization.Row where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Decoder as Decoder
+import qualified Hasql.Deserialization.Value as Value
+
+
+newtype Row a =
+  Row
+    (EitherT Error 
+      (ReaderT 
+        (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) 
+        (StateT LibPQ.Column IO)) 
+      a)
+  deriving (Functor, Applicative, Monad)
+
+data Error =
+  EndOfInput |
+  UnexpectedNull |
+  ValueError !Text
+  deriving (Show)
+
+
+run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)
+run (Row m) env =
+  flip evalStateT 0 (flip runReaderT env (runEitherT m))
+
+
+error :: Error -> Row a
+error x =
+  Row (EitherT (return (Left x)))
+
+-- |
+-- Next value, decoded using the provided value deserializer.
+value :: Value.Value a -> Row (Maybe a)
+value valueDes =
+  Row $ EitherT $ ReaderT $ \(result, row, maxCol, integerDatetimes) -> StateT $ \col ->
+    if col < maxCol
+      then
+        flip fmap (LibPQ.getvalue result row col) $ \x ->
+          (traverse (mapLeft ValueError . Decoder.run (Value.run valueDes integerDatetimes)) x,
+           succ col)
+      else return (Left EndOfInput, col)
+
+-- |
+-- Next value, decoded using the provided value deserializer.
+nonNullValue :: Value.Value a -> Row a
+nonNullValue valueDes =
+  value valueDes >>= maybe (error UnexpectedNull) pure

library/Hasql/Deserialization/Value.hs

@@ -0,0 +1,22 @@
+module Hasql.Deserialization.Value where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Decoder as Decoder
+
+
+newtype Value a =
+  Value (ReaderT Bool Decoder.Decoder a)
+  deriving (Functor)
+
+
+{-# INLINE run #-}
+run :: Value a -> Bool -> Decoder.Decoder a
+run (Value imp) integerDatetimes =
+  runReaderT imp integerDatetimes
+
+{-# INLINE decoder #-}
+decoder :: (Bool -> Decoder.Decoder a) -> Value a
+decoder =
+  Value . ReaderT
+

library/Hasql/IO.hs

@@ -0,0 +1,147 @@
+-- |
+-- An API of low-level IO operations.
+module Hasql.IO
+where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Commands as Commands
+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry
+import qualified Hasql.Deserialization.Result as ResultDeserialization
+import qualified Hasql.Deserialization.Results as ResultsDeserialization
+import qualified Hasql.Serialization.Params as ParamsSerialization
+import qualified Hasql.Settings as Settings
+import qualified Data.DList as DList
+
+
+{-# INLINE acquireConnection #-}
+acquireConnection :: Settings.Settings -> IO LibPQ.Connection
+acquireConnection settings =
+  LibPQ.connectdb (Settings.asBytes settings)
+
+{-# INLINE acquirePreparedStatementRegistry #-}
+acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry
+acquirePreparedStatementRegistry =
+  PreparedStatementRegistry.new
+
+{-# INLINE releaseConnection #-}
+releaseConnection :: LibPQ.Connection -> IO ()
+releaseConnection connection =
+  LibPQ.finish connection
+
+{-# INLINABLE checkConnectionStatus #-}
+checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))
+checkConnectionStatus c =
+  do
+    s <- LibPQ.status c
+    case s of
+      LibPQ.ConnectionOk -> return Nothing
+      _ -> fmap Just (LibPQ.errorMessage c)
+
+{-# INLINE checkServerVersion #-}
+checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)
+checkServerVersion c =
+  fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c)
+
+{-# INLINE getIntegerDatetimes #-}
+getIntegerDatetimes :: LibPQ.Connection -> IO Bool
+getIntegerDatetimes c =
+  fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"
+  where
+    decodeValue = 
+      \case
+        Just "on" -> True
+        _ -> False
+
+{-# INLINABLE initConnection #-}
+initConnection :: LibPQ.Connection -> IO ()
+initConnection c =
+  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodingToUTF8 <> Commands.setMinClientMessagesToWarning))
+
+{-# INLINE getResults #-}
+getResults :: LibPQ.Connection -> Bool -> ResultsDeserialization.Results a -> IO ( Either ResultsDeserialization.Error a )
+getResults connection integerDatetimes des =
+  do
+    result <- ResultsDeserialization.run des (integerDatetimes, connection)
+    fix $ \loop -> LibPQ.getResult connection >>= maybe (pure ()) (const loop)
+    pure result
+
+{-# INLINABLE getPreparedStatementKey #-}
+getPreparedStatementKey ::
+  LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->
+  ByteString -> [ LibPQ.Oid ] ->
+  IO ( Either ResultsDeserialization.Error ByteString )
+getPreparedStatementKey connection registry template oidList =
+  do
+    keyMaybe <- PreparedStatementRegistry.lookup template wordOIDList registry
+    case keyMaybe of
+      Just key ->
+        pure (pure key)
+      Nothing -> 
+        do
+          key <- PreparedStatementRegistry.register template wordOIDList registry
+          sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))
+          let resultsDeserializer = 
+                if sent
+                  then ResultsDeserialization.single ResultDeserialization.unit
+                  else ResultsDeserialization.clientError
+          runEitherT $ do
+            EitherT $ getResults connection undefined resultsDeserializer
+            pure key
+  where
+    wordOIDList =
+      map (\(LibPQ.Oid x) -> fromIntegral x) oidList
+
+{-# INLINABLE checkedSend #-}
+checkedSend :: LibPQ.Connection -> IO Bool -> IO ( Either ResultsDeserialization.Error () )
+checkedSend connection send =
+  send >>= \case
+    False -> fmap (Left . ResultsDeserialization.ClientError) $ LibPQ.errorMessage connection
+    True -> pure (Right ())
+
+{-# INLINABLE sendPreparedParametricQuery #-}
+sendPreparedParametricQuery ::
+  LibPQ.Connection ->
+  PreparedStatementRegistry.PreparedStatementRegistry ->
+  ByteString ->
+  [ LibPQ.Oid ] ->
+  [ Maybe ( ByteString , LibPQ.Format ) ] ->
+  IO ( Either ResultsDeserialization.Error () )
+sendPreparedParametricQuery connection registry template oidList valueAndFormatList =
+  runEitherT $ do
+    key <- EitherT $ getPreparedStatementKey connection registry template oidList
+    EitherT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
+
+{-# INLINABLE sendUnpreparedParametricQuery #-}
+sendUnpreparedParametricQuery ::
+  LibPQ.Connection ->
+  ByteString ->
+  [ Maybe ( LibPQ.Oid , ByteString , LibPQ.Format ) ] ->
+  IO ( Either ResultsDeserialization.Error () )
+sendUnpreparedParametricQuery connection template paramList =
+  checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary
+
+{-# INLINABLE sendParametricQuery #-}
+sendParametricQuery ::
+  LibPQ.Connection ->
+  Bool -> 
+  PreparedStatementRegistry.PreparedStatementRegistry ->
+  ByteString ->
+  ParamsSerialization.Params a ->
+  Bool ->
+  a ->
+  IO ( Either ResultsDeserialization.Error () )
+sendParametricQuery connection integerDatetimes registry template serializer prepared params =
+  if prepared
+    then
+      let
+        (oidList, valueAndFormatList) =
+          ParamsSerialization.run' serializer params integerDatetimes
+        in
+          sendPreparedParametricQuery connection registry template oidList valueAndFormatList
+    else
+      let
+        paramList =
+          ParamsSerialization.run'' serializer params integerDatetimes
+        in
+          sendUnpreparedParametricQuery connection template paramList

library/Hasql/PTI.hs

@@ -0,0 +1,93 @@
+module Hasql.PTI where
+
+import Hasql.Prelude hiding (bool)
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+
+
+-- | A Postgresql type info
+data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }
+
+-- | A Word32 and a LibPQ representation of an OID
+data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid }
+
+mkOID :: Word32 -> OID
+mkOID x =
+  OID x ((LibPQ.Oid . fromIntegral) x)
+
+mkPTI :: Word32 -> Maybe Word32 -> PTI
+mkPTI oid arrayOID =
+  PTI (mkOID oid) (fmap mkOID arrayOID)
+
+
+-- * Constants
+-------------------------
+
+abstime         = mkPTI 702  (Just 1023)
+aclitem         = mkPTI 1033 (Just 1034)
+bit             = mkPTI 1560 (Just 1561)
+bool            = mkPTI 16   (Just 1000)
+box             = mkPTI 603  (Just 1020)
+bpchar          = mkPTI 1042 (Just 1014)
+bytea           = mkPTI 17   (Just 1001)
+char            = mkPTI 18   (Just 1002)
+cid             = mkPTI 29   (Just 1012)
+cidr            = mkPTI 650  (Just 651)
+circle          = mkPTI 718  (Just 719)
+cstring         = mkPTI 2275 (Just 1263)
+date            = mkPTI 1082 (Just 1182)
+daterange       = mkPTI 3912 (Just 3913)
+float4          = mkPTI 700  (Just 1021)
+float8          = mkPTI 701  (Just 1022)
+gtsvector       = mkPTI 3642 (Just 3644)
+inet            = mkPTI 869  (Just 1041)
+int2            = mkPTI 21   (Just 1005)
+int2vector      = mkPTI 22   (Just 1006)
+int4            = mkPTI 23   (Just 1007)
+int4range       = mkPTI 3904 (Just 3905)
+int8            = mkPTI 20   (Just 1016)
+int8range       = mkPTI 3926 (Just 3927)
+interval        = mkPTI 1186 (Just 1187)
+json            = mkPTI 114  (Just 199)
+line            = mkPTI 628  (Just 629)
+lseg            = mkPTI 601  (Just 1018)
+macaddr         = mkPTI 829  (Just 1040)
+money           = mkPTI 790  (Just 791)
+name            = mkPTI 19   (Just 1003)
+numeric         = mkPTI 1700 (Just 1231)
+numrange        = mkPTI 3906 (Just 3907)
+oid             = mkPTI 26   (Just 1028)
+oidvector       = mkPTI 30   (Just 1013)
+path            = mkPTI 602  (Just 1019)
+point           = mkPTI 600  (Just 1017)
+polygon         = mkPTI 604  (Just 1027)
+record          = mkPTI 2249 (Just 2287)
+refcursor       = mkPTI 1790 (Just 2201)
+regclass        = mkPTI 2205 (Just 2210)
+regconfig       = mkPTI 3734 (Just 3735)
+regdictionary   = mkPTI 3769 (Just 3770)
+regoper         = mkPTI 2203 (Just 2208)
+regoperator     = mkPTI 2204 (Just 2209)
+regproc         = mkPTI 24   (Just 1008)
+regprocedure    = mkPTI 2202 (Just 2207)
+regtype         = mkPTI 2206 (Just 2211)
+reltime         = mkPTI 703  (Just 1024)
+text            = mkPTI 25   (Just 1009)
+tid             = mkPTI 27   (Just 1010)
+time            = mkPTI 1083 (Just 1183)
+timestamp       = mkPTI 1114 (Just 1115)
+timestamptz     = mkPTI 1184 (Just 1185)
+timetz          = mkPTI 1266 (Just 1270)
+tinterval       = mkPTI 704  (Just 1025)
+tsquery         = mkPTI 3615 (Just 3645)
+tsrange         = mkPTI 3908 (Just 3909)
+tstzrange       = mkPTI 3910 (Just 3911)
+tsvector        = mkPTI 3614 (Just 3643)
+txid_snapshot   = mkPTI 2970 (Just 2949)
+unknown         = mkPTI 705  Nothing
+uuid            = mkPTI 2950 (Just 2951)
+varbit          = mkPTI 1562 (Just 1563)
+varchar         = mkPTI 1043 (Just 1015)
+void            = mkPTI 2278 Nothing
+xid             = mkPTI 28   (Just 1011)
+xml             = mkPTI 142  (Just 143)
+

library/Hasql/Prelude.hs

@@ -1,53 +1,112 @@
 module Hasql.Prelude
 ( 
   module Exports,
+  LazyByteString,
+  ByteStringBuilder,
+  LazyText,
+  TextBuilder,
+  bug,
+  bottom,
 )
 where
 
 
 -- base-prelude
 -------------------------
-import BasePrelude as Exports hiding (left, right, isLeft, isRight)
+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)
 
 -- transformers
 -------------------------
-import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
-import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
-import Control.Monad.Trans.Writer as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
-import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
-import Control.Monad.Trans.Class as Exports
 import Control.Monad.IO.Class as Exports
+import Control.Monad.Trans.Class as Exports
+import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass)
+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)
+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)
 import Data.Functor.Identity as Exports
 
--- transformers-base
+-- data-default-class
 -------------------------
-import Control.Monad.Base as Exports
+import Data.Default.Class as Exports
 
--- monad-control
+-- profunctors
 -------------------------
-import Control.Monad.Trans.Control as Exports hiding (embed, embed_)
+import Data.Profunctor.Unsafe as Exports
 
--- mtl
+-- contravariant
 -------------------------
-import Control.Monad.Error.Class as Exports hiding (Error)
-
--- mmorph
--------------------------
-import Control.Monad.Morph as Exports
+import Data.Functor.Contravariant as Exports
+import Data.Functor.Contravariant.Divisible as Exports
 
 -- either
 -------------------------
 import Control.Monad.Trans.Either as Exports
 import Data.Either.Combinators as Exports
 
--- list-t
+-- hashable
 -------------------------
-import ListT as Exports (ListT)
+import Data.Hashable as Exports (Hashable(..))
+
+-- text
+-------------------------
+import Data.Text as Exports (Text)
+
+-- bytestring
+-------------------------
+import Data.ByteString as Exports (ByteString)
+
+-- scientific
+-------------------------
+import Data.Scientific as Exports (Scientific)
+
+-- uuid
+-------------------------
+import Data.UUID as Exports (UUID)
+
+-- time
+-------------------------
+import Data.Time as Exports
 
 -- vector
 -------------------------
 import Data.Vector as Exports (Vector)
 
--- text
+-- dlist
 -------------------------
-import Data.Text as Exports (Text)
+import Data.DList as Exports (DList)
+
+-- placeholders
+-------------------------
+import Development.Placeholders as Exports
+
+-- loch-th
+-------------------------
+import Debug.Trace.LocationTH as Exports
+
+-- custom
+-------------------------
+import qualified Debug.Trace.LocationTH
+import qualified Data.Text.Lazy
+import qualified Data.Text.Lazy.Builder
+import qualified Data.ByteString.Lazy
+import qualified Data.ByteString.Builder
+
+
+type LazyByteString =
+  Data.ByteString.Lazy.ByteString
+
+type ByteStringBuilder =
+  Data.ByteString.Builder.Builder
+
+type LazyText =
+  Data.Text.Lazy.Text
+
+type TextBuilder =
+  Data.Text.Lazy.Builder.Builder
+
+bug =
+  [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]
+  where
+    msg = "A \"hasql\" package bug: " :: String
+
+bottom =
+  [e| $bug "Bottom evaluated" |]

library/Hasql/PreparedStatementRegistry.hs

@@ -0,0 +1,46 @@
+module Hasql.PreparedStatementRegistry
+(
+  PreparedStatementRegistry,
+  new,
+  lookup,
+  register,
+)
+where
+
+import Hasql.Prelude hiding (lookup)
+import qualified Data.HashTable.IO as Hashtables
+
+
+data PreparedStatementRegistry =
+  PreparedStatementRegistry !(Hashtables.BasicHashTable LocalKey ByteString) !(IORef Word)
+
+{-# INLINABLE new #-}
+new :: IO PreparedStatementRegistry
+new =
+  PreparedStatementRegistry <$> Hashtables.new <*> newIORef 0
+
+{-# INLINABLE lookup #-}
+lookup :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO (Maybe ByteString)
+lookup template oids (PreparedStatementRegistry table counter) =
+  Hashtables.lookup table (LocalKey template oids)
+
+{-# INLINABLE register #-}
+register :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO ByteString
+register template oids (PreparedStatementRegistry table counter) =
+  do
+    n <- readIORef counter
+    writeIORef counter (succ n)
+    let remoteKey = fromString (show n)
+    Hashtables.insert table (LocalKey template oids) remoteKey
+    return remoteKey
+
+-- |
+-- Local statement key.
+data LocalKey =
+  LocalKey !ByteString ![Word32]
+  deriving (Show, Eq)
+
+instance Hashable LocalKey where
+  {-# INLINE hashWithSalt #-}
+  hashWithSalt salt (LocalKey template types) =
+    hashWithSalt salt template

library/Hasql/QQ.hs

@@ -1,61 +0,0 @@
-module Hasql.QQ where
-
-import Hasql.Prelude
-import Hasql.TH
-import Language.Haskell.TH
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH.Syntax
-import qualified Data.Text as Text
-import qualified Hasql.QQ.Parser as Parser
-import qualified Hasql.Backend as Bknd
-
-
--- |
--- Produces a lambda-expression, 
--- which takes as many parameters as there are placeholders in the quoted text
--- and results in a 'Bknd.Stmt'. 
--- 
--- E.g.:
--- 
--- >selectSum :: Int -> Int -> Stmt c
--- >selectSum = [stmt|SELECT (? + ?)|]
--- 
--- It also allows to directly refer to free variables like so:
--- 
--- >selectSum :: Int -> Int -> Stmt c
--- >selectSum a b = [stmt|SELECT ($a + $b)|]
-stmt :: QuasiQuoter
-stmt = 
-  QuasiQuoter
-    (parseExp)
-    (const $ fail "Pattern context is not supported")
-    (const $ fail "Type context is not supported")
-    (const $ fail "Declaration context is not supported")
-  where
-    parseExp =
-      fmap (uncurry statementF) .
-      either (fail . showString "Parsing failure: ") return .
-      Parser.parse .
-      fromString
-    statementF t params =
-      LamE
-        (map VarP argNames)
-        (purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|])
-      where
-        (varNames, argNames) =
-          (\(a, b) -> (reverse a, reverse b)) $ 
-          flip execState ([], []) $ forM_ params $ \case
-            Parser.ParamName n ->
-              modify $ \(a, b) -> (mkName (Text.unpack n) : a, b)
-            Parser.OrderedPlaceholder ->
-              modify $ \(a, b) -> 
-                let n = mkName $ '_' : show (length b + 1)
-                    in (n : a, n : b)
-            Parser.IndexedPlaceholder i ->
-              fail "Indexed placeholders are not supported"
-        statementE = 
-          LitE (StringL (Text.unpack t))
-        argsE =
-          vectorE $
-          map (\x -> purify [| Bknd.encodeValue $(varE x) |]) $
-          varNames

library/Hasql/QQ/Parser.hs

@@ -1,65 +0,0 @@
-module Hasql.QQ.Parser where
-
-import Hasql.Prelude hiding (takeWhile)
-import Data.Attoparsec.Text hiding (Result)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
-
-
-type Result =
-  (Text, [Param])
-
-data Param =
-  ParamName Text |
-  OrderedPlaceholder |
-  IndexedPlaceholder Int
-
--- |
--- Produces a whitespace-cleaned text and a count of placeholders in it.
-parse :: Text -> Either String (Text, [Param])
-parse = 
-  parseOnly $ singleTemplate
-
-singleTemplate :: Parser (Text, [Param])
-singleTemplate =
-  template <* 
-  ((endOfInput) <|>
-   (() <$ skipSpace <* char ';' <* fail "A semicolon detected, but only single statements are allowed"))
-
-template :: Parser (Text, [Param])
-template =
-  runWriterT $ do
-    lift $ skipSpace
-    fmap (TL.toStrict . TLB.toLazyText . mconcat) $ 
-      many $ 
-        (mempty <$ lift (takeWhile1 isSpace <* endOfInput)) <|>
-        (TLB.singleton ' ' <$ lift (takeWhile1 isSpace)) <|>
-        (TLB.fromText <$> lift stringLit) <|>
-        (TLB.singleton '?' <$ (lift param >>= tell . pure)) <|>
-        (TLB.singleton <$> lift (notChar ';'))
-
-stringLit :: Parser Text
-stringLit =
-  do
-    quote <- 
-      char '"' <|> char '\''
-    content <- 
-      fmap mconcat $ many $ 
-        TLB.fromText <$> string "\\\\" <|> 
-        TLB.fromText <$> string (fromString ['\\', quote]) <|> 
-        TLB.singleton <$> notChar quote
-    char quote
-    return $ TL.toStrict . TLB.toLazyText $
-      TLB.singleton quote <> content <> TLB.singleton quote
-
-param :: Parser Param
-param =
-  (char '$' *> ((ParamName <$> paramName) <|> (IndexedPlaceholder <$> decimal))) <|>
-  (OrderedPlaceholder <$ char '?')
-
-paramName :: Parser Text
-paramName =
-  T.cons <$> satisfy isLower <*> takeWhile (\c -> isAlphaNum c || elem c extraChars)
-  where
-    extraChars = "_'" :: [Char]

library/Hasql/Query.hs

@@ -0,0 +1,29 @@
+module Hasql.Query
+(
+  ParametricQuery(..),
+  NonparametricQuery(..),
+)
+where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.Deserialization as Deserialization
+import qualified Hasql.Serialization as Serialization
+
+
+-- |
+-- A strictly single-statement query, which can be parameterized and prepared.
+-- 
+-- SQL template, params serializer, results deserializer and a flag, determining whether it should be prepared.
+-- 
+type ParametricQuery a b =
+  (ByteString, Serialization.Params a, Deserialization.Results b, Bool)
+
+-- |
+-- A non-parameterizable and non-preparable query,
+-- which however can contain multiple statements.
+-- 
+-- SQL, results deserializer.
+-- 
+type NonparametricQuery a =
+  (ByteString, Deserialization.Results a)

library/Hasql/Serialization.hs

@@ -0,0 +1,337 @@
+module Hasql.Serialization
+(
+  -- * Params
+  Params,
+  value,
+  nullableValue,
+  -- * Value
+  Value,
+  bool,
+  int2,
+  int4,
+  int8,
+  float4,
+  float8,
+  numeric,
+  char,
+  text,
+  bytea,
+  date,
+  timestamp,
+  timestamptz,
+  time,
+  timetz,
+  interval,
+  uuid,
+  json,
+  array,
+  -- * Array
+  Array,
+  arrayValue,
+  arrayNullableValue,
+  arrayDimension,
+)
+where
+
+import Hasql.Prelude hiding (bool)
+import qualified PostgreSQL.Binary.Encoder as Encoder
+import qualified Data.Aeson as Aeson
+import qualified Hasql.Serialization.Params as Params
+import qualified Hasql.Serialization.Value as Value
+import qualified Hasql.Serialization.Array as Array
+import qualified Hasql.PTI as PTI
+import qualified Hasql.Prelude as Prelude
+
+
+-- * Parameters Product Serializer
+-------------------------
+
+-- |
+-- Serializer of some representation of a parameters product.
+-- 
+-- Has instances of 'Contravariant', 'Divisible' and 'Monoid',
+-- which you can use to compose multiple parameters together.
+-- E.g.,
+-- 
+-- >someParamsSerializer :: Params (Int64, Maybe Text)
+-- >someParamsSerializer =
+-- >  contramap fst (value int8) <>
+-- >  contramap snd (nullableValue text)
+-- 
+newtype Params a =
+  Params (Params.Params a)
+  deriving (Contravariant, Divisible, Monoid)
+
+-- |
+-- Lift an individual value serializer to a parameters serializer.
+-- 
+{-# INLINABLE value #-}
+value :: Value a -> Params a
+value (Value x) =
+  Params (Params.value x)
+
+-- |
+-- Lift an individual nullable value serializer to a parameters serializer.
+-- 
+{-# INLINABLE nullableValue #-}
+nullableValue :: Value a -> Params (Maybe a)
+nullableValue (Value x) =
+  Params (Params.nullableValue x)
+
+
+-- ** Instances
+-------------------------
+
+instance Default (Value a) => Default (Params (Identity a)) where
+  {-# INLINE def #-}
+  def =
+    contramap runIdentity (value def)
+
+instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where
+  {-# INLINE def #-}
+  def =
+    contramap fst (value def) <>
+    contramap snd (value def)
+
+
+-- * Value Serializer
+-------------------------
+
+-- |
+-- An individual value serializer.
+-- Will be mapped to a single placeholder in the query.
+-- 
+newtype Value a =
+  Value (Value.Value a)
+  deriving (Contravariant)
+
+{-# INLINABLE bool #-}
+bool :: Value Bool
+bool =
+  Value (Value.unsafePTI PTI.bool (const Encoder.bool))
+
+{-# INLINABLE int2 #-}
+int2 :: Value Int16
+int2 =
+  Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16))
+
+{-# INLINABLE int4 #-}
+int4 :: Value Int32
+int4 =
+  Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32))
+
+{-# INLINABLE int8 #-}
+int8 :: Value Int64
+int8 =
+  Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64))
+
+{-# INLINABLE float4 #-}
+float4 :: Value Float
+float4 =
+  Value (Value.unsafePTI PTI.float4 (const Encoder.float4))
+
+{-# INLINABLE float8 #-}
+float8 :: Value Double
+float8 =
+  Value (Value.unsafePTI PTI.float8 (const Encoder.float8))
+
+{-# INLINABLE numeric #-}
+numeric :: Value Scientific
+numeric =
+  Value (Value.unsafePTI PTI.numeric (const Encoder.numeric))
+
+{-# INLINABLE char #-}
+char :: Value Char
+char =
+  Value (Value.unsafePTI PTI.char (const Encoder.char))
+
+{-# INLINABLE text #-}
+text :: Value Text
+text =
+  Value (Value.unsafePTI PTI.text (const Encoder.text_strict))
+
+{-# INLINABLE bytea #-}
+bytea :: Value ByteString
+bytea =
+  Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict))
+
+{-# INLINABLE date #-}
+date :: Value Day
+date =
+  Value (Value.unsafePTI PTI.date (const Encoder.date))
+
+{-# INLINABLE timestamp #-}
+timestamp :: Value LocalTime
+timestamp =
+  Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float))
+
+{-# INLINABLE timestamptz #-}
+timestamptz :: Value UTCTime
+timestamptz =
+  Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float))
+
+{-# INLINABLE time #-}
+time :: Value TimeOfDay
+time =
+  Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float))
+
+{-# INLINABLE timetz #-}
+timetz :: Value (TimeOfDay, TimeZone)
+timetz =
+  Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float))
+
+{-# INLINABLE interval #-}
+interval :: Value DiffTime
+interval =
+  Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float))
+
+{-# INLINABLE uuid #-}
+uuid :: Value UUID
+uuid =
+  Value (Value.unsafePTI PTI.uuid (const Encoder.uuid))
+
+{-# INLINABLE json #-}
+json :: Value Aeson.Value
+json =
+  Value (Value.unsafePTI PTI.json (const Encoder.json))
+
+{-# INLINABLE array #-}
+array :: Array a -> Value a
+array (Array imp) =
+  Array.run imp & \(arrayOID, encoder') ->
+    Value (Value.Value arrayOID arrayOID encoder')
+
+
+-- ** Instances
+-------------------------
+
+-- | Maps to 'bool'.
+instance Default (Value Bool) where
+  {-# INLINE def #-}
+  def =
+    bool
+
+-- | Maps to 'int2'.
+instance Default (Value Int16) where
+  {-# INLINE def #-}
+  def =
+    int2
+
+-- | Maps to 'int4'.
+instance Default (Value Int32) where
+  {-# INLINE def #-}
+  def =
+    int4
+
+-- | Maps to 'int8'.
+instance Default (Value Int64) where
+  {-# INLINE def #-}
+  def =
+    int8
+
+-- | Maps to 'float4'.
+instance Default (Value Float) where
+  {-# INLINE def #-}
+  def =
+    float4
+
+-- | Maps to 'float8'.
+instance Default (Value Double) where
+  {-# INLINE def #-}
+  def =
+    float8
+
+-- | Maps to 'numeric'.
+instance Default (Value Scientific) where
+  {-# INLINE def #-}
+  def =
+    numeric
+
+-- | Maps to 'char'.
+instance Default (Value Char) where
+  {-# INLINE def #-}
+  def =
+    char
+
+-- | Maps to 'text'.
+instance Default (Value Text) where
+  {-# INLINE def #-}
+  def =
+    text
+
+-- | Maps to 'bytea'.
+instance Default (Value ByteString) where
+  {-# INLINE def #-}
+  def =
+    bytea
+
+-- | Maps to 'date'.
+instance Default (Value Day) where
+  {-# INLINE def #-}
+  def =
+    date
+
+-- | Maps to 'timestamp'.
+instance Default (Value LocalTime) where
+  {-# INLINE def #-}
+  def =
+    timestamp
+
+-- | Maps to 'timestamptz'.
+instance Default (Value UTCTime) where
+  {-# INLINE def #-}
+  def =
+    timestamptz
+
+-- | Maps to 'time'.
+instance Default (Value TimeOfDay) where
+  {-# INLINE def #-}
+  def =
+    time
+
+-- | Maps to 'timetz'.
+instance Default (Value (TimeOfDay, TimeZone)) where
+  {-# INLINE def #-}
+  def =
+    timetz
+
+-- | Maps to 'interval'.
+instance Default (Value DiffTime) where
+  {-# INLINE def #-}
+  def =
+    interval
+
+-- | Maps to 'uuid'.
+instance Default (Value UUID) where
+  {-# INLINE def #-}
+  def =
+    uuid
+
+-- | Maps to 'json'.
+instance Default (Value Aeson.Value) where
+  {-# INLINE def #-}
+  def =
+    json
+
+
+-- * Array
+-------------------------
+
+newtype Array a =
+  Array (Array.Array a)
+
+{-# INLINABLE arrayValue #-}
+arrayValue :: Value a -> Array a
+arrayValue (Value (Value.Value elementOID arrayOID encoder')) =
+  Array (Array.value elementOID arrayOID encoder')
+
+{-# INLINABLE arrayNullableValue #-}
+arrayNullableValue :: Value a -> Array (Maybe a)
+arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) =
+  Array (Array.nullableValue elementOID arrayOID encoder')
+
+{-# INLINABLE arrayDimension #-}
+arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
+arrayDimension foldl (Array imp) =
+  Array (Array.dimension foldl imp)
+

library/Hasql/Serialization/Array.hs

@@ -0,0 +1,31 @@
+module Hasql.Serialization.Array where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Encoder as Encoder
+import qualified Hasql.PTI as PTI
+
+
+data Array a =
+  Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a)
+
+{-# INLINE run #-}
+run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a)
+run (Array valueOID arrayOID encoder') =
+  (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env))
+
+{-# INLINE value #-}
+value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a
+value valueOID arrayOID encoder' =
+  Array valueOID arrayOID (Encoder.arrayValue . encoder')
+
+{-# INLINE nullableValue #-}
+nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a)
+nullableValue valueOID arrayOID encoder' =
+  Array valueOID arrayOID (Encoder.arrayNullableValue . encoder')
+
+{-# INLINE dimension #-}
+dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c
+dimension foldl (Array valueOID arrayOID encoder') =
+  Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder')
+

library/Hasql/Serialization/Params.hs

@@ -0,0 +1,46 @@
+module Hasql.Serialization.Params where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Encoder as Encoder
+import qualified Hasql.Serialization.Value as Value
+import qualified Hasql.PTI as PTI
+
+
+-- |
+-- Serializer of some representation of a parameters product.
+newtype Params a =
+  Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a)
+  deriving (Contravariant, Divisible, Monoid)
+
+run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString)
+run (Params (Op op)) params =
+  op params
+
+run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)])
+run' (Params (Op op)) params integerDatetimes =
+  foldr step ([], []) (op params)
+  where
+    step (oid, bytesGetter) ~(oidList, bytesAndFormatList) =
+      (,)
+        (oid : oidList)
+        (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList)
+
+run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)]
+run'' (Params (Op op)) params integerDatetimes =
+  foldr step [] (op params)
+  where
+    step a b =
+      mapping a : b
+      where
+        mapping (oid, bytesGetter) =
+          (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary
+
+value :: Value.Value a -> Params a
+value =
+  contramap Just . nullableValue
+
+nullableValue :: Value.Value a -> Params (Maybe a)
+nullableValue (Value.Value valueOID arrayOID encoder') =
+  Params $ Op $ \input -> 
+    pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input)

library/Hasql/Serialization/Value.hs

@@ -0,0 +1,27 @@
+module Hasql.Serialization.Value where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified PostgreSQL.Binary.Encoder as Encoder
+import qualified Hasql.PTI as PTI
+
+
+data Value a =
+  Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a)
+
+instance Contravariant Value where
+  {-# INLINE contramap #-}
+  contramap f (Value valueOID arrayOID encoder) =
+    Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input))
+
+{-# INLINE run #-}
+run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a)
+run (Value valueOID arrayOID encoder') =
+  (valueOID, arrayOID, encoder')
+
+{-# INLINE unsafePTI #-}
+unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a
+unsafePTI pti encoder' =
+  Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder'
+
+

library/Hasql/Settings.hs

@@ -0,0 +1,46 @@
+module Hasql.Settings where
+
+import Hasql.Prelude
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Builder as BB
+import qualified Data.ByteString.Lazy.Builder.ASCII as BB
+import qualified Data.ByteString.Lazy as BL
+
+
+-- |
+-- Connection settings.
+data Settings =
+  -- | 
+  -- A host, a port, a user, a password and a database.
+  ParametricSettings ByteString Word16 ByteString ByteString ByteString |
+  -- | 
+  -- All settings encoded in a single byte string according to 
+  -- <http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-CONNSTRING the PostgreSQL format>.
+  RawSettings ByteString
+  deriving (Show)
+
+{-# INLINE asBytes #-}
+asBytes :: Settings -> ByteString
+asBytes =
+  \case
+    ParametricSettings host port user password database ->
+      BL.toStrict $ BB.toLazyByteString $ mconcat $ intersperse (BB.char7 ' ') $ catMaybes $
+      [
+        mappend (BB.string7 "host=") . BB.byteString <$> 
+        mfilter (not . B.null) (pure host)
+        ,
+        mappend (BB.string7 "port=") . BB.word16Dec <$> 
+        mfilter (/= 0) (pure port)
+        ,
+        mappend (BB.string7 "user=") . BB.byteString <$> 
+        mfilter (not . B.null) (pure user)
+        ,
+        mappend (BB.string7 "password=") . BB.byteString <$> 
+        mfilter (not . B.null) (pure password)
+        ,
+        mappend (BB.string7 "dbname=") . BB.byteString <$> 
+        mfilter (not . B.null) (pure database)
+      ]
+    RawSettings bytes ->
+      bytes
+

library/Hasql/TH.hs

@@ -1,80 +0,0 @@
-{-# LANGUAGE CPP #-}
--- |
--- TH utils.
-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
-applicativeE head =
-  \case
-    [] -> error "Empty expressions list"
-    exps ->
-      reduce $ 
-        head : VarE '(<$>) : intersperse (VarE '(<*>)) exps
-      where
-        reduce =
-          \case
-            e : o : t -> UInfixE e o (reduce t)
-            e : [] -> e
-            _ -> 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 =
-  if null cellExps
-    then
-      VarE 'Vector.empty
-    else
-      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)))
-
-classP :: Name -> [Type] -> Pred
-#if MIN_VERSION_template_haskell(2,10,0)
-classP n tl = foldl AppT (ConT n) tl
-#else
-classP = ClassP
-#endif