hasql 0.7.4 → 0.14.0.2

raw patch · 37 files changed

+2967/−1115 lines, 37 filesdep +QuickCheckdep +aesondep +bytestringdep −hasql-backenddep −hasql-postgresdep −hspecdep ~basedep ~base-preludedep ~eitherPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, bytestring, contravariant, contravariant-extras, criterion, data-default-class, deepseq, dlist, hashable, hashtables, loch-th, placeholders, postgresql-binary, postgresql-libpq, profunctors, quickcheck-instances, scientific, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, time, uuid

Dependencies removed: hasql-backend, hasql-postgres, hspec, list-t, mmorph, monad-control, mtl, mtl-prelude, resource-pool, slave-thread, template-haskell, transformers-base

Dependency ranges changed: base, base-prelude, either, text, transformers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +0/−36
• benchmark/Main.hs +52/−0
• benchmark/Main/Prelude.hs +77/−0
• benchmark/Main/Queries.hs +29/−0
• demo/Main.hs +0/−77
• hasql.cabal +118/−126
• hspec-postgres/Main.hs +0/−149
• hspec/Main.hs +0/−51
• library/Hasql.hs +0/−387
• library/Hasql/Commands.hs +33/−0
• library/Hasql/Connection.hs +12/−0
• library/Hasql/Connection/Impl.hs +37/−0
• library/Hasql/CxRow.hs +0/−64
• library/Hasql/Decoding.hs +669/−0
• library/Hasql/Decoding/Array.hs +31/−0
• library/Hasql/Decoding/Composite.hs +26/−0
• library/Hasql/Decoding/Result.hs +232/−0
• library/Hasql/Decoding/Results.hs +91/−0
• library/Hasql/Decoding/Row.hs +65/−0
• library/Hasql/Decoding/Value.hs +23/−0
• library/Hasql/Encoding.hs +483/−0
• library/Hasql/Encoding/Array.hs +31/−0
• library/Hasql/Encoding/Params.hs +49/−0
• library/Hasql/Encoding/Value.hs +27/−0
• library/Hasql/IO.hs +151/−0
• library/Hasql/PTI.hs +93/−0
• library/Hasql/Prelude.hs +100/−19
• library/Hasql/PreparedStatementRegistry.hs +46/−0
• library/Hasql/QQ.hs +0/−61
• library/Hasql/QQ/Parser.hs +0/−65
• library/Hasql/Query.hs +165/−0
• library/Hasql/Settings.hs +39/−0
• library/Hasql/TH.hs +0/−80
• tasty/Main.hs +136/−0
• tasty/Main/DSL.hs +43/−0
• tasty/Main/Prelude.hs +73/−0
• tasty/Main/Queries.hs +36/−0

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

@@ -0,0 +1,52 @@+module Main where++import Main.Prelude+import Criterion.Main+import qualified Hasql.Connection as HC+import qualified Hasql.Settings as HS+import qualified Hasql.Query as HQ+import qualified Hasql.Encoding as HE+import qualified Hasql.Decoding as HD+import qualified Main.Queries as Q+++main =+  HC.acquire settings >>= either (fail . show) use+  where+    settings =+      HS.settings host port user password database+      where+        host = "localhost"+        port = 5432+        user = "postgres"+        password = ""+        database = "postgres"+    use connection =+      defaultMain+      [+        bgroup "decoding"+        [+          bgroup "1 column"+          [+            bench "1 row" $ nfIO $! query () $! Q.select1 1+            ,+            bench "100 rows" $ nfIO $! query () $! Q.select1 100+            ,+            bench "10000 rows" $ nfIO $! query () $! Q.select1 10000+          ]+          ,+          bgroup "4 columns"+          [+            bench "1 row" $ nfIO $! query () $! Q.select4 1+            ,+            bench "100 rows" $ nfIO $! query () $! Q.select4 100+            ,+            bench "10000 rows" $ nfIO $! query () $! Q.select4 10000+          ]+        ]+      ]+      where+        query :: a -> HQ.Query a b -> IO b+        query params query =+          {-# SCC "query" #-} +          HQ.run query params connection >>= either (fail . show) pure

@@ -0,0 +1,77 @@+module Main.Prelude+(+  module Exports,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)++-- transformers+-------------------------+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++-- data-default-class+-------------------------+import Data.Default.Class as Exports++-- profunctors+-------------------------+import Data.Profunctor.Unsafe as Exports++-- contravariant+-------------------------+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports++-- contravariant-extras+-------------------------+import Contravariant.Extras as Exports++-- either+-------------------------+import Control.Monad.Trans.Either as Exports+import Data.Either.Combinators as Exports++-- hashable+-------------------------+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)++-- dlist+-------------------------+import Data.DList as Exports (DList)++-- deepseq+-------------------------+import Control.DeepSeq as Exports (NFData(..), force, deepseq, ($!!))

