hpgsql-simple-compat (empty) → 0.1.0.0

raw patch · 49 files changed

+7178/−0 lines, 49 filesdep +Onlydep +aesondep +attoparsec

Dependencies added: Only, aeson, attoparsec, base, bytestring, case-insensitive, containers, hashable, haskell-src-meta, hpgsql, mtl, scientific, streaming, template-haskell, text, time-compat, transformers, uuid-types, vector

Files

• LICENSE +159/−0
• hpgsql-simple-compat.cabal +144/−0
• src/Database/PostgreSQL/LibPQ.hs +26/−0
• src/Database/PostgreSQL/Query.hs +62/−0
• src/Database/PostgreSQL/Query/Functions.hs +25/−0
• src/Database/PostgreSQL/Query/SqlBuilder.hs +10/−0
• src/Database/PostgreSQL/Query/SqlBuilder/Builder.hs +19/−0
• src/Database/PostgreSQL/Query/SqlBuilder/Class.hs +13/−0
• src/Database/PostgreSQL/Query/SqlBuilder/Types.hs +49/−0
• src/Database/PostgreSQL/Query/TH.hs +63/−0
• src/Database/PostgreSQL/Query/TH/SqlExp.hs +14/−0
• src/Database/PostgreSQL/Query/Types.hs +82/−0
• src/Database/PostgreSQL/Simple.hs +920/−0
• src/Database/PostgreSQL/Simple.hs-boot +21/−0
• src/Database/PostgreSQL/Simple/Arrays.hs +99/−0
• src/Database/PostgreSQL/Simple/Compat.hs +39/−0
• src/Database/PostgreSQL/Simple/Copy.hs +117/−0
• src/Database/PostgreSQL/Simple/Cursor.hs +72/−0
• src/Database/PostgreSQL/Simple/Errors.hs +140/−0
• src/Database/PostgreSQL/Simple/FromField.hs +323/−0
• src/Database/PostgreSQL/Simple/FromField.hs-boot +1/−0
• src/Database/PostgreSQL/Simple/FromRow.hs +109/−0
• src/Database/PostgreSQL/Simple/FromRow.hs-boot +3/−0
• src/Database/PostgreSQL/Simple/HStore.hs +36/−0
• src/Database/PostgreSQL/Simple/HStore/Implementation.hs +185/−0
• src/Database/PostgreSQL/Simple/HStore/Internal.hs +19/−0
• src/Database/PostgreSQL/Simple/HpgsqlUtils.hs +126/−0
• src/Database/PostgreSQL/Simple/Internal.hs +369/−0
• src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs +12/−0
• src/Database/PostgreSQL/Simple/Newtypes.hs +9/−0
• src/Database/PostgreSQL/Simple/Notification.hs +80/−0
• src/Database/PostgreSQL/Simple/Ok.hs +84/−0
• src/Database/PostgreSQL/Simple/Range.hs +92/−0
• src/Database/PostgreSQL/Simple/SqlQQ.hs +85/−0
• src/Database/PostgreSQL/Simple/Time.hs +245/−0
• src/Database/PostgreSQL/Simple/Time/Implementation.hs +157/−0
• src/Database/PostgreSQL/Simple/Time/Internal.hs +27/−0
• src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +210/−0
• src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +155/−0
• src/Database/PostgreSQL/Simple/ToField.hs +158/−0
• src/Database/PostgreSQL/Simple/ToField.hs-boot +1/−0
• src/Database/PostgreSQL/Simple/ToRow.hs +128/−0
• src/Database/PostgreSQL/Simple/ToRow.hs-boot +2/−0
• src/Database/PostgreSQL/Simple/Transaction.hs +264/−0
• src/Database/PostgreSQL/Simple/TypeInfo.hs +54/−0
• src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +46/−0
• src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +1689/−0
• src/Database/PostgreSQL/Simple/TypeInfo/Types.hs +105/−0
• src/Database/PostgreSQL/Simple/Types.hs +330/−0

@@ -0,0 +1,159 @@+Copyright (c) 2026, Marcelo Zabani++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marcelo Zabani nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2011, Leon P Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Leon P Smith nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2011, MailRank, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2014, Aleksey Uimanov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Aleksey Uimanov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2010, Grant Monroe+Copyright (c) 2011, Leon P Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the authors nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,144 @@+cabal-version:      1.12+name:               hpgsql-simple-compat+version:            0.1.0.0+synopsis:           Fork of postgresql-simple implemented with hpgsql instead of postgresql-libpq.+description:+  This is a fork of postgresql-simple that tries to preserve its API as much as possible, but+  uses hpgsql instead of postgresql-libpq under the hood.+  The idea is to ease migrating to hpgsql itself. Check the GitHub for more information.++license:            BSD3+license-file:       LICENSE+-- Authors of postgresql-simple, postgresql-libpq, and postgresql-query, plus myself+author:             Bryan O'Sullivan, Leon P Smith, Aleksey Uimanov, Grant Monroe, Marcelo Zabani+maintainer:         Marcelo Zabani+copyright:+  (c) 2026 Marcelo Zabani+  (c) 2011 MailRank, Inc.+  (c) 2011-2018 Leon P Smith+  (c) 2018-2020 Oleg Grenrus+  (c) 2014 Aleksey Uimanov+  (c) 2010 Grant Monroe++category:           Database+homepage:           https://github.com/mzabani/hpgsql#readme+bug-reports:        https://github.com/mzabani/hpgsql/issues+build-type:         Simple++source-repository head+  type:     git+  location: http://github.com/mzabani/hpgsql/hpgsql-simple-compat++library+  default-language:   Haskell2010+  hs-source-dirs:     src+  exposed-modules:+    -- postgresql-libpq+    Database.PostgreSQL.LibPQ+    -- postgresql-simple+    Database.PostgreSQL.Simple+    Database.PostgreSQL.Simple.Arrays+    Database.PostgreSQL.Simple.Copy+    Database.PostgreSQL.Simple.Cursor+    Database.PostgreSQL.Simple.Errors+    Database.PostgreSQL.Simple.FromField+    Database.PostgreSQL.Simple.FromRow+    Database.PostgreSQL.Simple.HStore+    Database.PostgreSQL.Simple.HStore.Internal+    Database.PostgreSQL.Simple.Internal+    Database.PostgreSQL.Simple.Newtypes+    Database.PostgreSQL.Simple.Notification+    Database.PostgreSQL.Simple.Ok+    Database.PostgreSQL.Simple.Range+    Database.PostgreSQL.Simple.SqlQQ+    Database.PostgreSQL.Simple.Time+    Database.PostgreSQL.Simple.Time.Internal+    Database.PostgreSQL.Simple.ToField+    Database.PostgreSQL.Simple.ToRow+    Database.PostgreSQL.Simple.Transaction+    Database.PostgreSQL.Simple.TypeInfo+    Database.PostgreSQL.Simple.TypeInfo.Macro+    Database.PostgreSQL.Simple.TypeInfo.Static+    Database.PostgreSQL.Simple.Types+    Database.PostgreSQL.Simple.HpgsqlUtils+    -- postgresql-query+    Database.PostgreSQL.Query+    Database.PostgreSQL.Query.Functions+    Database.PostgreSQL.Query.SqlBuilder+    Database.PostgreSQL.Query.SqlBuilder.Builder+    Database.PostgreSQL.Query.SqlBuilder.Class+    Database.PostgreSQL.Query.SqlBuilder.Types+    Database.PostgreSQL.Query.TH+    Database.PostgreSQL.Query.TH.SqlExp+    Database.PostgreSQL.Query.Types++  -- Other-modules:+  other-modules:+    Database.PostgreSQL.Simple.Compat+    Database.PostgreSQL.Simple.HStore.Implementation+    Database.PostgreSQL.Simple.Internal.PQResultUtils+    Database.PostgreSQL.Simple.Time.Implementation+    Database.PostgreSQL.Simple.Time.Internal.Parser+    Database.PostgreSQL.Simple.Time.Internal.Printer+    Database.PostgreSQL.Simple.TypeInfo.Types++  -- GHC bundled libs+  build-depends:+      base >= 4.18 && < 4.21+    , bytestring >= 0.11 && < 0.13+    , case-insensitive >= 1.2 && < 1.3+    , containers >= 0.6 && < 0.8+    , template-haskell >= 2.20 && < 2.23+    , text >= 2.0 && < 2.2+    , aeson >= 2.2 && < 2.3+    , attoparsec >= 0.14 && < 0.15+    , haskell-src-meta >= 0.8 && < 0.9+    , hpgsql >= 0.1 && < 0.2+    , hashable >= 1.5 && < 1.6+    , mtl >= 2.3 && < 2.4+    , streaming >= 0.2 && < 0.3+    , time-compat >= 1.9 && < 1.10+    , transformers >= 0.6 && < 0.7+    , Only >= 0.1 && < 0.2+    , scientific >= 0.3 && < 0.4+    , uuid-types >= 1.0 && < 1.1+    , vector >= 0.13 && < 0.14++  default-extensions:+      CPP+      BangPatterns+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveFunctor+      DeriveGeneric+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      LambdaCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NumericUnderscores+      OverloadedRecordDot+      OverloadedStrings+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      QuasiQuotes+      TemplateHaskell+      ViewPatterns++  ghc-options: -Wall -Wincomplete-uni-patterns -Wunused-packages -Wpartial-fields -optP-Wno-nonportable-include-path -fno-warn-name-shadowing

@@ -0,0 +1,26 @@+module Database.PostgreSQL.LibPQ (fname, transactionStatus, Column (..), Connection (..), ExecStatus (..), Format (..), Oid (..), Result (..), Row (..), TransactionStatus (..)) where++import Data.ByteString (ByteString)+import qualified Hpgsql+import Hpgsql.Transaction (TransactionStatus (..))+import qualified Hpgsql.Transaction+import Hpgsql.TypeInfo (Oid (..))++data Connection = Connection {hpgConn :: Hpgsql.HPgConnection}++data ExecStatus = FatalError+  deriving (Eq, Show)++data Result = Result++data Column = Column++data Row = Row++data Format = Text | Binary++fname :: Result -> Column -> IO (Maybe ByteString)+fname _ _ = pure Nothing++transactionStatus :: Connection -> IO TransactionStatus+transactionStatus conn = Hpgsql.Transaction.transactionStatus $ hpgConn conn

@@ -0,0 +1,62 @@+module Database.PostgreSQL.Query+  ( -- * Common usage modules++    -- module Database.PostgreSQL.Query.Entity+    module Database.PostgreSQL.Query.Functions,+    module Database.PostgreSQL.Query.SqlBuilder,+    module Database.PostgreSQL.Query.TH,+    module Database.PostgreSQL.Query.Types,++    -- * Some re-exports from postgresql-simple+    Connection,+    connect,+    defaultConnectInfo,+    connectPostgreSQL,+    ConnectInfo (..),+    ToField (..),+    ToRow (..),+    FromField (..),+    FromRow (..),+    Query (..),+    Only (..),+    In (..),+    Oid (..),+    Values (..),+    (:.) (..),+    PGArray (..),+    HStoreList (..),+    HStoreMap (..),+    ToHStore (..),+    HStoreBuilder,+    hstore,+    parseHStoreList,+    ToHStoreText (..),+    HStoreText,+  )+where++-- to prevent conflicts++-- import Database.PostgreSQL.Query.Entity+import Database.PostgreSQL.Query.Functions+import Database.PostgreSQL.Query.SqlBuilder+import Database.PostgreSQL.Query.TH+import Database.PostgreSQL.Query.Types+import Database.PostgreSQL.Simple+  ( ConnectInfo (..),+    Connection,+    FromRow,+    ToRow,+    connect,+    connectPostgreSQL,+    defaultConnectInfo,+  )+import Database.PostgreSQL.Simple.FromField (FromField (..))+import Database.PostgreSQL.Simple.FromRow (FromRow (..))+import Database.PostgreSQL.Simple.HStore hiding+  ( toBuilder,+    toLazyByteString,+  )+import Database.PostgreSQL.Simple.ToField (ToField (..))+import Database.PostgreSQL.Simple.ToRow (ToRow (..))+import Database.PostgreSQL.Simple.Types

