postgresql-simple-postgresql-types (empty) → 0.1

raw patch · 9 files changed

+835/−0 lines, 9 filesdep +QuickCheckdep +asyncdep +attoparsec

Dependencies added: QuickCheck, async, attoparsec, base, hspec, postgresql-simple, postgresql-simple-postgresql-types, postgresql-types, postgresql-types-algebra, quickcheck-instances, stm, tagged, testcontainers-postgresql, text, text-builder

Files

• LICENSE +22/−0
• README.md +6/−0
• postgresql-simple-postgresql-types.cabal +127/−0
• src/integration-tests/IntegrationTests/Scopes.hs +114/−0
• src/integration-tests/IntegrationTests/Scripts.hs +81/−0
• src/integration-tests/Main.hs +121/−0
• src/library/Database/PostgreSQL/Simple/PostgresqlTypes.hs +189/−0
• src/library/Database/PostgreSQL/Simple/PostgresqlTypes/Prelude.hs +50/−0
• src/library/Database/PostgreSQL/Simple/PostgresqlTypes/ViaIsScalar.hs +125/−0

@@ -0,0 +1,22 @@+Copyright (c) 2026, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,6 @@+# postgresql-simple-postgresql-types++[![Hackage](https://img.shields.io/hackage/v/postgresql-simple-postgresql-types.svg)](https://hackage.haskell.org/package/postgresql-simple-postgresql-types)+[![Continuous Haddock](https://img.shields.io/badge/haddock-master-blue)](https://nikita-volkov.github.io/postgresql-simple-postgresql-types/)++Integration of ["postgresql-simple"](http://github.com/haskellari/postgresql-simple) with ["postgresql-types"](https://github.com/nikita-volkov/postgresql-types).

@@ -0,0 +1,127 @@+cabal-version: 3.0+name: postgresql-simple-postgresql-types+version: 0.1+category: PostgreSQL, Codecs+synopsis: Integration of "postgresql-simple" with "postgresql-types"+homepage: https://github.com/nikita-volkov/postgresql-simple-postgresql-types+bug-reports: https://github.com/nikita-volkov/postgresql-simple-postgresql-types/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2026, Nikita Volkov+license: MIT+license-file: LICENSE+extra-doc-files:+  LICENSE+  README.md++source-repository head+  type: git+  location: https://github.com/nikita-volkov/postgresql-simple-postgresql-types++common base+  default-language: Haskell2010+  default-extensions:+    ApplicativeDo+    BangPatterns+    BinaryLiterals+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    DuplicateRecordFields+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NoImplicitPrelude+    NoMonomorphismRestriction+    NumericUnderscores+    OverloadedStrings+    ParallelListComp+    PatternGuards+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    StrictData+    TemplateHaskell+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    UnboxedTuples+    ViewPatterns++common executable+  import: base+  ghc-options:+    -O2+    -threaded+    -with-rtsopts=-N+    -rtsopts+    -funbox-strict-fields++common test+  import: base+  ghc-options:+    -threaded+    -with-rtsopts=-N++library+  import: base+  hs-source-dirs: src/library+  exposed-modules:+    Database.PostgreSQL.Simple.PostgresqlTypes++  other-modules:+    Database.PostgreSQL.Simple.PostgresqlTypes.Prelude+    Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsScalar++  build-depends:+    attoparsec ^>=0.14.4,+    base >=4.11 && <5,+    postgresql-simple >=0.7.0.1 && <0.8,+    postgresql-types ^>=0.1,+    postgresql-types-algebra ^>=0.1,+    tagged ^>=0.8.9,+    text >=1.2 && <3,+    text-builder ^>=1.0.0.5,++test-suite integration-tests+  import: test+  type: exitcode-stdio-1.0+  hs-source-dirs: src/integration-tests+  main-is: Main.hs+  other-modules:+    IntegrationTests.Scopes+    IntegrationTests.Scripts++  build-depends:+    QuickCheck >=2.14 && <3,+    async >=2.2.6 && <2.3,+    base >=4.11 && <5,+    hspec >=2.11 && <3,+    postgresql-simple >=0.7.0.1 && <0.8,+    postgresql-simple-postgresql-types,+    postgresql-types ^>=0.1,+    postgresql-types-algebra ^>=0.1,+    quickcheck-instances ^>=0.3.33,+    stm >=2.5 && <3,+    tagged ^>=0.8.9,+    testcontainers-postgresql ^>=0.2.0.1,+    text >=1.2 && <3,