@@ -0,0 +1,29 @@+module Main.Queries where++import Main.Prelude+import qualified Hasql.Query as HQ+import qualified Hasql.Encoding as HE+import qualified Hasql.Decoding as HD+++select1 :: Int -> HQ.Query () (Vector Int64)+select1 amount =+  {-# SCC "select1" #-} +  HQ.Query sql mempty decoder True+  where+    !sql =+      "values " <>+      mconcat (intersperse ", " (replicate amount "(1)"))+    decoder =+      HD.rowsVector (HD.value HD.int8)++select4 :: Int -> HQ.Query () (Vector (Int64, Int64, Int64, Int64))+select4 amount =+  {-# SCC "select4" #-} +  HQ.Query sql mempty decoder True+  where+    !sql =+      "values " <>+      mconcat (intersperse ", " (replicate amount "(1, 2, 3, 4)"))+    decoder =+      HD.rowsVector ((,,,) <$> HD.value HD.int8 <*> HD.value HD.int8 <*> HD.value HD.int8 <*> HD.value HD.int8)

@@ -1,77 +0,0 @@--- You can execute this file with 'cabal bench demo'.-{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}--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---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----

@@ -1,53 +1,15 @@ name:   hasql version:-  0.7.4+  0.14.0.2+category:+  Hasql, Database, PostgreSQL synopsis:-  A minimalistic general high level API for relational databases+  A very efficient PostgreSQL driver and a flexible mapping API 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>.+  This package is the root of the \"hasql\" ecosystem.   .-category:-  Database+  The API is completely disinfected from exceptions. All error-reporting is explicit and is presented using the 'Either' type. homepage:   https://github.com/nikita-volkov/hasql  bug-reports:@@ -66,8 +28,6 @@   Simple cabal-version:   >=1.10-extra-source-files:-  CHANGELOG.md   source-repository head@@ -81,123 +41,155 @@   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+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, 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.Commands+    Hasql.Decoding.Array+    Hasql.Decoding.Composite+    Hasql.Decoding.Value+    Hasql.Decoding.Row+    Hasql.Decoding.Result+    Hasql.Decoding.Results+    Hasql.Encoding.Array+    Hasql.Encoding.Value+    Hasql.Encoding.Params+    Hasql.PreparedStatementRegistry+    Hasql.Connection.Impl   exposed-modules:-    Hasql+    Hasql.Decoding+    Hasql.Encoding+    Hasql.Settings+    Hasql.Connection+    Hasql.Query   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.3 && < 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.3.*,+    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---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+    -- errors:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    base-prelude >= 0.1.19 && < 0.2,+    base >= 4.6 && < 5  -test-suite hspec-postgres+-- Note that this test-suite is supposed to be single-threaded.+-- Hence the absense of the appropriate GHC flags.+test-suite tasty   type:     exitcode-stdio-1.0   hs-source-dirs:-    hspec-postgres+    tasty   main-is:     Main.hs-  ghc-options:-    -threaded-    "-with-rtsopts=-N"-    -funbox-strict-fields+  other-modules:+    Main.DSL+    Main.Queries+    Main.Prelude   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+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, 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.*,-    -- +    -- testing:+    tasty == 0.11.*,+    tasty-quickcheck == 0.8.*,+    tasty-smallcheck == 0.8.*,+    tasty-hunit == 0.9.*,+    quickcheck-instances >= 0.3.11 && < 0.4,+    QuickCheck >= 2.8.1 && < 2.9,+    -- data:+    uuid,+    time,+    scientific,+    bytestring,     text,-    -- -    monad-control,+    vector,+    hashable,+    dlist,+    -- general:+    data-default-class,+    profunctors,+    contravariant,+    contravariant-extras,     either,-    mtl-prelude < 3,-    base-prelude+    transformers,+    base-prelude,+    base  --- 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+benchmark benchmark   type:      exitcode-stdio-1.0   hs-source-dirs:-    demo+    benchmark   main-is:     Main.hs+  other-modules:+    Main.Queries+    Main.Prelude   ghc-options:     -O2     -threaded     "-with-rtsopts=-N"-    -funbox-strict-fields+  ghc-prof-options:+    -O2+    -threaded+    -fprof-auto+    "-with-rtsopts=-N -p -s -h -i0.1"+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, 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-postgres == 0.10.*,-    transformers >= 0.3 && < 0.5,+    -- benchmarking:+    criterion == 1.1.*,+    -- data:+    uuid,+    time,+    scientific,+    bytestring,+    text,+    vector,+    hashable,+    dlist,+    -- general:+    deepseq >= 1 && < 2,+    data-default-class,+    profunctors,+    contravariant,+    contravariant-extras,+    either,+    transformers,+    base-prelude,     base- 

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

@@ -1,51 +0,0 @@-import BasePrelude-import Test.Hspec-import qualified Hasql as H-import qualified Hasql.Backend as HB-import qualified Data.Vector as V---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

@@ -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)-

@@ -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")++

@@ -0,0 +1,12 @@+-- |+-- This module provides a low-level effectful API dealing with the connections to the database.+module Hasql.Connection+(+  Connection,+  ConnectionError(..),+  acquire,+  release,+)+where++import Hasql.Connection.Impl

@@ -0,0 +1,37 @@+module Hasql.Connection.Impl+where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry+import qualified Hasql.IO as IO+++-- |+-- A single connection to the database.+data Connection =+  Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry++-- |+-- Possible details of the connection acquistion error.+type ConnectionError =+  Maybe ByteString++-- |+-- Acquire a connection using the provided settings encoded according to the PostgreSQL format.+acquire :: ByteString -> IO (Either ConnectionError Connection)+acquire settings =+  {-# SCC "acquire" #-} +  runEitherT $ do+    pqConnection <- lift (IO.acquireConnection settings)+    lift (IO.checkConnectionStatus pqConnection) >>= traverse left+    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

@@ -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]-