@@ -0,0 +1,25 @@+module Database.PostgreSQL.Query.Functions+  ( pgQuery,+  )+where++import Control.Monad.IO.Class (liftIO)+import Database.PostgreSQL.Query.SqlBuilder (ToSqlBuilder (..), defaultLogMasker, runSqlBuilder)+import Database.PostgreSQL.Query.Types (HasPostgres (..), MonadPostgres)+import Database.PostgreSQL.Simple (query)+import Database.PostgreSQL.Simple.FromRow (FromRow)+import GHC.Stack (HasCallStack)++-- | Execute a query generated by 'sqlExp' and return results.+--+-- @+-- let userName = "Vovka Erohin" :: Text+-- pgQuery [sqlExp| SELECT id, name FROM users WHERE name = \#{userName}|]+-- @+pgQuery ::+  (MonadPostgres m, ToSqlBuilder q, FromRow r, HasCallStack) =>+  q ->+  m [r]+pgQuery q = withPGConnection $ \conn -> liftIO $ do+  (simpleQ, row) <- runSqlBuilder conn defaultLogMasker (toSqlBuilder q)+  query conn simpleQ row

@@ -0,0 +1,10 @@+module Database.PostgreSQL.Query.SqlBuilder+  ( module Database.PostgreSQL.Query.SqlBuilder.Builder,+    module Database.PostgreSQL.Query.SqlBuilder.Class,+    module Database.PostgreSQL.Query.SqlBuilder.Types,+  )+where++import Database.PostgreSQL.Query.SqlBuilder.Builder+import Database.PostgreSQL.Query.SqlBuilder.Class+import Database.PostgreSQL.Query.SqlBuilder.Types

@@ -0,0 +1,19 @@+module Database.PostgreSQL.Query.SqlBuilder.Builder+  ( SqlBuilder,++    -- * Running+    runSqlBuilder,+  )+where++import Database.PostgreSQL.Query.SqlBuilder.Types (LogMasker)+import Database.PostgreSQL.Simple (Connection)+import Database.PostgreSQL.Simple.HpgsqlUtils (PgSimpleRow, toPgSimpleQuery)+import qualified Database.PostgreSQL.Simple.Types as PgSimple+import qualified Hpgsql.InternalTypes as HQ++-- | This is just an alias for hpgsql's `Query` type in hpgsql-simple-compat.+type SqlBuilder = HQ.Query++runSqlBuilder :: Connection -> LogMasker -> SqlBuilder -> IO (PgSimple.Query, PgSimpleRow)+runSqlBuilder _ _ q = pure $ toPgSimpleQuery q

@@ -0,0 +1,13 @@+module Database.PostgreSQL.Query.SqlBuilder.Class+  ( ToSqlBuilder (..),+  )+where++import Database.PostgreSQL.Query.SqlBuilder.Builder (SqlBuilder)++-- | Typeclass for types convertible to 'SqlBuilder'.+class ToSqlBuilder a where+  toSqlBuilder :: a -> SqlBuilder++instance ToSqlBuilder SqlBuilder where+  toSqlBuilder = id

@@ -0,0 +1,49 @@+module Database.PostgreSQL.Query.SqlBuilder.Types+  ( -- * Sql builder result+    SqlBuilderResult (..),+    builderResultPure,++    -- * Field masking in logs+    FieldOption (..),+    LogMasker,+    defaultLogMasker,+  )+where++import Data.ByteString (ByteString)+import qualified Hpgsql.InternalTypes as HQ++-- | Result of SqlBuilder. In hpgsql-simple-compat the query string is an+-- hpgsql 'HQ.Query' and logging is a no-op.+data SqlBuilderResult = SqlBuilderResult+  { sbQueryString :: HQ.Query,+    sbLogString :: ()+  }++instance Semigroup SqlBuilderResult where+  (SqlBuilderResult a ()) <> (SqlBuilderResult a' ()) =+    SqlBuilderResult (a <> a') ()++instance Monoid SqlBuilderResult where+  mempty = SqlBuilderResult "" ()++builderResultPure :: HQ.Query -> SqlBuilderResult+builderResultPure q = SqlBuilderResult q ()++-- | Option for field instructing 'LogMasker' what to do with field when logging+data FieldOption+  = -- | Do nothing. Field should be pasted as is+    FieldDefault+  | -- | Mask field in logs with placeholder.+    FieldMasked+  deriving (Eq, Ord, Show)++-- | Function modifying query parameter value before pasting it to log.+-- In hpgsql-simple-compat this is a no-op since logging is not supported,+-- but the type is preserved for some API compatibility.+type LogMasker = FieldOption -> ByteString -> ByteString++-- | Simply replaces masked fields with placeholder.+defaultLogMasker :: LogMasker+defaultLogMasker FieldDefault bb = bb+defaultLogMasker FieldMasked _ = "<MASKED BY POSTGRESQL-QUERY>"

@@ -0,0 +1,63 @@+module Database.PostgreSQL.Query.TH+  ( -- * Deriving instances++    -- deriveEverything,+    -- , module Database.PostgreSQL.Query.TH.Entity+    -- , module Database.PostgreSQL.Query.TH.Enum+    -- , module Database.PostgreSQL.Query.TH.Row+    module Database.PostgreSQL.Query.TH.SqlExp,+  )+where++-- import Database.PostgreSQL.Query.TH.Entity+-- import Database.PostgreSQL.Query.TH.Enum+-- import Database.PostgreSQL.Query.TH.Row+import Database.PostgreSQL.Query.TH.SqlExp++-- | Calls sequently `deriveFromRow` `deriveToRow` `deriveEntity`. E.g. code like this:+--+-- @+-- data Agent = Agent+--    { aName          :: !Text+--    , aAttributes    :: !HStoreMap+--    , aLongWeirdName :: !Int+--    } deriving (Ord, Eq, Show)+--+-- \$(deriveEverything+--  def { eoIdType        = ''Id+--      , eoTableName     = textFN . toUnderscore'+--      , eoColumnNames   = textFN . toUnderscore' . drop 1+--      , eoDeriveClasses =+--        [''Show, ''Read, ''Ord, ''Eq+--        , ''FromField, ''ToField, ''PathPiece]+--      }+--  ''Agent )+-- @+--+-- will generate that:+--+-- @+-- instance ToRow Agent where+--    toRow (Agent a_aE3w a_aE3x a_aE3y)+--        = [toField a_aE3w, toField a_aE3x, toField a_aE3y]+-- instance FromRow Agent where+--  fromRow+--      = Agent <$> Database.PostgreSQL.Simple.FromRow.field+--        <*> Database.PostgreSQL.Simple.FromRow.field+--        <*> Database.PostgreSQL.Simple.FromRow.field+-- instance Database.PostgreSQL.Query.Entity Agent where+--    newtype EntityId Agent+--        = AgentId {getAgentId :: Id}+--        deriving (Show, Read, Ord, Eq, FromField, ToField, PathPiece)+--    tableName _ = "agent"+--    fieldNames _ = ["name", "attributes", "long_weird_name"]+-- type AgentId = EntityId Agent+-- @+-- deriveEverything :: EntityOptions -> Name -> Q [Dec]+-- deriveEverything opts tname =+--   fmap concat $+--     sequence+--       [ deriveToRow tname,+--         deriveFromRow tname,+--         deriveEntity opts tname+--       ]

@@ -0,0 +1,14 @@+module Database.PostgreSQL.Query.TH.SqlExp+  ( -- * QQ+    sqlExp,+  )+where++import Hpgsql.Query (sql)+import Language.Haskell.TH.Quote (QuasiQuoter)++-- | Quasiquoter for SQL expressions. Returns a 'SqlBuilder' (which is an alias+-- for hpgsql's 'Hpgsql.Query.Query'). Supports @#{}@ for parameter interpolation+-- and @^{}@ for query fragment embedding.+sqlExp :: QuasiQuoter+sqlExp = sql

@@ -0,0 +1,82 @@+module Database.PostgreSQL.Query.Types+  ( -- * Auxiliary types+    FN (..),+    fnToQuery,++    -- * Query execution+    HasPostgres (..),+    MonadPostgres,+    PgMonadT (..),+    runPgMonadT,+  )+where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (MonadReader (..), ReaderT (..))+import Control.Monad.Trans (MonadTrans)+import qualified Data.List as L+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Database.PostgreSQL.Query.SqlBuilder (ToSqlBuilder (..))+import Database.PostgreSQL.Simple.Internal (Connection)+import Hpgsql.InternalTypes (Query)+import Hpgsql.Query (escapeIdentifier)++-- | Dot-separated field name. Each element in nested list will be+-- properly quoted and separated by dot.+--+-- >>> "user.name" :: FN+-- FN ["user","name"]+--+-- >>> ("user" <> "name") :: FN+-- FN ["user","name"]+newtype FN = FN [Text]+  deriving stock (Ord, Eq, Show)+  deriving newtype (Semigroup, Monoid)++instance IsString FN where+  fromString s =+    FN $+      map T.pack $+        filter (/= ".") $+          L.groupBy f s+    where+      f a b = not $ a == '.' || b == '.'++instance ToSqlBuilder FN where+  toSqlBuilder = fnToQuery++-- | Convert a 'FN' to a 'Query' by quoting each part and joining with dots.+fnToQuery :: FN -> Query+fnToQuery (FN parts) =+  case parts of+    [] -> ""+    _ ->+      foldr1 (<>) $+        L.intersperse "." $+          map (escapeIdentifier . T.encodeUtf8) parts++-- | Instances of this typeclass can acquire a connection and pass it to+-- a computation.+class (MonadIO m) => HasPostgres m where+  withPGConnection :: (Connection -> m a) -> m a++type MonadPostgres m = HasPostgres m++-- | Reader of connection. Has instance of 'HasPostgres'. If you have a+-- connection you can run queries in this monad using 'runPgMonadT'.+newtype PgMonadT m a = PgMonadT+  { unPgMonadT :: ReaderT Connection m a+  }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadFail)++instance (MonadIO m) => HasPostgres (PgMonadT m) where+  withPGConnection action = do+    conn <- PgMonadT ask+    action conn+  {-# INLINEABLE withPGConnection #-}++runPgMonadT :: Connection -> PgMonadT m a -> m a+runPgMonadT conn (PgMonadT action) = runReaderT action conn

@@ -0,0 +1,920 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- A mid-level client library for the PostgreSQL database, aimed at ease of+-- use and high performance.+module Database.PostgreSQL.Simple+  ( hpgConn,++    -- * Writing queries+    -- $use++    -- ** The Query type+    -- $querytype++    -- ** Parameter substitution+    -- $subst++    -- *** Type inference+    -- $inference++    -- ** Substituting a single parameter+    -- $only_param++    -- ** Representing a list of values+    -- $in++    -- ** Modifying multiple rows at once+    -- $many++    -- ** @RETURNING@: modifications that return results+    -- $returning++    -- * Extracting results+    -- $result++    -- ** Handling null values+    -- $null++    -- ** Type conversions+    -- $types++    -- * Types+    Connection,+    Query,+    ToRow,+    FromRow,+    In (..),+    Binary (..),+    Only (..),+    (:.) (..),++    -- ** Exceptions+    SomePostgreSqlException (..),+    SqlError (..),+    PQ.ExecStatus (..),+    FormatError (..),+    QueryError (..),+    ResultError (..),++    -- * Connection management+    Base.connectPostgreSQL,+    Base.close,+    Base.connect,+    Base.withConnect,+    Base.ConnectInfo (..),+    Base.defaultConnectInfo,+    Base.postgreSQLConnectionString,++    -- * Queries that return results+    query,+    query_,++    -- ** Queries taking parser as argument+    queryWith,+    queryWith_,++    -- * Queries that stream results+    FoldOptions (..),+    FetchQuantity (..),+    defaultFoldOptions,+    fold,+    foldWithOptions,+    fold_,+    foldWithOptions_,+    forEach,+    forEach_,+    returning,++    -- ** Queries that stream results taking a parser as an argument+    foldWith,+    foldWithOptionsAndParser,+    foldWith_,+    foldWithOptionsAndParser_,+    forEachWith,+    forEachWith_,+    returningWith,++    -- * Statements that do not return results+    execute,+    execute_,+    executeMany,+    --    , Base.insertID++    -- * Transaction handling+    withTransaction,+    withSavepoint,+    --    , Base.autocommit+    begin,+    commit,+    rollback,++    -- * Helper functions+    formatMany,+  )+where++import Control.Exception (bracket)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Builder (char8)+import qualified Data.ByteString.Char8 as B+import Data.Int (Int64)+import Data.List (intersperse)+import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.Compat (toByteString)+import Database.PostgreSQL.Simple.Cursor (closeCursor, declareCursor, foldForwardWithParser)+import Database.PostgreSQL.Simple.FromField (ResultError (..))+import Database.PostgreSQL.Simple.FromRow (FromRow (..), RowParser)+import Database.PostgreSQL.Simple.HpgsqlUtils (toHpgsqlQuery, toHpgsqlRowParams)+import Database.PostgreSQL.Simple.Internal as Base+import Database.PostgreSQL.Simple.ToRow (ToRow (..))+import Database.PostgreSQL.Simple.Transaction+import Database.PostgreSQL.Simple.Types+  ( Binary (..),+    In (..),+    Only (..),+    Query (..),+    (:.) (..),+  )+import qualified Hpgsql+import qualified Hpgsql.Query as Hpgsql++-- | Format a query string with a variable number of rows.+--+-- This function is exposed to help with debugging and logging. Do not+-- use it to prepare queries for execution.+--+-- The query string must contain exactly one substitution group,+-- identified by the SQL keyword \"@VALUES@\" (case insensitive)+-- followed by an \"@(@\" character, a series of one or more \"@?@\"+-- characters separated by commas, and a \"@)@\" character. White+-- space in a substitution group is permitted.+--+-- Throws 'FormatError' if the query string could not be formatted+-- correctly.+formatMany :: forall q. (ToRow q) => Connection -> Query -> [q] -> IO Hpgsql.Query+formatMany _ q [] = fmtError "no rows supplied" q []+formatMany _conn q@(Query template) qs = do+  -- First we replace the query string's ? with (?,?,?,...) with as many+  -- parameters as each row contains+  pgSimpleQuery <- case parseTemplate template of+    Nothing -> fmtError "query is not of the expected form" q+    Just (before, qbits, after) ->+      let numCols = B.count '?' qbits+       in case filter (\r -> length (toHpgsqlRowParams r) /= numCols) qs of+            (bad : _) ->+              error+                ( show numCols+                    ++ " single '?' characters, but "+                    ++ show (length $ toHpgsqlRowParams bad)+                    ++ " parameters"+                )+            [] ->+              pure $ before <> BS.intercalate "," (map renderRow qs) <> after+  -- Now we ask Hpgsql to parse the query with one ? per query parameter+  pure $ Hpgsql.mkQueryInternal pgSimpleQuery (concatMap toHpgsqlRowParams qs)+  where+    renderRow :: (ToRow q) => q -> B.ByteString+    renderRow row =+      let numCols = length $ toHpgsqlRowParams row+       in toByteString $+            char8 '(' <> mconcat (intersperse (char8 ',') (replicate numCols "?")) <> char8 ')'++-- Split the input string into three pieces, @before@, @qbits@, and @after@,+-- following this grammar:+--+-- start: ^ before qbits after $+--     before: ([^?]* [^?\w])? 'VALUES' \s*+--     qbits:  '(' \s* '?' \s* (',' \s* '?' \s*)* ')'+--     after:  [^?]*+--+-- \s: [ \t\n\r\f]+-- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9]+--+-- This would be much more concise with some sort of regex engine.+-- 'formatMany' used to use pcre-light instead of this hand-written parser,+-- but pcre is a hassle to install on Windows.+parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString)+parseTemplate template =+  -- Convert input string to uppercase, to facilitate searching.+  search $ B.map toUpper_ascii template+  where+    -- Search for the next occurrence of "VALUES"+    search bs =+      case B.breakSubstring "VALUES" bs of+        (x, y)+          -- If "VALUES" is not present in the string, or any '?' characters+          -- were encountered prior to it, fail.+          | B.null y || ('?' `B.elem` x) ->+              Nothing+          -- If "VALUES" is preceded by an identifier character (a.k.a. \w),+          -- try the next occurrence.+          | not (B.null x) && isIdent (B.last x) ->+              search $ B.drop 6 y+          -- Otherwise, we have a legitimate "VALUES" token.+          | otherwise ->+              parseQueryBits $ skipSpace $ B.drop 6 y++    -- Parse '(' \s* '?' \s* .  If this doesn't match+    -- (and we don't consume a '?'), look for another "VALUES".+    --+    -- qb points to the open paren (if present), meaning it points to the+    -- beginning of the "qbits" production described above.  This is why we+    -- pass it down to finishQueryBits.+    parseQueryBits qb+      | Just ('(', skipSpace -> bs1) <- B.uncons qb,+        Just ('?', skipSpace -> bs2) <- B.uncons bs1 =+          finishQueryBits qb bs2+      | otherwise =+          search qb++    -- Parse (',' \s* '?' \s*)* ')' [^?]* .+    --+    -- Since we've already consumed at least one '?', there's no turning back.+    -- The parse has to succeed here, or the whole thing fails+    -- (because we don't allow '?' to appear outside of the VALUES list).+    finishQueryBits qb bs0+      | Just (')', bs1) <- B.uncons bs0 =+          if '?' `B.elem` bs1+            then Nothing+            else Just $ slice3 template qb bs1+      | Just (',', skipSpace -> bs1) <- B.uncons bs0,+        Just ('?', skipSpace -> bs2) <- B.uncons bs1 =+          finishQueryBits qb bs2+      | otherwise =+          Nothing++    -- Slice a string into three pieces, given the start offset of the second+    -- and third pieces.  Each "offset" is actually a tail of the uppercase+    -- version of the template string.  Its length is used to infer the offset.+    --+    -- It is important to note that we only slice the original template.+    -- We don't want our all-caps trick messing up the actual query string.+    slice3 source p1 p2 =+      (s1, s2, source'')+      where+        (s1, source') = B.splitAt (B.length source - B.length p1) source+        (s2, source'') = B.splitAt (B.length p1 - B.length p2) source'++    toUpper_ascii c+      | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32)+      | otherwise = c++    -- Based on the definition of {ident_cont} in src/backend/parser/scan.l+    -- in the PostgreSQL source.  No need to check [a-z], since we converted+    -- the whole string to uppercase.+    isIdent c =+      (c >= '0' && c <= '9')+        || (c >= 'A' && c <= 'Z')+        || (c >= '\x80' && c <= '\xFF')+        || c == '_'+        || c == '$'++    -- Based on {space} in scan.l+    isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r')++    skipSpace = B.dropWhile isSpace_ascii++-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not+-- expected to return results.+--+-- Returns the number of rows affected.+--+-- Throws 'FormatError' if the query could not be formatted correctly, or+-- a 'SqlError' exception if the backend returns an error.+execute :: (ToRow q) => Connection -> Query -> q -> IO Int64+execute conn template qs =+  mapHpgsqlErrors $+    Hpgsql.execute (hpgConn conn) (toHpgsqlQuery template qs)++-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not+-- expected to return results.+--+-- Returns the number of rows affected.   If the list of parameters is empty,+-- this function will simply return 0 without issuing the query to the backend.+-- If this is not desired, consider using the 'Values' constructor instead.+--+-- Throws 'FormatError' if the query could not be formatted correctly, or+-- a 'SqlError' exception if the backend returns an error.+--+-- For example,  here's a command that inserts two rows into a table+-- with two columns:+--+-- @+-- executeMany c [sql|+--     INSERT INTO sometable VALUES (?,?)+--  |] [(1, \"hello\"),(2, \"world\")]+-- @+--+-- Here's an canonical example of a multi-row update command:+--+-- @+-- executeMany c [sql|+--     UPDATE sometable+--        SET y = upd.y+--       FROM (VALUES (?,?)) as upd(x,y)+--      WHERE sometable.x = upd.x+--  |] [(1, \"hello\"),(2, \"world\")]+-- @+executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64+executeMany _ _ [] = return 0+executeMany conn q qs = mapHpgsqlErrors $ do+  qry <- formatMany conn q qs+  Hpgsql.execute (hpgConn conn) qry++-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL+-- query that accepts multi-row input and is expected to return results.+-- Note that it is possible to write+--    @'query' conn "INSERT ... RETURNING ..." ...@+-- in cases where you are only inserting a single row,  and do not need+-- functionality analogous to 'executeMany'.+--+-- If the list of parameters is empty,  this function will simply return @[]@+-- without issuing the query to the backend.   If this is not desired,+-- consider using the 'Values' constructor instead.+--+-- Throws 'FormatError' if the query could not be formatted correctly.+returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]+returning = returningWith fromRow++-- | A version of 'returning' taking parser as argument+returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]+returningWith _ _ _ [] = return []+returningWith _parser _conn _q _qs = error "TODO Hpgsql"++-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. All results are retrieved and converted before this+-- function returns.+--+-- When processing large results, this function will consume a lot of+-- client-side memory.  Consider using 'fold' instead.+--+-- Exceptions that may be thrown:+--+-- * 'FormatError': the query string could not be formatted correctly.+--+-- * 'QueryError': the result contains no columns (i.e. you should be+--   using 'execute' instead of 'query').+--+-- * 'ResultError': result conversion failed.+--+-- * 'SqlError':  the postgresql backend returned an error,  e.g.+--   a syntax or type error,  or an incorrect table or column name.+query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]+query conn q qs = queryWith fromRow conn q qs++-- | A version of 'query' that does not perform query substitution.+query_ :: (FromRow r) => Connection -> Query -> IO [r]+query_ conn q = query conn q ()++-- | A version of 'query' taking parser as argument+queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r]+queryWith parser conn template qs =+  mapHpgsqlErrors $+    Hpgsql.queryMWith parser (hpgConn conn) (toHpgsqlQuery template qs)++-- | A version of 'query_' taking parser as argument+queryWith_ :: RowParser r -> Connection -> Query -> IO [r]+queryWith_ parser conn q = queryWith parser conn q ()++-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. Results are streamed incrementally from the server, and+-- consumed via a left fold.+--+-- When dealing with small results, it may be simpler (and perhaps+-- faster) to use 'query' instead.+--+-- This fold is /not/ strict. The stream consumer is responsible for+-- forcing the evaluation of its result to avoid space leaks.+--+-- This is implemented using a database cursor.    As such,  this requires+-- a transaction.   This function will detect whether or not there is a+-- transaction in progress,  and will create a 'ReadCommitted' 'ReadOnly'+-- transaction if needed.   The cursor is given a unique temporary name,+-- so the consumer may itself call fold.+--+-- Exceptions that may be thrown:+--+-- * 'FormatError': the query string could not be formatted correctly.+--+-- * 'QueryError': the result contains no columns (i.e. you should be+--   using 'execute' instead of 'query').+--+-- * 'ResultError': result conversion failed.+--+-- * 'SqlError':  the postgresql backend returned an error,  e.g.+--   a syntax or type error,  or an incorrect table or column name.+fold ::+  (FromRow row, ToRow params) =>+  Connection ->+  Query ->+  params ->+  a ->+  (a -> row -> IO a) ->+  IO a+fold = foldWithOptions defaultFoldOptions++-- | A version of 'fold' taking a parser as an argument+foldWith ::+  (ToRow params) =>+  RowParser row ->+  Connection ->+  Query ->+  params ->+  a ->+  (a -> row -> IO a) ->+  IO a+foldWith = foldWithOptionsAndParser defaultFoldOptions++-- | Number of rows to fetch at a time.   'Automatic' currently defaults+--   to 256 rows,  although it might be nice to make this more intelligent+--   based on e.g. the average size of the rows.+data FetchQuantity+  = Automatic+  | Fixed !Int++data FoldOptions+  = FoldOptions+  { fetchQuantity :: !FetchQuantity,+    transactionMode :: !TransactionMode+  }++-- | defaults to 'Automatic',  and 'TransactionMode' 'ReadCommitted' 'ReadOnly'+defaultFoldOptions :: FoldOptions+defaultFoldOptions =+  FoldOptions+    { fetchQuantity = Automatic,+      transactionMode = TransactionMode ReadCommitted ReadOnly+    }++-- | The same as 'fold',  but this provides a bit more control over+--   lower-level details.  Currently,  the number of rows fetched per+--   round-trip to the server and the transaction mode may be adjusted+--   accordingly.    If the connection is already in a transaction,+--   then the existing transaction is used and thus the 'transactionMode'+--   option is ignored.+foldWithOptions ::+  (FromRow row, ToRow params) =>+  FoldOptions ->+  Connection ->+  Query ->+  params ->+  a ->+  (a -> row -> IO a) ->+  IO a+foldWithOptions opts = foldWithOptionsAndParser opts fromRow++-- | A version of 'foldWithOptions' taking a parser as an argument+foldWithOptionsAndParser ::+  (ToRow params) =>+  FoldOptions ->+  RowParser row ->+  Connection ->+  Query ->+  params ->+  a ->+  (a -> row -> IO a) ->+  IO a+foldWithOptionsAndParser opts parser conn template qs a f = do+  doFold opts parser conn template qs a f++-- | A version of 'fold' that does not perform query substitution.+fold_ ::+  (FromRow r) =>+  Connection ->+  -- | Query.+  Query ->+  -- | Initial state for result consumer.+  a ->+  -- | Result consumer.+  (a -> r -> IO a) ->+  IO a+fold_ = foldWithOptions_ defaultFoldOptions++-- | A version of 'fold_' taking a parser as an argument+foldWith_ ::+  RowParser r ->+  Connection ->+  Query ->+  a ->+  (a -> r -> IO a) ->+  IO a+foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions++foldWithOptions_ ::+  (FromRow r) =>+  FoldOptions ->+  Connection ->+  -- | Query.+  Query ->+  -- | Initial state for result consumer.+  a ->+  -- | Result consumer.+  (a -> r -> IO a) ->+  IO a+foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' () a f++-- | A version of 'foldWithOptions_' taking a parser as an argument+foldWithOptionsAndParser_ ::+  FoldOptions ->+  RowParser r ->+  Connection ->+  -- | Query.+  Query ->+  -- | Initial state for result consumer.+  a ->+  -- | Result consumer.+  (a -> r -> IO a) ->+  IO a+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' () a f++doFold ::+  (ToRow q) =>+  FoldOptions ->+  RowParser row ->+  Connection ->+  Query ->+  q ->+  a ->+  (a -> row -> IO a) ->+  IO a+doFold FoldOptions {..} parser conn q params a0 f = mapHpgsqlErrors $ do+  stat <- withConnection conn PQ.transactionStatus+  case stat of+    PQ.TransIdle -> withTransactionMode transactionMode conn go+    PQ.TransInTrans -> go+    PQ.TransActive -> fail "foldWithOpts FIXME:  PQ.TransActive"+    -- This _shouldn't_ occur in the current incarnation of+    -- the library,  as we aren't using libpq asynchronously.+    -- However,  it could occur in future incarnations of+    -- this library or if client code uses the Internal module+    -- to use raw libpq commands on postgresql-simple connections.+    PQ.TransInError -> fail "foldWithOpts FIXME:  PQ.TransInError"+  where+    -- This should be turned into a better error message.+    -- It is probably a bad idea to automatically roll+    -- back the transaction and start another.++    declare =+      declareCursor conn $ toHpgsqlQuery q params+    fetch cursor a =+      foldForwardWithParser cursor parser chunkSize f a++    go = bracket declare closeCursor $ \cursor ->+      let loop a =+            fetch cursor a+              >>= \r -> case r of+                Left x -> return x+                Right x -> loop x+       in loop a0+    -- FIXME: choose the Automatic chunkSize more intelligently+    --   One possibility is to use the type of the results,  although this+    --   still isn't a perfect solution, given that common types (e.g. text)+    --   are of highly variable size.+    --   A refinement of this technique is to pick this number adaptively+    --   as results are read in from the database.+    chunkSize = case fetchQuantity of+      Automatic -> 256+      Fixed n -> n++-- | A version of 'fold' that does not transform a state value.+forEach ::+  (ToRow q, FromRow r) =>+  Connection ->+  -- | Query template.+  Query ->+  -- | Query parameters.+  q ->+  -- | Result consumer.+  (r -> IO ()) ->+  IO ()+forEach = forEachWith fromRow+{-# INLINE forEach #-}++-- | A version of 'forEach' taking a parser as an argument+forEachWith ::+  (ToRow q) =>+  RowParser r ->+  Connection ->+  Query ->+  q ->+  (r -> IO ()) ->+  IO ()+forEachWith parser conn template qs = foldWith parser conn template qs () . const+{-# INLINE forEachWith #-}++-- | A version of 'forEach' that does not perform query substitution.+forEach_ ::+  (FromRow r) =>+  Connection ->+  -- | Query template.+  Query ->+  -- | Result consumer.+  (r -> IO ()) ->+  IO ()+forEach_ = forEachWith_ fromRow+{-# INLINE forEach_ #-}++forEachWith_ ::+  RowParser r ->+  Connection ->+  Query ->+  (r -> IO ()) ->+  IO ()+forEachWith_ parser conn template = foldWith_ parser conn template () . const+{-# INLINE forEachWith_ #-}++-- $use+--+-- SQL-based applications are somewhat notorious for their+-- susceptibility to attacks through the injection of maliciously+-- crafted data. The primary reason for widespread vulnerability to+-- SQL injections is that many applications are sloppy in handling+-- user data when constructing SQL queries.+--+-- This library provides a 'Query' type and a parameter substitution+-- facility to address both ease of use and security.++-- $querytype+--+-- A 'Query' is a @newtype@-wrapped 'ByteString'. It intentionally+-- exposes a tiny API that is not compatible with the 'ByteString'+-- API; this makes it difficult to construct queries from fragments of+-- strings.  The 'query' and 'execute' functions require queries to be+-- of type 'Query'.+--+-- To most easily construct a query, enable GHC's @OverloadedStrings@+-- language extension and write your query as a normal literal string.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Database.PostgreSQL.Simple+-- >+-- > hello :: IO Int+-- > hello = do+-- >   conn <- connectPostgreSQL ""+-- >   [Only i] <- query_ conn "select 2 + 2"+-- >   return i+--+-- A 'Query' value does not represent the actual query that will be+-- executed, but is a template for constructing the final query.++-- $subst+--+-- Since applications need to be able to construct queries with+-- parameters that change, this library provides a query substitution+-- capability.+--+-- The 'Query' template accepted by 'query' and 'execute' can contain+-- any number of \"@?@\" characters.  Both 'query' and 'execute'+-- accept a third argument, typically a tuple. When constructing the+-- real query to execute, these functions replace the first \"@?@\" in+-- the template with the first element of the tuple, the second+-- \"@?@\" with the second element, and so on. If necessary, each+-- tuple element will be quoted and escaped prior to substitution;+-- this defeats the single most common injection vector for malicious+-- data.+--+-- For example, given the following 'Query' template:+--+-- > select * from user where first_name = ? and age > ?+--+-- And a tuple of this form:+--+-- > ("Boris" :: String, 37 :: Int)+--+-- The query to be executed will look like this after substitution:+--+-- > select * from user where first_name = 'Boris' and age > 37+--+-- If there is a mismatch between the number of \"@?@\" characters in+-- your template and the number of elements in your tuple, a+-- 'FormatError' will be thrown.+--+-- Note that the substitution functions do not attempt to parse or+-- validate your query. It's up to you to write syntactically valid+-- SQL, and to ensure that each \"@?@\" in your query template is+-- matched with the right tuple element.++-- $inference+--+-- Automated type inference means that you will often be able to avoid+-- supplying explicit type signatures for the elements of a tuple.+-- However, sometimes the compiler will not be able to infer your+-- types. Consider a case where you write a numeric literal in a+-- parameter tuple:+--+-- > query conn "select ? + ?" (40,2)+--+-- The above query will be rejected by the compiler, because it does+-- not know the specific numeric types of the literals @40@ and @2@.+-- This is easily fixed:+--+-- > query conn "select ? + ?" (40 :: Double, 2 :: Double)+--+-- The same kind of problem can arise with string literals if you have+-- the @OverloadedStrings@ language extension enabled.  Again, just+-- use an explicit type signature if this happens.+--+-- Finally, remember that the compiler must be able to infer the type+-- of a query's /results/ as well as its parameters.  We might like+-- the following example to work:+--+-- > print =<< query_ conn "select 2 + 2"+--+-- Unfortunately, while a quick glance tells us that the result type+-- should be a single row containing a single numeric column, the+-- compiler has no way to infer what the types are.  We can easily fix+-- this by providing an explicit type annotation:+--+-- > xs <- query_ conn "select 2 + 2"+-- > print (xs :: [Only Int])++-- $only_param+--+-- Haskell lacks a single-element tuple type, so if you have just one+-- value you want substituted into a query or a single-column result,+-- what should you do?+--+-- The obvious approach would appear to be something like this:+--+-- > instance (ToField a) => ToRow a where+-- >     ...+--+-- Unfortunately, this wreaks havoc with type inference, so we take a+-- different tack. To represent a single value @val@ as a parameter, write+-- a singleton list @[val]@, use 'Just' @val@, or use 'Only' @val@.+--+-- Here's an example using a singleton list:+--+-- > execute conn "insert into users (first_name) values (?)"+-- >              ["Nuala"]+--+-- A row of /n/ query results is represented using an /n/-tuple, so+-- you should use 'Only' to represent a single-column result.++-- $in+--+-- Suppose you want to write a query using an @IN@ clause:+--+-- > select * from users where first_name in ('Anna', 'Boris', 'Carla')+--+-- In such cases, it's common for both the elements and length of the+-- list after the @IN@ keyword to vary from query to query.+--+-- To address this case, use the 'In' type wrapper, and use a single+-- \"@?@\" character to represent the list.  Omit the parentheses+-- around the list; these will be added for you.+--+-- Here's an example:+--+-- > query conn "select * from users where first_name in ?" $+-- >       Only $ In ["Anna", "Boris", "Carla"]+--+-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be+-- substituted instead, to ensure that your clause remains+-- syntactically valid.++-- $many+--+-- If you know that you have many rows of data to insert into a table,+-- it is much more efficient to perform all the insertions in a single+-- multi-row @INSERT@ statement than individually.+--+-- The 'executeMany' function is intended specifically for helping+-- with multi-row @INSERT@ and @UPDATE@ statements. Its rules for+-- query substitution are different than those for 'execute'.+--+-- What 'executeMany' searches for in your 'Query' template is a+-- single substring of the form:+--+-- > values (?,?,?)+--+-- The rules are as follows:+--+-- * The keyword @VALUES@ is matched case insensitively.+--+-- * There must be no other \"@?@\" characters anywhere in your+--   template.+--+-- * There must be one or more \"@?@\" in the parentheses.+--+-- * Extra white space is fine.+--+-- The last argument to 'executeMany' is a list of parameter+-- tuples. These will be substituted into the query where the @(?,?)@+-- string appears, in a form suitable for use in a multi-row @INSERT@+-- or @UPDATE@.+--+-- Here is an example:+--+-- > executeMany conn+-- >   "insert into users (first_name,last_name) values (?,?)"+-- >   [("Boris","Karloff"),("Ed","Wood")]+--+-- The query that will be executed here will look like this+-- (reformatted for tidiness):+--+-- > insert into users (first_name,last_name) values+-- >   ('Boris','Karloff'),('Ed','Wood')++-- $returning+--+-- PostgreSQL supports returning values from data manipulation statements+-- such as @INSERT@ and @UPDATE@.   You can use these statements by+-- using 'query' instead of 'execute'.   For multi-tuple inserts,+-- use 'returning' instead of 'executeMany'.+--+-- For example, were there an auto-incrementing @id@ column and+-- timestamp column @t@ that defaulted to the present time for the+-- @sales@ table, then the following query would insert two new+-- sales records and also return their new @id@s and timestamps.+--+-- > let q = "insert into sales (amount, label) values (?,?) returning id, t"+-- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust")+-- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")]++-- $result+--+-- The 'query' and 'query_' functions return a list of values in the+-- 'FromRow' typeclass. This class performs automatic extraction+-- and type conversion of rows from a query result.+--+-- Here is a simple example of how to extract results:+--+-- > import qualified Data.Text as Text+-- >+-- > xs <- query_ conn "select name,age from users"+-- > forM_ xs $ \(name,age) ->+-- >   putStrLn $ Text.unpack name ++ " is " ++ show (age :: Int)+--+-- Notice two important details about this code:+--+-- * The number of columns we ask for in the query template must+--   exactly match the number of elements we specify in a row of the+--   result tuple.  If they do not match, a 'ResultError' exception+--   will be thrown.+--+-- * Sometimes, the compiler needs our help in specifying types. It+--   can infer that @name@ must be a 'Text', due to our use of the+--   @unpack@ function. However, we have to tell it the type of @age@,+--   as it has no other information to determine the exact type.++-- $null+--+-- The type of a result tuple will look something like this:+--+-- > (Text, Int, Int)+--+-- Although SQL can accommodate @NULL@ as a value for any of these+-- types, Haskell cannot. If your result contains columns that may be+-- @NULL@, be sure that you use 'Maybe' in those positions of your+-- tuple.+--+-- > (Text, Maybe Int, Int)+--+-- If 'query' encounters a @NULL@ in a row where the corresponding+-- Haskell type is not 'Maybe', it will throw a 'ResultError'+-- exception.++-- $only_result+--+-- To specify that a query returns a single-column result, use the+-- 'Only' type.+--+-- > xs <- query_ conn "select id from users"+-- > forM_ xs $ \(Only dbid) -> {- ... -}++-- $types+--+-- Conversion of SQL values to Haskell values is somewhat+-- permissive. Here are the rules.+--+-- * For numeric types, any Haskell type that can accurately represent+--   all values of the given PostgreSQL type is considered \"compatible\".+--   For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@+--   column to a Haskell 'Int'.  The Haskell 'Float' type can accurately+--   represent a @SMALLINT@, so it is considered compatible with those types.+--+-- * A numeric compatibility check is based only on the type of a+--   column, /not/ on its values. For instance, a PostgreSQL 64-bit+--   @BIGINT@ column will be considered incompatible with a Haskell+--   'Int16', even if it contains the value @1@.+--+-- * If a numeric incompatibility is found, 'query' will throw a+--   'ResultError'.+--+-- * The 'String' and 'Text' types are assumed to be encoded as+--   UTF-8. If you use some other encoding, decoding may fail or give+--   wrong results. In such cases, write a @newtype@ wrapper and a+--   custom 'Result' instance to handle your encoding.

@@ -0,0 +1,21 @@+module Database.PostgreSQL.Simple+  ( Connection,+    Query,+    query,+    query_,+    execute,+    execute_,+    executeMany,+  )+where++import Data.Int (Int64)+import Database.PostgreSQL.Simple.FromRow (FromRow)+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.ToRow (ToRow)+import Database.PostgreSQL.Simple.Types++query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]+query_ :: (FromRow r) => Connection -> Query -> IO [r]+execute :: (ToRow q) => Connection -> Query -> q -> IO Int64+executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64