@@ -0,0 +1,114 @@+module IntegrationTests.Scopes where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Typeable+import Data.Word+import qualified Database.PostgreSQL.Simple as Ps+import qualified Database.PostgreSQL.Simple.PostgresqlTypes ()+import qualified Database.PostgreSQL.Simple.Types as Ps+import Test.Hspec+import qualified TestcontainersPostgresql+import Prelude++-- | Run specs with a PostgreSQL container+withContainer :: Text -> SpecWith (Text, Word16) -> Spec+withContainer tagName =+  describe (Text.unpack tagName) . aroundAll (TestcontainersPostgresql.run config)+  where+    config =+      TestcontainersPostgresql.Config+        { forwardLogs = False,+          auth = TestcontainersPostgresql.TrustAuth,+          tagName+        }++-- | Create a connection from container info+withConnection :: SpecWith Ps.Connection -> SpecWith (Text, Word16)+withConnection =+  withConnectInfo . withConnectionPool 100 . withTQueueElement pure++withConnectInfo :: SpecWith Ps.ConnectInfo -> SpecWith (Text, Word16)+withConnectInfo =+  mapSubject \(host, port) ->+    Ps.defaultConnectInfo+      { Ps.connectHost = Text.unpack host,+        Ps.connectPort = fromIntegral @Word16 port,+        Ps.connectUser = "postgres",+        Ps.connectPassword = "postgres",+        Ps.connectDatabase = "postgres"+      }++withConnectionPool :: Int -> SpecWith (TQueue Ps.Connection) -> SpecWith Ps.ConnectInfo+withConnectionPool poolSize =+  withPool poolSize acquire Ps.close+  where+    acquire connectInfo = do+      connection <- Ps.connect connectInfo+      void do+        Ps.execute_ connection "SET client_min_messages TO WARNING"+      createExtensionIfNotExists connection "hstore"+      pure connection+      where+        createExtensionIfNotExists connection extension =+          handle handler do+            void do+              Ps.execute connection "CREATE EXTENSION IF NOT EXISTS ?" (Ps.Only (Ps.Identifier extension))+          where+            handler (e :: Ps.SqlError) =+              if Ps.sqlState e == "23505"+                && Ps.sqlErrorMsg e == "duplicate key value violates unique constraint \"pg_extension_name_index\""+                then pure ()+                else throwIO e++withPool ::+  -- | Pool size.+  Int ->+  -- | Acquire.+  (b -> IO a) ->+  -- | Release.+  (a -> IO ()) ->+  SpecWith (TQueue a) ->+  SpecWith b+withPool poolSize acquire release =+  aroundAllWith \actionWithQueue b ->+    bracket+      ( do+          queue <- newTQueueIO+          replicateConcurrently_ poolSize do+            element <- acquire b+            atomically $ writeTQueue queue element+          pure queue+      )+      ( \queue -> do+          replicateConcurrently_ poolSize do+            element <- atomically $ readTQueue queue+            release element+      )+      actionWithQueue++withTQueueElement ::+  -- | Clean. Called upon returning to the pool.+  (a -> IO a) ->+  SpecWith a ->+  SpecWith (TQueue a)+withTQueueElement clean =+  aroundWith \actionWithElement queue ->+    bracket+      (atomically $ readTQueue queue)+      ( \element -> do+          element <- clean element+          atomically $ writeTQueue queue element+      )+      actionWithElement++-- | Helper to describe a test for a specific type+withType :: forall a b. (Typeable a) => [Proxy a -> SpecWith b] -> SpecWith b+withType specs = do+  describe (show (typeOf (undefined :: a))) do+    mapM_ (\spec -> spec Proxy) specs