@@ -0,0 +1,669 @@+-- |+-- A DSL for declaration of result decoders.+module Hasql.Decoding+(+  -- * Result+  Result,+  unit,+  rowsAffected,+  singleRow,+  -- ** Specialized multi-row results+  maybeRow,+  rowsVector,+  rowsList,+  -- ** Multi-row traversers+  foldlRows,+  foldrRows,+  -- * 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,+  enum,+  -- * 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.Decoding.Results as Results+import qualified Hasql.Decoding.Result as Result+import qualified Hasql.Decoding.Row as Row+import qualified Hasql.Decoding.Value as Value+import qualified Hasql.Decoding.Array as Array+import qualified Hasql.Decoding.Composite as Composite+import qualified Hasql.Prelude as Prelude+++-- * Result+-------------------------++-- |+-- Decoder of a query result.+-- +newtype Result a =+  Result (Results.Results a)+  deriving (Functor)++-- |+-- Decode no value from the result.+-- +-- Useful for statements like @INSERT@ or @CREATE@.+-- +{-# INLINABLE unit #-}+unit :: Result ()+unit =+  Result (Results.single Result.unit)++-- |+-- Get the amount of rows affected by such statements as+-- @UPDATE@ or @DELETE@.+-- +{-# INLINABLE rowsAffected #-}+rowsAffected :: Result Int64+rowsAffected =+  Result (Results.single Result.rowsAffected)++-- |+-- Exactly one row.+-- Will raise the 'Hasql.Query.UnexpectedAmountOfRows' error if it's any other.+-- +{-# INLINABLE singleRow #-}+singleRow :: Row a -> Result a+singleRow (Row row) =+  Result (Results.single (Result.single row))++-- ** Multi-row traversers+-------------------------++-- |+-- Foldl multiple rows.+-- +{-# INLINABLE foldlRows #-}+foldlRows :: (a -> b -> a) -> a -> Row b -> Result a+foldlRows step init (Row row) =+  Result (Results.single (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 (Results.single (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 (Results.single (Result.maybe row))++-- |+-- Zero or more rows packed into the vector.+-- +-- It's recommended to prefer this function to 'rowsList',+-- since it performs notably better.+-- +{-# INLINABLE rowsVector #-}+rowsVector :: Row a -> Result (Vector a)+rowsVector (Row row) =+  Result (Results.single (Result.vector row))++-- |+-- Zero or more rows packed into the list.+-- +{-# INLINABLE rowsList #-}+rowsList :: Row a -> Result [a]+rowsList =+  foldrRows strictCons []+++-- ** Instances+-------------------------++-- | Maps to 'unit'.+instance Default (Result ()) where+  {-# INLINE def #-}+  def =+    unit++-- | 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+-------------------------++-- |+-- Decoder of an individual row,+-- which gets composed of column value decoders.+-- +-- 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 decoder to a composable row decoder.+-- +{-# INLINABLE value #-}+value :: Value a -> Row a+value (Value imp) =+  Row (Row.nonNullValue imp)++-- |+-- Lift an individual nullable value decoder to a composable row decoder.+-- +{-# 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+-------------------------++-- |+-- Decoder of an individual value.+-- +newtype Value a =+  Value (Value.Value a)+  deriving (Functor)+++-- ** Plain value decoders+-------------------------++-- |+-- Decoder of the @BOOL@ values.+-- +{-# INLINABLE bool #-}+bool :: Value Bool+bool =+  Value (Value.decoder (const Decoder.bool))++-- |+-- Decoder of the @INT2@ values.+-- +{-# INLINABLE int2 #-}+int2 :: Value Int16+int2 =+  Value (Value.decoder (const Decoder.int))++-- |+-- Decoder of the @INT4@ values.+-- +{-# INLINABLE int4 #-}+int4 :: Value Int32+int4 =+  Value (Value.decoder (const Decoder.int))++-- |+-- Decoder of the @INT8@ values.+-- +{-# INLINABLE int8 #-}+int8 :: Value Int64+int8 =+  {-# SCC "int8" #-} +  Value (Value.decoder (const ({-# SCC "int8.int" #-} Decoder.int)))++-- |+-- Decoder of the @FLOAT4@ values.+-- +{-# INLINABLE float4 #-}+float4 :: Value Float+float4 =+  Value (Value.decoder (const Decoder.float4))++-- |+-- Decoder of the @FLOAT8@ values.+-- +{-# INLINABLE float8 #-}+float8 :: Value Double+float8 =+  Value (Value.decoder (const Decoder.float8))++-- |+-- Decoder of the @NUMERIC@ values.+-- +{-# INLINABLE numeric #-}+numeric :: Value Scientific+numeric =+  Value (Value.decoder (const Decoder.numeric))++-- |+-- Decoder of the @CHAR@ values.+-- Note that it supports UTF-8 values.+{-# INLINABLE char #-}+char :: Value Char+char =+  Value (Value.decoder (const Decoder.char))++-- |+-- Decoder of the @TEXT@ values.+-- +{-# INLINABLE text #-}+text :: Value Text+text =+  Value (Value.decoder (const Decoder.text_strict))++-- |+-- Decoder of the @BYTEA@ values.+-- +{-# INLINABLE bytea #-}+bytea :: Value ByteString+bytea =+  Value (Value.decoder (const Decoder.bytea_strict))++-- |+-- Decoder of the @DATE@ values.+-- +{-# INLINABLE date #-}+date :: Value Day+date =+  Value (Value.decoder (const Decoder.date))++-- |+-- Decoder of the @TIMESTAMP@ values.+-- +{-# INLINABLE timestamp #-}+timestamp :: Value LocalTime+timestamp =+  Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int))++-- |+-- Decoder 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))++-- |+-- Decoder of the @TIME@ values.+-- +{-# INLINABLE time #-}+time :: Value TimeOfDay+time =+  Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int))++-- |+-- Decoder 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))++-- |+-- Decoder of the @INTERVAL@ values.+-- +{-# INLINABLE interval #-}+interval :: Value DiffTime+interval =+  Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int))++-- |+-- Decoder of the @UUID@ values.+-- +{-# INLINABLE uuid #-}+uuid :: Value UUID+uuid =+  Value (Value.decoder (const Decoder.uuid))++-- |+-- Decoder of the @JSON@ values.+-- +{-# INLINABLE json #-}+json :: Value Aeson.Value+json =+  Value (Value.decoder (const Decoder.json))+++-- ** Composite value decoders+-------------------------++-- |+-- Lifts the 'Array' decoder to the 'Value' decoder.+-- +{-# INLINABLE array #-}+array :: Array a -> Value a+array (Array imp) =+  Value (Value.decoder (Array.run imp))++-- |+-- Lifts the 'Composite' decoder to the 'Value' decoder.+-- +{-# INLINABLE composite #-}+composite :: Composite a -> Value a+composite (Composite imp) =+  Value (Value.decoder (Composite.run imp))++-- |+-- A generic decoder 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)))++-- |+-- Given a partial mapping from text to value,+-- produces a decoder of that value.+enum :: (Text -> Maybe a) -> Value a+enum mapping =+  Value (Value.decoder (const (Decoder.enum mapping)))+++-- ** 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 decoders+-------------------------++-- |+-- A generic array decoder.+-- +-- Here's how you can use it to produce a specific array value decoder:+-- +-- @+-- 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 decoder 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' decoder into an 'Array' decoder 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' decoder into an 'Array' decoder for parsing of nullable leaf values.+{-# INLINABLE arrayNullableValue #-}+arrayNullableValue :: Value a -> Array (Maybe a)+arrayNullableValue (Value imp) =+  Array (Array.value (Value.run imp))+++-- * Composite decoders+-------------------------++-- |+-- Composable decoder of composite values (rows, records).+newtype Composite a =+  Composite (Composite.Composite a)+  deriving (Functor, Applicative, Monad)++-- |+-- Lift a 'Value' decoder into a 'Composite' decoder 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' decoder into a 'Composite' decoder for parsing of nullable leaf values.+{-# INLINABLE compositeNullableValue #-}+compositeNullableValue :: Value a -> Composite (Maybe a)+compositeNullableValue (Value imp) =+  Composite (Composite.value (Value.run imp))+

@@ -0,0 +1,31 @@+module Hasql.Decoding.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'+

@@ -0,0 +1,26 @@+module Hasql.Decoding.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'+

@@ -0,0 +1,232 @@+module Hasql.Decoding.Result where++import Hasql.Prelude hiding (maybe, many)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Decoding.Row as Row+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec+import qualified Data.ByteString as ByteString+import qualified Hasql.Prelude as Prelude+import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MutableVector+++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)++{-# INLINE run #-}+run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a)+run (Result reader) env =+  runEitherT (runReaderT reader env)++{-# INLINE unit #-}+unit :: Result ()+unit =+  checkExecStatus $ \case+    LibPQ.CommandOk -> True+    LibPQ.TuplesOk -> True+    _ -> False++{-# INLINE rowsAffected #-}+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++{-# INLINE checkExecStatus #-}+checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()+checkExecStatus predicate =+  {-# SCC "checkExecStatus" #-} +  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)++{-# INLINE serverError #-}+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++{-# INLINE maybe #-}+maybe :: Row.Row a -> Result (Maybe a)+maybe rowDec =+  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 rowDec (result, 0, maxCols, integerDatetimes)+        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE single #-}+single :: Row.Row a -> Result a+single rowDec =+  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 rowDec (result, 0, maxCols, integerDatetimes)+        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE vector #-}+vector :: Row.Row a -> Result (Vector a)+vector rowDec =+  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do+      maxRows <- LibPQ.ntuples result+      maxCols <- LibPQ.nfields result+      mvector <- MutableVector.unsafeNew (rowToInt maxRows)+      failureRef <- newIORef Nothing+      forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do+        rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)+        case rowResult of+          Left !x -> writeIORef failureRef (Just (RowError rowIndex x))+          Right !x -> MutableVector.unsafeWrite mvector rowIndex x+      readIORef failureRef >>= \case+        Nothing -> Right <$> Vector.unsafeFreeze mvector+        Just x -> pure (Left x)+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE foldl #-}+foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a+foldl step init rowDec =+  {-# SCC "foldl" #-} +  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ {-# SCC "traversal" #-} do+      maxRows <- LibPQ.ntuples result+      maxCols <- LibPQ.nfields result+      accRef <- newIORef init+      failureRef <- newIORef Nothing+      forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do+        rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)+        case rowResult of+          Left !x -> writeIORef failureRef (Just (RowError rowIndex x))+          Right !x -> modifyIORef accRef (\acc -> step acc x)+      readIORef failureRef >>= \case+        Nothing -> Right <$> readIORef accRef+        Just x -> pure (Left x)+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE foldr #-}+foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a+foldr step init rowDec =+  {-# SCC "foldr" #-} +  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do+      maxRows <- LibPQ.ntuples result+      maxCols <- LibPQ.nfields result+      accRef <- newIORef init+      failureRef <- newIORef Nothing+      forMToZero_ (rowToInt maxRows) $ \rowIndex -> do+        rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)+        case rowResult of+          Left !x -> writeIORef failureRef (Just (RowError rowIndex x))+          Right !x -> modifyIORef accRef (\acc -> step x acc)+      readIORef failureRef >>= \case+        Nothing -> Right <$> readIORef accRef+        Just x -> pure (Left x)+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral

@@ -0,0 +1,91 @@+-- |+-- 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.Decoding.Results where++import Hasql.Prelude hiding (maybe, many)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Prelude as Prelude+import qualified Hasql.Decoding.Result as Result+import qualified Hasql.Decoding.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)++{-# INLINE clientError #-}+clientError :: Results a+clientError =+  Results $ ReaderT $ \(_, connection) -> EitherT $+  fmap (Left . ClientError) (LibPQ.errorMessage connection)++-- |+-- Parse a single result.+{-# INLINE single #-}+single :: Result.Result a -> Results a+single resultDec =+  Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do+    resultMaybe <- LibPQ.getResult connection+    case resultMaybe of+      Just result ->+        mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) +          <* LibPQ.unsafeFreeResult result+      Nothing ->+        fmap (Left . ClientError) (LibPQ.errorMessage connection)++-- |+-- Fetch a single result.+{-# INLINE 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.+{-# INLINE getResultMaybe #-}+getResultMaybe :: Results (Maybe LibPQ.Result)+getResultMaybe =+  Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection++{-# INLINE dropRemainders #-}+dropRemainders :: Results ()+dropRemainders =+  {-# SCC "dropRemainders" #-} +  Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection+  where+    loop integerDatetimes connection =+      getResultMaybe >>= Prelude.maybe (pure ()) onResult+      where+        getResultMaybe =+          lift $ LibPQ.getResult connection+        onResult result =+          checkErrors *> loop integerDatetimes connection+          where+            checkErrors =+              EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result)

@@ -0,0 +1,65 @@+module Hasql.Decoding.Row where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Decoder as Decoder+import qualified Hasql.Decoding.Value as Value+++newtype Row a =+  Row (ReaderT Env (EitherT Error IO) a)+  deriving (Functor, Applicative, Monad)++data Env =+  Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)++data Error =+  EndOfInput |+  UnexpectedNull |+  ValueError !Text+  deriving (Show)+++-- * Functions+-------------------------++{-# INLINE run #-}+run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)+run (Row impl) (result, row, columnsAmount, integerDatetimes) =+  do+    columnRef <- newIORef 0+    runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef))++{-# INLINE error #-}+error :: Error -> Row a+error x =+  Row (ReaderT (const (EitherT (pure (Left x)))))++-- |+-- Next value, decoded using the provided value decoder.+{-# INLINE value #-}+value :: Value.Value a -> Row (Maybe a)+value valueDec =+  {-# SCC "value" #-} +  Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> EitherT $ do+    col <- readIORef columnRef+    writeIORef columnRef (succ col)+    if col < columnsAmount+      then do+        valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col+        pure $ +          case valueMaybe of+            Nothing ->+              Right Nothing+            Just value ->+              fmap Just $ mapLeft ValueError $+              {-# SCC "decode" #-} Decoder.run (Value.run valueDec integerDatetimes) value+      else pure (Left EndOfInput)++-- |+-- Next value, decoded using the provided value decoder.+{-# INLINE nonNullValue #-}+nonNullValue :: Value.Value a -> Row a+nonNullValue valueDec =+  {-# SCC "nonNullValue" #-} +  value valueDec >>= maybe (error UnexpectedNull) pure

@@ -0,0 +1,23 @@+module Hasql.Decoding.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 =+  {-# SCC "decoder" #-} +  Value . ReaderT+

@@ -0,0 +1,483 @@+-- |+-- A DSL for declaration of query parameter encoders.+module Hasql.Encoding+(+  -- * Params+  Params,+  unit,+  value,+  nullableValue,+  -- * Value+  Value,+  bool,+  int2,+  int4,+  int8,+  float4,+  float8,+  numeric,+  char,+  text,+  bytea,+  date,+  timestamp,+  timestamptz,+  time,+  timetz,+  interval,+  uuid,+  json,+  array,+  enum,+  -- * 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.Encoding.Params as Params+import qualified Hasql.Encoding.Value as Value+import qualified Hasql.Encoding.Array as Array+import qualified Hasql.PTI as PTI+import qualified Hasql.Prelude as Prelude+++-- * Parameters Product Encoder+-------------------------++-- |+-- Encoder of some representation of the parameters product.+-- +-- Has instances of 'Contravariant', 'Divisible' and 'Monoid',+-- which you can use to compose multiple parameters together.+-- E.g.,+-- +-- @+-- someParamsEncoder :: 'Params' (Int64, Maybe Text)+-- someParamsEncoder =+--   'contramap' 'fst' ('value' 'int8') '<>'+--   'contramap' 'snd' ('nullableValue' 'text')+-- @+-- +-- As a general solution for tuples of any arity, instead of 'fst' and 'snd',+-- consider the functions of the @contrazip@ family+-- from the \"contravariant-extras\" package.+-- E.g., here's how you can achieve the same as the above:+-- +-- @+-- someParamsEncoder :: 'Params' (Int64, Maybe Text)+-- someParamsEncoder =+--   'contrazip2' ('value' 'int8') ('nullableValue' 'text')+-- @+-- +-- Here's how you can implement encoders for custom composite types:+-- +-- @+-- data Person =+--   Person { name :: Text, gender :: Gender, age :: Int }+-- +-- data Gender =+--   Male | Female+-- +-- personParams :: 'Params' Person+-- personParams =+--   'contramap' name ('value' 'text') '<>'+--   'contramap' gender ('value' genderValue) '<>'+--   'contramap' (fromIntegral . age) ('value' 'int8')+-- +-- genderValue :: 'Value' Gender+-- genderValue =+--   'contramap' genderText 'text'+--   where+--     genderText gender =+--       case gender of+--         Male -> "male"+--         Female -> "female"+-- @+-- +newtype Params a =+  Params (Params.Params a)+  deriving (Contravariant, Divisible, Monoid)++-- |+-- Encode no parameters.+-- +{-# INLINABLE unit #-}+unit :: Params ()+unit =+  Params mempty++-- |+-- Lift an individual value encoder to a parameters encoder.+-- +{-# INLINABLE value #-}+value :: Value a -> Params a+value (Value x) =+  Params (Params.value x)++-- |+-- Lift an individual nullable value encoder to a parameters encoder.+-- +{-# INLINABLE nullableValue #-}+nullableValue :: Value a -> Params (Maybe a)+nullableValue (Value x) =+  Params (Params.nullableValue x)+++-- ** Instances+-------------------------++-- |+-- Maps to 'unit'.+instance Default (Params ()) where+  {-# INLINE def #-}+  def =+    unit++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 =+    contrazip2 (value def) (value def)++instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where+  {-# INLINE def #-}+  def =+    contrazip3 (value def) (value def) (value def)++instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where+  {-# INLINE def #-}+  def =+    contrazip4 (value def) (value def) (value def) (value def)++instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where+  {-# INLINE def #-}+  def =+    contrazip5 (value def) (value def) (value def) (value def) (value def)+++-- * Value Encoder+-------------------------++-- |+-- An individual value encoder.+-- Will be mapped to a single placeholder in the query.+-- +newtype Value a =+  Value (Value.Value a)+  deriving (Contravariant)++-- |+-- Encoder of @BOOL@ values.+{-# INLINABLE bool #-}+bool :: Value Bool+bool =+  Value (Value.unsafePTI PTI.bool (const Encoder.bool))++-- |+-- Encoder of @INT2@ values.+{-# INLINABLE int2 #-}+int2 :: Value Int16+int2 =+  Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16))++-- |+-- Encoder of @INT4@ values.+{-# INLINABLE int4 #-}+int4 :: Value Int32+int4 =+  Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32))++-- |+-- Encoder of @INT8@ values.+{-# INLINABLE int8 #-}+int8 :: Value Int64+int8 =+  Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64))++-- |+-- Encoder of @FLOAT4@ values.+{-# INLINABLE float4 #-}+float4 :: Value Float+float4 =+  Value (Value.unsafePTI PTI.float4 (const Encoder.float4))++-- |+-- Encoder of @FLOAT8@ values.+{-# INLINABLE float8 #-}+float8 :: Value Double+float8 =+  Value (Value.unsafePTI PTI.float8 (const Encoder.float8))++-- |+-- Encoder of @NUMERIC@ values.+{-# INLINABLE numeric #-}+numeric :: Value Scientific+numeric =+  Value (Value.unsafePTI PTI.numeric (const Encoder.numeric))++-- |+-- Encoder of @CHAR@ values.+-- Note that it supports UTF-8 values and+-- identifies itself under the @TEXT@ OID because of that.+{-# INLINABLE char #-}+char :: Value Char+char =+  Value (Value.unsafePTI PTI.text (const Encoder.char))++-- |+-- Encoder of @TEXT@ values.+{-# INLINABLE text #-}+text :: Value Text+text =+  Value (Value.unsafePTI PTI.text (const Encoder.text_strict))++-- |+-- Encoder of @BYTEA@ values.+{-# INLINABLE bytea #-}+bytea :: Value ByteString+bytea =+  Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict))++-- |+-- Encoder of @DATE@ values.+{-# INLINABLE date #-}+date :: Value Day+date =+  Value (Value.unsafePTI PTI.date (const Encoder.date))++-- |+-- Encoder of @TIMESTAMP@ values.+{-# INLINABLE timestamp #-}+timestamp :: Value LocalTime+timestamp =+  Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float))++-- |+-- Encoder of @TIMESTAMPTZ@ values.+{-# INLINABLE timestamptz #-}+timestamptz :: Value UTCTime+timestamptz =+  Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float))++-- |+-- Encoder of @TIME@ values.+{-# INLINABLE time #-}+time :: Value TimeOfDay+time =+  Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float))++-- |+-- Encoder of @TIMETZ@ values.+{-# INLINABLE timetz #-}+timetz :: Value (TimeOfDay, TimeZone)+timetz =+  Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float))++-- |+-- Encoder of @INTERVAL@ values.+{-# INLINABLE interval #-}+interval :: Value DiffTime+interval =+  Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float))++-- |+-- Encoder of @UUID@ values.+{-# INLINABLE uuid #-}+uuid :: Value UUID+uuid =+  Value (Value.unsafePTI PTI.uuid (const Encoder.uuid))++-- |+-- Encoder of @JSON@ values.+{-# INLINABLE json #-}+json :: Value Aeson.Value+json =+  Value (Value.unsafePTI PTI.json (const Encoder.json))++-- |+-- Unlifts the 'Array' encoder to the plain 'Value' encoder.+{-# INLINABLE array #-}+array :: Array a -> Value a+array (Array imp) =+  Array.run imp & \(arrayOID, encoder') ->+    Value (Value.Value arrayOID arrayOID encoder')++-- |+-- Given a function,+-- which maps the value into the textual enum label from the DB side,+-- produces a encoder of that value.+{-# INLINABLE enum #-}+enum :: (a -> Text) -> Value a+enum mapping =+  Value (Value.unsafePTI PTI.text (const (Encoder.enum mapping)))+++-- ** 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+-------------------------++-- |+-- A generic array encoder.+-- +-- Here's an example of its usage:+-- +-- >x :: Value [[Int64]]+-- >x =+-- >  array (arrayDimension foldl' (arrayDimension foldl' (arrayValue int8)))+-- +newtype Array a =+  Array (Array.Array a)++-- |+-- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value.+{-# INLINABLE arrayValue #-}+arrayValue :: Value a -> Array a+arrayValue (Value (Value.Value elementOID arrayOID encoder')) =+  Array (Array.value elementOID arrayOID encoder')++-- |+-- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value.+{-# INLINABLE arrayNullableValue #-}+arrayNullableValue :: Value a -> Array (Maybe a)+arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) =+  Array (Array.nullableValue elementOID arrayOID encoder')++-- |+-- An encoder of an array dimension,+-- which thus provides support for multidimensional arrays.+-- +-- Accepts:+-- +-- * An implementation of the left-fold operation,+-- such as @Data.Foldable.'foldl''@,+-- which determines the input value.+-- +-- * A component encoder, which can be either another 'arrayDimension',+-- 'arrayValue' or 'arrayNullableValue'.+-- +{-# INLINABLE arrayDimension #-}+arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c+arrayDimension foldl (Array imp) =+  Array (Array.dimension foldl imp)+

@@ -0,0 +1,31 @@+module Hasql.Encoding.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')+

@@ -0,0 +1,49 @@+module Hasql.Encoding.Params where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified Hasql.Encoding.Value as Value+import qualified Hasql.PTI as PTI+++-- |+-- Encoder 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 =+  {-# SCC "run" #-} +  op params++run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)])+run' (Params (Op op)) params integerDatetimes =+  {-# SCC "run'" #-} +  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 =+  {-# SCC "run''" #-} +  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)

@@ -0,0 +1,27 @@+module Hasql.Encoding.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'++

@@ -0,0 +1,151 @@+-- |+-- 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.Decoding.Result as ResultDecoding+import qualified Hasql.Decoding.Results as ResultsDecoding+import qualified Hasql.Encoding.Params as ParamsEncoding+import qualified Data.DList as DList+++{-# INLINE acquireConnection #-}+acquireConnection :: ByteString -> IO LibPQ.Connection+acquireConnection =+  LibPQ.connectdb++{-# INLINE acquirePreparedStatementRegistry #-}+acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry+acquirePreparedStatementRegistry =+  PreparedStatementRegistry.new++{-# INLINE releaseConnection #-}+releaseConnection :: LibPQ.Connection -> IO ()+releaseConnection connection =+  LibPQ.finish connection++{-# INLINE 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++{-# INLINE initConnection #-}+initConnection :: LibPQ.Connection -> IO ()+initConnection c =+  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodingToUTF8 <> Commands.setMinClientMessagesToWarning))++{-# INLINE getResults #-}+getResults :: LibPQ.Connection -> Bool -> ResultsDecoding.Results a -> IO (Either ResultsDecoding.Error a)+getResults connection integerDatetimes des =+  {-# SCC "getResults" #-} +  ResultsDecoding.run (des <* ResultsDecoding.dropRemainders) (integerDatetimes, connection)++{-# INLINE getPreparedStatementKey #-}+getPreparedStatementKey ::+  LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString -> [LibPQ.Oid] ->+  IO (Either ResultsDecoding.Error ByteString)+getPreparedStatementKey connection registry template oidList =+  {-# SCC "getPreparedStatementKey" #-} +  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 resultsDecoder = +                if sent+                  then ResultsDecoding.single ResultDecoding.unit+                  else ResultsDecoding.clientError+          runEitherT $ do+            EitherT $ getResults connection undefined resultsDecoder+            pure key+  where+    wordOIDList =+      map (\(LibPQ.Oid x) -> fromIntegral x) oidList++{-# INLINE checkedSend #-}+checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoding.Error ())+checkedSend connection send =+  send >>= \case+    False -> fmap (Left . ResultsDecoding.ClientError) $ LibPQ.errorMessage connection+    True -> pure (Right ())++{-# INLINE sendPreparedParametricQuery #-}+sendPreparedParametricQuery ::+  LibPQ.Connection ->+  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  [LibPQ.Oid] ->+  [Maybe (ByteString, LibPQ.Format)] ->+  IO (Either ResultsDecoding.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++{-# INLINE sendUnpreparedParametricQuery #-}+sendUnpreparedParametricQuery ::+  LibPQ.Connection ->+  ByteString ->+  [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] ->+  IO (Either ResultsDecoding.Error ())+sendUnpreparedParametricQuery connection template paramList =+  checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary++{-# INLINE sendParametricQuery #-}+sendParametricQuery ::+  LibPQ.Connection ->+  Bool -> +  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  ParamsEncoding.Params a ->+  Bool ->+  a ->+  IO (Either ResultsDecoding.Error ())+sendParametricQuery connection integerDatetimes registry template encoder prepared params =+  {-# SCC "sendParametricQuery" #-} +  if prepared+    then+      let+        (oidList, valueAndFormatList) =+          ParamsEncoding.run' encoder params integerDatetimes+        in+          sendPreparedParametricQuery connection registry template oidList valueAndFormatList+    else+      let+        paramList =+          ParamsEncoding.run'' encoder params integerDatetimes+        in+          sendUnpreparedParametricQuery connection template paramList++{-# INLINE sendNonparametricQuery #-}+sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoding.Error ())+sendNonparametricQuery connection sql =+  checkedSend connection $ LibPQ.sendQuery connection sql

@@ -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)+

@@ -1,53 +1,134 @@ module Hasql.Prelude-( +(   module Exports,+  LazyByteString,+  ByteStringBuilder,+  LazyText,+  TextBuilder,+  bug,+  bottom,+  forMToZero_,+  forMFromZero_,+  strictCons, ) 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)+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports --- mmorph+-- contravariant-extras --------------------------import Control.Monad.Morph as Exports+import Contravariant.Extras 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" |]++{-# INLINE forMToZero_ #-}+forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m ()+forMToZero_ !startN f =+  ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure ()++{-# INLINE forMFromZero_ #-}+forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m ()+forMFromZero_ !endN f =+  ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()++{-# INLINE strictCons #-}+strictCons :: a -> [a] -> [a]+strictCons !a b =+  let !c = a : b in c

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

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

@@ -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]

@@ -0,0 +1,165 @@+module Hasql.Query+(+  Query(..),+  -- * Execution+  ResultsError(..),+  ResultError(..),+  RowError(..),+  run,+)+where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry+import qualified Hasql.Decoding.Results as ResultsDecoding+import qualified Hasql.Decoding as Decoding+import qualified Hasql.Encoding.Params as ParamsEncoding+import qualified Hasql.Encoding as Encoding+import qualified Hasql.Settings as Settings+import qualified Hasql.IO as IO+import qualified Hasql.Connection.Impl as Connection+++-- |+-- An error of the result-decoder.+data ResultsError =+  -- |+  -- An error on the client-side,+  -- with a message generated by the \"libpq\" library.+  -- Usually indicates problems with connection.+  ClientError !(Maybe ByteString) |+  -- |+  -- Decoder error details.+  ResultError !ResultError+  deriving (Show, Eq)++-- |+-- Decoder error details.+data ResultError =+  -- | +  -- An error reported by the DB.+  -- Consists of the following: Code, message, details, hint.+  -- +  -- * __Code__.+  -- The SQLSTATE code for the error.+  -- It's recommended to use+  -- <http://hackage.haskell.org/package/postgresql-error-codes the "postgresql-error-codes" package>+  -- to work with those.+  -- +  -- * __Message__.+  -- The primary human-readable error message (typically one line). Always present.+  -- +  -- * __Details__.+  -- An optional secondary error message carrying more detail about the problem. +  -- Might run to multiple lines.+  -- +  -- * __Hint__.+  -- An optional suggestion on 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, Eq)++-- |+-- An error during the decoding of a specific row.+data RowError =+  -- |+  -- Appears on the attempt to parse more columns than there are in the result.+  EndOfInput |+  -- |+  -- Appears on the attempt to parse a @NULL@ as some value.+  UnexpectedNull |+  -- |+  -- Appears when a wrong value parser is used.+  -- Comes with the error details.+  ValueError !Text+  deriving (Show, Eq)+++-- |+-- A specification of a strictly single-statement query, which can be parameterized and prepared.+-- +-- Consists of the following:+-- +-- * SQL template,+-- * params encoder,+-- * result decoder,+-- * a flag, determining whether it should be prepared.+-- +-- The SQL template must be formatted according to Postgres' standard,+-- with any non-ASCII characters of the template must be encoded using UTF-8.+-- According to the format,+-- parameters must be referred to using the positional notation, as in the following:+-- @$1@, @$2@, @$3@ and etc.+-- Those references must be used to refer to the values of the 'Encoding.Params' encoder.+-- +-- Following is an example of the declaration of a prepared statement with its associated codecs.+-- +-- @+-- selectSum :: Hasql.'Hasql.Query' (Int64, Int64) Int64+-- selectSum =+--   Hasql.'Hasql.Query' sql encoder decoder True+--   where+--     sql =+--       "select ($1 + $2)"+--     encoder =+--       'contramap' 'fst' (Hasql.Encoding.'Hasql.Encoding.value' Hasql.Encoding.'Hasql.Encoding.int8') '<>'+--       'contramap' 'snd' (Hasql.Encoding.'Hasql.Encoding.value' Hasql.Encoding.'Hasql.Encoding.int8')+--     decoder =+--       Hasql.Decoding.'Hasql.Decoding.singleRow' (Hasql.Decoding.'Hasql.Decoding.value' Hasql.Decoding.'Hasql.Decoding.int8')+-- @+-- +-- The statement above accepts a product of two parameters of type 'Int64'+-- and results in a single result of type 'Int64'.+-- +data Query a b =+  Query !ByteString !(Encoding.Params a) !(Decoding.Result b) !Bool+  deriving (Functor)++instance Profunctor Query where+  {-# INLINE lmap #-}+  lmap f (Query p1 p2 p3 p4) =+    Query p1 (contramap f p2) p3 p4+  {-# INLINE rmap #-}+  rmap f (Query p1 p2 p3 p4) =+    Query p1 p2 (fmap f p3) p4+  {-# INLINE dimap #-}+  dimap f1 f2 (Query p1 p2 p3 p4) =+    Query p1 (contramap f1 p2) (fmap f2 p3) p4++-- |+-- Execute the query, producing either a deserialization failure or a successful result.+run :: Query a b -> a -> Connection.Connection -> IO (Either ResultsError b)+run (Query template encoder decoder preparable) params (Connection.Connection pqConnection integerDatetimes registry) =+  {-# SCC "query" #-} +  fmap (mapLeft coerceResultsError) $ runEitherT $ do+    EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params+    EitherT $ IO.getResults pqConnection integerDatetimes (coerceDecoder decoder)++-- |+-- WARNING: We need to take special care that the structure of+-- the "ResultsDecoding.Error" type in the public API is an exact copy of+-- "Error", since we're using coercion.+coerceResultsError :: ResultsDecoding.Error -> ResultsError+coerceResultsError =+  unsafeCoerce++coerceDecoder :: Decoding.Result a -> ResultsDecoding.Results a+coerceDecoder =+  unsafeCoerce++coerceEncoder :: Encoding.Params a -> ParamsEncoding.Params a+coerceEncoder =+  unsafeCoerce

@@ -0,0 +1,39 @@+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++++-- | +-- 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>.+type Settings =+  ByteString++-- |+-- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string.+{-# INLINE settings #-}+settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings+settings 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)+  ]+

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

@@ -0,0 +1,136 @@+module Main where++import Main.Prelude hiding (assert, isRight, isLeft)+import Test.QuickCheck.Instances+import Test.Tasty+import qualified Main.Queries as Queries+import qualified Test.Tasty.HUnit as HUnit+import qualified Test.Tasty.SmallCheck as SmallCheck+import qualified Test.Tasty.QuickCheck as QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified Main.DSL as DSL+import qualified Hasql.Query as Query+import qualified Hasql.Encoding as Encoding+import qualified Hasql.Decoding as Decoding++main =+  defaultMain tree++tree =+  testGroup "All tests"+  [+    HUnit.testCase "Enum" $+    HUnit.assertEqual "" (Right "ok") $+    let+      actual =+        unsafePerformIO $+        DSL.session $ do+          let+            query =+              Query.Query sql mempty Decoding.unit True+              where+                sql =+                  "drop type if exists mood"+            in DSL.query () query+          let+            query =+              Query.Query sql mempty Decoding.unit True+              where+                sql =+                  "create type mood as enum ('sad', 'ok', 'happy')"+            in DSL.query () query+          let+            query =+              Query.Query sql encoder decoder True+              where+                sql =+                  "select ($1 :: mood)"+                decoder =+                  (Decoding.singleRow (Decoding.value (Decoding.enum (Just . id))))+                encoder =+                  Encoding.value (Encoding.enum id)+            in DSL.query "ok" query+      in actual+    ,+    HUnit.testCase "The same prepared statement used on different types" $ +    HUnit.assertEqual "" (Right ("ok", 1)) $+    let+      actual =+        unsafePerformIO $+        DSL.session $ do+          let+            effect1 =+              DSL.query "ok" query+              where+                query =+                  Query.Query sql encoder decoder True+                  where+                    sql =+                      "select $1"+                    encoder =+                      Encoding.value Encoding.text+                    decoder =+                      (Decoding.singleRow (Decoding.value (Decoding.text)))+            effect2 =+              DSL.query 1 query+              where+                query =+                  Query.Query sql encoder decoder True+                  where+                    sql =+                      "select $1"+                    encoder =+                      Encoding.value Encoding.int8+                    decoder =+                      (Decoding.singleRow (Decoding.value Decoding.int8))+            in (,) <$> effect1 <*> effect2+      in actual+    ,+    HUnit.testCase "Affected rows counting" $+    HUnit.assertEqual "" (Right 100) $+    let+      actual =+        unsafePerformIO $+        DSL.session $ do+          dropTable+          createTable+          replicateM_ 100 insertRow+          deleteRows <* dropTable+        where+          dropTable =+            DSL.query () $ Queries.plain $ +            "drop table if exists a"+          createTable =+            DSL.query () $ Queries.plain $+            "create table a (id bigserial not null, name varchar not null, primary key (id))"+          insertRow =+            DSL.query () $ Queries.plain $+            "insert into a (name) values ('a')"  +          deleteRows =+            DSL.query () $ Query.Query sql def decoder False+            where+              sql =+                "delete from a"+              decoder =+                Decoding.rowsAffected+      in actual+    ,+    HUnit.testCase "Result of an auto-incremented column" $+    let+      actualIO =+        DSL.session $ do+          DSL.query () $ Queries.plain $ "drop table if exists a"+          DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))"+          id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False+          id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False+          DSL.query () $ Queries.plain $ "drop table if exists a"+          pure (id1, id2)+      in HUnit.assertEqual "" (Right (1, 2)) =<< actualIO+    ,+    HUnit.testCase "List decoding" $+    let+      actualIO =+        DSL.session $ DSL.query () $ Queries.selectList+      in HUnit.assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO+  ]+

@@ -0,0 +1,43 @@+module Main.DSL where++import Main.Prelude+import qualified Hasql.Connection as HC+import qualified Hasql.Query as HQ+import qualified Hasql.Settings as HS+import qualified Hasql.Encoding as HE+import qualified Hasql.Decoding as HD+++newtype Session a =+  Session (ReaderT HC.Connection (EitherT HQ.ResultsError IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++data SessionError =+  ConnectionError (HC.ConnectionError) |+  ResultsError (HQ.ResultsError)+  deriving (Show, Eq)++session :: Session a -> IO (Either SessionError a)+session (Session impl) =+  runEitherT $ acquire >>= \connection -> use connection <* release connection+  where+    acquire =+      EitherT $ fmap (mapLeft ConnectionError) $ HC.acquire settings+      where+        settings =+          HS.settings host port user password database+          where+            host = "localhost"+            port = 5432+            user = "postgres"+            password = ""+            database = "postgres"+    use connection =+      bimapEitherT ResultsError id $+      runReaderT impl connection+    release connection =+      lift $ HC.release connection++query :: a -> HQ.Query a b -> Session b+query params query =+  Session $ ReaderT $ EitherT . HQ.run query params

@@ -0,0 +1,73 @@+module Main.Prelude+(+  module Exports,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)++-- transformers+-------------------------+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++-- data-default-class+-------------------------+import Data.Default.Class as Exports++-- profunctors+-------------------------+import Data.Profunctor.Unsafe as Exports++-- contravariant+-------------------------+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports++-- contravariant-extras+-------------------------+import Contravariant.Extras as Exports++-- either+-------------------------+import Control.Monad.Trans.Either as Exports+import Data.Either.Combinators as Exports++-- hashable+-------------------------+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)++-- dlist+-------------------------+import Data.DList as Exports (DList)

@@ -0,0 +1,36 @@+module Main.Queries where++import Main.Prelude hiding (def)+import qualified Hasql.Query as HQ+import qualified Hasql.Encoding as HE+import qualified Hasql.Decoding as HD+import qualified Main.Prelude as Prelude+++def :: ByteString -> HQ.Query () ()+def sql =+  HQ.Query sql Prelude.def Prelude.def False++plain :: ByteString -> HQ.Query () ()+plain sql =+  HQ.Query sql mempty HD.unit False++dropType :: ByteString -> HQ.Query () ()+dropType name =+  plain $+    "drop type if exists " <> name++createEnum :: ByteString -> [ByteString] -> HQ.Query () ()+createEnum name values =+  plain $+    "create type " <> name <> " as enum (" <> +    mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) <> ")"++selectList :: HQ.Query () ([] (Int64, Int64))+selectList =+  HQ.Query sql mempty decoder True+  where+    sql =+      "values (1,2), (3,4), (5,6)"+    decoder =+      HD.rowsList ((,) <$> HD.value HD.int8 <*> HD.value HD.int8)