@@ -0,0 +1,99 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Arrays+-- Copyright:   (c) 2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- A Postgres array parser and pretty-printer.+module Database.PostgreSQL.Simple.Arrays where++import Control.Applicative (Alternative (..))+import Data.Attoparsec.ByteString.Char8+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B++-- | Parse one of three primitive field formats: array, quoted and plain.+arrayFormat :: Char -> Parser ArrayFormat+arrayFormat delim =+  Array+    <$> array delim+      <|> Plain+    <$> plain delim+      <|> Quoted+    <$> quoted++data ArrayFormat+  = Array [ArrayFormat]+  | Plain ByteString+  | Quoted ByteString+  deriving (Eq, Show, Ord)++array :: Char -> Parser [ArrayFormat]+array delim = char '{' *> option [] (arrays <|> strings) <* char '}'+  where+    strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim)+    arrays = sepBy1 (Array <$> array delim) (char ',')++-- NB: Arrays seem to always be delimited by commas.++-- | Recognizes a quoted string.+quoted :: Parser ByteString+quoted = char '"' *> option "" contents <* char '"'+  where+    esc' = char '\\' *> (char '\\' <|> char '"')+    unQ = takeWhile1 (notInClass "\"\\")+    contents = mconcat <$> many (unQ <|> B.singleton <$> esc')++-- | Recognizes a plain string literal, not containing quotes or brackets and+--   not containing the delimiter character.+plain :: Char -> Parser ByteString+plain delim = takeWhile1 (notInClass (delim : "\"{}"))++-- Mutually recursive 'fmt' and 'delimit' separate out value formatting+-- from the subtleties of delimiting.++-- | Format an array format item, using the delimiter character if the item is+--   itself an array.+fmt :: Char -> ArrayFormat -> ByteString+fmt = fmt' False++-- | Format a list of array format items, inserting the appropriate delimiter+--   between them. When the items are arrays, they will be delimited with+--   commas; otherwise, they are delimited with the passed-in-delimiter.+delimit :: Char -> [ArrayFormat] -> ByteString+delimit _ [] = ""+delimit c [x] = fmt' True c x+delimit c (x : y : z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y : z)+  where+    c'+      | Array _ <- x = ','+      | otherwise = c++-- | Format an array format item, using the delimiter character if the item is+--   itself an array, optionally applying quoting rules. Creates copies for+--   safety when used in 'FromField' instances.+fmt' :: Bool -> Char -> ArrayFormat -> ByteString+fmt' quoting c x =+  case x of+    Array items -> '{' `B.cons` (delimit c items `B.snoc` '}')+    Plain bytes -> B.copy bytes+    Quoted q+      | quoting -> '"' `B.cons` (esc q `B.snoc` '"')+      | otherwise -> B.copy q++-- NB: The 'snoc' and 'cons' functions always copy.++-- | Escape a string according to Postgres double-quoted string format.+esc :: ByteString -> ByteString+esc = B.concatMap f+  where+    f '"' = "\\\""+    f '\\' = "\\\\"+    f c = B.singleton c++-- TODO: Implement easy performance improvements with unfoldr.

@@ -0,0 +1,39 @@+-- | This is a module of its own, partly because it uses the CPP extension,+-- which doesn't play well with backslash-broken string literals.+module Database.PostgreSQL.Simple.Compat+  ( mask,+    (<>),+    unsafeDupablePerformIO,+    toByteString,+    scientificBuilder,+    toPico,+    fromPico,+  ) where++import qualified Control.Exception as E+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, toLazyByteString)+import Data.ByteString.Lazy (toStrict)+import Data.Fixed (Fixed (MkFixed), Pico)+import Data.Text.Lazy.Builder.Scientific (scientificBuilder)+import System.IO.Unsafe (unsafeDupablePerformIO)++-- | Like 'E.mask', but backported to base before version 4.3.0.+--+-- Note that the restore callback is monomorphic, unlike in 'E.mask'.  This+-- could be fixed by changing the type signature, but it would require us to+-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type).  The+-- 'withTransactionMode' function calls the restore callback only once, so we+-- don't need that polymorphism.+mask :: ((IO a -> IO a) -> IO b) -> IO b+mask io = E.mask $ \restore -> io restore+{-# INLINE mask #-}++toByteString :: Builder -> ByteString+toByteString x = toStrict (toLazyByteString x)++toPico :: Integer -> Pico+toPico = MkFixed++fromPico :: Pico -> Integer+fromPico (MkFixed i) = i

@@ -0,0 +1,117 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Copy+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- mid-level support for COPY IN and COPY OUT.   See+-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for+-- more information.+--+-- To use this binding,  first call 'copy' with an appropriate+-- query as documented in the link above.  Then, in the case of a+-- @COPY TO STDOUT@ query,  call 'getCopyData' repeatedly until it+-- returns 'CopyOutDone'.   In the case of a @COPY FROM STDIN@+-- query,  call 'putCopyData' repeatedly and then finish by calling+-- either 'putCopyEnd' to proceed or 'putCopyError' to abort.+--+-- You cannot issue another query on the same connection while a copy+-- is ongoing; this will result in an exception.   It is harmless to+-- concurrently call @getNotification@ on a connection while it is in+-- a @CopyIn@ or @CopyOut@ state,  however be aware that current versions+-- of the PostgreSQL backend will not deliver notifications to a client+-- while a transaction is ongoing.+module Database.PostgreSQL.Simple.Copy+  ( copy,+    copy_,+    CopyOutResult (..),+    -- foldCopyData,+    -- getCopyData,+    putCopyData,+    putCopyEnd,+    putCopyError,+  )+where++import qualified Data.ByteString.Char8 as B+import Data.Int (Int64)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)+import Data.Typeable (Typeable)+import Database.PostgreSQL.Simple.HpgsqlUtils (toHpgsqlQuery)+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.ToRow (ToRow)+import Database.PostgreSQL.Simple.Types+import qualified Hpgsql.Copy+import qualified Hpgsql.Query++-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query.   In the former+--   case, the connection's state will change to @CopyIn@;  in the latter,+--   @CopyOut@.  The connection must be in the ready state in order+--   to call this function.  Performs parameter substitution.+copy :: (ToRow params) => Connection -> Query -> params -> IO ()+copy conn template qs = do+  let qry = toHpgsqlQuery template qs+  doCopy "Database.PostgreSQL.Simple.Copy.copy" conn qry++-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query.   In the former+--   case, the connection's state will change to @CopyIn@;  in the latter,+--   @CopyOut@.  The connection must be in the ready state in order+--   to call this function.  Does not perform parameter substitution.+copy_ :: Connection -> Query -> IO ()+copy_ conn template = do+  let qry = toHpgsqlQuery template ()+  doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn qry++doCopy :: B.ByteString -> Connection -> Hpgsql.Query.Query -> IO ()+doCopy _funcName conn q = mapHpgsqlErrors $ do+  Hpgsql.Copy.copyStart (hpgConn conn) q++data CopyOutResult+  = -- | Data representing either exactly+    --   one row of the result,  or header+    --   or footer data depending on format.+    CopyOutRow !B.ByteString+  | -- | No more rows, and a count of the+    --   number of rows returned.+    CopyOutDone {-# UNPACK #-} !Int64+  deriving (Eq, Typeable, Show)++-- | Feed some data to a @COPY FROM STDIN@ query.  Note that+--   the data does not need to represent a single row,  or even an+--   integral number of rows.  The net result of+--   @putCopyData conn a >> putCopyData conn b@+--   is the same as @putCopyData conn c@ whenever @c == BS.append a b@.+--+--   A connection must be in the @CopyIn@ state in order to call this+--   function,  otherwise a 'SqlError' exception will result.  The+--   connection remains in the @CopyIn@ state after this function+--   is called.+putCopyData :: Connection -> B.ByteString -> IO ()+putCopyData conn dat = mapHpgsqlErrors $ Hpgsql.Copy.putCopyData (hpgConn conn) dat++-- | Completes a @COPY FROM STDIN@ query.  Returns the number of rows+--   processed.+--+--   A connection must be in the @CopyIn@ state in order to call this+--   function,  otherwise a 'SqlError' exception will result.  The+--   connection's state changes back to ready after this function+--   is called.+putCopyEnd :: Connection -> IO Int64+putCopyEnd conn = mapHpgsqlErrors $ Hpgsql.Copy.copyEnd (hpgConn conn)++-- | Aborts a @COPY FROM STDIN@ query.  The string parameter is simply+--   an arbitrary error message that may show up in the PostgreSQL+--   server's log.+--+--   A connection must be in the @CopyIn@ state in order to call this+--   function,  otherwise a 'SqlError' exception will result.  The+--   connection's state changes back to ready after this function+--   is called.+putCopyError :: Connection -> B.ByteString -> IO ()+putCopyError conn err = mapHpgsqlErrors $ Hpgsql.Copy.putCopyError (hpgConn conn) (Text.unpack $ decodeUtf8 err)

@@ -0,0 +1,72 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Cursor+-- Copyright:   (c) 2011-2012 Leon P Smith+--              (c) 2017 Bardur Arantsson+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+module Database.PostgreSQL.Simple.Cursor+  ( -- * Types+    Cursor,++    -- * Cursor management+    declareCursor,+    closeCursor,++    -- * Folding over rows from a cursor+    foldForward,+    foldForwardWithParser,+  )+where++import Control.Exception as E+import Control.Monad (foldM, unless, void)+import Data.String (fromString)+import Database.PostgreSQL.Simple.FromRow (FromRow (..))+import Database.PostgreSQL.Simple.Internal as Base+import Database.PostgreSQL.Simple.Transaction+import Database.PostgreSQL.Simple.Types (Query (..))+import Hpgsql (execute_, queryMWith)+import Hpgsql.Encoding.RowDecoderMonadic (RowDecoderMonadic)+import Hpgsql.Query (Query, escapeIdentifier, sql)++-- | Cursor within a transaction.+data Cursor = Cursor !Database.PostgreSQL.Simple.Types.Query !Connection++-- | Declare a temporary cursor. The cursor is given a+-- unique name for the given connection.+declareCursor :: Connection -> Hpgsql.Query.Query -> IO Cursor+declareCursor conn q = mapHpgsqlErrors $ do+  name <- newTempName conn+  void $ Hpgsql.execute_ (hpgConn conn) [sql|DECLARE ^{escapeIdentifier (fromQuery name)} NO SCROLL CURSOR FOR ^{q}|]+  return $ Cursor name conn++-- | Close the given cursor.+closeCursor :: Cursor -> IO ()+closeCursor (Cursor name conn) =+  (void $ mapHpgsqlErrors $ Hpgsql.execute_ (hpgConn conn) [sql|CLOSE ^{escapeIdentifier $ fromQuery name}|]) `E.catch` \ex ->+    -- Don't throw exception if CLOSE failed because the transaction is+    -- aborted.  Otherwise, it will throw away the original error.+    unless (isFailedTransactionError ex) $ throwIO ex++-- | Fold over a chunk of rows from the given cursor, calling the+-- supplied fold-like function on each row as it is received. In case+-- the cursor is exhausted, a 'Left' value is returned, otherwise a+-- 'Right' value is returned.+foldForwardWithParser :: Cursor -> RowDecoderMonadic r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)+foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = mapHpgsqlErrors $ do+  let q =+        [sql|FETCH FORWARD ^{fromString (show chunkSize)} FROM ^{escapeIdentifier (fromQuery name)}|]+  rows <- queryMWith parser (hpgConn conn) q+  case rows of+    [] -> pure $ Left a0+    _ -> Right <$> foldM f a0 rows++-- | Fold over a chunk of rows, calling the supplied fold-like function+-- on each row as it is received. In case the cursor is exhausted,+-- a 'Left' value is returned, otherwise a 'Right' value is returned.+foldForward :: (FromRow r) => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)+foldForward cursor = foldForwardWithParser cursor fromRow

@@ -0,0 +1,140 @@+------------------------------------------------------------------------------++----------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Errors+-- Copyright:   (c) 2012-2013 Leonid Onokhov, Joey Adams+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- | Module for parsing errors from postgresql error messages.+--  Currently only parses integrity violation errors (class 23).+--+-- /Note: Success of parsing may depend on language settings./+module Database.PostgreSQL.Simple.Errors+  ( ConstraintViolation (..),+    constraintViolation,+    constraintViolationE,+    catchViolation,+    isSerializationError,+    isNoActiveTransactionError,+    isFailedTransactionError,+  )+where++import Control.Exception as E++import Data.Attoparsec.ByteString.Char8+import Data.ByteString (ByteString)+import Data.Typeable++import Database.PostgreSQL.Simple.Internal++-- Examples of parsed error messages+--+-- `ERROR:  new row for relation "users" violates check+-- constraint "user_kind_check"`+--+-- `ERROR:  insert or update on table "user_group_map" violates foreign key+--  constraint "user_id"`+--+-- `ERROR: null value in column "login" violates not-null constraint`+--+-- `ERROR: duplicate key value violates unique constraint "users_login_key"`++data ConstraintViolation+  = -- | The field is a column name+    NotNullViolation ByteString+  | -- | Table name and name of violated constraint+    ForeignKeyViolation ByteString ByteString+  | -- | Name of violated constraint+    UniqueViolation ByteString+  | -- | Relation name (usually table), constraint name+    CheckViolation ByteString ByteString+  | -- | Name of the exclusion violation constraint+    ExclusionViolation ByteString+  deriving (Show, Eq, Ord, Typeable)++-- Default instance should be enough+instance Exception ConstraintViolation where+  toException = postgresqlExceptionToException+  fromException = postgresqlExceptionFromException++-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and+-- succeeds only if able to parse sqlErrorMsg.+--+-- > createUser = handleJust constraintViolation handler $ execute conn ...+-- >   where+-- >     handler (UniqueViolation "user_login_key") = ...+-- >     handler _ = ...+constraintViolation :: SqlError -> Maybe ConstraintViolation+constraintViolation e =+  case sqlState e of+    "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg+    "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg+    "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg+    "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg+    "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg+    _ -> Nothing+  where+    msg = sqlErrorMsg e++-- | Like constraintViolation, but also packs original SqlError.+--+-- > createUser = handleJust constraintViolationE handler $ execute conn ...+-- >   where+-- >     handler (_, UniqueViolation "user_login_key") = ...+-- >     handler (e, _) = throwIO e+constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)+constraintViolationE e = fmap ((,) e) $ constraintViolation e++-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws+-- on fail. Provides alternative interface to 'E.handleJust'+--+-- > createUser = catchViolation catcher $ execute conn ...+-- >   where+-- >     catcher _ (UniqueViolation "user_login_key") = ...+-- >     catcher e _ = throwIO e+catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a+catchViolation f m =+  E.catch+    m+    (\e -> maybe (throwIO e) (f e) $ constraintViolation e)++-- Parsers just try to extract quoted strings from error messages, number+-- of quoted strings depend on error type.+scanTillQuote :: Parser ByteString+scanTillQuote = scan False go+  where+    go True _ = Just False -- escaped character+    go False '"' = Nothing -- end parse+    go False '\\' = Just True -- next one is escaped+    go _ _ = Just False++parseQ1 :: Parser ByteString+parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'++parseQ2 :: Parser (ByteString, ByteString)+parseQ2 = (,) <$> parseQ1 <*> parseQ1++parseMaybe :: Parser a -> ByteString -> Maybe a+parseMaybe p b = either (const Nothing) Just $ parseOnly p b++------------------------------------------------------------------------+-- Error predicates+--+-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html++isSerializationError :: SqlError -> Bool+isSerializationError = isSqlState "40001"++isNoActiveTransactionError :: SqlError -> Bool+isNoActiveTransactionError = isSqlState "25P01"++isFailedTransactionError :: SqlError -> Bool+isFailedTransactionError = isSqlState "25P02"++isSqlState :: ByteString -> SqlError -> Bool+isSqlState s SqlError {..} = sqlState == s

@@ -0,0 +1,323 @@+-- |+-- Module:      Database.PostgreSQL.Simple.FromField+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- The 'FromField' typeclass, for converting a single value in a row+-- returned by a SQL query into a more useful Haskell representation.+-- Note that each instance of 'FromField' is documented by a list of+-- compatible postgresql types.+--+-- A Haskell numeric type is considered to be compatible with all+-- PostgreSQL numeric types that are less accurate than it. For instance,+-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit+-- @int@ type because it can represent a @int@ exactly.  On the other hand,+-- since a 'Double' might lose precision if representing PostgreSQL's 64-bit+-- @bigint@, the two are /not/ considered compatible.+--+-- Note that the 'Float' and 'Double' instances use attoparsec's 'double'+-- conversion routine,  which sacrifices some accuracy for speed.   If you+-- need accuracy,  consider first converting data to a 'Scientific' or 'Rational'+-- type,  and then converting to a floating-point type.   If you are defining+-- your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances,  this can be+-- achieved simply by+-- @'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@,  although+-- this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@+-- types.  If this is unacceptable,  you may find+-- 'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.+--+-- Also note that while converting to a 'Double' through the 'Scientific' type+-- is likely somewhat faster than converting through the 'Rational' type,+-- the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.+-- Thus,  if you need precision conversion of regular floating point values+-- and the possibility of receiving these special values from the backend,+-- stick with 'Rational'.+--+-- Because 'FromField' is a typeclass,  one may provide conversions to+-- additional Haskell types without modifying hpgsql-simple-compat.  This is+-- particularly useful for supporting PostgreSQL types that hpgsql-simple-compat+-- does not support out-of-box.  Here's an example of what such an instance+-- might look like for a UUID type that implements the @Read@ class:+--+-- @+-- import Data.UUID ( UUID )+-- import Database.PostgreSQL.Simple.FromField+--        ( FromField (fromField) , typeOid, returnError, ResultError (..) )+-- import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid)+-- import qualified Data.ByteString.Char8 as B+--+-- instance FromField UUID where+--    fromField f mdata =+--       if typeOid f /= typoid uuid+--         then returnError Incompatible f \"\"+--         else case B.unpack \`fmap\` mdata of+--                Nothing  -> returnError UnexpectedNull f \"\"+--                Just dat ->+--                   case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of+--                     [x] -> return x+--                     _   -> returnError ConversionFailed f dat+-- @+--+-- Note that because PostgreSQL's @uuid@ type is built into postgres and is+-- not provided by an extension,  the 'typeOid' of @uuid@ does not change and+-- thus we can examine it directly.  One could hard-code the type oid,  or+-- obtain it by other means, but in this case we simply pull it out of the+-- static table provided by hpgsql-simple-compat.+--+-- On the other hand if the type is provided by an extension,  such as+-- @PostGIS@ or @hstore@,  then the 'typeOid' is not stable and can vary from+-- database to database. In this case it is recommended that FromField+-- instances use 'typename' instead.+module Database.PostgreSQL.Simple.FromField+  ( FromField (..),+    FromPgField (..),+    FieldParser,+    Conversion (..),+    -- conversionMap,+    conversionError,+    ResultError (..),+    returnError,+    Field,+    typename,+    TypeInfo (..),+    Attribute (..),+    typeInfo,+    typeInfoByOid,+    name,+    typeOid,+    PQ.Oid (..),+    PQ.Format (..),+    optionalField,+    fromFieldJSONByteString,+    fromJSONField,+  )+where++import Control.Exception (Exception (fromException, toException))+import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as LBS+import Data.CaseInsensitive (CI)+import Data.Int (Int16, Int32, Int64)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Lazy as LT+import Data.Time.Calendar.Compat (Day)+import Data.Time.Compat (UTCTime)+import Data.Time.LocalTime.Compat (CalendarDiffTime, LocalTime, TimeOfDay, ZonedTime)+import Data.Typeable (Typeable, typeOf)+import Data.UUID.Types (UUID)+import Data.Vector (Vector)+import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.HpgsqlUtils+import Database.PostgreSQL.Simple.Internal (postgresqlExceptionFromException, postgresqlExceptionToException)+import Database.PostgreSQL.Simple.Ok (Ok (..))+import Database.PostgreSQL.Simple.TypeInfo as TI+import Database.PostgreSQL.Simple.TypeInfo.Types (fromHpgsqlTypeInfo)+import Database.PostgreSQL.Simple.Types (Binary (..))+import Hpgsql.Encoding (EncodingContext (..), FieldInfo (..), FromPgField (..))+import qualified Hpgsql.Encoding as Hpgsql+import Hpgsql.Time (Unbounded (..))+import Hpgsql.TypeInfo (Oid, lookupTypeByOid)+import Hpgsql.Types (Aeson, PGArray (..), getAeson, pgJsonByteString)++-- | Exception thrown if conversion from a SQL value to a Haskell+-- value fails.+data ResultError+  = -- | The SQL and Haskell types are not compatible.+    Incompatible+      { errSQLType :: String,+        errSQLTableOid :: Maybe PQ.Oid,+        errSQLField :: String,+        errHaskellType :: String,+        errMessage :: String+      }+  | -- | A SQL @NULL@ was encountered when the Haskell+    -- type did not permit it.+    UnexpectedNull+      { errSQLType :: String,+        errSQLTableOid :: Maybe PQ.Oid,+        errSQLField :: String,+        errHaskellType :: String,+        errMessage :: String+      }+  | -- | The SQL value could not be parsed, or could not+    -- be represented as a valid Haskell value, or an+    -- unexpected low-level error occurred (e.g. mismatch+    -- between metadata and actual data in a row).+    ConversionFailed+      { errSQLType :: String,+        errSQLTableOid :: Maybe PQ.Oid,+        errSQLField :: String,+        errHaskellType :: String,+        errMessage :: String+      }+  deriving (Eq, Show, Typeable)++instance Exception ResultError where+  toException = postgresqlExceptionToException+  fromException = postgresqlExceptionFromException++-- | This might be very different from postgresql-simple.+conversionError :: (Exception err) => err -> Conversion a+conversionError ex = Conversion $ \_ -> Errors [toException ex]++left :: (Exception a) => a -> Conversion b+left = conversionError++class FromField a where+  fromField :: FieldParser a+  default fromField :: (Hpgsql.FromPgField a) => FieldParser a+  fromField =+    let dec = Hpgsql.fieldDecoder+     in \f ->+          if (Hpgsql.allowedPgTypes dec) f+            then \mbs -> Conversion $ \_encCtx -> case (Hpgsql.fieldValueDecoder dec) f mbs of+              Right v -> Ok v+              Left err -> Errors [toException $ userError err]+            else \_ -> Conversion $ \_encCtx -> Errors [toException $ userError "Invalid type OID for FromField instance"]++instance FromField ()++instance FromField Int++instance FromField Int16++instance FromField Int32++instance FromField Int64++instance FromField Integer++instance FromField Oid++instance FromField Scientific++instance FromField Rational++instance FromField Float++instance FromField Double++instance FromField Bool++instance FromField Char++instance FromField ByteString++instance FromField LBS.ByteString++instance FromField Text++instance FromField LT.Text++instance FromField String++instance FromField UTCTime++instance FromField ZonedTime++instance FromField LocalTime++instance FromField TimeOfDay++instance FromField Day++instance FromField CalendarDiffTime++instance FromField Aeson.Value++instance FromField UUID++instance FromField (CI Text)++instance FromField (CI LT.Text)++instance FromField (CI String)++instance FromField (Unbounded Day)++instance FromField (Unbounded UTCTime)++instance FromField (Unbounded ZonedTime)++instance (FromField a) => FromField (Maybe a) where+  fromField = optionalField fromField++-- instance (FromField a) => FromField (Vector a)++-- instance (FromField a) => FromField (PGArray a)++instance (Hpgsql.FromPgField a) => FromField (PGArray a)++instance (Hpgsql.FromPgField a) => FromField (Vector a)++instance {-# OVERLAPPING #-} (Hpgsql.FromPgField a) => FromField (Vector (Vector a))++instance FromField (Binary ByteString)++instance (Aeson.FromJSON a) => FromField (Aeson a)++typeOid :: Field -> Oid+typeOid field = field.fieldTypeOid++typename :: Field -> Conversion ByteString+typename field = typname <$> typeInfo field++typeInfo :: Field -> Conversion TypeInfo+typeInfo colInfo = typeInfoByOid colInfo.fieldTypeOid++typeInfoByOid :: PQ.Oid -> Conversion TypeInfo+typeInfoByOid oid = Conversion $ \encCtx -> do+  case lookupTypeByOid oid encCtx.typeInfoCache of+    Nothing -> Errors [toException $ userError $ "Type OID " ++ show oid ++ " not found in TypeInfoCache"]+    Just t -> Ok (fromHpgsqlTypeInfo encCtx t)++-- | Returns the name of the column.  This is often determined by a table+--   definition,  but it can be set using an @as@ clause.+name :: Field -> Maybe ByteString+name f = encodeUtf8 <$> fieldName f++-- | Given one of the constructors from 'ResultError',  the field,+--   and an 'errMessage',  this fills in the other fields in the+--   exception value and returns it in a 'Left . SomeException'+--   constructor.+returnError ::+  forall a err.+  (Typeable a, Exception err) =>+  (String -> Maybe PQ.Oid -> String -> String -> String -> err) ->+  Field ->+  String ->+  Conversion a+returnError mkErr f msg = do+  typnam <- typename f+  left $+    mkErr+      (B8.unpack typnam)+      (error "no tableOid in hpgsql")+      -- (maybe "" B8.unpack (name f))+      "column name not available in hpgsql-simple-compat"+      (show (typeOf (undefined :: a)))+      msg++-- | For dealing with SQL @null@ values outside of the 'FromField' class.+--   Alternatively, one could use 'Control.Applicative.optional',  but that+--   also turns type and conversion errors into 'Nothing',  whereas this is+--   more specific and turns only @null@ values into 'Nothing'.+optionalField :: FieldParser a -> FieldParser (Maybe a)+optionalField p f mv =+  case mv of+    Nothing -> pure Nothing+    Just _ -> Just <$> p f mv+{-# INLINE optionalField #-}++fromJSONField :: (Aeson.FromJSON a) => FieldParser a+fromJSONField f mbs = getAeson <$> fromField f mbs++fromFieldJSONByteString :: FieldParser ByteString+fromFieldJSONByteString = fromHpgsqlFieldDecoder $ pgJsonByteString <$> fieldDecoder

@@ -0,0 +1,1 @@+module Database.PostgreSQL.Simple.FromField where

@@ -0,0 +1,109 @@+{-# LANGUAGE UndecidableInstances #-}++------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.FromRow+-- Copyright:   (c) 2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- The 'FromRow' typeclass, for converting a row of results+-- returned by a SQL query into a more useful Haskell representation.+--+-- Predefined instances are provided for tuples containing up to ten+-- elements.  The instances for 'Maybe' types return 'Nothing' if all+-- the columns that would have been otherwise consumed are null,  otherwise+-- it attempts a regular conversion.+module Database.PostgreSQL.Simple.FromRow+  ( FromRow (..),+    FromPgRow (..),+    RowParser,+    field,+    fieldWith,+    numFieldsRemaining,+  )+where++import Database.PostgreSQL.Simple.FromField (FromField (..))+import Database.PostgreSQL.Simple.HpgsqlUtils+import GHC.Generics (Generic (..), K1 (..), M1 (..), (:*:) (..))+import Hpgsql.Encoding (FieldDecoder, FromPgField (..), FromPgRow (..), singleField)+import Hpgsql.Encoding.RowDecoderMonadic (ConversionState (..), RowDecoderMonadic (..), toMonadicRowDecoder)+import Hpgsql.Types (Only (..), (:.) (..))+import Prelude hiding (null)++type RowParser = RowDecoderMonadic++class FromRow a where+  fromRow :: RowParser a+  default fromRow :: (Generic a, ProductTypeDecoder (Rep a)) => RowParser a+  fromRow = genericFromPgRow++fromHpgsqlField :: (FromField a) => FieldDecoder a+fromHpgsqlField = toHpgsqlFieldDecoder fromField++instance (FromField a) => FromRow (Only a) where+  fromRow = Only <$> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b) => FromRow (a, b) where+  fromRow = (,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c) => FromRow (a, b, c) where+  fromRow = (,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a, b, c, d) where+  fromRow = (,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a, b, c, d, e) where+  fromRow = (,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a, b, c, d, e, f) where+  fromRow = (,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (a, b, c, d, e, f, g) where+  fromRow = (,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h) => FromRow (a, b, c, d, e, f, g, h) where+  fromRow = (,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i) => FromRow (a, b, c, d, e, f, g, h, i) where+  fromRow = (,,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j) => FromRow (a, b, c, d, e, f, g, h, i, j) where+  fromRow = (,,,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k) => FromRow (a, b, c, d, e, f, g, h, i, j, k) where+  fromRow = (,,,,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField)++instance (FromRow a, FromRow b) => FromRow (a :. b) where+  fromRow = (:.) <$> fromRow <*> fromRow++field :: (FromPgField a) => RowDecoderMonadic a+field = toMonadicRowDecoder $ singleField fieldDecoder++-- | Parse a single field using the given 'FieldParser'.+fieldWith :: FieldParser a -> RowParser a+fieldWith fp = toMonadicRowDecoder $ singleField $ toHpgsqlFieldDecoder fp++-- | Return the number of fields remaining in the current row.+numFieldsRemaining :: RowParser Int+numFieldsRemaining = RowDecoderMonadic $ \cs -> pure (length (colsLeftToParse cs), 0)++class ProductTypeDecoder f where+  genRowDecoder :: RowDecoderMonadic (f a)++instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where+  genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder++instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where+  genRowDecoder = M1 <$> genRowDecoder++instance (FromField a) => ProductTypeDecoder (K1 r a) where+  genRowDecoder = fmap K1 $ toMonadicRowDecoder $ singleField $ fromHpgsqlField @a++genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowParser a+genericFromPgRow = to <$> genRowDecoder @(Rep a)

@@ -0,0 +1,3 @@+module Database.PostgreSQL.Simple.FromRow where++class FromRow a

@@ -0,0 +1,36 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.HStore+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- Parsers and printers for hstore,  a extended type bundled with+-- PostgreSQL providing finite maps from text strings to text strings.+-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more+-- information.+--+-- Note that in order to use this type,  a database superuser must+-- install it by running a sql script in the share directory.  This+-- can be done on PostgreSQL 9.1 and later with the command+-- @CREATE EXTENSION hstore@.  See+-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more+-- information.+module Database.PostgreSQL.Simple.HStore+  ( HStoreList (..),+    HStoreMap (..),+    ToHStore (..),+    HStoreBuilder,+    toBuilder,+    toLazyByteString,+    hstore,+    parseHStoreList,+    ToHStoreText (..),+    HStoreText,+  ) where++import Database.PostgreSQL.Simple.HStore.Implementation

@@ -0,0 +1,185 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.HStore.Implementation+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- This code has yet to be profiled and optimized.+module Database.PostgreSQL.Simple.HStore.Implementation where++import Control.Applicative+import qualified Data.Attoparsec.ByteString as P+import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder, byteString, char8)+import qualified Data.ByteString.Builder as BU+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy as BL+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TS+import Data.Text.Encoding.Error (UnicodeException)+import qualified Data.Text.Lazy as TL+import Data.Typeable++class ToHStore a where+  toHStore :: a -> HStoreBuilder++-- | Represents valid hstore syntax.+data HStoreBuilder+  = Empty+  | Comma !Builder+  deriving (Typeable)++instance ToHStore HStoreBuilder where+  toHStore = id++toBuilder :: HStoreBuilder -> Builder+toBuilder x = case x of+  Empty -> mempty+  Comma c -> c++toLazyByteString :: HStoreBuilder -> BL.ByteString+toLazyByteString x = case x of+  Empty -> BL.empty+  Comma c -> BU.toLazyByteString c++instance Semigroup HStoreBuilder where+  Empty <> x = x+  Comma a <> x =+    Comma+      ( a `mappend` case x of+          Empty -> mempty+          Comma b -> char8 ',' `mappend` b+      )++instance Monoid HStoreBuilder where+  mempty = Empty++class ToHStoreText a where+  toHStoreText :: a -> HStoreText++-- | Represents escape text, ready to be the key or value to a hstore value+newtype HStoreText = HStoreText Builder+  deriving stock (Typeable)+  deriving newtype (Semigroup, Monoid)++instance ToHStoreText HStoreText where+  toHStoreText = id++-- | Assumed to be UTF-8 encoded+instance ToHStoreText BS.ByteString where+  toHStoreText str = HStoreText (escapeAppend str mempty)++-- | Assumed to be UTF-8 encoded+instance ToHStoreText BL.ByteString where+  toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty++instance ToHStoreText TS.Text where+  toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty)++instance ToHStoreText TL.Text where+  toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty++escapeAppend :: BS.ByteString -> Builder -> Builder+escapeAppend = loop+  where+    loop (BS.break quoteNeeded -> (a, b)) rest =+      byteString a+        `mappend` case BS.uncons b of+          Nothing -> rest+          Just (c, d) -> quoteChar c `mappend` loop d rest++    quoteNeeded c = c == c2w '\"' || c == c2w '\\'+    quoteChar c+      | c == c2w '\"' = byteString "\\\""+      | otherwise = byteString "\\\\"++hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder+hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =+  Comma+    ( char8 '"'+        `mappend` key+        `mappend` byteString "\"=>\""+        `mappend` val+        `mappend` char8 '"'+    )++newtype HStoreList = HStoreList {fromHStoreList :: [(Text, Text)]} deriving (Typeable, Show)++-- | hstore+instance ToHStore HStoreList where+  toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs)++newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show)++instance ToHStore HStoreMap where+  toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs+    where+      f k v xs' = hstore k v `mappend` xs'++parseHStoreList :: BS.ByteString -> Either String HStoreList+parseHStoreList dat =+  case P.parseOnly (parseHStore <* P.endOfInput) dat of+    Left err -> Left (show err)+    Right (Left err) -> Left (show err)+    Right (Right val) -> Right val++parseHStore :: P.Parser (Either UnicodeException HStoreList)+parseHStore = do+  kvs <-+    P.sepBy'+      (skipWhiteSpace *> parseHStoreKeyVal)+      (skipWhiteSpace *> P.word8 (c2w ','))+  return $ HStoreList <$> sequence kvs++parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text, Text))+parseHStoreKeyVal = do+  mkey <- parseHStoreText+  case mkey of+    Left err -> return (Left err)+    Right key -> do+      skipWhiteSpace+      _ <- P.string "=>"+      skipWhiteSpace+      mval <- parseHStoreText+      case mval of+        Left err -> return (Left err)+        Right val -> return (Right (key, val))++skipWhiteSpace :: P.Parser ()+skipWhiteSpace = P.skipWhile P.isSpace_w8++parseHStoreText :: P.Parser (Either UnicodeException Text)+parseHStoreText = do+  _ <- P.word8 (c2w '"')+  mtexts <- parseHStoreTexts id+  case mtexts of+    Left err -> return (Left err)+    Right texts -> do+      _ <- P.word8 (c2w '"')+      return (Right (TS.concat texts))++parseHStoreTexts ::+  ([Text] -> [Text]) ->+  P.Parser (Either UnicodeException [Text])+parseHStoreTexts acc = do+  mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar)+  case mchunk of+    Left err -> return (Left err)+    Right chunk ->+      ( do+          _ <- P.word8 (c2w '\\')+          c <- TS.singleton . w2c <$> P.satisfy isSpecialChar+          parseHStoreTexts (acc . (chunk :) . (c :))+      )+        <|> return (Right (acc [chunk]))+  where+    isSpecialChar c = c == c2w '\\' || c == c2w '"'