@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-imports -Wno-name-shadowing -Wno-incomplete-patterns -Wno-unused-matches -Wno-missing-methods -Wno-unused-record-wildcards -Wno-redundant-constraints -Wno-deprecations -Wno-missing-signatures #-}++module IntegrationTests.Scripts where++import Control.Monad+import qualified Data.List as List+import Data.Proxy+import Data.Tagged+import qualified Data.Text.Encoding as Text+import Data.Typeable+import qualified Database.PostgreSQL.Simple as Ps+import qualified Database.PostgreSQL.Simple.FromField as Ps+import qualified Database.PostgreSQL.Simple.PostgresqlTypes ()+import qualified Database.PostgreSQL.Simple.ToField as Ps+import qualified Database.PostgreSQL.Simple.Types as Ps+import qualified PostgresqlTypes.Algebra as Pta+import Test.Hspec+import Test.QuickCheck ((===))+import qualified Test.QuickCheck as QuickCheck+import Prelude++-- | Test roundtrip encoding/decoding via postgresql-simple+mappingSpec ::+  forall a.+  ( HasCallStack,+    QuickCheck.Arbitrary a,+    Show a,+    Eq a,+    Pta.IsScalar a,+    Ps.ToField a,+    Ps.FromField a,+    Typeable a+  ) =>+  -- | Whether to test arrays.+  Bool ->+  Proxy a ->+  SpecWith Ps.Connection+mappingSpec arraysEnabled _ = do+  let typeSignature = untag (Pta.typeSignature @a)++  describe "Single value roundtrip" do+    it "Should encode and decode to the same value" \(connection :: Ps.Connection) ->+      QuickCheck.property \(value :: a) -> do+        QuickCheck.idempotentIOProperty do+          let query = "SELECT ?"+          let params = Ps.Only value++          results <- Ps.query connection query params+          case results of+            [Ps.Only (decoded :: a)] -> do+              pure (decoded === value)+            _ -> do+              fail $ "Expected exactly one result, got: " <> show (length results)++  when arraysEnabled do+    describe "Array roundtrip" do+      it "Should encode and decode arrays correctly" \(connection :: Ps.Connection) ->+        QuickCheck.property \(values :: [a]) -> do+          QuickCheck.idempotentIOProperty do+            let query =+                  Ps.Query+                    ( Text.encodeUtf8+                        ("SELECT ?::" <> typeSignature <> "[]")+                    )++            -- Use postgresql-simple to roundtrip array values with explicit type casting+            results <- Ps.query connection query (Ps.Only (Ps.PGArray values))+            case results of+              [Ps.Only (Ps.PGArray (decoded :: [a]))] -> do+                pure (decoded === values)+              _ -> do+                fail $ "Expected exactly one array result, got: " <> show (length results)++  describe "NULL handling" do+    it "Should decode NULL values appropriately" \(connection :: Ps.Connection) -> do+      results <- Ps.query_ connection "SELECT NULL"+      case results of+        [Ps.Only (maybeValue :: Maybe a)] -> do+          maybeValue `shouldBe` Nothing+        _ -> do+          fail $ "Expected exactly one result with NULL, got: " <> show (length results)