@@ -0,0 +1,19 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.HStore.Internal+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+module Database.PostgreSQL.Simple.HStore.Internal+  ( HStoreBuilder (..),+    HStoreText (..),+    parseHStore,+    parseHStoreKeyVal,+    parseHStoreText,+  ) where++import Database.PostgreSQL.Simple.HStore.Implementation

@@ -0,0 +1,126 @@+module Database.PostgreSQL.Simple.HpgsqlUtils+  ( toHpgsqlQuery,+    toHpgsqlRowParams,+    toPgSimpleQuery,+    Conversion (..),+    PgSimpleRow (..),+    toHpgsqlFieldDecoder,+    fromHpgsqlFieldDecoder,+    Field,+    FieldParser,+  )+where++import Control.Applicative (Alternative (..))+import Control.Exception (toException)+import Control.Monad (MonadPlus (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.IntMap.Strict as IntMap+import Database.PostgreSQL.Simple.Ok (Ok (..))+import Database.PostgreSQL.Simple.ToField (Action (..))+import Database.PostgreSQL.Simple.ToRow (ToRow (..))+import Database.PostgreSQL.Simple.Types (Query (..))+import Hpgsql.Builder (BinaryField)+import Hpgsql.Encoding (FieldDecoder (..), FieldInfo (..))+import Hpgsql.InternalTypes (SingleQueryFragment (..))+import qualified Hpgsql.InternalTypes as HpgsqlTypes+import qualified Hpgsql.Query as Hpgsql+import Hpgsql.TypeInfo (EncodingContext, Oid)++toHpgsqlQuery :: (ToRow q) => Query -> q -> Hpgsql.Query+toHpgsqlQuery (Query qry) row = Hpgsql.mkQueryInternal qry (toHpgsqlRowParams row)++toHpgsqlRowParams :: (ToRow q) => q -> [[Either ByteString (EncodingContext -> (Maybe Oid, BinaryField))]]+toHpgsqlRowParams = concatMap actionToPgParams . toRow+  where+    actionToPgParams :: Action -> [[Either ByteString (EncodingContext -> (Maybe Oid, BinaryField))]]+    actionToPgParams = \case+      Plain sql -> [[Left $ LBS.toStrict sql]] -- Static SQL fragments go to the query string directly+      QueryArgument qa -> [[Right qa]]+      EscapeIdentifier ident -> [[Left $ escapeIdentifier ident]] -- These should be encoded into the query string directly+      Many actions -> [mconcat $ concatMap actionToPgParams actions]++escapeIdentifier :: ByteString -> ByteString+escapeIdentifier v = "\"" <> BS.intercalate "\"\"" (BS.split 0x22 {- '"' -} v) <> "\""++newtype PgSimpleRow = PgSimpleRow [Action]+  deriving newtype (ToRow)++-- |  This is different from postgresql-simple's `Conversion` type, but it's the+-- best we can do, because hpgsql-simple-compat's decoding cannot run IO.+newtype Conversion a = Conversion {runConversion :: EncodingContext -> Ok a}++-- liftConversion :: IO a -> Conversion a+-- liftConversion m = Conversion (\_ -> Ok <$> m)++instance Functor Conversion where+  fmap f m = Conversion $ \encCtx -> fmap f (runConversion m encCtx)++instance Applicative Conversion where+  pure a = Conversion $ \_conn -> pure a+  mf <*> ma = Conversion $ \conn -> do+    case runConversion mf conn of+      Ok f -> fmap f (runConversion ma conn)+      Errors errs -> (Errors errs)++instance Alternative Conversion where+  empty = Conversion $ \_ -> empty+  ma <|> mb = Conversion $ \encCtx ->+    case runConversion ma encCtx of+      Ok v -> return v+      Errors _ -> runConversion mb encCtx++instance Monad Conversion where+  m >>= f = Conversion $ \conn -> do+    case runConversion m conn of+      Ok a -> runConversion (f a) conn+      Errors err -> Errors err++instance MonadPlus Conversion where+  mzero = empty+  mplus = (<|>)++-- conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b+-- conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn++-- conversionError :: (Exception err) => err -> Conversion a+-- conversionError err = Conversion $ \_ -> return (Errors [toException err])++type Field = FieldInfo++type FieldParser a = Field -> Maybe ByteString -> Conversion a++toHpgsqlFieldDecoder :: FieldParser a -> FieldDecoder a+toHpgsqlFieldDecoder fp =+  FieldDecoder+    { fieldValueDecoder = \colInfo mbs ->+        let valConv = fp colInfo mbs+         in case runConversion valConv colInfo.encodingContext of+              Ok v -> Right v+              Errors errs -> Left (show errs),+      allowedPgTypes = const True -- No way to check if types are valid ahead of time+    }++fromHpgsqlFieldDecoder :: FieldDecoder a -> FieldParser a+fromHpgsqlFieldDecoder dec = \f mbs -> Conversion $ \_encCtx -> case dec.fieldValueDecoder f mbs of+  Right v -> Ok v+  Left err -> Errors [toException $ userError $ show err]++-- | Given a Hpgsql query, returns the text format with question marks+-- for query arguments and a row object. With both, you can call+-- hpgsql-simple-compat's querying functions as you normally would.+toPgSimpleQuery :: Hpgsql.Query -> (Query, PgSimpleRow)+toPgSimpleQuery hpgsqlQuery =+  let paramsMap = IntMap.fromList $ zip [1 ..] hpgsqlQuery.queryParams+      go frag (ts, as) = case frag of+        FragmentOfStaticSql bs -> (bs : ts, as)+        FragmentWithSemiColon -> (";" : ts, as)+        FragmentOfCommentsOrWhitespace bs -> (bs : ts, as)+        QueryArgumentPlaceHolder n -> case IntMap.lookup n paramsMap of+          Just p -> ("?" : ts, QueryArgument p : as)+          Nothing -> error $ "toPgSimpleQuery: query argument placeholder $" ++ show n ++ " has no corresponding parameter"+      (textParts, actions) = foldr go ([], []) hpgsqlQuery.queryString+      queryText = mconcat textParts+   in (Query queryText, PgSimpleRow actions)

@@ -0,0 +1,369 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Internal+-- Copyright:   (c) 2011-2015 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- Internal bits.  This interface is less stable and can change at any time.+-- In particular this means that while the rest of the hpgsql-simple-compat+-- package endeavors to follow the package versioning policy,  this module+-- does not.  Also, at the moment there are things in here that aren't+-- particularly internal and are exported elsewhere;  these will eventually+-- disappear from this module.+module Database.PostgreSQL.Simple.Internal where++import Control.Concurrent.MVar+import Control.Exception+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as LBS+import Data.IORef+import Data.Int (Int64)+import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as Map+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Typeable+import Data.Word+import Database.PostgreSQL.LibPQ (ExecStatus (..), Oid (..))+import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.ToField (Action (..))+import Database.PostgreSQL.Simple.TypeInfo.Types (TypeInfo)+import Database.PostgreSQL.Simple.Types (Query (..))+import GHC.Generics+import GHC.IO.Exception+import Hpgsql (ErrorDetail (..), HPgConnection, IrrecoverableHpgsqlError (..), PostgresError (..))+import qualified Hpgsql+import qualified Hpgsql.Connection++type TypeInfoCache = IntMap.IntMap TypeInfo++data Connection = Connection+  { connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache),+    connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64),+    hpgConn :: HPgConnection+  }+  deriving (Typeable)++instance Eq Connection where+  x == y = hpgConn x == hpgConn y++-- | Superclass for postgresql exceptions+data SomePostgreSqlException = forall e. (Exception e) => SomePostgreSqlException e+  deriving (Typeable)++postgresqlExceptionToException :: (Exception e) => e -> SomeException+postgresqlExceptionToException = toException . SomePostgreSqlException++postgresqlExceptionFromException :: (Exception e) => SomeException -> Maybe e+postgresqlExceptionFromException x = do+  SomePostgreSqlException a <- fromException x+  cast a++instance Show SomePostgreSqlException where+  showsPrec :: Int -> SomePostgreSqlException -> ShowS+  showsPrec p (SomePostgreSqlException e) = showsPrec p e++instance Exception SomePostgreSqlException where+  displayException (SomePostgreSqlException e) = displayException e++data SqlError = SqlError+  { sqlState :: ByteString,+    sqlExecStatus :: ExecStatus,+    sqlErrorMsg :: ByteString,+    sqlErrorDetail :: ByteString,+    sqlErrorHint :: ByteString,+    -- | This is a new field present only in hpgsql-simple-compat,+    -- to help debugging the source of errors.+    sqlStatement :: ByteString+  }+  deriving (Eq, Show, Typeable)++fatalError :: ByteString -> SqlError+fatalError msg = SqlError "" FatalError msg "" "" ""++instance Exception SqlError where+  toException = postgresqlExceptionToException+  fromException = postgresqlExceptionFromException++-- | Exception thrown if 'query' is used to perform an @INSERT@-like+-- operation, or 'execute' is used to perform a @SELECT@-like operation.+data QueryError = QueryError+  { qeMessage :: String,+    qeQuery :: Query+  }+  deriving (Eq, Show, Typeable)++instance Exception QueryError where+  toException = postgresqlExceptionToException+  fromException = postgresqlExceptionFromException++-- | Exception thrown if a 'Query' could not be formatted correctly.+-- This may occur if the number of \'@?@\' characters in the query+-- string does not match the number of parameters provided.+data FormatError = FormatError+  { fmtMessage :: String,+    fmtQuery :: Query,+    fmtParams :: [ByteString]+  }+  deriving (Eq, Show, Typeable)++instance Exception FormatError where+  toException = postgresqlExceptionToException+  fromException = postgresqlExceptionFromException++data ConnectInfo = ConnectInfo+  { connectHost :: String,+    connectPort :: Word16,+    connectUser :: String,+    connectPassword :: String,+    connectDatabase :: String+  }+  deriving (Generic, Eq, Read, Show, Typeable)++-- | Default information for setting up a connection.+--+-- Defaults are as follows:+--+-- * Server on @localhost@+--+-- * Port on @5432@+--+-- * User @postgres@+--+-- * No password+--+-- * Database @postgres@+--+-- Use as in the following example:+--+-- > connect defaultConnectInfo { connectHost = "db.example.com" }+defaultConnectInfo :: ConnectInfo+defaultConnectInfo =+  ConnectInfo+    { connectHost = "127.0.0.1",+      connectPort = 5432,+      connectUser = "postgres",+      connectPassword = "",+      connectDatabase = ""+    }++-- | Connect with the given username to the given database. Will throw+--   an exception if it cannot connect.+connect :: ConnectInfo -> IO Connection+connect = connectPostgreSQL . postgreSQLConnectionString++-- | Memory bracket around 'connect' and 'close'.+--+-- @since 0.6.5+withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c+withConnect connInfo = bracket (connect connInfo) close++-- | Atomically perform an action with the database handle, if there is one.+withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a+withConnection Connection {..} m = m $ PQ.Connection hpgConn++-- | Attempt to make a connection based on a libpq connection string.+--   See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>+--   for more information.  Also note that environment variables also affect+--   parameters not provided, parameters provided as the empty string, and a+--   few other things; see+--   <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>+--   for details.  Here is an example with some of the most commonly used+--   parameters:+--+-- > host='db.somedomain.com' port=5432 ...+--+--   This attempts to connect to @db.somedomain.com:5432@.  Omitting the port+--   will normally default to 5432.+--+--   On systems that provide unix domain sockets,  omitting the host parameter+--   will cause libpq to attempt to connect via unix domain sockets.+--   The default filesystem path to the socket is constructed from the+--   port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the+--   @pg_config_manual.h@ header file.  Connecting via unix sockets tends+--   to use the @peer@ authentication method, which is very secure and+--   does not require a password.+--+--   On Windows and other systems without unix domain sockets, omitting+--   the host will default to @localhost@.+--+-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'+--+--   This attempts to connect to a database named @postgres@ with+--   user @postgres@ and password @secret \' \\ pw@.  Backslash+--   characters will have to be double-quoted in literal Haskell strings,+--   of course.  Omitting @dbname@ and @user@ will both default to the+--   system username that the client process is running as.+--+--   Omitting @password@ will default to an appropriate password found+--   in the @pgpass@ file,  or no password at all if a matching line is+--   not found.  The path of the @pgpass@ file may be specified by setting+--   the @PGPASSFILE@ environment variable. See+--   <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for+--   more information regarding this file.+--+--   As all parameters are optional and the defaults are sensible,  the+--   empty connection string can be useful for development and+--   exploratory use,  assuming your system is set up appropriately.+--+--   On Unix,  such a setup would typically consist of a local+--   postgresql server listening on port 5432,  as well as a system user,+--   database user, and database sharing a common name,  with permissions+--   granted to the user on the database.+--+--   On Windows,  in addition you will either need @pg_hba.conf@+--   to specify the use of the @trust@ authentication method for+--   the connection,  which may not be appropriate for multiuser+--   or production machines, or you will need to use a @pgpass@ file+--   with the @password@ or @md5@ authentication methods.+--+--   See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>+--   for more information regarding the authentication process.+--+--   SSL/TLS will typically "just work" if your postgresql server supports or+--   requires it.  However,  note that libpq is trivially vulnerable to a MITM+--   attack without setting additional SSL connection parameters.  In+--   particular,  @sslmode@ needs to be set to @require@, @verify-ca@, or+--   @verify-full@ in order to perform certificate validation.  When @sslmode@+--   is @require@,  then you will also need to specify a @sslrootcert@ file,+--   otherwise no validation of the server's identity will be performed.+--   Client authentication via certificates is also possible via the+--   @sslcert@ and @sslkey@ parameters.   See+--   <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>+--   for detailed information regarding libpq and SSL.+connectPostgreSQL :: ByteString -> IO Connection+connectPostgreSQL connstr = do+  connectionObjects <- newMVar (IntMap.empty)+  connectionTempNameCounter <- newIORef 0+  case Hpgsql.Connection.parseLibpqConnectionString (TE.decodeUtf8 connstr) of+    Left err -> error err+    Right connStr -> do+      hpgConn <- mapHpgsqlErrors $ Hpgsql.Connection.connect connStr 30+      pure $ Connection {..}++-- | Turns a 'ConnectInfo' data structure into a libpq connection string.+postgreSQLConnectionString :: ConnectInfo -> ByteString+postgreSQLConnectionString connectInfo = fromString connstr+  where+    connstr =+      str "host=" connectHost $+        num "port=" connectPort $+          str "user=" connectUser $+            str "password=" connectPassword $+              str "dbname=" connectDatabase $+                []++    str name field+      | null value = id+      | otherwise = showString name . addQuotes value . space+      where+        value = field connectInfo++    num name field+      | value <= 0 = id+      | otherwise = showString name . shows value . space+      where+        value = field connectInfo++    addQuotes s rest = '\'' : foldr delta ('\'' : rest) s+      where+        delta c cs = case c of+          '\\' -> '\\' : '\\' : cs+          '\'' -> '\\' : '\'' : cs+          _ -> c : cs++    space [] = []+    space xs = ' ' : xs++oid2int :: Oid -> Int+oid2int (Oid x) = fromIntegral x+{-# INLINE oid2int #-}++-- | Maps Hpgsql's 'PostgresError' to postgresql-simple's 'SqlError', and+-- some IrrecoverableHpgsqlError errors with a PostgresError behind them+-- as well.+postgresErrorToSqlError :: SomeException -> Maybe SqlError+postgresErrorToSqlError e+  | Just (sqlEx :: PostgresError) <- fromException e = Just $ mkSqlError sqlEx+  | Just IrrecoverableHpgsqlError {innerException} <- fromException e =+      case fromException <$> innerException of+        Just (Just (sqlEx :: PostgresError)) -> Just $ mkSqlError sqlEx+        _ -> Nothing+  | otherwise = Nothing+  where+    mkSqlError PostgresError {pgErrorDetails, failedStatement} =+      let lookupDetail key = maybe "" LBS.toStrict (Map.lookup key pgErrorDetails)+       in SqlError+            { sqlState = lookupDetail ErrorCode,+              sqlExecStatus = FatalError, -- TODO: lookupDetail ErrorSeverity,+              sqlErrorMsg = lookupDetail ErrorHumanReadableMsg,+              sqlErrorDetail = lookupDetail ErrorDetail,+              sqlErrorHint = lookupDetail ErrorHint,+              sqlStatement = failedStatement+            }++-- | Wraps an IO action to rethrow Hpgsql's 'PostgresError' as postgresql-simple's 'SqlError'.+mapHpgsqlErrors :: IO a -> IO a+mapHpgsqlErrors = handleJust postgresErrorToSqlError throwIO++-- | A version of 'execute' that does not perform query substitution.+execute_ :: Connection -> Query -> IO Int64+execute_ conn (Query stmt) =+  mapHpgsqlErrors $+    Hpgsql.execute (hpgConn conn) (fromString $ T.unpack $ TE.decodeUtf8 stmt)++disconnectedError :: SqlError+disconnectedError = fatalError "connection disconnected"++close :: Connection -> IO ()+close Connection {..} = mapHpgsqlErrors $ Hpgsql.Connection.closeGracefully hpgConn++newTempName :: Connection -> IO Query+newTempName Connection {..} = do+  !n <-+    atomicModifyIORef+      connectionTempNameCounter+      (\n -> let !n' = n + 1 in (n', n'))+  return $! Query $ B8.pack $ "temp" ++ show n++-- FIXME?  What error should getNotification and getCopyData throw?+fdError :: ByteString -> IOError+fdError funcName =+  IOError+    { ioe_handle = Nothing,+      ioe_type = ResourceVanished,+      ioe_location = B8.unpack funcName,+      ioe_description = "failed to fetch file descriptor",+      ioe_errno = Nothing,+      ioe_filename = Nothing+    }++libPQError :: ByteString -> IOError+libPQError desc =+  IOError+    { ioe_handle = Nothing,+      ioe_type = OtherError,+      ioe_location = "libpq",+      ioe_description = B8.unpack desc,+      ioe_errno = Nothing,+      ioe_filename = Nothing+    }++fmtError :: String -> Query -> a+fmtError msg q =+  throw+    FormatError+      { fmtMessage = msg,+        fmtQuery = q,+        fmtParams = []+      }++fmtErrorBs :: Query -> [Action] -> ByteString -> a+fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs

@@ -0,0 +1,12 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Internal.PQResultUtils+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+module Database.PostgreSQL.Simple.Internal.PQResultUtils () where

@@ -0,0 +1,9 @@+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.+--+-- The newtypes are named after packages they wrap.+module Database.PostgreSQL.Simple.Newtypes+  ( Aeson (..),+  )+where++import Hpgsql.Types (Aeson (..))

@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      :  Database.PostgreSQL.Simple.Notification+-- Copyright   :  (c) 2011-2015 Leon P Smith+--                (c) 2012 Joey Adams+-- License     :  BSD3+--+-- Maintainer  :  leon@melding-monads.com+-- Stability   :  experimental+--+-- Support for receiving asynchronous notifications via PostgreSQL's+-- Listen/Notify mechanism.  See+-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more+-- information.+--+-- Note that on Windows,  @getNotification@ currently uses a polling loop+-- of 1 second to check for more notifications,  due to some inadequacies+-- in GHC's IO implementation and interface on that platform.   See GHC+-- issue #7353 for more information.  While this workaround is less than+-- ideal,  notifications are still better than polling the database directly.+-- Notifications do not create any extra work for the backend,  and are+-- likely cheaper on the client side as well.+--+-- <https://hackage.haskell.org/trac/ghc/ticket/7353>+module Database.PostgreSQL.Simple.Notification+  ( Notification (..),+    getNotification,+    getNotificationNonBlocking,+    getBackendPID,+  )+where++import qualified Data.ByteString as B+import Data.Text.Encoding (encodeUtf8)+import Database.PostgreSQL.Simple.Internal+import qualified Hpgsql.Connection+import qualified Hpgsql.Notification+import System.Posix.Types (CPid)++data Notification = Notification+  { notificationPid :: {-# UNPACK #-} !CPid,+    notificationChannel :: {-# UNPACK #-} !B.ByteString,+    notificationData :: {-# UNPACK #-} !B.ByteString+  }+  deriving (Show, Eq)++-- | Returns a single notification.   If no notifications are available,+--   'getNotification' blocks until one arrives.+--+--   It is safe to call 'getNotification' on a connection that is concurrently+--   being used for other purposes,   note however that PostgreSQL does not+--   deliver notifications while a connection is inside a transaction.+getNotification :: Connection -> IO Notification+getNotification conn = fromHpgsqlNotification <$> Hpgsql.Notification.getNotification (hpgConn conn)++-- | Non-blocking variant of 'getNotification'.   Returns a single notification,+-- if available.   If no notifications are available,  returns 'Nothing'.+getNotificationNonBlocking :: Connection -> IO (Maybe Notification)+getNotificationNonBlocking conn = fmap fromHpgsqlNotification <$> Hpgsql.Notification.getNotificationNonBlocking (hpgConn conn)++fromHpgsqlNotification :: Hpgsql.Notification.NotificationResponse -> Notification+fromHpgsqlNotification Hpgsql.Notification.NotificationResponse {..} =+  Notification+    { notificationPid = fromIntegral notifierPid,+      notificationChannel = encodeUtf8 channelName,+      notificationData = encodeUtf8 notifPayload+    }++-- | Returns the process 'CPid' of the backend server process+-- handling this connection.+--+-- The backend PID is useful for debugging purposes and for comparison+-- to NOTIFY messages (which include the PID of the notifying backend+-- process). Note that the PID belongs to a process executing on the+-- database server host, not the local host!+getBackendPID :: Connection -> IO CPid+getBackendPID conn = pure $ fromIntegral $ Hpgsql.Connection.getBackendPid (hpgConn conn)

@@ -0,0 +1,84 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module      :  Database.PostgreSQL.Simple.Ok+-- Copyright   :  (c) 2012-2015 Leon P Smith+-- License     :  BSD3+--+-- Maintainer  :  leon@melding-monads.com+-- Stability   :  experimental+--+-- The 'Ok' type is a simple error handler,  basically equivalent to+-- @Either [SomeException]@.   This type (without the list) was used to+-- handle conversion errors in early versions of hpgsql-simple-compat.+--+-- One of the primary reasons why this type  was introduced is that+-- @Either SomeException@ had not been provided an instance for 'Alternative',+-- and it would have been a bad idea to provide an orphaned instance for a+-- commonly-used type and typeclass included in @base@.+--+-- Extending the failure case to a list of 'SomeException's enables a+-- more sensible 'Alternative' instance definitions:   '<|>' concatenates+-- the list of exceptions when both cases fail,  and 'empty' is defined as+-- 'Errors []'.   Though '<|>' one could pick one of two exceptions, and+-- throw away the other,  and have 'empty' provide a generic exception,+-- this avoids cases where 'empty' overrides a more informative exception+-- and allows you to see all the different ways your computation has failed.+module Database.PostgreSQL.Simple.Ok where++import Control.Applicative+import Control.Exception+import Control.Monad (MonadPlus (..))+import Data.Typeable++import qualified Control.Monad.Fail as Fail++-- FIXME:   [SomeException] should probably be something else,  maybe+--          a difference list (or a tree?)++data Ok a = Errors [SomeException] | Ok !a+  deriving (Show, Typeable, Functor)++-- | Two 'Errors' cases are considered equal, regardless of what the+--   list of exceptions looks like.+instance (Eq a) => Eq (Ok a) where+  Errors _ == Errors _ = True+  Ok a == Ok b = a == b+  _ == _ = False++instance Applicative Ok where+  pure = Ok++  Errors es <*> _ = Errors es+  _ <*> Errors es = Errors es+  Ok f <*> Ok a = Ok (f a)++instance Alternative Ok where+  empty = Errors []++  a@(Ok _) <|> _ = a+  Errors _ <|> b@(Ok _) = b+  Errors as <|> Errors bs = Errors (as ++ bs)++instance MonadPlus Ok where+  mzero = empty+  mplus = (<|>)++instance Monad Ok where+  Errors es >>= _ = Errors es+  Ok a >>= f = f a++#if !(MIN_VERSION_base(4,13,0))+    fail = Fail.fail+#endif++instance Fail.MonadFail Ok where+  fail str = Errors [SomeException (ErrorCall str)]++-- | a way to reify a list of exceptions into a single exception+newtype ManyErrors = ManyErrors [SomeException]+  deriving (Show, Typeable)++instance Exception ManyErrors

@@ -0,0 +1,92 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Range+-- Copyright:   (c) 2014-2015 Leonid Onokhov+--              (c) 2014-2015 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+module Database.PostgreSQL.Simple.Range+  ( RangeBound (..),+    PGRange (..),+    empty,+    isEmpty,+    isEmptyBy,+    contains,+    containsBy,+  )+where++import Data.Typeable (Typeable)++-- | Represents boundary of a range+data RangeBound a+  = NegInfinity+  | Inclusive !a+  | Exclusive !a+  | PosInfinity+  deriving (Show, Typeable, Eq, Functor)++-- | Generic range type+data PGRange a = PGRange !(RangeBound a) !(RangeBound a)+  deriving (Show, Typeable, Functor)++empty :: PGRange a+empty = PGRange PosInfinity NegInfinity++instance (Ord a) => Eq (PGRange a) where+  x == y = eq x y || (isEmpty x && isEmpty y)+    where+      eq (PGRange a m) (PGRange b n) = a == b && m == n++isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool+isEmptyBy cmp v =+  case v of+    (PGRange PosInfinity _) -> True+    (PGRange _ NegInfinity) -> True+    (PGRange NegInfinity _) -> False+    (PGRange _ PosInfinity) -> False+    (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT+    (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT+    (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT+    (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT++-- | Is a range empty?   If this returns 'True',  then the 'contains'+--   predicate will always return 'False'.   However,  if this returns+--   'False', it is not necessarily true that there exists a point for+--   which 'contains' returns 'True'.+--   Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,+--   for example.+isEmpty :: (Ord a) => PGRange a -> Bool+isEmpty = isEmptyBy compare++-- | Does a range contain a given point?   Note that in some cases, this may+-- not correspond exactly with a server-side computation.   Consider @UTCTime@+-- for example, which has a resolution of a picosecond,  whereas postgresql's+-- @timestamptz@ types have a resolution of a microsecond.  Putting such+-- Haskell values into the database will result in them being rounded, which+-- can change the value of the containment predicate.+contains :: (Ord a) => PGRange a -> (a -> Bool)+contains = containsBy compare++containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)+containsBy cmp rng x =+  case rng of+    PGRange _lb NegInfinity -> False+    PGRange lb ub -> checkLB lb x && checkUB ub x+  where+    checkLB lb y =+      case lb of+        NegInfinity -> True+        PosInfinity -> False+        Inclusive a -> cmp a y /= GT+        Exclusive a -> cmp a y == LT++    checkUB ub y =+      case ub of+        NegInfinity -> False+        PosInfinity -> True+        Inclusive z -> cmp y z /= GT+        Exclusive z -> cmp y z == LT

@@ -0,0 +1,85 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.SqlQQ+-- Copyright:   (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+module Database.PostgreSQL.Simple.SqlQQ (sql) where++import Data.Char+import Data.String+import Database.PostgreSQL.Simple.Types (Query)+import Language.Haskell.TH+import Language.Haskell.TH.Quote++-- | 'sql' is a quasiquoter that eases the syntactic burden+-- of writing big sql statements in Haskell source code.  For example:+--+-- > {-# LANGUAGE QuasiQuotes #-}+-- >+-- > query conn [sql| SELECT column_a, column_b+-- >                    FROM table1 NATURAL JOIN table2+-- >                   WHERE ? <= time AND time < ?+-- >                     AND name LIKE ?+-- >                   ORDER BY size DESC+-- >                   LIMIT 100                        |]+-- >            (beginTime,endTime,string)+--+-- This quasiquoter returns a literal string expression of type 'Query',+-- and attempts to minimize whitespace;  otherwise the above query would+-- consist of approximately half whitespace when sent to the database+-- backend.  It also recognizes and strips out standard sql comments "--".+--+-- The implementation of the whitespace reducer is currently incomplete.+-- Thus it can mess up your syntax in cases where whitespace should be+-- preserved as-is.  It does preserve whitespace inside standard SQL string+-- literals.  But it can get confused by the non-standard PostgreSQL string+-- literal syntax (which is the default setting in PostgreSQL 8 and below),+-- the extended escape string syntax,  quoted identifiers,  and other similar+-- constructs.+--+-- Of course, this caveat only applies to text written inside the SQL+-- quasiquoter; whitespace reduction is a compile-time computation and+-- thus will not touch the @string@ parameter above,  which is a run-time+-- value.+--+-- Also note that this will not work if the substring @|]@ is contained+-- in the query.+sql :: QuasiQuoter+sql =+  QuasiQuoter+    { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context",+      quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context",+      quoteExp = sqlExp,+      quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"+    }++sqlExp :: String -> Q Exp+sqlExp = appE [|fromString :: String -> Query|] . stringE . minimizeSpace++minimizeSpace :: String -> String+minimizeSpace = drop 1 . reduceSpace+  where+    needsReduced [] = False+    needsReduced ('-' : '-' : _) = True+    needsReduced (x : _) = isSpace x++    reduceSpace xs =+      case dropWhile isSpace xs of+        [] -> []+        ('-' : '-' : ys) -> reduceSpace (dropWhile (/= '\n') ys)+        ys -> ' ' : insql ys++    insql ('\'' : xs) = '\'' : instring xs+    insql xs | needsReduced xs = reduceSpace xs+    insql (x : xs) = x : insql xs+    insql [] = []++    instring ('\'' : '\'' : xs) = '\'' : '\'' : instring xs+    instring ('\'' : xs) = '\'' : insql xs+    instring (x : xs) = x : instring xs+    instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"

@@ -0,0 +1,245 @@+-- |+-- Module:      Database.PostgreSQL.Simple.Time+-- Copyright:   (c) 2012-2015 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- This module provides time types that supports positive and negative+-- infinity,  as well as some functions for converting to and from strings.+--+-- Also, this module also contains commentary regarding postgresql's timestamp+-- types,  civil timekeeping in general,  and how it relates to+-- hpgsql-simple-compat. You can read more about PostgreSQL's date and time types+-- at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,+-- and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.+--+-- Stack Overflow also has some excellent commentary on time,  if it is a+-- wiki page or a highly upvoted question and answer.   If the answer regarding+-- time has not received about a hundred upvotes at least,  then the answer is+-- almost invariably completely and painfully wrong,  even if it's the chosen+-- answer or the most highly upvoted answer to a question.+--+-- PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be+-- converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,+-- because values of these types represent a self-contained, unambiguous point+-- in time.  PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)+-- can be converted to Haskell's 'Data.Time.LocalTime',  because values of these+-- types are ambiguous by themselves,  and require context to disambiguate.+--+-- While this behavior may be superficially counterintuitive because the+-- names might suggest otherwise,  this behavior is correct.   In fact,+-- the \"timezone\" language in both the postgresql and haskell types would+-- be better read as \"offset (from UTC)\",   thus we have postgresql's+-- \"timestamp with offset\"  corresponding to Haskell's \"time with the+-- offset \'zero\'\"  and Haskell's \"time with an offset (that might be+-- nonzero)\".  Similarly,  postgresql's \"timestamp without an offset\"+-- corresponds to Haskell's \"local time (without an offset)\".+--+-- It's important to distinguish between an offset, a standard time, and+-- a time zone.  An offset is simply a difference of a local time from UTC,+-- such as @+00@, @-05@, or @+05:30@.   A standard time specifies an offset+-- (which may vary throughout the year, due to daylight savings) that a+-- region follows,  such as Universal Coordinated Time (UTC), Eastern Standard+-- Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).+-- And a time zone, much like a standard time, is a function from+-- timestamps to offsets.+--+-- A time zone is different from a standard time because different regions+-- inside a standard time can be governed by different civil authorities with+-- different laws and thus have different histories of civil time.  An IANA+-- time zone is any region of the world that has had the same history of+-- civil time since @1970-01-01 00:00+00@.+--+-- For example, as of today,  both @America\/New_York@ and+-- @America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard,  but+-- Indiana used to be on Central Standard Time until 1942, and did not observe+-- daylight savings time (EST only) until 2006.   Thus,  the choice between+-- these two time zones still matters if you are dealing with timestamps+-- prior to 2006,  and could become relevant again if (most of) Indiana+-- moves back to Central Time.  (Of course,  if the Central to Eastern switch+-- was the only difference,  then these two time zones would be the same in+-- IANA's eyes,  due to their cutoff date of 1970-01-01.)+--+-- Getting back to practicalities,  PostgreSQL's @timestamptz@ type does not+-- actually store an offset;  rather, it uses the offset provided to calculate+-- UTC, and stores the timestamp as UTC.   If an offset is not provided, the+-- given timestamp is assumed to be a local time for whatever the @timezone@+-- variable is set to, and the IANA TZ database is consulted to calculate an+-- offset from UTC for the time in question.+--+-- Note that while most (local timestamp, time zone) pairs correspond to exactly+-- one UTC timestamp, some correspond to two UTC timestamps,  while others+-- correspond to none at all.   The ambiguous case occurs when the civil time+-- is rolled back,  making a calendar day longer than 24 hours.  In this case,+-- PostgreSQL silently chooses the second, later possibility.  The inconsistent+-- case occurs when the civil time is moved forward,  making a calendar day less+-- than 24 hours.  In this case,  PostgreSQL silently assumes the local time+-- was read off a clock that had not been moved forward at the prescribed time,+-- and moves the clock forward for you.   Thus,  converting from local time+-- to UTC need not be monotonic,  if these inconsistent cases are allowed.+--+-- When retrieving a @timestamptz@,  the backend looks at the @time zone@+-- connection variable and then consults the IANA TZ database to calculate+-- an offset for the timestamp in the given time zone.+--+-- Note that while some of the information contained in the IANA TZ database+-- is a bit of a standardized fiction, the conversion from UTC time to a+-- (local time, offset) pair in a particular time zone is always unambiguous,+-- and the result can always be unambiguously converted back to UTC.  Thus,+-- hpgsql-simple-compat can interpret such a result as a 'Data.Time.ZonedTime',+-- or use the offset to convert back to 'Data.Time.UTCTime'.+--+-- By contrast, the @timestamp@ type ignores any offsets provided to it,+-- and never sends back an offset.   Thus,  hpgsql-simple-compat equates this+-- with 'Data.Time.LocalTime',  which has no concept of an offset.  One can+-- convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@+-- operator, whose semantics also demonstrates that @timestamptz@ is+-- 'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'.+--+-- PostgreSQL's @timezone@ is a per-connection variable that by default is+-- initialized to @\'localtime\'@,  which normally corresponds to the server's+-- time zone.  However, this default can be modified on the server side for an+-- entire cluster, or on a per-user or per-database basis.  Moreover, a client+-- can modify their instance of the variable at any time,  and can apply that+-- change to the remaining duration of the connection, the current transaction,+-- or the execution context of a server-side function.  In addition, upon+-- connection initialization, the libpq client checks for the existence of+-- the @PGTZ@  environment variable, and if it exists, modifies @timezone@+-- accordingly.+--+-- With a few caveats,  hpgsql-simple-compat is designed so that you can both send+-- and receive timestamps with the server and get a correct result,  no matter+-- what the @timezone@ setting is.  But it is important to understand the caveats:+--+-- 1. The correctness of server-side computations can depend on the @timezone@+--    setting.  Examples include adding an @interval@ to a @timestamptz@, or+--    type casting between @timestamp@ and @timestamptz@,  or applying+--    the @DATE@ function to a @timestamptz@.+--+-- 2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result+--    will depend on the @timezone@ setting,  although the result will always+--    represent the same instant in time regardless of the time zone.+--+-- 3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@+--    can be useful,  as it will be converted to UTC via the tz database,+--    but correctness will depend on the @timezone@ setting.   You may prefer+--    to use an explicit @AT TIME ZONE@ conversion instead, which would avoid+--    this contextual dependence.+--+-- Furthermore,  although these following points don't involve the @timezone@+-- setting, they are related to the last point above:+--+-- 1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can+--    be useful.  In practice,  the most common context used to disambiguate+--    @timestamp@ is that it represents UTC,  and this coding technique will+--    work as expected in this situation.+--+-- 2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is+--    almost always the wrong thing to do,  as the offset will be ignored and+--    discarded.  This is likely to lead to inconsistencies in the database,+--    and may lead to partial data loss.+--+-- When dealing with local timestamps that refer to the future,  it is often+-- useful to store it as a local time in a @timestamp@ column and store the+-- time zone in a second column.  One reason to do this is so that you can+-- convert to UTC on the fly as needed, and be protected against future changes+-- to the TZ database due to changes in local time standards.  In any case,+-- 'Data.Time.ZonedTime' is not suitable for this application, because despite+-- its name,  it represents an offset and not a time zone.  Time zones can change;+-- offsets do not.  In reality,  we can't convert a local timestamp that occurs+-- sufficiently far in the future to UTC, because we don't know how to do it yet.+--+-- There are a few limitations and caveats that one might need to be aware+-- of with the current implementation when dealing with older timestamps:+--+-- For sufficiently old timestamps in almost all time zones,  the IANA TZ+-- database specifies offsets from UTC that is not an integral number of+-- minutes.   This corresponds to local mean time;  that is, astronomical+-- time in the city that defines the time zone.  Different time zones moved+-- away from local mean time to a standard time at different points in+-- history,  so \"sufficiently old\" depends on the time zone in question.+--+-- Thus, when retrieving a @timestamptz@ postgresql will in some cases+-- provide seconds in the offset.  For example:+--+-- @+-- \$ psql+-- psql (9.4.5)+-- Type \"help\" for help.+--+-- lpsmith=> SET timezone TO \'America/New_York\';+-- SET+-- lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz),+--                  (\'1883-11-18 17:00:00+00\'::timestamptz);+--            column1+-- ------------------------------+--  1883-11-18 12:03:57-04:56:02+--  1883-11-18 12:00:00-05+-- (2 rows)+-- @+--+-- Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,+-- however 'Data.Time.ZonedTime' will fail on the former timestamp.+-- Because 'Data.Time.ZonedTime' assumes that offsets are an integer number+-- of minutes,  there isn't an particularly good solution here.+--+-- PostgreSQL,  like most software,  uses the proleptic Gregorian calendar+-- for its date calculations,  extending the Gregorian calendar backwards+-- in time before its introduction and pretending that the Julian calendar+-- does not exist.  For most purposes, the adoption of the Gregorian calendar+-- ranges from @1582-10-15@ to @1923-03-01@,  depending on location and+-- sometimes even political allegiances within a single location.+--+-- Timestamps BCE are not supported.  For example, PostgreSQL+-- will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of+-- the year the Roman Empire adopted the Julian Calendar,  but+-- hpgsql-simple-compat does not (yet?) have the ability to either parse or+-- generate this syntax.   Unfortunately this syntax isn't convenient to+-- print or especially parse.+--+-- Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,+-- which is the Julian date on the proleptic Gregorian Calendar.   Although+-- postgresql's timestamp types are perfectly capable of representing timestamps+-- nearly 300,000 years in the past,  using this would require hpgsql-simple-compat+-- and other client programs to support binary parameters and results.+--+-- Dealing with years BCE is also complicated slightly by the fact that+-- Haskell's time library has a year \"0000\",  which is a convention often+-- used by astronomers,  while postgresql adopts the more historically+-- accurate convention that there is no year zero, but rather \"1 BCE\"+-- was immediately followed by \"1 CE\".+module Database.PostgreSQL.Simple.Time+  ( Unbounded (..),+    Date,+    UTCTimestamp,+    ZonedTimestamp,+    LocalTimestamp,+    parseDay,+    parseUTCTime,+    parseZonedTime,+    parseLocalTime,+    parseTimeOfDay,+    parseDate,+    parseUTCTimestamp,+    parseZonedTimestamp,+    parseLocalTimestamp,+    parseCalendarDiffTime,+    dayToBuilder,+    utcTimeToBuilder,+    zonedTimeToBuilder,+    localTimeToBuilder,+    timeOfDayToBuilder,+    timeZoneToBuilder,+    dateToBuilder,+    utcTimestampToBuilder,+    zonedTimestampToBuilder,+    localTimestampToBuilder,+    unboundedToBuilder,+    nominalDiffTimeToBuilder,+    calendarDiffTimeToBuilder,+  )+where++import Database.PostgreSQL.Simple.Time.Implementation+import Hpgsql.Time (Unbounded (..))

@@ -0,0 +1,157 @@+------------------------------------------------------------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Time.Implementation+-- Copyright:   (c) 2012-2015 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+module Database.PostgreSQL.Simple.Time.Implementation where++import Control.Applicative+import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.ByteString as B+import Data.ByteString.Builder (Builder, byteString)+import Data.ByteString.Builder.Prim (primBounded)+import Data.Maybe (fromMaybe)+import Data.Time.Compat (Day, LocalTime, NominalDiffTime, TimeOfDay, TimeZone, UTCTime, ZonedTime, utc)+import Data.Time.LocalTime.Compat (CalendarDiffTime)+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP+import Hpgsql.Time (Unbounded (..))+import Prelude hiding (take)++type LocalTimestamp = Unbounded LocalTime++type UTCTimestamp = Unbounded UTCTime++type ZonedTimestamp = Unbounded ZonedTime++type Date = Unbounded Day++parseUTCTime :: B.ByteString -> Either String UTCTime+parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput)++parseZonedTime :: B.ByteString -> Either String ZonedTime+parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput)++parseLocalTime :: B.ByteString -> Either String LocalTime+parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput)++parseDay :: B.ByteString -> Either String Day+parseDay = A.parseOnly (getDay <* A.endOfInput)++parseTimeOfDay :: B.ByteString -> Either String TimeOfDay+parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput)++parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp+parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput)++parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp+parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput)++parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp+parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)++parseDate :: B.ByteString -> Either String Date+parseDate = A.parseOnly (getDate <* A.endOfInput)++parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)++getUnbounded :: A.Parser a -> A.Parser (Unbounded a)+getUnbounded getFinite =+  (pure NegInfinity <* A.string "-infinity")+    <|> (pure PosInfinity <* A.string "infinity")+    <|> (Finite <$> getFinite)++getDay :: A.Parser Day+getDay = TP.day++getDate :: A.Parser Date+getDate = getUnbounded getDay++getTimeOfDay :: A.Parser TimeOfDay+getTimeOfDay = TP.timeOfDay++getLocalTime :: A.Parser LocalTime+getLocalTime = TP.localTime++getLocalTimestamp :: A.Parser LocalTimestamp+getLocalTimestamp = getUnbounded getLocalTime++getTimeZone :: A.Parser TimeZone+getTimeZone = fromMaybe utc <$> TP.timeZone++type TimeZoneHMS = (Int, Int, Int)++getTimeZoneHMS :: A.Parser TimeZoneHMS+getTimeZoneHMS = munge <$> TP.timeZoneHMS+  where+    munge Nothing = (0, 0, 0)+    munge (Just (TP.UTCOffsetHMS h m s)) = (h, m, s)++localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)+localToUTCTimeOfDayHMS (dh, dm, ds) tod =+  TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod++getZonedTime :: A.Parser ZonedTime+getZonedTime = TP.zonedTime++getZonedTimestamp :: A.Parser ZonedTimestamp+getZonedTimestamp = getUnbounded getZonedTime++getUTCTime :: A.Parser UTCTime+getUTCTime = TP.utcTime++getUTCTimestamp :: A.Parser UTCTimestamp+getUTCTimestamp = getUnbounded getUTCTime++getCalendarDiffTime :: A.Parser CalendarDiffTime+getCalendarDiffTime = TP.calendarDiffTime++dayToBuilder :: Day -> Builder+dayToBuilder = primBounded TPP.day++timeOfDayToBuilder :: TimeOfDay -> Builder+timeOfDayToBuilder = primBounded TPP.timeOfDay++timeZoneToBuilder :: TimeZone -> Builder+timeZoneToBuilder = primBounded TPP.timeZone++utcTimeToBuilder :: UTCTime -> Builder+utcTimeToBuilder = primBounded TPP.utcTime++zonedTimeToBuilder :: ZonedTime -> Builder+zonedTimeToBuilder = primBounded TPP.zonedTime++localTimeToBuilder :: LocalTime -> Builder+localTimeToBuilder = primBounded TPP.localTime++unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)+unboundedToBuilder finiteToBuilder unbounded =+  case unbounded of+    NegInfinity -> byteString "-infinity"+    Finite a -> finiteToBuilder a+    PosInfinity -> byteString "infinity"++utcTimestampToBuilder :: UTCTimestamp -> Builder+utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder++zonedTimestampToBuilder :: ZonedTimestamp -> Builder+zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder++localTimestampToBuilder :: LocalTimestamp -> Builder+localTimestampToBuilder = unboundedToBuilder localTimeToBuilder++dateToBuilder :: Date -> Builder+dateToBuilder = unboundedToBuilder dayToBuilder++nominalDiffTimeToBuilder :: NominalDiffTime -> Builder+nominalDiffTimeToBuilder = TPP.nominalDiffTime++calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder+calendarDiffTimeToBuilder = TPP.calendarDiffTime