@@ -0,0 +1,121 @@+module Main (main) where++import Database.PostgreSQL.Simple.PostgresqlTypes ()+import IntegrationTests.Scopes+import IntegrationTests.Scripts+import qualified PostgresqlTypes as Pt+import Test.Hspec+import Test.QuickCheck.Instances ()+import Prelude++main :: IO ()+main =+  hspec do+    parallel do+      withContainer "postgres:18" do+        withConnection do+          withType @(Pt.Bit 42) [mappingSpec True]+          withType @(Pt.Bpchar 42) [mappingSpec True]+          withType @(Pt.Multirange Pt.Date) [mappingSpec False]+          withType @(Pt.Multirange Pt.Int4) [mappingSpec False]+          withType @(Pt.Multirange Pt.Int8) [mappingSpec False]+          withType @(Pt.Multirange (Pt.Numeric 0 0)) [mappingSpec False]+          withType @(Pt.Multirange Pt.Timestamp) [mappingSpec False]+          withType @(Pt.Multirange Pt.Timestamptz) [mappingSpec False]+          withType @(Pt.Range Pt.Date) [mappingSpec True]+          withType @(Pt.Range Pt.Int4) [mappingSpec True]+          withType @(Pt.Range Pt.Int8) [mappingSpec True]+          withType @(Pt.Range (Pt.Numeric 0 0)) [mappingSpec True]+          withType @(Pt.Range Pt.Timestamp) [mappingSpec True]+          withType @(Pt.Range Pt.Timestamptz) [mappingSpec True]+          withType @Pt.Bool [mappingSpec True]+          withType @Pt.Box [mappingSpec True]+          withType @Pt.Bytea [mappingSpec True]+          withType @Pt.Char [mappingSpec True]+          withType @Pt.Cidr [mappingSpec True]+          withType @Pt.Circle [mappingSpec True]+          withType @Pt.Date [mappingSpec True]+          withType @Pt.Float4 [mappingSpec True]+          withType @Pt.Float8 [mappingSpec True]+          withType @Pt.Hstore [mappingSpec True]+          withType @Pt.Inet [mappingSpec True]+          withType @Pt.Int2 [mappingSpec True]+          withType @Pt.Int4 [mappingSpec True]+          withType @Pt.Int8 [mappingSpec True]+          withType @Pt.Interval [mappingSpec True]+          withType @Pt.Json [mappingSpec True]+          withType @Pt.Jsonb [mappingSpec True]+          withType @Pt.Line [mappingSpec True]+          withType @Pt.Lseg [mappingSpec True]+          withType @Pt.Macaddr [mappingSpec True]+          withType @Pt.Macaddr8 [mappingSpec True]+          withType @Pt.Money [mappingSpec True]+          withType @(Pt.Numeric 0 0) [mappingSpec True]+          withType @(Pt.Numeric 5 0) [mappingSpec True]+          withType @(Pt.Numeric 5 2) [mappingSpec True]+          withType @Pt.Oid [mappingSpec True]+          withType @Pt.Path [mappingSpec True]+          withType @Pt.Point [mappingSpec True]+          withType @Pt.Polygon [mappingSpec True]+          withType @Pt.Text [mappingSpec True]+          withType @Pt.Time [mappingSpec True]+          withType @Pt.Timestamp [mappingSpec True]+          withType @Pt.Timestamptz [mappingSpec True]+          withType @Pt.Timetz [mappingSpec True]+          withType @Pt.Uuid [mappingSpec True]+          withType @(Pt.Varbit 5) [mappingSpec True]+          withType @(Pt.Varchar 5) [mappingSpec True]++      withContainer "postgres:14" do+        withConnection do+          withType @(Pt.Bit 42) [mappingSpec True]+          withType @(Pt.Bpchar 42) [mappingSpec True]+          withType @(Pt.Multirange Pt.Date) [mappingSpec False]+          withType @(Pt.Multirange Pt.Int4) [mappingSpec False]+          withType @(Pt.Multirange Pt.Int8) [mappingSpec False]+          withType @(Pt.Multirange (Pt.Numeric 0 0)) [mappingSpec False]+          withType @(Pt.Multirange Pt.Timestamp) [mappingSpec False]+          withType @(Pt.Multirange Pt.Timestamptz) [mappingSpec False]+          withType @(Pt.Range Pt.Date) [mappingSpec True]+          withType @(Pt.Range Pt.Int4) [mappingSpec True]+          withType @(Pt.Range Pt.Int8) [mappingSpec True]+          withType @(Pt.Range (Pt.Numeric 0 0)) [mappingSpec True]+          withType @(Pt.Range Pt.Timestamp) [mappingSpec True]+          withType @(Pt.Range Pt.Timestamptz) [mappingSpec True]+          withType @Pt.Bool [mappingSpec True]+          withType @Pt.Box [mappingSpec True]+          withType @Pt.Bytea [mappingSpec True]+          withType @Pt.Char [mappingSpec True]+          withType @Pt.Cidr [mappingSpec True]+          withType @Pt.Circle [mappingSpec True]+          withType @Pt.Date [mappingSpec True]+          withType @Pt.Float4 [mappingSpec True]+          withType @Pt.Float8 [mappingSpec True]+          withType @Pt.Hstore [mappingSpec True]+          withType @Pt.Inet [mappingSpec True]+          withType @Pt.Int2 [mappingSpec True]+          withType @Pt.Int4 [mappingSpec True]+          withType @Pt.Int8 [mappingSpec True]+          withType @Pt.Interval [mappingSpec True]+          withType @Pt.Json [mappingSpec True]+          withType @Pt.Jsonb [mappingSpec True]+          withType @Pt.Line [mappingSpec True]+          withType @Pt.Lseg [mappingSpec True]+          withType @Pt.Macaddr [mappingSpec True]+          withType @Pt.Macaddr8 [mappingSpec True]+          withType @Pt.Money [mappingSpec True]+          withType @(Pt.Numeric 0 0) [mappingSpec True]+          withType @(Pt.Numeric 5 0) [mappingSpec True]+          withType @(Pt.Numeric 5 2) [mappingSpec True]+          withType @Pt.Oid [mappingSpec True]+          withType @Pt.Path [mappingSpec True]+          withType @Pt.Point [mappingSpec True]+          withType @Pt.Polygon [mappingSpec True]+          withType @Pt.Text [mappingSpec True]+          withType @Pt.Time [mappingSpec True]+          withType @Pt.Timestamp [mappingSpec True]+          withType @Pt.Timestamptz [mappingSpec True]+          withType @Pt.Timetz [mappingSpec True]+          withType @Pt.Uuid [mappingSpec True]+          withType @(Pt.Varbit 5) [mappingSpec True]+          withType @(Pt.Varchar 5) [mappingSpec True]