@@ -0,0 +1,27 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Time.Internal+-- Copyright:   (c) 2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+module Database.PostgreSQL.Simple.Time.Internal+  ( getDay,+    getDate,+    getTimeOfDay,+    getLocalTime,+    getLocalTimestamp,+    getTimeZone,+    getZonedTime,+    getZonedTimestamp,+    getUTCTime,+    getUTCTimestamp,+    TimeZoneHMS,+    getTimeZoneHMS,+    localToUTCTimeOfDayHMS,+  ) where++import Database.PostgreSQL.Simple.Time.Implementation

@@ -0,0 +1,210 @@+-- |+-- Module:      Database.PostgreSQL.Simple.Time.Internal.Parser+-- Copyright:   (c) 2012-2015 Leon P Smith+--              (c) 2015 Bryan O'Sullivan+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- Parsers for parsing dates and times.+module Database.PostgreSQL.Simple.Time.Internal.Parser+  ( day,+    localTime,+    timeOfDay,+    timeZone,+    UTCOffsetHMS (..),+    timeZoneHMS,+    localToUTCTimeOfDayHMS,+    utcTime,+    zonedTime,+    calendarDiffTime,+  )+where++import Data.Attoparsec.ByteString.Char8 as A+import Data.Bits ((.&.))+import qualified Data.ByteString.Char8 as B8+import Data.Char (ord)+import Data.Fixed (Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Calendar.Compat (Day, addDays, fromGregorianValid)+import Data.Time.Clock.Compat (UTCTime (..))+import Data.Time.Format.ISO8601.Compat (iso8601ParseM)+import Data.Time.LocalTime.Compat (CalendarDiffTime)+import qualified Data.Time.LocalTime.Compat as Local+import Database.PostgreSQL.Simple.Compat (toPico)++-- | Parse a date of the form @YYYY-MM-DD@.+day :: Parser Day+day = do+  y <- decimal <* char '-'+  m <- twoDigits <* char '-'+  d <- twoDigits+  maybe (fail "invalid date") return (fromGregorianValid y m d)++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+  a <- digit+  b <- digit+  let c2d c = ord c .&. 15+  return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+  h <- twoDigits <* char ':'+  m <- twoDigits+  mc <- peekChar+  s <- case mc of+    Just ':' -> anyChar *> seconds+    _ -> return 0+  if h < 24 && m < 60 && s <= 60+    then return (Local.TimeOfDay h m s)+    else fail "invalid time"++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+  real <- twoDigits+  mc <- peekChar+  case mc of+    Just '.' -> do+      t <- anyChar *> takeWhile1 isDigit+      return $! parsePicos (fromIntegral real) t+    _ -> return $! fromIntegral real+  where+    parsePicos :: Int64 -> B8.ByteString -> Pico+    parsePicos a0 t = toPico (fromIntegral (t' * 10 ^ n))+      where+        n = max 0 (12 - B8.length t)+        t' =+          B8.foldl'+            (\a c -> 10 * a + fromIntegral (ord c .&. 15))+            a0+            (B8.take 12 t)++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+  ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+  if ch == 'Z'+    then return Nothing+    else do+      h <- twoDigits+      mm <- peekChar+      m <- case mm of+        Just ':' -> anyChar *> twoDigits+        _ -> return 0+      let off+            | ch == '-' = negate off0+            | otherwise = off0+          off0 = h * 60 + m+      case undefined of+        _+          | off == 0 ->+              return Nothing+          | h > 23 || m > 59 ->+              fail "invalid time zone offset"+          | otherwise ->+              let !tz = Local.minutesToTimeZone off+               in return (Just tz)++data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)+timeZoneHMS = do+  ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+  if ch == 'Z'+    then return Nothing+    else do+      h <- twoDigits+      m <- maybeTwoDigits+      s <- maybeTwoDigits+      case undefined of+        _+          | h == 0 && m == 0 && s == 0 ->+              return Nothing+          | h > 23 || m >= 60 || s >= 60 ->+              fail "invalid time zone offset"+          | otherwise ->+              if ch == '+'+                then+                  let !tz = UTCOffsetHMS h m s+                   in return (Just tz)+                else+                  let !tz = UTCOffsetHMS (-h) (-m) (-s)+                   in return (Just tz)+  where+    maybeTwoDigits = do+      ch <- peekChar+      case ch of+        Just ':' -> anyChar *> twoDigits+        _ -> return 0++localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =+  (\ !a !b -> (a, b)) dday (Local.TimeOfDay h'' m'' s'')+  where+    s' = s - fromIntegral ds+    (!s'', m')+      | s' < 0 = (s' + 60, m - dm - 1)+      | s' >= 60 = (s' - 60, m - dm + 1)+      | otherwise = (s', m - dm)+    (!m'', h')+      | m' < 0 = (m' + 60, h - dh - 1)+      | m' >= 60 = (m' - 60, h - dh + 1)+      | otherwise = (m', h - dh)+    (!h'', dday)+      | h' < 0 = (h' + 24, -1)+      | h' >= 24 = (h' - 24, 1)+      | otherwise = (h', 0)++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.+-- The space may be replaced with a @T@.  The number of seconds may be+-- followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+  where+    daySep = satisfy (\c -> c == ' ' || c == 'T')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+  (Local.LocalTime d t) <- localTime+  mtz <- timeZoneHMS+  case mtz of+    Nothing ->+      let !tt = Local.timeOfDayToTime t+       in return (UTCTime d tt)+    Just tz ->+      let !(dd, t') = localToUTCTimeOfDayHMS tz t+          !d' = addDays dd d+          !tt = Local.timeOfDayToTime t'+       in return (UTCTime d' tt)++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM:SS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++utc :: Local.TimeZone+utc = Local.TimeZone 0 False ""++calendarDiffTime :: Parser CalendarDiffTime+calendarDiffTime = do+  contents <- takeByteString+  iso8601ParseM $ B8.unpack contents

@@ -0,0 +1,155 @@+------------------------------------------------------------------------------+-- Module:      Database.PostgreSQL.Simple.Time.Internal.Printer+-- Copyright:   (c) 2012-2015 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time.Internal.Printer+  ( day,+    timeOfDay,+    timeZone,+    utcTime,+    localTime,+    zonedTime,+    nominalDiffTime,+    calendarDiffTime,+  )+where++import Control.Arrow ((>>>))+import Data.ByteString.Builder (Builder, byteString, integerDec)+import Data.ByteString.Builder.Prim+  ( BoundedPrim,+    FixedPrim,+    char8,+    condB,+    emptyB,+    int32Dec,+    liftFixedToBounded,+    primBounded,+    (>$<),+    (>*<),+  )+import Data.Char (chr)+import Data.Int (Int32, Int64)+import Data.String (fromString)+import Data.Time.Compat+  ( Day,+    LocalTime (..),+    NominalDiffTime,+    TimeOfDay (..),+    TimeZone,+    UTCTime (..),+    ZonedTime (..),+    timeToTimeOfDay,+    timeZoneMinutes,+    toGregorian,+  )+import Data.Time.Format.ISO8601.Compat (iso8601Show)+import Data.Time.LocalTime.Compat (CalendarDiffTime)+import Database.PostgreSQL.Simple.Compat (fromPico)+import Unsafe.Coerce (unsafeCoerce)++liftB :: FixedPrim a -> BoundedPrim a+liftB = liftFixedToBounded++digit :: FixedPrim Int+digit = (\x -> chr (x + 48)) >$< char8++digits2 :: FixedPrim Int+digits2 = (`quotRem` 10) >$< (digit >*< digit)++digits3 :: FixedPrim Int+digits3 = (`quotRem` 10) >$< (digits2 >*< digit)++digits4 :: FixedPrim Int+digits4 = (`quotRem` 10) >$< (digits3 >*< digit)++frac :: BoundedPrim Int64+frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))+  where+    trunc12 :: BoundedPrim Int64+    trunc12 =+      (`quotRem` 1000000)+        >$< condB+          (\(_, y) -> y == 0)+          (fst >$< trunc6)+          (liftB digits6 >*< trunc6)++    digitB = liftB digit++    digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)+    digits5 = (`quotRem` 10) >$< (digits4 >*< digit)++    trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)+    trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))+    trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))+    trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))+    trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))+    trunc1 = condB (== 0) emptyB digitB++year :: BoundedPrim Int32+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)+  where+    checkBCE :: Int32 -> Int+    checkBCE y+      | y > 0 = fromIntegral y+      | otherwise = error msg++    msg = "Database.PostgreSQL.Simple.Time.Printer.year:  years BCE not supported"++day :: BoundedPrim Day+day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))+  where+    toYMD (toGregorian -> (fromIntegral -> !y, !m, !d)) = (y, ('-', (m, ('-', d))))++timeOfDay :: BoundedPrim TimeOfDay+timeOfDay = f >$< (hh_mm_ >*< ss)+  where+    f (TimeOfDay h m s) = ((h, (':', (m, ':'))), s)++    hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)++    ss =+      (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000)+        >$< (liftB (fromIntegral >$< digits2) >*< frac)++timeZone :: BoundedPrim TimeZone+timeZone = timeZoneMinutes >$< tz+  where+    tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)++    tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))++    tzm = condB (== 0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))++utcTime :: BoundedPrim UTCTime+utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)+  where+    f (UTCTime d (timeToTimeOfDay -> tod)) = (d, (' ', (tod, 'Z')))++localTime :: BoundedPrim LocalTime+localTime = f >$< (day >*< liftB char8 >*< timeOfDay)+  where+    f (LocalTime d tod) = (d, (' ', tod))++zonedTime :: BoundedPrim ZonedTime+zonedTime = f >$< (localTime >*< timeZone)+  where+    f (ZonedTime lt tz) = (lt, tz)++nominalDiffTime :: NominalDiffTime -> Builder+nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))+  where+    (x, y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000++calendarDiffTime :: CalendarDiffTime -> Builder+calendarDiffTime =+  byteString+    . fromString+    -- from the docs: "Beware: fromString truncates multi-byte characters to octets".+    -- However, I think this is a safe usage, because ISO8601-encoding seems restricted+    -- to ASCII output.+    . iso8601Show

@@ -0,0 +1,158 @@+{-# LANGUAGE UndecidableInstances #-}++------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.ToField+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- The 'ToField' typeclass, for rendering a parameter to a SQL query.+module Database.PostgreSQL.Simple.ToField+  ( Action (..),+    ToField (..),+    ToPgField (..),+    toJSONField,+  )+where++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (CI)+import Data.Int (Int16, Int32, Int64)+import Data.Proxy (Proxy (..))+import Data.Scientific (Scientific)+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+import Data.Time.Calendar.Compat (Day)+import Data.Time.Compat (CalendarDiffTime, NominalDiffTime, UTCTime, ZonedTime)+import Data.Time.LocalTime.Compat (LocalTime, TimeOfDay)+import Data.Typeable (Typeable)+import Data.UUID.Types (UUID)+import Data.Vector (Vector)+import Hpgsql.Builder (BinaryField (..))+import Hpgsql.Encoding (EncodingContext, FieldEncoder (toTypeOid), ToPgField (..))+import Hpgsql.Query (encodeParam)+import Hpgsql.Time (Unbounded (..))+import Hpgsql.TypeInfo (Oid)+import Hpgsql.Types (Aeson, PGArray)++-- | How to render an element when substituting it into a query.+data Action+  = QueryArgument (EncodingContext -> (Maybe Oid, BinaryField))+  | -- | Escape before substituting. Use for all sql identifiers like+    -- table, column names, etc. This is used by the 'Identifier' newtype+    -- wrapper.+    EscapeIdentifier ByteString+  | -- | Concatenate a series of rendering actions.+    Many [Action]+  | -- | Just a static SQL fragment to render+    Plain LB.ByteString+  deriving (Typeable)++instance Show Action where+  show (QueryArgument _) = "QueryArgument"+  show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b+  show (Many b) = "Many " ++ show b+  show (Plain b) = "Plain " ++ show b++-- | A type that may be used as a single parameter to a SQL query.+class ToField a where+  toField :: a -> Action+  default toField :: (ToPgField a) => a -> Action+  toField v = QueryArgument $ encodeParam v++instance ToField Action where+  toField v = v++instance ToField Int++instance ToField Int16++instance ToField Int32++instance ToField Int64++instance ToField Integer++instance ToField Oid++instance ToField Scientific++instance ToField Rational++instance ToField Float++instance ToField Double++instance ToField Bool++instance ToField Day++instance ToField CalendarDiffTime++instance ToField NominalDiffTime++instance ToField UTCTime++instance ToField ZonedTime++instance ToField LocalTime++instance ToField TimeOfDay++instance ToField Char++instance ToField ByteString++instance ToField LB.ByteString++instance ToField Text++instance ToField LT.Text++instance ToField String++instance ToField Aeson.Value++instance ToField UUID++instance ToField (CI Text)++instance ToField (CI LT.Text)++instance ToField (CI String)++instance ToField (Unbounded Day)++instance ToField (Unbounded UTCTime)++instance ToField (Unbounded ZonedTime)++class HasFieldType a where+  fieldTypeOid :: Proxy a -> EncodingContext -> Maybe Oid++instance (ToPgField a) => HasFieldType a where+  fieldTypeOid _ = toTypeOid (fieldEncoder @a)++instance forall a. (ToField a, HasFieldType a) => ToField (Maybe a) where+  toField = \case+    Nothing -> QueryArgument $ \encCtx -> (fieldTypeOid (Proxy @a) encCtx, SqlNull)+    Just v -> case toField v of+      QueryArgument enc -> QueryArgument enc+      _ -> error "hpgsql-simple-compat does not support (ToField (Maybe a)) instances that aren't simple query arguments"++instance (ToPgField a) => ToField (Vector a)++instance (ToPgField a) => ToField (PGArray a)++instance (Aeson.ToJSON a) => ToField (Aeson a)++toJSONField :: (Aeson.ToJSON a) => a -> Action+toJSONField v = QueryArgument $ encodeParam $ Aeson.toJSON v

@@ -0,0 +1,1 @@+module Database.PostgreSQL.Simple.ToField where

@@ -0,0 +1,128 @@+{-# LANGUAGE UndecidableInstances #-}++------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.ToRow+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- The 'ToRow' typeclass, for rendering a collection of+-- parameters to a SQL query.+--+-- Predefined instances are provided for tuples containing up to ten+-- elements.+module Database.PostgreSQL.Simple.ToRow+  ( ToRow (..),+    ToPgRow (..),+  )+where++import Data.Functor.Contravariant (Contravariant (..))+import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))+import GHC.Generics (Generic (..), K1 (..), M1 (..), type (:*:) (..))+import Hpgsql.Encoding (ToPgRow (..))+import Hpgsql.Types (Only (..), (:.) (..))++-- | A collection type that can be turned into a list of rendering+-- 'Action's.+--+-- Instances should use the 'toField' method of the 'ToField' class+-- to perform conversion of each element of the collection.+--+-- You can derive 'ToRow' for your data type using GHC generics, like this:+--+-- @+-- \{-# LANGUAGE DeriveAnyClass \#-}+-- \{-# LANGUAGE DeriveGeneric  \#-}+--+-- import "GHC.Generics" ('GHC.Generics.Generic')+-- import "Database.PostgreSQL.Simple" ('ToRow')+--+-- data User = User { name :: String, fileQuota :: Int }+--   deriving ('GHC.Generics.Generic', 'ToRow')+-- @+--+-- Note that this only works for product types (e.g. records) and does not+-- support sum types or recursive types.+class ToRow a where+  toRow :: a -> [Action]+  default toRow :: (Generic a, ProductTypeEncoder (Rep a)) => a -> [Action]+  toRow = toPgParams genericToPgRow+  -- ^ ToField a collection of values.++instance ToRow () where+  toRow () = []++instance (ToField a) => ToRow (Only a) where+  toRow (Only v) = [toField v]++instance (ToField a, ToField b) => ToRow (a, b) where+  toRow (a, b) = [toField a, toField b]++instance (ToField a, ToField b, ToField c) => ToRow (a, b, c) where+  toRow (a, b, c) = [toField a, toField b, toField c]++instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a, b, c, d) where+  toRow (a, b, c, d) = [toField a, toField b, toField c, toField d]++instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a, b, c, d, e) where+  toRow (a, b, c, d, e) = [toField a, toField b, toField c, toField d, toField e]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a, b, c, d, e, f) where+  toRow (a, b, c, d, e, f) = [toField a, toField b, toField c, toField d, toField e, toField f]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a, b, c, d, e, f, g) where+  toRow (a, b, c, d, e, f, g) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) => ToRow (a, b, c, d, e, f, g, h) where+  toRow (a, b, c, d, e, f, g, h) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i) => ToRow (a, b, c, d, e, f, g, h, i) where+  toRow (a, b, c, d, e, f, g, h, i) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j) => ToRow (a, b, c, d, e, f, g, h, i, j) where+  toRow (a, b, c, d, e, f, g, h, i, j) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k) => ToRow (a, b, c, d, e, f, g, h, i, j, k) where+  toRow (a, b, c, d, e, f, g, h, i, j, k) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k]++instance (ToField a) => ToRow [a] where+  toRow = map toField++instance (ToRow a, ToRow b) => ToRow (a :. b) where+  toRow (a :. b) = toRow a ++ toRow b++-- | This is a simplified version of hpgsql's RowEncoder; it contains just as much as necessary+-- for this module.+newtype RowEncoder a = RowEncoder {toPgParams :: a -> [Action]}++instance Contravariant RowEncoder where+  contramap f rec = RowEncoder (\v -> (toPgParams rec) (f v))++-- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that.+divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a+divide d re1 re2 =+  RowEncoder+    { toPgParams = \a -> let (b, c) = d a in (toPgParams re1) b ++ (toPgParams re2) c+    }++genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a+genericToPgRow = contramap from genRowEncoder++class ProductTypeEncoder f where+  genRowEncoder :: RowEncoder (f a)++instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where+  genRowEncoder = divide (\(a :*: b) -> (a, b)) genRowEncoder genRowEncoder++instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where+  genRowEncoder = contramap unM1 genRowEncoder++instance (ToField a) => ProductTypeEncoder (K1 r a) where+  genRowEncoder = contramap unK1 (RowEncoder $ (: []) . toField)

@@ -0,0 +1,2 @@++module Database.PostgreSQL.Simple.ToRow () where

@@ -0,0 +1,264 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Transaction+-- Copyright:   (c) 2011-2013 Leon P Smith+--              (c) 2013 Joey Adams+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+module Database.PostgreSQL.Simple.Transaction+  ( -- * Transaction handling+    withTransaction,+    withTransactionLevel,+    withTransactionMode,+    withTransactionModeRetry,+    withTransactionModeRetry',+    withTransactionSerializable,+    TransactionMode (..),+    IsolationLevel (..),+    ReadWriteMode (..),+    defaultTransactionMode,+    defaultIsolationLevel,+    defaultReadWriteMode,+    --    , Base.autocommit+    begin,+    beginLevel,+    beginMode,+    commit,+    rollback,++    -- * Savepoint+    withSavepoint,+    Savepoint,+    newSavepoint,+    releaseSavepoint,+    rollbackToSavepoint,+    rollbackToAndReleaseSavepoint,++    -- * Error predicates+    isSerializationError,+    isNoActiveTransactionError,+    isFailedTransactionError,+  )+where++import qualified Control.Exception as E+import qualified Data.ByteString as B+import Database.PostgreSQL.Simple.Compat (mask)+import Database.PostgreSQL.Simple.Errors+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.Types++-- | Of the four isolation levels defined by the SQL standard,+-- these are the three levels distinguished by PostgreSQL as of version 9.0.+-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>+-- for more information.   Note that prior to PostgreSQL 9.0, 'RepeatableRead'+-- was equivalent to 'Serializable'.+data IsolationLevel+  = -- | the isolation level will be taken from+    --   PostgreSQL's per-connection+    --   @default_transaction_isolation@ variable,+    --   which is initialized according to the+    --   server's config.  The default configuration+    --   is 'ReadCommitted'.+    DefaultIsolationLevel+  | ReadCommitted+  | RepeatableRead+  | Serializable+  deriving (Show, Eq, Ord, Enum, Bounded)++data ReadWriteMode+  = -- | the read-write mode will be taken from+    --   PostgreSQL's per-connection+    --   @default_transaction_read_only@ variable,+    --   which is initialized according to the+    --   server's config.  The default configuration+    --   is 'ReadWrite'.+    DefaultReadWriteMode+  | ReadWrite+  | ReadOnly+  deriving (Show, Eq, Ord, Enum, Bounded)++data TransactionMode = TransactionMode+  { isolationLevel :: !IsolationLevel,+    readWriteMode :: !ReadWriteMode+  }+  deriving (Show, Eq)++defaultTransactionMode :: TransactionMode+defaultTransactionMode =+  TransactionMode+    defaultIsolationLevel+    defaultReadWriteMode++defaultIsolationLevel :: IsolationLevel+defaultIsolationLevel = DefaultIsolationLevel++defaultReadWriteMode :: ReadWriteMode+defaultReadWriteMode = DefaultReadWriteMode++-- | Execute an action inside a SQL transaction.+--+-- This function initiates a transaction with a \"@begin+-- transaction@\" statement, then executes the supplied action.  If+-- the action succeeds, the transaction will be completed with+-- 'Base.commit' before this function returns.+--+-- If the action throws /any/ kind of exception (not just a+-- PostgreSQL-related exception), the transaction will be rolled back using+-- 'rollback', then the exception will be rethrown.+--+-- For nesting transactions, see 'withSavepoint'.+withTransaction :: Connection -> IO a -> IO a+withTransaction = withTransactionMode defaultTransactionMode++-- | Execute an action inside of a 'Serializable' transaction.  If a+-- serialization failure occurs, roll back the transaction and try again.+-- Be warned that this may execute the IO action multiple times.+--+-- A 'Serializable' transaction creates the illusion that your program has+-- exclusive access to the database.  This means that, even in a concurrent+-- setting, you can perform queries in sequence without having to worry about+-- what might happen between one statement and the next.+--+-- Think of it as STM, but without @retry@.+withTransactionSerializable :: Connection -> IO a -> IO a+withTransactionSerializable =+  withTransactionModeRetry+    TransactionMode+      { isolationLevel = Serializable,+        readWriteMode = ReadWrite+      }+    isSerializationError++-- | Execute an action inside a SQL transaction with a given isolation level.+withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a+withTransactionLevel lvl =+  withTransactionMode defaultTransactionMode {isolationLevel = lvl}++-- | Execute an action inside a SQL transaction with a given transaction mode.+withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a+withTransactionMode mode conn act =+  mask $ \restore -> do+    beginMode mode conn+    r <- restore act `E.onException` rollback_ conn+    commit conn+    return r++-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry = withTransactionModeRetry'++-- | Like 'withTransactionMode', but also takes a custom callback to+-- determine if a transaction should be retried if an exception occurs.+-- If the callback returns 'True', then the transaction will be retried.+-- If the callback returns 'False', or an exception other than an @e@+-- occurs then the transaction will be rolled back and the exception rethrown.+--+-- This is used to implement 'withTransactionSerializable'.+withTransactionModeRetry' :: forall a e. (E.Exception e) => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry' mode shouldRetry conn act =+  mask $ \restore ->+    retryLoop $ E.try $ do+      a <- restore act `E.onException` rollback_ conn+      commit conn+      return a+  where+    retryLoop :: IO (Either e a) -> IO a+    retryLoop act' = do+      beginMode mode conn+      r <- act'+      case r of+        Left e ->+          case shouldRetry e of+            True -> retryLoop act'+            False -> E.throwIO e+        Right a ->+          return a++-- | Rollback a transaction.+rollback :: Connection -> IO ()+rollback conn = execute_ conn "ROLLBACK" >> return ()++-- | Rollback a transaction, ignoring any @IOErrors@+rollback_ :: Connection -> IO ()+rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()++-- | Commit a transaction.+commit :: Connection -> IO ()+commit conn = execute_ conn "COMMIT" >> return ()++-- | Begin a transaction.+begin :: Connection -> IO ()+begin = beginMode defaultTransactionMode++-- | Begin a transaction with a given isolation level+beginLevel :: IsolationLevel -> Connection -> IO ()+beginLevel lvl = beginMode defaultTransactionMode {isolationLevel = lvl}++-- | Begin a transaction with a given transaction mode+beginMode :: TransactionMode -> Connection -> IO ()+beginMode mode conn = do+  _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])+  return ()+  where+    isolevel = case isolationLevel mode of+      DefaultIsolationLevel -> ""+      ReadCommitted -> " ISOLATION LEVEL READ COMMITTED"+      RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"+      Serializable -> " ISOLATION LEVEL SERIALIZABLE"+    readmode = case readWriteMode mode of+      DefaultReadWriteMode -> ""+      ReadWrite -> " READ WRITE"+      ReadOnly -> " READ ONLY"++------------------------------------------------------------------------+-- Savepoint++-- | Create a savepoint, and roll back to it if an error occurs.  This may only+-- be used inside of a transaction, and provides a sort of+-- \"nested transaction\".+--+-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>+withSavepoint :: Connection -> IO a -> IO a+withSavepoint conn body =+  mask $ \restore -> do+    sp <- newSavepoint conn+    r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp+    releaseSavepoint conn sp `E.catch` \err ->+      if isFailedTransactionError err+        then rollbackToAndReleaseSavepoint conn sp+        else E.throwIO err+    return r++-- | Create a new savepoint.  This may only be used inside of a transaction.+newSavepoint :: Connection -> IO Savepoint+newSavepoint conn = do+  name <- newTempName conn+  _ <- execute_ conn ("SAVEPOINT " <> name)+  return (Savepoint name)++-- | Destroy a savepoint, but retain its effects.+--+-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if+-- the transaction is aborted due to an error.  'commit' would merely warn and+-- roll back.+releaseSavepoint :: Connection -> Savepoint -> IO ()+releaseSavepoint conn (Savepoint name) =+  execute_ conn ("RELEASE SAVEPOINT " <> name) >> return ()++-- | Roll back to a savepoint.  This will not release the savepoint.+rollbackToSavepoint :: Connection -> Savepoint -> IO ()+rollbackToSavepoint conn (Savepoint name) =+  execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return ()++-- | Roll back to a savepoint and release it.  This is like calling+-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a+-- round trip to the database server.+rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO ()+rollbackToAndReleaseSavepoint conn (Savepoint name) =+  execute_ conn sql >> return ()+  where+    sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name

@@ -0,0 +1,54 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- This module provides convenient and efficient access to parts of the+-- @pg_type@ metatable.  At the moment, this requires PostgreSQL 8.4 if+-- you need to work with types that do not appear in+-- 'Database.PostgreSQL.Simple.TypeInfo.Static'.+--+-- The current scheme could be more efficient, especially for some use+-- cases.  In particular,  connection pools that use many user-added+-- types and connect to a set of servers with identical (or at least+-- compatible) @pg_type@ and associated tables could share a common+-- typeinfo cache,  thus saving memory and communication between the+-- client and server.+module Database.PostgreSQL.Simple.TypeInfo+  ( getTypeInfo,+    TypeInfo (..),+    Attribute (..),+  )+where++import Control.Concurrent.MVar+import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.TypeInfo.Static+import Database.PostgreSQL.Simple.TypeInfo.Types+import Hpgsql.Encoding ()++-- | Returns the metadata of the type with a particular oid.  To find+--   this data, 'getTypeInfo' first consults hpgsql-simple-compat's+--   built-in 'staticTypeInfo' table,  then checks  the connection's+--   typeinfo cache.   Finally,  the database's 'pg_type' table will+--   be queried only if necessary,  and the result will be stored+--   in the connections's cache.+getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo+getTypeInfo conn@Connection {..} oid' =+  case staticTypeInfo oid' of+    Just name' -> return name'+    Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'++getTypeInfo' ::+  Connection ->+  PQ.Oid ->+  TypeInfoCache ->+  IO (TypeInfoCache, TypeInfo)+getTypeInfo' _conn _oid' _oidmap = error "TODO getTypeInfo'"

@@ -0,0 +1,46 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo.Macro+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- A Template Haskell macro for efficiently checking membership in+-- a set of type oids.+module Database.PostgreSQL.Simple.TypeInfo.Macro+  ( mkCompats,+    inlineTypoid,+  ) where++import Database.PostgreSQL.Simple.TypeInfo.Static+import Database.PostgreSQL.Simple.Types (Oid (..))+import Language.Haskell.TH++-- | Returns an expression that has type @'Oid' -> 'Bool'@,  true if the+--   oid is equal to any one of the 'typoid's of the given 'TypeInfo's.+mkCompats :: [TypeInfo] -> ExpQ+mkCompats tys = do+  x <- newName "x"+  lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])+  where+    alt :: TypeInfo -> MatchQ+    alt ty = match (inlineTypoidP ty) (normalB [|True|]) []++    catchAll :: MatchQ+    catchAll = match wildP (normalB [|False|]) []++-- | Literally substitute the 'typoid' of a 'TypeInfo' expression.+--   Returns an expression of type 'Oid'.  Useful because GHC tends+--   not to fold constants.+inlineTypoid :: TypeInfo -> ExpQ+inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)++inlineTypoidP :: TypeInfo -> PatQ+inlineTypoidP ty = litP (getTypoid ty)++getTypoid :: TypeInfo -> Lit+getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)