@@ -0,0 +1,189 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- This module provides a bridge between PostgreSQL's standard types and the "postgresql-simple" library,+-- offering 'ToField' and 'FromField' instances for types defined in the "postgresql-types" library.+--+-- = Usage+--+-- Import this module in addition to @Database.PostgreSQL.Simple@ to get encoding/decoding support+-- for postgresql-types in postgresql-simple queries:+--+-- > import Database.PostgreSQL.Simple+-- > import Database.PostgreSQL.Simple.PostgresqlTypes+-- > import PostgresqlTypes.Types qualified as Pt+-- >+-- > -- Now you can use postgresql-types directly in queries+-- > example :: Connection -> Pt.Int4 -> IO [Only Pt.Text]+-- > example conn myInt = query conn "SELECT name FROM users WHERE id = ?" (Only myInt)+module Database.PostgreSQL.Simple.PostgresqlTypes+  (+  )+where++import Data.Data (Typeable)+import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsScalar (ViaIsScalar (ViaIsScalar))+import Database.PostgreSQL.Simple.ToField+import GHC.TypeLits+import PostgresqlTypes+import PostgresqlTypes.Algebra++deriving via ViaIsScalar (Bit length) instance (KnownNat length) => FromField (Bit length)++deriving via ViaIsScalar (Bit length) instance (KnownNat length) => ToField (Bit length)++deriving via ViaIsScalar (Bpchar length) instance (KnownNat length) => FromField (Bpchar length)++deriving via ViaIsScalar (Bpchar length) instance (KnownNat length) => ToField (Bpchar length)++deriving via ViaIsScalar (Numeric precision scale) instance (KnownNat precision, KnownNat scale) => FromField (Numeric precision scale)++deriving via ViaIsScalar (Numeric precision scale) instance (KnownNat precision, KnownNat scale) => ToField (Numeric precision scale)++deriving via ViaIsScalar (Varbit maxLen) instance (KnownNat maxLen) => FromField (Varbit maxLen)++deriving via ViaIsScalar (Varbit maxLen) instance (KnownNat maxLen) => ToField (Varbit maxLen)++deriving via ViaIsScalar (Varchar maxLen) instance (KnownNat maxLen) => FromField (Varchar maxLen)++deriving via ViaIsScalar (Varchar maxLen) instance (KnownNat maxLen) => ToField (Varchar maxLen)++-- | Decoder of 'Multirange' types.+--+-- Notice that \"postgresql-simple\" has an issue due to which queries producing arrays of multiranges always fail. See https://github.com/haskellari/postgresql-simple/issues/163. In other cases everything should work fine.+deriving via ViaIsScalar (Multirange a) instance (IsMultirangeElement a, Typeable a) => FromField (Multirange a)++deriving via ViaIsScalar (Multirange a) instance (IsMultirangeElement a) => ToField (Multirange a)++deriving via ViaIsScalar (Range a) instance (IsRangeElement a, Typeable a) => FromField (Range a)++deriving via ViaIsScalar (Range a) instance (IsRangeElement a) => ToField (Range a)++deriving via ViaIsScalar Bool instance FromField Bool++deriving via ViaIsScalar Bool instance ToField Bool++deriving via ViaIsScalar Box instance FromField Box++deriving via ViaIsScalar Box instance ToField Box++deriving via ViaIsScalar Bytea instance FromField Bytea++deriving via ViaIsScalar Bytea instance ToField Bytea++deriving via ViaIsScalar Char instance FromField Char++deriving via ViaIsScalar Char instance ToField Char++deriving via ViaIsScalar Cidr instance FromField Cidr++deriving via ViaIsScalar Cidr instance ToField Cidr++deriving via ViaIsScalar Circle instance FromField Circle++deriving via ViaIsScalar Circle instance ToField Circle++deriving via ViaIsScalar Date instance FromField Date++deriving via ViaIsScalar Date instance ToField Date++deriving via ViaIsScalar Float4 instance FromField Float4++deriving via ViaIsScalar Float4 instance ToField Float4++deriving via ViaIsScalar Float8 instance FromField Float8++deriving via ViaIsScalar Float8 instance ToField Float8++deriving via ViaIsScalar Hstore instance FromField Hstore++deriving via ViaIsScalar Hstore instance ToField Hstore++deriving via ViaIsScalar Inet instance FromField Inet++deriving via ViaIsScalar Inet instance ToField Inet++deriving via ViaIsScalar Int2 instance FromField Int2++deriving via ViaIsScalar Int2 instance ToField Int2++deriving via ViaIsScalar Int4 instance FromField Int4++deriving via ViaIsScalar Int4 instance ToField Int4++deriving via ViaIsScalar Int8 instance FromField Int8++deriving via ViaIsScalar Int8 instance ToField Int8++deriving via ViaIsScalar Interval instance FromField Interval++deriving via ViaIsScalar Interval instance ToField Interval++deriving via ViaIsScalar Json instance FromField Json++deriving via ViaIsScalar Json instance ToField Json++deriving via ViaIsScalar Jsonb instance FromField Jsonb++deriving via ViaIsScalar Jsonb instance ToField Jsonb++deriving via ViaIsScalar Line instance FromField Line++deriving via ViaIsScalar Line instance ToField Line++deriving via ViaIsScalar Lseg instance FromField Lseg++deriving via ViaIsScalar Lseg instance ToField Lseg++deriving via ViaIsScalar Macaddr instance FromField Macaddr++deriving via ViaIsScalar Macaddr instance ToField Macaddr++deriving via ViaIsScalar Macaddr8 instance FromField Macaddr8++deriving via ViaIsScalar Macaddr8 instance ToField Macaddr8++deriving via ViaIsScalar Money instance FromField Money++deriving via ViaIsScalar Money instance ToField Money++deriving via ViaIsScalar Oid instance FromField Oid++deriving via ViaIsScalar Oid instance ToField Oid++deriving via ViaIsScalar Path instance FromField Path++deriving via ViaIsScalar Path instance ToField Path++deriving via ViaIsScalar Point instance FromField Point++deriving via ViaIsScalar Point instance ToField Point++deriving via ViaIsScalar Polygon instance FromField Polygon++deriving via ViaIsScalar Polygon instance ToField Polygon++deriving via ViaIsScalar Text instance FromField Text++deriving via ViaIsScalar Text instance ToField Text++deriving via ViaIsScalar Time instance FromField Time++deriving via ViaIsScalar Time instance ToField Time++deriving via ViaIsScalar Timestamp instance FromField Timestamp++deriving via ViaIsScalar Timestamp instance ToField Timestamp++deriving via ViaIsScalar Timestamptz instance FromField Timestamptz++deriving via ViaIsScalar Timestamptz instance ToField Timestamptz++deriving via ViaIsScalar Timetz instance FromField Timetz++deriving via ViaIsScalar Timetz instance ToField Timetz++deriving via ViaIsScalar Uuid instance FromField Uuid++deriving via ViaIsScalar Uuid instance ToField Uuid

@@ -0,0 +1,50 @@+module Database.PostgreSQL.Simple.PostgresqlTypes.Prelude+  ( module Exports,+  )+where++import Control.Applicative as Exports hiding (WrappedArrow (..))+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Control.Monad.ST.Unsafe as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip)+import Data.Functor.Contravariant as Exports+import Data.Functor.Identity as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (First (..), Last (..), (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.Semigroup as Exports+import Data.String as Exports+import Data.Tagged as Exports (Tagged (..), retag, untag)+import Data.Text as Exports (Text)+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import TextBuilder as Exports (TextBuilder)+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))

@@ -0,0 +1,125 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- This module provides a bridge between PostgreSQL's standard types and the postgresql-simple library,+-- offering automatic ToField and FromField instance generation for types that implement the 'IsScalar' constraint.+--+-- = Usage+--+-- Import this module in addition to @Database.PostgreSQL.Simple@ to get encoding/decoding support+-- for postgresql-types in postgresql-simple queries:+--+-- > import Database.PostgreSQL.Simple+-- > import Database.PostgreSQL.Simple.PostgresqlTypes+-- > import PostgresqlTypes.Types (Int4, Text)+-- >+-- > -- Now you can use postgresql-types directly in queries+-- > example :: Connection -> Int4 -> IO [Only Text]+-- > example conn myInt = query conn "SELECT name FROM users WHERE id = ?" (Only myInt)+--+-- = How it works+--+-- * 'toFieldVia' creates a 'ToField' compatible 'Action' using the 'textualEncoder' from 'Pta.IsScalar'+-- * 'fromFieldVia' creates a 'FromField' compatible parser using the 'textualDecoder' from 'Pta.IsScalar'+--+-- The module uses textual format for encoding/decoding since that's what postgresql-simple primarily uses.+module Database.PostgreSQL.Simple.PostgresqlTypes.ViaIsScalar (ViaIsScalar (..)) where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import qualified Data.Text.Encoding.Error as TextEncoding+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.PostgresqlTypes.Prelude+import Database.PostgreSQL.Simple.ToField+import qualified PostgresqlTypes.Algebra as Pta+import qualified TextBuilder++newtype ViaIsScalar a = ViaIsScalar a++instance (Pta.IsScalar a) => ToField (ViaIsScalar a) where+  toField (ViaIsScalar value) = toFieldVia value++instance (Typeable a, Pta.IsScalar a) => FromField (ViaIsScalar a) where+  fromField field mdata = ViaIsScalar <$> fromFieldVia field mdata++-- | Convert a postgresql-types value to a postgresql-simple 'Action'.+--+-- This function uses the textual encoder from 'IsScalar' to produce+-- an escaped text value suitable for use in SQL queries.+--+-- > instance ToField Int4 where+-- >   toField = toFieldVia+toFieldVia :: forall a. (Pta.IsScalar a) => a -> Action+toFieldVia value =+  Many+    [ Escape (TextEncoding.encodeUtf8 (TextBuilder.toText (Pta.textualEncoder value))),+      Plain ("::" <> TextEncoding.encodeUtf8Builder (untag (Pta.typeSignature @a)))+    ]++-- | Parse a postgresql-types value from a postgresql-simple field.+--+-- This function uses the textual decoder from 'Pta.IsScalar' to parse+-- values received from PostgreSQL in text format.+--+-- It validates the field's type by comparing:+-- * The field's OID against the type's expected base OID or array OID+-- * When OID is not statically known, falls back to comparing type names+-- * Automatically handles array types by checking against arrayOid+--+-- > instance FromField Int4 where+-- >   fromField = fromFieldVia+fromFieldVia :: forall a. (Typeable a, Pta.IsScalar a) => FieldParser a+fromFieldVia field mdata = do+  -- Type validation: check OID or name+  let expectedBaseOid = untag (Pta.baseOid @a)+      expectedArrayOid = untag (Pta.arrayOid @a)+      expectedTypeName = untag (Pta.typeName @a)+      fieldOid = typeOid field++  case (expectedBaseOid, expectedArrayOid) of+    -- For types with known OIDs, validate against OID without calling typename+    (Just expectedBaseOid, Just expectedArrayOid) -> do+      let typeMatches =+            fieldOid == Oid (fromIntegral expectedBaseOid)+              || fieldOid == Oid (fromIntegral expectedArrayOid)++      unless typeMatches do+        returnError Incompatible field $+          mconcat+            [ "Type mismatch: expected ",+              Text.unpack expectedTypeName,+              " (OID ",+              show expectedBaseOid,+              ", array OID " <> show expectedArrayOid,+              ") but got field with OID ",+              show fieldOid+            ]++    -- Only call typename if we need it for validation (when OID is not available)+    _ -> do+      fieldTypeName <- typename field+      let expectedName = TextEncoding.encodeUtf8 expectedTypeName+      unless (fieldTypeName == expectedName) do+        returnError Incompatible field $+          mconcat+            [ "Type mismatch: expected ",+              Text.unpack expectedTypeName,+              " (OID unknown) but got field with type name ",+              show (TextEncoding.decodeUtf8With TextEncoding.lenientDecode fieldTypeName)+            ]++  -- Data validation and parsing+  case mdata of+    Nothing -> returnError UnexpectedNull field ""+    Just bytes -> case TextEncoding.decodeUtf8' bytes of+      Left err ->+        returnError ConversionFailed field $+          "UTF-8 decoding failed: " <> show err+      Right text ->+        case Attoparsec.parseOnly (Pta.textualDecoder @a <* Attoparsec.endOfInput) text of+          Left err ->+            returnError ConversionFailed field $+              "Parsing failed: " <> err+          Right value -> pure value