@@ -0,0 +1,1689 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- Note that this file is generated by tools/GenTypeInfo.hs, and should+-- not be edited directly++-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo+-- Copyright:   (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- This module contains portions of the @pg_type@ table that are relevant+-- to hpgsql-simple-compat and are believed to not change between PostgreSQL+-- versions.+module Database.PostgreSQL.Simple.TypeInfo.Static+  ( TypeInfo (..),+    staticTypeInfo,+    bool,+    boolOid,+    bytea,+    byteaOid,+    char,+    charOid,+    name,+    nameOid,+    int8,+    int8Oid,+    int2,+    int2Oid,+    int4,+    int4Oid,+    regproc,+    regprocOid,+    text,+    textOid,+    oid,+    oidOid,+    tid,+    tidOid,+    xid,+    xidOid,+    cid,+    cidOid,+    xml,+    xmlOid,+    point,+    pointOid,+    lseg,+    lsegOid,+    path,+    pathOid,+    box,+    boxOid,+    polygon,+    polygonOid,+    line,+    lineOid,+    cidr,+    cidrOid,+    float4,+    float4Oid,+    float8,+    float8Oid,+    unknown,+    unknownOid,+    circle,+    circleOid,+    money,+    moneyOid,+    macaddr,+    macaddrOid,+    inet,+    inetOid,+    bpchar,+    bpcharOid,+    varchar,+    varcharOid,+    date,+    dateOid,+    time,+    timeOid,+    timestamp,+    timestampOid,+    timestamptz,+    timestamptzOid,+    interval,+    intervalOid,+    timetz,+    timetzOid,+    bit,+    bitOid,+    varbit,+    varbitOid,+    numeric,+    numericOid,+    refcursor,+    refcursorOid,+    record,+    recordOid,+    void,+    voidOid,+    array_record,+    array_recordOid,+    regprocedure,+    regprocedureOid,+    regoper,+    regoperOid,+    regoperator,+    regoperatorOid,+    regclass,+    regclassOid,+    regtype,+    regtypeOid,+    uuid,+    uuidOid,+    json,+    jsonOid,+    jsonb,+    jsonbOid,+    int2vector,+    int2vectorOid,+    oidvector,+    oidvectorOid,+    array_xml,+    array_xmlOid,+    array_json,+    array_jsonOid,+    array_line,+    array_lineOid,+    array_cidr,+    array_cidrOid,+    array_circle,+    array_circleOid,+    array_money,+    array_moneyOid,+    array_bool,+    array_boolOid,+    array_bytea,+    array_byteaOid,+    array_char,+    array_charOid,+    array_name,+    array_nameOid,+    array_int2,+    array_int2Oid,+    array_int2vector,+    array_int2vectorOid,+    array_int4,+    array_int4Oid,+    array_regproc,+    array_regprocOid,+    array_text,+    array_textOid,+    array_tid,+    array_tidOid,+    array_xid,+    array_xidOid,+    array_cid,+    array_cidOid,+    array_oidvector,+    array_oidvectorOid,+    array_bpchar,+    array_bpcharOid,+    array_varchar,+    array_varcharOid,+    array_int8,+    array_int8Oid,+    array_point,+    array_pointOid,+    array_lseg,+    array_lsegOid,+    array_path,+    array_pathOid,+    array_box,+    array_boxOid,+    array_float4,+    array_float4Oid,+    array_float8,+    array_float8Oid,+    array_polygon,+    array_polygonOid,+    array_oid,+    array_oidOid,+    array_macaddr,+    array_macaddrOid,+    array_inet,+    array_inetOid,+    array_timestamp,+    array_timestampOid,+    array_date,+    array_dateOid,+    array_time,+    array_timeOid,+    array_timestamptz,+    array_timestamptzOid,+    array_interval,+    array_intervalOid,+    array_numeric,+    array_numericOid,+    array_timetz,+    array_timetzOid,+    array_bit,+    array_bitOid,+    array_varbit,+    array_varbitOid,+    array_refcursor,+    array_refcursorOid,+    array_regprocedure,+    array_regprocedureOid,+    array_regoper,+    array_regoperOid,+    array_regoperator,+    array_regoperatorOid,+    array_regclass,+    array_regclassOid,+    array_regtype,+    array_regtypeOid,+    array_uuid,+    array_uuidOid,+    array_jsonb,+    array_jsonbOid,+    int4range,+    int4rangeOid,+    _int4range,+    _int4rangeOid,+    numrange,+    numrangeOid,+    _numrange,+    _numrangeOid,+    tsrange,+    tsrangeOid,+    _tsrange,+    _tsrangeOid,+    tstzrange,+    tstzrangeOid,+    _tstzrange,+    _tstzrangeOid,+    daterange,+    daterangeOid,+    _daterange,+    _daterangeOid,+    int8range,+    int8rangeOid,+    _int8range,+    _int8rangeOid,+  )+where++import Database.PostgreSQL.LibPQ (Oid (..))+import Database.PostgreSQL.Simple.TypeInfo.Types++staticTypeInfo :: Oid -> Maybe TypeInfo+staticTypeInfo (Oid x) = case x of+  16 -> Just bool+  17 -> Just bytea+  18 -> Just char+  19 -> Just name+  20 -> Just int8+  21 -> Just int2+  23 -> Just int4+  24 -> Just regproc+  25 -> Just text+  26 -> Just oid+  27 -> Just tid+  28 -> Just xid+  29 -> Just cid+  142 -> Just xml+  600 -> Just point+  601 -> Just lseg+  602 -> Just path+  603 -> Just box+  604 -> Just polygon+  628 -> Just line+  650 -> Just cidr+  700 -> Just float4+  701 -> Just float8+  705 -> Just unknown+  718 -> Just circle+  790 -> Just money+  829 -> Just macaddr+  869 -> Just inet+  1042 -> Just bpchar+  1043 -> Just varchar+  1082 -> Just date+  1083 -> Just time+  1114 -> Just timestamp+  1184 -> Just timestamptz+  1186 -> Just interval+  1266 -> Just timetz+  1560 -> Just bit+  1562 -> Just varbit+  1700 -> Just numeric+  1790 -> Just refcursor+  2249 -> Just record+  2278 -> Just void+  2287 -> Just array_record+  2202 -> Just regprocedure+  2203 -> Just regoper+  2204 -> Just regoperator+  2205 -> Just regclass+  2206 -> Just regtype+  2950 -> Just uuid+  114 -> Just json+  3802 -> Just jsonb+  22 -> Just int2vector+  30 -> Just oidvector+  143 -> Just array_xml+  199 -> Just array_json+  629 -> Just array_line+  651 -> Just array_cidr+  719 -> Just array_circle+  791 -> Just array_money+  1000 -> Just array_bool+  1001 -> Just array_bytea+  1002 -> Just array_char+  1003 -> Just array_name+  1005 -> Just array_int2+  1006 -> Just array_int2vector+  1007 -> Just array_int4+  1008 -> Just array_regproc+  1009 -> Just array_text+  1010 -> Just array_tid+  1011 -> Just array_xid+  1012 -> Just array_cid+  1013 -> Just array_oidvector+  1014 -> Just array_bpchar+  1015 -> Just array_varchar+  1016 -> Just array_int8+  1017 -> Just array_point+  1018 -> Just array_lseg+  1019 -> Just array_path+  1020 -> Just array_box+  1021 -> Just array_float4+  1022 -> Just array_float8+  1027 -> Just array_polygon+  1028 -> Just array_oid+  1040 -> Just array_macaddr+  1041 -> Just array_inet+  1115 -> Just array_timestamp+  1182 -> Just array_date+  1183 -> Just array_time+  1185 -> Just array_timestamptz+  1187 -> Just array_interval+  1231 -> Just array_numeric+  1270 -> Just array_timetz+  1561 -> Just array_bit+  1563 -> Just array_varbit+  2201 -> Just array_refcursor+  2207 -> Just array_regprocedure+  2208 -> Just array_regoper+  2209 -> Just array_regoperator+  2210 -> Just array_regclass+  2211 -> Just array_regtype+  2951 -> Just array_uuid+  3807 -> Just array_jsonb+  3904 -> Just int4range+  3905 -> Just _int4range+  3906 -> Just numrange+  3907 -> Just _numrange+  3908 -> Just tsrange+  3909 -> Just _tsrange+  3910 -> Just tstzrange+  3911 -> Just _tstzrange+  3912 -> Just daterange+  3913 -> Just _daterange+  3926 -> Just int8range+  3927 -> Just _int8range+  _ -> Nothing++bool :: TypeInfo+bool =+  Basic+    { typoid = boolOid,+      typname = "bool"+    }++boolOid :: Oid+boolOid = Oid 16+{-# INLINE boolOid #-}++bytea :: TypeInfo+bytea =+  Basic+    { typoid = byteaOid,+      typname = "bytea"+    }++byteaOid :: Oid+byteaOid = Oid 17+{-# INLINE byteaOid #-}++char :: TypeInfo+char =+  Basic+    { typoid = charOid,+      typname = "char"+    }++charOid :: Oid+charOid = Oid 18+{-# INLINE charOid #-}++name :: TypeInfo+name =+  Basic+    { typoid = nameOid,+      typname = "name"+    }++nameOid :: Oid+nameOid = Oid 19+{-# INLINE nameOid #-}++int8 :: TypeInfo+int8 =+  Basic+    { typoid = int8Oid,+      typname = "int8"+    }++int8Oid :: Oid+int8Oid = Oid 20+{-# INLINE int8Oid #-}++int2 :: TypeInfo+int2 =+  Basic+    { typoid = int2Oid,+      typname = "int2"+    }++int2Oid :: Oid+int2Oid = Oid 21+{-# INLINE int2Oid #-}++int4 :: TypeInfo+int4 =+  Basic+    { typoid = int4Oid,+      typname = "int4"+    }++int4Oid :: Oid+int4Oid = Oid 23+{-# INLINE int4Oid #-}++regproc :: TypeInfo+regproc =+  Basic+    { typoid = regprocOid,+      typname = "regproc"+    }++regprocOid :: Oid+regprocOid = Oid 24+{-# INLINE regprocOid #-}++text :: TypeInfo+text =+  Basic+    { typoid = textOid,+      typname = "text"+    }++textOid :: Oid+textOid = Oid 25+{-# INLINE textOid #-}++oid :: TypeInfo+oid =+  Basic+    { typoid = oidOid,+      typname = "oid"+    }++oidOid :: Oid+oidOid = Oid 26+{-# INLINE oidOid #-}++tid :: TypeInfo+tid =+  Basic+    { typoid = tidOid,+      typname = "tid"+    }++tidOid :: Oid+tidOid = Oid 27+{-# INLINE tidOid #-}++xid :: TypeInfo+xid =+  Basic+    { typoid = xidOid,+      typname = "xid"+    }++xidOid :: Oid+xidOid = Oid 28+{-# INLINE xidOid #-}++cid :: TypeInfo+cid =+  Basic+    { typoid = cidOid,+      typname = "cid"+    }++cidOid :: Oid+cidOid = Oid 29+{-# INLINE cidOid #-}++xml :: TypeInfo+xml =+  Basic+    { typoid = xmlOid,+      typname = "xml"+    }++xmlOid :: Oid+xmlOid = Oid 142+{-# INLINE xmlOid #-}++point :: TypeInfo+point =+  Basic+    { typoid = pointOid,+      typname = "point"+    }++pointOid :: Oid+pointOid = Oid 600+{-# INLINE pointOid #-}++lseg :: TypeInfo+lseg =+  Basic+    { typoid = lsegOid,+      typname = "lseg"+    }++lsegOid :: Oid+lsegOid = Oid 601+{-# INLINE lsegOid #-}++path :: TypeInfo+path =+  Basic+    { typoid = pathOid,+      typname = "path"+    }++pathOid :: Oid+pathOid = Oid 602+{-# INLINE pathOid #-}++box :: TypeInfo+box =+  Basic+    { typoid = boxOid,+      typname = "box"+    }++boxOid :: Oid+boxOid = Oid 603+{-# INLINE boxOid #-}++polygon :: TypeInfo+polygon =+  Basic+    { typoid = polygonOid,+      typname = "polygon"+    }++polygonOid :: Oid+polygonOid = Oid 604+{-# INLINE polygonOid #-}++line :: TypeInfo+line =+  Basic+    { typoid = lineOid,+      typname = "line"+    }++lineOid :: Oid+lineOid = Oid 628+{-# INLINE lineOid #-}++cidr :: TypeInfo+cidr =+  Basic+    { typoid = cidrOid,+      typname = "cidr"+    }++cidrOid :: Oid+cidrOid = Oid 650+{-# INLINE cidrOid #-}++float4 :: TypeInfo+float4 =+  Basic+    { typoid = float4Oid,+      typname = "float4"+    }++float4Oid :: Oid+float4Oid = Oid 700+{-# INLINE float4Oid #-}++float8 :: TypeInfo+float8 =+  Basic+    { typoid = float8Oid,+      typname = "float8"+    }++float8Oid :: Oid+float8Oid = Oid 701+{-# INLINE float8Oid #-}++unknown :: TypeInfo+unknown =+  Basic+    { typoid = unknownOid,+      typname = "unknown"+    }++unknownOid :: Oid+unknownOid = Oid 705+{-# INLINE unknownOid #-}++circle :: TypeInfo+circle =+  Basic+    { typoid = circleOid,+      typname = "circle"+    }++circleOid :: Oid+circleOid = Oid 718+{-# INLINE circleOid #-}++money :: TypeInfo+money =+  Basic+    { typoid = moneyOid,+      typname = "money"+    }++moneyOid :: Oid+moneyOid = Oid 790+{-# INLINE moneyOid #-}++macaddr :: TypeInfo+macaddr =+  Basic+    { typoid = macaddrOid,+      typname = "macaddr"+    }++macaddrOid :: Oid+macaddrOid = Oid 829+{-# INLINE macaddrOid #-}++inet :: TypeInfo+inet =+  Basic+    { typoid = inetOid,+      typname = "inet"+    }++inetOid :: Oid+inetOid = Oid 869+{-# INLINE inetOid #-}++bpchar :: TypeInfo+bpchar =+  Basic+    { typoid = bpcharOid,+      typname = "bpchar"+    }++bpcharOid :: Oid+bpcharOid = Oid 1042+{-# INLINE bpcharOid #-}++varchar :: TypeInfo+varchar =+  Basic+    { typoid = varcharOid,+      typname = "varchar"+    }++varcharOid :: Oid+varcharOid = Oid 1043+{-# INLINE varcharOid #-}++date :: TypeInfo+date =+  Basic+    { typoid = dateOid,+      typname = "date"+    }++dateOid :: Oid+dateOid = Oid 1082+{-# INLINE dateOid #-}++time :: TypeInfo+time =+  Basic+    { typoid = timeOid,+      typname = "time"+    }++timeOid :: Oid+timeOid = Oid 1083+{-# INLINE timeOid #-}++timestamp :: TypeInfo+timestamp =+  Basic+    { typoid = timestampOid,+      typname = "timestamp"+    }++timestampOid :: Oid+timestampOid = Oid 1114+{-# INLINE timestampOid #-}++timestamptz :: TypeInfo+timestamptz =+  Basic+    { typoid = timestamptzOid,+      typname = "timestamptz"+    }++timestamptzOid :: Oid+timestamptzOid = Oid 1184+{-# INLINE timestamptzOid #-}++interval :: TypeInfo+interval =+  Basic+    { typoid = intervalOid,+      typname = "interval"+    }++intervalOid :: Oid+intervalOid = Oid 1186+{-# INLINE intervalOid #-}++timetz :: TypeInfo+timetz =+  Basic+    { typoid = timetzOid,+      typname = "timetz"+    }++timetzOid :: Oid+timetzOid = Oid 1266+{-# INLINE timetzOid #-}++bit :: TypeInfo+bit =+  Basic+    { typoid = bitOid,+      typname = "bit"+    }++bitOid :: Oid+bitOid = Oid 1560+{-# INLINE bitOid #-}++varbit :: TypeInfo+varbit =+  Basic+    { typoid = varbitOid,+      typname = "varbit"+    }++varbitOid :: Oid+varbitOid = Oid 1562+{-# INLINE varbitOid #-}++numeric :: TypeInfo+numeric =+  Basic+    { typoid = numericOid,+      typname = "numeric"+    }++numericOid :: Oid+numericOid = Oid 1700+{-# INLINE numericOid #-}++refcursor :: TypeInfo+refcursor =+  Basic+    { typoid = refcursorOid,+      typname = "refcursor"+    }++refcursorOid :: Oid+refcursorOid = Oid 1790+{-# INLINE refcursorOid #-}++record :: TypeInfo+record =+  Basic+    { typoid = recordOid,+      typname = "record"+    }++recordOid :: Oid+recordOid = Oid 2249+{-# INLINE recordOid #-}++void :: TypeInfo+void =+  Basic+    { typoid = voidOid,+      typname = "void"+    }++voidOid :: Oid+voidOid = Oid 2278+{-# INLINE voidOid #-}++array_record :: TypeInfo+array_record =+  Array+    { typoid = array_recordOid,+      typname = "_record",+      typelem = Just record+    }++array_recordOid :: Oid+array_recordOid = Oid 2287+{-# INLINE array_recordOid #-}++regprocedure :: TypeInfo+regprocedure =+  Basic+    { typoid = regprocedureOid,+      typname = "regprocedure"+    }++regprocedureOid :: Oid+regprocedureOid = Oid 2202+{-# INLINE regprocedureOid #-}++regoper :: TypeInfo+regoper =+  Basic+    { typoid = regoperOid,+      typname = "regoper"+    }++regoperOid :: Oid+regoperOid = Oid 2203+{-# INLINE regoperOid #-}++regoperator :: TypeInfo+regoperator =+  Basic+    { typoid = regoperatorOid,+      typname = "regoperator"+    }++regoperatorOid :: Oid+regoperatorOid = Oid 2204+{-# INLINE regoperatorOid #-}++regclass :: TypeInfo+regclass =+  Basic+    { typoid = regclassOid,+      typname = "regclass"+    }++regclassOid :: Oid+regclassOid = Oid 2205+{-# INLINE regclassOid #-}++regtype :: TypeInfo+regtype =+  Basic+    { typoid = regtypeOid,+      typname = "regtype"+    }++regtypeOid :: Oid+regtypeOid = Oid 2206+{-# INLINE regtypeOid #-}++uuid :: TypeInfo+uuid =+  Basic+    { typoid = uuidOid,+      typname = "uuid"+    }++uuidOid :: Oid+uuidOid = Oid 2950+{-# INLINE uuidOid #-}++json :: TypeInfo+json =+  Basic+    { typoid = jsonOid,+      typname = "json"+    }++jsonOid :: Oid+jsonOid = Oid 114+{-# INLINE jsonOid #-}++jsonb :: TypeInfo+jsonb =+  Basic+    { typoid = jsonbOid,+      typname = "jsonb"+    }++jsonbOid :: Oid+jsonbOid = Oid 3802+{-# INLINE jsonbOid #-}++int2vector :: TypeInfo+int2vector =+  Array+    { typoid = int2vectorOid,+      typname = "int2vector",+      typelem = Just int2+    }++int2vectorOid :: Oid+int2vectorOid = Oid 22+{-# INLINE int2vectorOid #-}++oidvector :: TypeInfo+oidvector =+  Array+    { typoid = oidvectorOid,+      typname = "oidvector",+      typelem = Just oid+    }++oidvectorOid :: Oid+oidvectorOid = Oid 30+{-# INLINE oidvectorOid #-}++array_xml :: TypeInfo+array_xml =+  Array+    { typoid = array_xmlOid,+      typname = "_xml",+      typelem = Just xml+    }++array_xmlOid :: Oid+array_xmlOid = Oid 143+{-# INLINE array_xmlOid #-}++array_json :: TypeInfo+array_json =+  Array+    { typoid = array_jsonOid,+      typname = "_json",+      typelem = Just json+    }++array_jsonOid :: Oid+array_jsonOid = Oid 199+{-# INLINE array_jsonOid #-}++array_line :: TypeInfo+array_line =+  Array+    { typoid = array_lineOid,+      typname = "_line",+      typelem = Just line+    }++array_lineOid :: Oid+array_lineOid = Oid 629+{-# INLINE array_lineOid #-}++array_cidr :: TypeInfo+array_cidr =+  Array+    { typoid = array_cidrOid,+      typname = "_cidr",+      typelem = Just cidr+    }++array_cidrOid :: Oid+array_cidrOid = Oid 651+{-# INLINE array_cidrOid #-}++array_circle :: TypeInfo+array_circle =+  Array+    { typoid = array_circleOid,+      typname = "_circle",+      typelem = Just circle+    }++array_circleOid :: Oid+array_circleOid = Oid 719+{-# INLINE array_circleOid #-}++array_money :: TypeInfo+array_money =+  Array+    { typoid = array_moneyOid,+      typname = "_money",+      typelem = Just money+    }++array_moneyOid :: Oid+array_moneyOid = Oid 791+{-# INLINE array_moneyOid #-}++array_bool :: TypeInfo+array_bool =+  Array+    { typoid = array_boolOid,+      typname = "_bool",+      typelem = Just bool+    }++array_boolOid :: Oid+array_boolOid = Oid 1000+{-# INLINE array_boolOid #-}++array_bytea :: TypeInfo+array_bytea =+  Array+    { typoid = array_byteaOid,+      typname = "_bytea",+      typelem = Just bytea+    }++array_byteaOid :: Oid+array_byteaOid = Oid 1001+{-# INLINE array_byteaOid #-}++array_char :: TypeInfo+array_char =+  Array+    { typoid = array_charOid,+      typname = "_char",+      typelem = Just char+    }++array_charOid :: Oid+array_charOid = Oid 1002+{-# INLINE array_charOid #-}++array_name :: TypeInfo+array_name =+  Array+    { typoid = array_nameOid,+      typname = "_name",+      typelem = Just name+    }++array_nameOid :: Oid+array_nameOid = Oid 1003+{-# INLINE array_nameOid #-}++array_int2 :: TypeInfo+array_int2 =+  Array+    { typoid = array_int2Oid,+      typname = "_int2",+      typelem = Just int2+    }++array_int2Oid :: Oid+array_int2Oid = Oid 1005+{-# INLINE array_int2Oid #-}++array_int2vector :: TypeInfo+array_int2vector =+  Array+    { typoid = array_int2vectorOid,+      typname = "_int2vector",+      typelem = Just int2vector+    }++array_int2vectorOid :: Oid+array_int2vectorOid = Oid 1006+{-# INLINE array_int2vectorOid #-}++array_int4 :: TypeInfo+array_int4 =+  Array+    { typoid = array_int4Oid,+      typname = "_int4",+      typelem = Just int4+    }++array_int4Oid :: Oid+array_int4Oid = Oid 1007+{-# INLINE array_int4Oid #-}++array_regproc :: TypeInfo+array_regproc =+  Array+    { typoid = array_regprocOid,+      typname = "_regproc",+      typelem = Just regproc+    }++array_regprocOid :: Oid+array_regprocOid = Oid 1008+{-# INLINE array_regprocOid #-}++array_text :: TypeInfo+array_text =+  Array+    { typoid = array_textOid,+      typname = "_text",+      typelem = Just text+    }++array_textOid :: Oid+array_textOid = Oid 1009+{-# INLINE array_textOid #-}++array_tid :: TypeInfo+array_tid =+  Array+    { typoid = array_tidOid,+      typname = "_tid",+      typelem = Just tid+    }++array_tidOid :: Oid+array_tidOid = Oid 1010+{-# INLINE array_tidOid #-}++array_xid :: TypeInfo+array_xid =+  Array+    { typoid = array_xidOid,+      typname = "_xid",+      typelem = Just xid+    }++array_xidOid :: Oid+array_xidOid = Oid 1011+{-# INLINE array_xidOid #-}++array_cid :: TypeInfo+array_cid =+  Array+    { typoid = array_cidOid,+      typname = "_cid",+      typelem = Just cid+    }++array_cidOid :: Oid+array_cidOid = Oid 1012+{-# INLINE array_cidOid #-}++array_oidvector :: TypeInfo+array_oidvector =+  Array+    { typoid = array_oidvectorOid,+      typname = "_oidvector",+      typelem = Just oidvector+    }++array_oidvectorOid :: Oid+array_oidvectorOid = Oid 1013+{-# INLINE array_oidvectorOid #-}++array_bpchar :: TypeInfo+array_bpchar =+  Array+    { typoid = array_bpcharOid,+      typname = "_bpchar",+      typelem = Just bpchar+    }++array_bpcharOid :: Oid+array_bpcharOid = Oid 1014+{-# INLINE array_bpcharOid #-}++array_varchar :: TypeInfo+array_varchar =+  Array+    { typoid = array_varcharOid,+      typname = "_varchar",+      typelem = Just varchar+    }++array_varcharOid :: Oid+array_varcharOid = Oid 1015+{-# INLINE array_varcharOid #-}++array_int8 :: TypeInfo+array_int8 =+  Array+    { typoid = array_int8Oid,+      typname = "_int8",+      typelem = Just int8+    }++array_int8Oid :: Oid+array_int8Oid = Oid 1016+{-# INLINE array_int8Oid #-}++array_point :: TypeInfo+array_point =+  Array+    { typoid = array_pointOid,+      typname = "_point",+      typelem = Just point+    }++array_pointOid :: Oid+array_pointOid = Oid 1017+{-# INLINE array_pointOid #-}++array_lseg :: TypeInfo+array_lseg =+  Array+    { typoid = array_lsegOid,+      typname = "_lseg",+      typelem = Just lseg+    }++array_lsegOid :: Oid+array_lsegOid = Oid 1018+{-# INLINE array_lsegOid #-}++array_path :: TypeInfo+array_path =+  Array+    { typoid = array_pathOid,+      typname = "_path",+      typelem = Just path+    }++array_pathOid :: Oid+array_pathOid = Oid 1019+{-# INLINE array_pathOid #-}++array_box :: TypeInfo+array_box =+  Array+    { typoid = array_boxOid,+      typname = "_box",+      typelem = Just box+    }++array_boxOid :: Oid+array_boxOid = Oid 1020+{-# INLINE array_boxOid #-}++array_float4 :: TypeInfo+array_float4 =+  Array+    { typoid = array_float4Oid,+      typname = "_float4",+      typelem = Just float4+    }++array_float4Oid :: Oid+array_float4Oid = Oid 1021+{-# INLINE array_float4Oid #-}++array_float8 :: TypeInfo+array_float8 =+  Array+    { typoid = array_float8Oid,+      typname = "_float8",+      typelem = Just float8+    }++array_float8Oid :: Oid+array_float8Oid = Oid 1022+{-# INLINE array_float8Oid #-}++array_polygon :: TypeInfo+array_polygon =+  Array+    { typoid = array_polygonOid,+      typname = "_polygon",+      typelem = Just polygon+    }++array_polygonOid :: Oid+array_polygonOid = Oid 1027+{-# INLINE array_polygonOid #-}++array_oid :: TypeInfo+array_oid =+  Array+    { typoid = array_oidOid,+      typname = "_oid",+      typelem = Just oid+    }++array_oidOid :: Oid+array_oidOid = Oid 1028+{-# INLINE array_oidOid #-}++array_macaddr :: TypeInfo+array_macaddr =+  Array+    { typoid = array_macaddrOid,+      typname = "_macaddr",+      typelem = Just macaddr+    }++array_macaddrOid :: Oid+array_macaddrOid = Oid 1040+{-# INLINE array_macaddrOid #-}++array_inet :: TypeInfo+array_inet =+  Array+    { typoid = array_inetOid,+      typname = "_inet",+      typelem = Just inet+    }++array_inetOid :: Oid+array_inetOid = Oid 1041+{-# INLINE array_inetOid #-}++array_timestamp :: TypeInfo+array_timestamp =+  Array+    { typoid = array_timestampOid,+      typname = "_timestamp",+      typelem = Just timestamp+    }++array_timestampOid :: Oid+array_timestampOid = Oid 1115+{-# INLINE array_timestampOid #-}++array_date :: TypeInfo+array_date =+  Array+    { typoid = array_dateOid,+      typname = "_date",+      typelem = Just date+    }++array_dateOid :: Oid+array_dateOid = Oid 1182+{-# INLINE array_dateOid #-}++array_time :: TypeInfo+array_time =+  Array+    { typoid = array_timeOid,+      typname = "_time",+      typelem = Just time+    }++array_timeOid :: Oid+array_timeOid = Oid 1183+{-# INLINE array_timeOid #-}++array_timestamptz :: TypeInfo+array_timestamptz =+  Array+    { typoid = array_timestamptzOid,+      typname = "_timestamptz",+      typelem = Just timestamptz+    }++array_timestamptzOid :: Oid+array_timestamptzOid = Oid 1185+{-# INLINE array_timestamptzOid #-}++array_interval :: TypeInfo+array_interval =+  Array+    { typoid = array_intervalOid,+      typname = "_interval",+      typelem = Just interval+    }++array_intervalOid :: Oid+array_intervalOid = Oid 1187+{-# INLINE array_intervalOid #-}++array_numeric :: TypeInfo+array_numeric =+  Array+    { typoid = array_numericOid,+      typname = "_numeric",+      typelem = Just numeric+    }++array_numericOid :: Oid+array_numericOid = Oid 1231+{-# INLINE array_numericOid #-}++array_timetz :: TypeInfo+array_timetz =+  Array+    { typoid = array_timetzOid,+      typname = "_timetz",+      typelem = Just timetz+    }++array_timetzOid :: Oid+array_timetzOid = Oid 1270+{-# INLINE array_timetzOid #-}++array_bit :: TypeInfo+array_bit =+  Array+    { typoid = array_bitOid,+      typname = "_bit",+      typelem = Just bit+    }++array_bitOid :: Oid+array_bitOid = Oid 1561+{-# INLINE array_bitOid #-}++array_varbit :: TypeInfo+array_varbit =+  Array+    { typoid = array_varbitOid,+      typname = "_varbit",+      typelem = Just varbit+    }++array_varbitOid :: Oid+array_varbitOid = Oid 1563+{-# INLINE array_varbitOid #-}++array_refcursor :: TypeInfo+array_refcursor =+  Array+    { typoid = array_refcursorOid,+      typname = "_refcursor",+      typelem = Just refcursor+    }++array_refcursorOid :: Oid+array_refcursorOid = Oid 2201+{-# INLINE array_refcursorOid #-}++array_regprocedure :: TypeInfo+array_regprocedure =+  Array+    { typoid = array_regprocedureOid,+      typname = "_regprocedure",+      typelem = Just regprocedure+    }++array_regprocedureOid :: Oid+array_regprocedureOid = Oid 2207+{-# INLINE array_regprocedureOid #-}++array_regoper :: TypeInfo+array_regoper =+  Array+    { typoid = array_regoperOid,+      typname = "_regoper",+      typelem = Just regoper+    }++array_regoperOid :: Oid+array_regoperOid = Oid 2208+{-# INLINE array_regoperOid #-}++array_regoperator :: TypeInfo+array_regoperator =+  Array+    { typoid = array_regoperatorOid,+      typname = "_regoperator",+      typelem = Just regoperator+    }++array_regoperatorOid :: Oid+array_regoperatorOid = Oid 2209+{-# INLINE array_regoperatorOid #-}++array_regclass :: TypeInfo+array_regclass =+  Array+    { typoid = array_regclassOid,+      typname = "_regclass",+      typelem = Just regclass+    }++array_regclassOid :: Oid+array_regclassOid = Oid 2210+{-# INLINE array_regclassOid #-}++array_regtype :: TypeInfo+array_regtype =+  Array+    { typoid = array_regtypeOid,+      typname = "_regtype",+      typelem = Just regtype+    }++array_regtypeOid :: Oid+array_regtypeOid = Oid 2211+{-# INLINE array_regtypeOid #-}++array_uuid :: TypeInfo+array_uuid =+  Array+    { typoid = array_uuidOid,+      typname = "_uuid",+      typelem = Just uuid+    }++array_uuidOid :: Oid+array_uuidOid = Oid 2951+{-# INLINE array_uuidOid #-}++array_jsonb :: TypeInfo+array_jsonb =+  Array+    { typoid = array_jsonbOid,+      typname = "_jsonb",+      typelem = Just jsonb+    }++array_jsonbOid :: Oid+array_jsonbOid = Oid 3807+{-# INLINE array_jsonbOid #-}++int4range :: TypeInfo+int4range =+  Range+    { typoid = int4rangeOid,+      typname = "int4range"+      -- rngsubtype = int4+    }++int4rangeOid :: Oid+int4rangeOid = Oid 3904+{-# INLINE int4rangeOid #-}++_int4range :: TypeInfo+_int4range =+  Array+    { typoid = _int4rangeOid,+      typname = "_int4range",+      typelem = Just int4range+    }++_int4rangeOid :: Oid+_int4rangeOid = Oid 3905+{-# INLINE _int4rangeOid #-}++numrange :: TypeInfo+numrange =+  Range+    { typoid = numrangeOid,+      typname = "numrange"+      -- rngsubtype = numeric+    }++numrangeOid :: Oid+numrangeOid = Oid 3906+{-# INLINE numrangeOid #-}++_numrange :: TypeInfo+_numrange =+  Array+    { typoid = _numrangeOid,+      typname = "_numrange",+      typelem = Just numrange+    }++_numrangeOid :: Oid+_numrangeOid = Oid 3907+{-# INLINE _numrangeOid #-}++tsrange :: TypeInfo+tsrange =+  Range+    { typoid = tsrangeOid,+      typname = "tsrange"+      -- rngsubtype = timestamp+    }++tsrangeOid :: Oid+tsrangeOid = Oid 3908+{-# INLINE tsrangeOid #-}++_tsrange :: TypeInfo+_tsrange =+  Array+    { typoid = _tsrangeOid,+      typname = "_tsrange",+      typelem = Just tsrange+    }++_tsrangeOid :: Oid+_tsrangeOid = Oid 3909+{-# INLINE _tsrangeOid #-}++tstzrange :: TypeInfo+tstzrange =+  Range+    { typoid = tstzrangeOid,+      typname = "tstzrange"+      -- rngsubtype = timestamptz+    }++tstzrangeOid :: Oid+tstzrangeOid = Oid 3910+{-# INLINE tstzrangeOid #-}++_tstzrange :: TypeInfo+_tstzrange =+  Array+    { typoid = _tstzrangeOid,+      typname = "_tstzrange",+      typelem = Just tstzrange+    }++_tstzrangeOid :: Oid+_tstzrangeOid = Oid 3911+{-# INLINE _tstzrangeOid #-}++daterange :: TypeInfo+daterange =+  Range+    { typoid = daterangeOid,+      typname = "daterange"+      -- rngsubtype = date+    }++daterangeOid :: Oid+daterangeOid = Oid 3912+{-# INLINE daterangeOid #-}++_daterange :: TypeInfo+_daterange =+  Array+    { typoid = _daterangeOid,+      typname = "_daterange",+      typelem = Just daterange+    }++_daterangeOid :: Oid+_daterangeOid = Oid 3913+{-# INLINE _daterangeOid #-}++int8range :: TypeInfo+int8range =+  Range+    { typoid = int8rangeOid,+      typname = "int8range"+      -- rngsubtype = int8+    }++int8rangeOid :: Oid+int8rangeOid = Oid 3926+{-# INLINE int8rangeOid #-}++_int8range :: TypeInfo+_int8range =+  Array+    { typoid = _int8rangeOid,+      typname = "_int8range",+      typelem = Just int8range+    }++_int8rangeOid :: Oid+_int8rangeOid = Oid 3927+{-# INLINE _int8rangeOid #-}

@@ -0,0 +1,105 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo.Types+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+module Database.PostgreSQL.Simple.TypeInfo.Types where++import Data.ByteString (ByteString)+import Data.Text.Encoding (encodeUtf8)+import Database.PostgreSQL.LibPQ (Oid)+import Hpgsql.TypeInfo (ArrayTypeDetails (..), TypeDetails (..), lookupTypeByOid)+import qualified Hpgsql.TypeInfo as Hpgsql++-- | This is not exactly like postgresql-simple's TypeInfo,+-- since some fields are slightly altered and others have been removed.+data TypeInfo+  = Basic+      { typoid :: Oid,+        -- typcategory :: Char,+        -- typdelim :: Char,+        typname :: ByteString+      }+  | Array+      { typoid :: Oid,+        -- typcategory :: Char,+        -- typdelim :: Char,+        typname :: ByteString,+        -- | In postgresql-simple typelem is not a Maybe+        typelem :: Maybe TypeInfo+      }+  | Composite+      { typoid :: Oid,+        -- typcategory :: Char,+        -- typdelim :: Char,+        typname :: ByteString+        -- typrelid :: Oid,+        -- attributes :: (Vector Attribute)+      }+  | Range+      { typoid :: Oid,+        -- typcategory :: Char,+        -- typdelim :: Char,+        typname :: ByteString+        -- rngsubtype :: TypeInfo+      }+  deriving+    ( Show+    )++fromHpgsqlTypeInfo :: Hpgsql.EncodingContext -> Hpgsql.TypeInfo -> TypeInfo+fromHpgsqlTypeInfo encCtx ti = case ti.typeDetails of+  ArrayType arrDetails ->+    Array+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName,+        typelem = fromHpgsqlTypeInfo encCtx <$> lookupTypeByOid arrDetails.elemTypeOid encCtx.typeInfoCache+      }+  BasicType ->+    Basic+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+      }+  CompositeType ->+    Composite+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+      }+  RangeType ->+    Range+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+        -- rngsubtype = error "rngsubtype not available in hpgsql-simple-compat"+      }+  DomainType ->+    Basic+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+      }+  EnumType ->+    Basic+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+      }+  PseudoType ->+    Basic+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+      }+  MultiRangeType ->+    Basic+      { typoid = ti.typeOid,+        typname = encodeUtf8 ti.typeName+      }++data Attribute+  = Attribute+  { attname :: !ByteString,+    atttype :: !TypeInfo+  }+  deriving (Show)

@@ -0,0 +1,330 @@+------------------------------------------------------------------------------++------------------------------------------------------------------------------++-- |+-- Module:      Database.PostgreSQL.Simple.Types+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- Basic types.+module Database.PostgreSQL.Simple.Types+  ( Null (..),+    Default (..),+    Only (..),+    In (..),+    Binary (..),+    Identifier (..),+    QualifiedIdentifier (..),+    Query (..),+    Oid (..),+    (:.) (..),+    Savepoint (..),+    PGArray (..),+    Values (..),+  )+where++import Control.Arrow (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Builder (stringUtf8)+import Data.Foldable (toList)+import Data.Functor.Contravariant (contramap)+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.List as List+import Data.Semigroup+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Tuple.Only (Only (..))+import Data.Typeable (Typeable)+import Database.PostgreSQL.LibPQ (Oid (..))+import Database.PostgreSQL.Simple.Compat (toByteString)+import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..))+import Database.PostgreSQL.Simple.ToRow (ToRow (..))+import Hpgsql.Encoding (ToPgField (..))+import qualified Hpgsql.Encoding as Hpgsql+import Hpgsql.Types (PGArray (..), (:.) (..))++-- | A placeholder for the SQL @NULL@ value.+data Null = Null+  deriving (Read, Show, Typeable)++-- | A placeholder for the PostgreSQL @DEFAULT@ value.+data Default = Default+  deriving (Read, Show, Typeable)++-- | A query string. This type is intended to make it difficult to+-- construct a SQL query by concatenating string fragments, as that is+-- an extremely common way to accidentally introduce SQL injection+-- vulnerabilities into an application.+--+-- This type is an instance of 'IsString', so the easiest way to+-- construct a query is to enable the @OverloadedStrings@ language+-- extension and then simply write the query in double quotes.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Database.PostgreSQL.Simple+-- >+-- > q :: Query+-- > q = "select ?"+--+-- The underlying type is a 'ByteString', and literal Haskell strings+-- that contain Unicode characters will be correctly transformed to+-- UTF-8.+newtype Query = Query+  { fromQuery :: ByteString+  }+  deriving (Eq, Ord, Typeable)++instance Show Query where+  show = show . fromQuery++instance Read Query where+  readsPrec i = fmap (first Query) . readsPrec i++instance IsString Query where+  fromString = Query . toByteString . stringUtf8++instance Semigroup Query where+  Query a <> Query b = Query (B.append a b)+  {-# INLINE (<>) #-}+  sconcat xs = Query (B.concat $ map fromQuery $ toList xs)++instance Monoid Query where+  mempty = Query B.empty++-- | Wrap a list of values for use in an @IN@ clause.  Replaces a+-- single \"@?@\" character with a parenthesized list of rendered+-- values.+--+-- Example:+--+-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))+--+-- Note that @In []@ expands to @(null)@, which works as expected in+-- the query above, but evaluates to the logical null value on every+-- row instead of @TRUE@.  This means that changing the query above+-- to @... id NOT in ?@ and supplying the empty list as the parameter+-- returns zero rows, instead of all of them as one would expect.+--+-- Since postgresql doesn't seem to provide a syntax for actually specifying+-- an empty list,  which could solve this completely,  there are two+-- workarounds particularly worth mentioning,  namely:+--+-- 1.  Use hpgsql-simple-compat's 'Values' type instead,  which can handle the+--     empty case correctly.  Note however that while specifying the+--     postgresql type @"int4"@ is mandatory in the empty case,  specifying+--     the haskell type @Values (Only Int)@ would not normally be needed in+--     realistic use cases.+--+--     > query c "select * from whatever where id not in ?"+--     >         (Only (Values ["int4"] [] :: Values (Only Int)))+--+--+-- 2.  Use sql's @COALESCE@ operator to turn a logical @null@ into the correct+--     boolean.  Note however that the correct boolean depends on the use+--     case:+--+--     > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"+--     >         (Only (In [] :: In [Int]))+--+--     > query c "select * from whatever where coalesce(id IN ?, FALSE)"+--     >         (Only (In [] :: In [Int]))+--+--     Note that at as of PostgreSQL 9.4,  the query planner cannot see inside+--     the @COALESCE@ operator,  so if you have an index on @id@ then you+--     probably don't want to write the last example with @COALESCE@,  which+--     would result in a table scan.   There are further caveats if @id@ can+--     be null or you want null treated sensibly as a component of @IN@ or+--     @NOT IN@.+newtype In a = In a+  deriving (Eq, Ord, Read, Show, Typeable, Functor)++instance (ToField a) => ToField (In [a]) where+  toField (In []) = Plain "(NULL)"+  toField (In xs) = Many $ Plain "(" : List.intersperse (Plain ",") (map toField xs) ++ [Plain ")"]++-- | Wrap binary data for use as a @bytea@ value.+newtype Binary a = Binary {fromBinary :: a}+  deriving (Eq, Ord, Read, Show, Typeable, Functor)++instance ToField (Binary ByteString)++instance Hpgsql.FromPgField (Binary ByteString) where+  fieldDecoder = Binary <$> Hpgsql.fieldDecoder++instance ToPgField (Binary ByteString) where+  fieldEncoder = contramap fromBinary fieldEncoder++-- | Wrap text for use as sql identifier, i.e. a table or column name.+newtype Identifier = Identifier {fromIdentifier :: Text}+  deriving stock (Eq, Ord, Read, Show, Typeable)+  deriving newtype (IsString)++instance ToField Identifier where+  toField (Identifier ident) = EscapeIdentifier $ encodeUtf8 ident++instance Hashable Identifier where+  hashWithSalt i (Identifier t) = hashWithSalt i t++-- | Wrap text for use as (maybe) qualified identifier, i.e. a table+-- with schema, or column with table.+data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text+  deriving (Eq, Ord, Read, Show, Typeable)++instance ToField QualifiedIdentifier where+  toField (QualifiedIdentifier m n) = case m of+    Nothing -> toField $ Identifier n+    Just m' -> Many [toField (Identifier m'), Plain ".", toField (Identifier n)]++instance Hashable QualifiedIdentifier where+  hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t)++-- | @\"foo.bar\"@ will get turned into+-- @QualifiedIdentifier (Just \"foo\") \"bar\"@,  while @\"foo\"@ will get+-- turned into @QualifiedIdentifier Nothing \"foo\"@.   Note this instance+-- is for convenience,  and does not match postgres syntax.   It+-- only examines the first period character,  and thus cannot be used if the+-- qualifying identifier contains a period for example.+instance IsString QualifiedIdentifier where+  fromString str =+    let (x, y) = T.break (== '.') (fromString str)+     in if T.null y+          then QualifiedIdentifier Nothing x+          else QualifiedIdentifier (Just x) (T.tail y)++newtype Savepoint = Savepoint Query+  deriving (Eq, Ord, Show, Read, Typeable)++-- | Represents a @VALUES@ table literal,  usable as an alternative to+--   'Database.PostgreSQL.Simple.executeMany' and+--   'Database.PostgreSQL.Simple.returning'.  The main advantage is that+--   you can parametrize more than just a single @VALUES@ expression.+--   For example,  here's a query to insert a thing into one table+--   and some attributes of that thing into another,   returning the+--   new id generated by the database:+--+--+-- > query c [sql|+-- >     WITH new_thing AS (+-- >       INSERT INTO thing (name) VALUES (?) RETURNING id+-- >     ), new_attributes AS (+-- >       INSERT INTO thing_attributes+-- >          SELECT new_thing.id, attrs.*+-- >            FROM new_thing JOIN ? attrs ON TRUE+-- >     ) SELECT * FROM new_thing+-- >  |] ("foo", Values [  "int4", "text"    ]+-- >                    [ ( 1    , "hello" )+-- >                    , ( 2    , "world" ) ])+--+--   (Note this example uses writable common table expressions,+--    which were added in PostgreSQL 9.1)+--+--   The second parameter gets expanded into the following SQL syntax:+--+-- > (VALUES (1::"int4",'hello'::"text"),(2,'world'))+--+--   When the list of attributes is empty,  the second parameter expands to:+--+-- > (VALUES (null::"int4",null::"text") LIMIT 0)+--+--   By contrast, @executeMany@ and @returning@ don't issue the query+--   in the empty case, and simply return @0@ and @[]@ respectively.+--   This behavior is usually correct given their intended use cases,+--   but would certainly be wrong in the example above.+--+--   The first argument is a list of postgresql type names.  Because this+--   is turned into a properly quoted identifier,  the type name is case+--   sensitive and must be as it appears in the @pg_type@ table.   Thus,+--   you must write @timestamptz@ instead of @timestamp with time zone@,+--   @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,+--   etcetera.+--+--   You may omit the type names,  however,  if you do so the list+--   of values must be non-empty,  and postgresql must be able to infer+--   the types of the columns from the surrounding context.   If the first+--   condition is not met,  hpgsql-simple-compat will throw an exception+--   without issuing the query.   In the second case,  the postgres server+--   will return an error which will be turned into a @SqlError@ exception.+--+--   See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for+--   more information.+data Values a = Values [QualifiedIdentifier] [a]+  deriving (Eq, Ord, Show, Read, Typeable)++interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]+interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as+{-# INLINE interleaveFoldr #-}++instance (ToRow a) => ToField (Values a) where+  toField (Values types rows) =+    case rows of+      [] -> case types of+        [] -> error norows+        (_ : _) ->+          values $+            typedRow+              (repeat (lit "null"))+              types+              [lit " LIMIT 0)"]+      (_ : _) -> case types of+        [] -> values $ untypedRows rows [lit ")"]+        (_ : _) -> values $ typedRows rows types [lit ")"]+    where+      funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"+      norows = funcname ++ "  either values or types must be non-empty"+      emptyrow = funcname ++ "  each row must contain at least one column"+      lit = Plain+      values x = Many (lit "(VALUES " : x)++      typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]+      typedField (val, typ) rest = val : lit "::" : toField typ : rest++      typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]+      typedRow (val : vals) (typ : typs) rest =+        lit "("+          : typedField+            (val, typ)+            ( interleaveFoldr+                typedField+                (lit ",")+                (lit ")" : rest)+                (zip vals typs)+            )+      typedRow _ _ _ = error emptyrow++      untypedRow :: [Action] -> [Action] -> [Action]+      untypedRow (val : vals) rest =+        lit "("+          : val+          : interleaveFoldr+            (:)+            (lit ",")+            (lit ")" : rest)+            vals+      untypedRow _ _ = error emptyrow++      typedRows :: (ToRow a) => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]+      typedRows [] _ _ = error funcname+      typedRows (val : vals) typs rest =+        typedRow (toRow val) typs (multiRows vals rest)++      untypedRows :: (ToRow a) => [a] -> [Action] -> [Action]+      untypedRows [] _ = error funcname+      untypedRows (val : vals) rest =+        untypedRow (toRow val) (multiRows vals rest)++      multiRows :: (ToRow a) => [a] -> [Action] -> [Action]+      multiRows vals rest =+        interleaveFoldr+          (untypedRow . toRow)+          (lit ",")+          rest+          vals