packages feed

postgresql-types (empty) → 0.1

raw patch · 105 files changed

+11251/−0 lines, 105 filesdep +QuickCheckdep +aesondep +async

Dependencies added: QuickCheck, aeson, async, attoparsec, base, bytestring, containers, hashable, hspec, invariant, jsonifier, mtl, postgresql-libpq, postgresql-types, postgresql-types-algebra, profunctors, ptr-peeker, ptr-poker, quickcheck-classes, quickcheck-extras, quickcheck-instances, scientific, stm, tagged, testcontainers-postgresql, text, text-builder, time, transformers, uuid, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2025, 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.
+ README.md view
@@ -0,0 +1,93 @@+# postgresql-types++[![Hackage](https://img.shields.io/hackage/v/postgresql-types.svg)](https://hackage.haskell.org/package/postgresql-types)+[![Continuous Haddock](https://img.shields.io/badge/haddock-master-blue)](https://nikita-volkov.github.io/postgresql-types/)++Precise Haskell representations of PostgreSQL data types with mappings to and from both binary and textual formats.++## Status++In active development, but already working and exhaustively tested.++## Key Features++### Ecosystem Integration++Adapter packages provide integrations for major PostgreSQL client libraries:++- "hasql": ["hasql-postgresql-types"](https://github.com/nikita-volkov/hasql-postgresql-types)+- "postgresql-simple": ["postgresql-simple-postgresql-types"](https://github.com/nikita-volkov/postgresql-simple-postgresql-types)++### Supported Types++This package provides support for nearly all PostgreSQL data types, including:++- **Numeric types**: Int2, Int4, Int8, Float4, Float8, Numeric, Money, Oid+- **Character types**: Char, Varchar, Text, Bpchar+- **Boolean type**: Bool+- **Binary data**: Bytea+- **Date/time types**: Date, Time, Timestamp, Timestamptz, Timetz, Interval+- **Network address types**: Inet, Cidr, Macaddr, Macaddr8+- **Geometric types**: Point, Line, Lseg, Box, Path, Polygon, Circle+- **Bit string types**: Bit, Varbit+- **UUID type**: Uuid+- **JSON types**: Json, Jsonb+- **Key-value types**: Hstore+- **Range types**: Range (supporting int4range, int8range, numrange, tsrange, tstzrange, daterange)+- **Multirange types**: Multirange (supporting int4multirange, int8multirange, etc.)+- **Array types** for all of the above++For detailed information about each type, see the [package documentation](https://hackage.haskell.org/package/postgresql-types).++### Type Safety & Valid Ranges++All PostgreSQL types are represented with hidden constructors, ensuring that only valid PostgreSQL values can be constructed. This design prevents invalid data from being represented at the type level.++Values can only be created through explicit constructor functions, guaranteeing adherence to PostgreSQL's constraints (e.g., dates within PostgreSQL's supported range, text without NUL bytes).++### Type-Safe Constructors++The library provides three types of functions for working with PostgreSQL types:++- **Normalizing constructors** (prefix: `normalizeFrom*`) - Always succeed by clamping or canonicalizing input values to valid ranges+- **Refining constructors** (prefix: `refineFrom*`) - Return `Maybe`, failing if the input is out of range+- **Accessor functions** (prefix: `to*`) - Extract values from PostgreSQL types to common Haskell types++This approach ensures that:+- Type constructors remain hidden to protect invariants+- All conversions are explicit and type-safe+- Invalid data is either rejected or canonicalized (e.g., removing NUL bytes from text, clamping dates to valid range)+- Round-trip properties are maintained via accessor functions++### Complete Range Coverage with Property Testing++Every type implements `Arbitrary` instances that **simulate the complete range of valid PostgreSQL values**, not just convenient Haskell subsets. For example:++- **`Date`** generates values spanning PostgreSQL's full range: 4713 BC to 5874897 AD+- **`Text`** generates strings excluding NUL characters (as PostgreSQL doesn't allow them)+- **`Circle`** generates circles with non-negative radii+- **`Numeric`** covers arbitrary-precision numbers including edge cases++This comprehensive approach to test data generation ensures that the library is tested against the actual constraints and edge cases of PostgreSQL, not just typical use cases.++### Exhaustive Testing++The library employs a rigorous multi-layered testing strategy:++#### Unit Tests+- **Encoder/Decoder Round-trips**: Every type is tested for round-trip fidelity through both binary and textual encodings+- **Constructor Properties**: All constructor functions are validated for proper normalization and refinement behavior using property-based testing+- **Cross-format Validation**: Binary encoders are tested against textual decoders and vice versa++#### Integration Tests+- **Real PostgreSQL Validation**: Tests run against actual PostgreSQL servers (versions 9 through 18)+- **Four-way Round-trip Matrix**: Each value is tested through all four combinations:+  1. Text encoding → Text decoding+  2. Text encoding → Binary decoding  +  3. Binary encoding → Text decoding+  4. Binary encoding → Binary decoding+- **Server Canonical Form**: All encodings are validated by sending values to PostgreSQL and verifying the server produces the expected output+- **Array Support**: Every type is tested both as a scalar and as array elements+- **Metadata Validation**: Type OIDs are verified against the PostgreSQL system catalog++This comprehensive testing model provides confidence that the library correctly handles all PostgreSQL types across all encoding formats and PostgreSQL versions.
+ postgresql-types.cabal view
@@ -0,0 +1,333 @@+cabal-version: 3.0+name: postgresql-types+version: 0.1+category: PostgreSQL, Codecs+synopsis: Precise PostgreSQL types representation and driver-agnostic codecs+description:+  This package provides a Haskell representation of PostgreSQL data types, with mappings to and from both binary and textual formats of the PostgreSQL wire protocol. The types are implemented in their canonical forms, directly corresponding to their PostgreSQL counterparts. The philosophy is that nuance matters, so all special values are represented without data loss or compromise.++  The types presented by this package do not necessarily have direct mappings to common Haskell types. Canonicalizing conversions and smart constructors are provided to address this.++  For example, any @text@ value from PostgreSQL produces a valid 'Data.Text.Text' value in Haskell, but not every Haskell 'Data.Text.Text' value produces a valid PostgreSQL @text@, because PostgreSQL does not allow NUL bytes in text fields, whereas Haskell's 'Data.Text.Text' does. In the case of dates, the supported date ranges may differ between PostgreSQL and Haskell's "time" library. Therefore, conversions between these types and common Haskell types may be partial and may fail if the data cannot be represented in the target type.++  All types supply 'Test.QuickCheck.Arbitrary' instances that cover the full range of valid PostgreSQL values. Every type is property-tested to validate round-trip conversions between binary and textual formats against PostgreSQL versions 9 to 18.++  The library can be used as the basis for various PostgreSQL libraries. Ecosystem integration adapters are available for:++  * hasql: <https://hackage.haskell.org/package/hasql-postgresql-types>++  * postgresql-simple: <https://hackage.haskell.org/package/postgresql-simple-postgresql-types>++homepage: https://github.com/nikita-volkov/postgresql-types+bug-reports: https://github.com/nikita-volkov/postgresql-types/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2025, 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-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:+    PostgresqlTypes+    PostgresqlTypes.Bit+    PostgresqlTypes.Bool+    PostgresqlTypes.Box+    PostgresqlTypes.Bpchar+    PostgresqlTypes.Bytea+    PostgresqlTypes.Char+    PostgresqlTypes.Cidr+    PostgresqlTypes.Circle+    PostgresqlTypes.Date+    PostgresqlTypes.Float4+    PostgresqlTypes.Float8+    PostgresqlTypes.Hstore+    PostgresqlTypes.Inet+    PostgresqlTypes.Int2+    PostgresqlTypes.Int4+    PostgresqlTypes.Int8+    PostgresqlTypes.Interval+    PostgresqlTypes.Json+    PostgresqlTypes.Jsonb+    PostgresqlTypes.Line+    PostgresqlTypes.Lseg+    PostgresqlTypes.Macaddr+    PostgresqlTypes.Macaddr8+    PostgresqlTypes.Money+    PostgresqlTypes.Multirange+    PostgresqlTypes.Numeric+    PostgresqlTypes.Oid+    PostgresqlTypes.Path+    PostgresqlTypes.Point+    PostgresqlTypes.Polygon+    PostgresqlTypes.Range+    PostgresqlTypes.Text+    PostgresqlTypes.Time+    PostgresqlTypes.Timestamp+    PostgresqlTypes.Timestamptz+    PostgresqlTypes.Timetz+    PostgresqlTypes.Uuid+    PostgresqlTypes.Varbit+    PostgresqlTypes.Varchar++  other-modules:+    PostgresqlTypes.Numeric.Integer+    PostgresqlTypes.Numeric.Scientific+    PostgresqlTypes.Prelude+    PostgresqlTypes.Timetz.Offset+    PostgresqlTypes.Timetz.Time+    PostgresqlTypes.Via+    PostgresqlTypes.Via.IsScalar++  build-depends:+    QuickCheck >=2.14 && <3,+    aeson >=2.2 && <3,+    attoparsec >=0.14 && <0.19,+    base >=4.11 && <5,+    bytestring >=0.10 && <0.13,+    containers >=0.6 && <0.9,+    hashable >=1.3 && <2,+    invariant ^>=0.6.4,+    jsonifier ^>=0.2.1.3,+    mtl >=2.2 && <3,+    postgresql-types:base-extras,+    postgresql-types:jsonifier-aeson,+    postgresql-types:time-extras,+    postgresql-types-algebra ^>=0.1,+    profunctors ^>=5.6 && <6,+    ptr-peeker ^>=0.1,+    ptr-poker ^>=0.1.3,+    quickcheck-extras ^>=0.1,+    quickcheck-instances ^>=0.3.33,+    scientific >=0.3 && <1,+    tagged ^>=0.8.9,+    text >=1.2 && <3,+    text-builder ^>=1.0.0.4,+    time >=1.12 && <2,+    transformers >=0.5 && <0.7,+    uuid >=1.3 && <2,+    vector ^>=0.13,++library jsonifier-aeson+  import: base+  hs-source-dirs: src/jsonifier-aeson+  exposed-modules:+    JsonifierAeson++  other-modules:+  build-depends:+    aeson >=2.2 && <3,+    base >=4.11 && <5,+    jsonifier ^>=0.2.1.3,++library time-extras+  import: base+  hs-source-dirs: src/time-extras+  exposed-modules:+    TimeExtras.TimeOfDay+    TimeExtras.TimeZone++  other-modules:+  build-depends:+    base >=4.11 && <5,+    time >=1.12 && <2,++library base-extras+  import: base+  hs-source-dirs: src/base-extras+  exposed-modules:+    BaseExtras.List++library pq-procedures+  import: base+  hs-source-dirs: src/pq-procedures+  exposed-modules:+    PqProcedures+    PqProcedures.Algebra+    PqProcedures.Procedures++  other-modules:+    PqProcedures.Procedures.GetTypeInfoByName+    PqProcedures.Procedures.RunRoundtripQuery+    PqProcedures.Procedures.RunStatement++  build-depends:+    base >=4.11 && <5,+    bytestring >=0.10 && <0.13,+    postgresql-libpq >=0.10 && <0.12,+    ptr-peeker ^>=0.1,+    text >=1.2 && <3,+    text-builder ^>=1.0.0.4,++test-suite unit-tests+  import: test+  type: exitcode-stdio-1.0+  hs-source-dirs: src/unit-tests+  main-is: Main.hs+  other-modules:+    PostgresqlTypes.BitSpec+    PostgresqlTypes.BoolSpec+    PostgresqlTypes.BoxSpec+    PostgresqlTypes.BpcharSpec+    PostgresqlTypes.ByteaSpec+    PostgresqlTypes.CharSpec+    PostgresqlTypes.CidrSpec+    PostgresqlTypes.CircleSpec+    PostgresqlTypes.DateSpec+    PostgresqlTypes.Float4Spec+    PostgresqlTypes.Float8Spec+    PostgresqlTypes.HstoreSpec+    PostgresqlTypes.InetSpec+    PostgresqlTypes.Int2Spec+    PostgresqlTypes.Int4Spec+    PostgresqlTypes.Int8Spec+    PostgresqlTypes.IntervalSpec+    PostgresqlTypes.JsonSpec+    PostgresqlTypes.JsonbSpec+    PostgresqlTypes.LineSpec+    PostgresqlTypes.LsegSpec+    PostgresqlTypes.Macaddr8Spec+    PostgresqlTypes.MacaddrSpec+    PostgresqlTypes.MoneySpec+    PostgresqlTypes.MultirangeSpec+    PostgresqlTypes.NumericSpec+    PostgresqlTypes.OidSpec+    PostgresqlTypes.PathSpec+    PostgresqlTypes.PointSpec+    PostgresqlTypes.PolygonSpec+    PostgresqlTypes.RangeSpec+    PostgresqlTypes.TextSpec+    PostgresqlTypes.TimeSpec+    PostgresqlTypes.TimestampSpec+    PostgresqlTypes.TimestamptzSpec+    PostgresqlTypes.TimetzSpec+    PostgresqlTypes.UuidSpec+    PostgresqlTypes.VarbitSpec+    PostgresqlTypes.VarcharSpec+    SpecHook+    UnitTests.Scripts++  build-tool-depends:+    hspec-discover:hspec-discover >=2 && <3++  build-depends:+    QuickCheck >=2.14 && <3,+    aeson >=2.2 && <3,+    attoparsec >=0.14 && <0.15,+    base >=4.11 && <5,+    bytestring >=0.10 && <0.13,+    containers >=0.6 && <0.9,+    hspec >=2.11 && <3,+    postgresql-types,+    postgresql-types-algebra,+    ptr-peeker ^>=0.1,+    ptr-poker ^>=0.1.2.16,+    quickcheck-classes ^>=0.6.5,+    scientific >=0.3 && <1,+    tagged ^>=0.8.9,+    text >=1.2 && <3,+    text-builder ^>=1.0.0.4,+    time >=1.12 && <2,+    uuid >=1.3 && <2,+    vector ^>=0.13,++test-suite integration-tests+  import: test+  type: exitcode-stdio-1.0+  hs-source-dirs: src/integration-tests+  main-is: Main.hs+  other-modules:+    Main.Scopes+    Main.Scripts++  build-depends:+    QuickCheck >=2.14 && <3,+    async >=2.2.6 && <2.3,+    attoparsec >=0.14 && <0.15,+    base >=4.11 && <5,+    bytestring >=0.10 && <0.13,+    hspec >=2.11 && <3,+    postgresql-libpq >=0.10 && <0.12,+    postgresql-types,+    postgresql-types:pq-procedures,+    postgresql-types-algebra,+    ptr-peeker ^>=0.1,+    ptr-poker ^>=0.1.2.16,+    quickcheck-instances ^>=0.3.33,+    stm >=2.5 && <3,+    tagged ^>=0.8.9,+    testcontainers-postgresql ^>=0.2.0.1,+    text >=1.2 && <3,+    text-builder ^>=1.0.0.4,
+ src/base-extras/BaseExtras/List.hs view
@@ -0,0 +1,6 @@+module BaseExtras.List where++toPairs :: [a] -> [(a, a)]+toPairs [] = []+toPairs [_] = []+toPairs (x : y : xs) = (x, y) : toPairs xs
+ src/integration-tests/Main.hs view
@@ -0,0 +1,186 @@+module Main (main) where++import Main.Scopes+import Main.Scripts+import qualified PostgresqlTypes as PostgresqlTypes+import Test.Hspec+import Test.QuickCheck.Instances ()+import Prelude++main :: IO ()+main =+  hspec do+    parallel do+      withContainer "postgres:18" do+        withConnection Nothing do+          withType @(PostgresqlTypes.Bit 0) [mappingSpec]+          withType @(PostgresqlTypes.Bit 1) [mappingSpec]+          withType @(PostgresqlTypes.Bit 64) [mappingSpec]+          withType @PostgresqlTypes.Bool [mappingSpec]+          withType @PostgresqlTypes.Box [mappingSpec]+          withType @PostgresqlTypes.Bytea [mappingSpec]+          withType @PostgresqlTypes.Char [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 0) [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 1) [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 64) [mappingSpec]+          withType @PostgresqlTypes.Cidr [mappingSpec]+          withType @PostgresqlTypes.Circle [mappingSpec]+          withType @PostgresqlTypes.Date [mappingSpec]+          withType @PostgresqlTypes.Float4 [mappingSpec]+          withType @PostgresqlTypes.Float8 [mappingSpec]+          withType @PostgresqlTypes.Inet [mappingSpec]+          withType @PostgresqlTypes.Int2 [mappingSpec]+          withType @PostgresqlTypes.Int4 [mappingSpec]+          withType @PostgresqlTypes.Int8 [mappingSpec]+          withType @PostgresqlTypes.Interval [mappingSpec]+          withType @PostgresqlTypes.Json [mappingSpec]+          withType @PostgresqlTypes.Jsonb [mappingSpec]+          withType @PostgresqlTypes.Line [mappingSpec]+          withType @PostgresqlTypes.Lseg [mappingSpec]+          withType @PostgresqlTypes.Macaddr [mappingSpec]+          withType @PostgresqlTypes.Macaddr8 [mappingSpec]+          withType @PostgresqlTypes.Money [mappingSpec]+          withType @(PostgresqlTypes.Numeric 0 0) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 7 0) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 7 2) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 7 7) [mappingSpec]+          withType @PostgresqlTypes.Oid [mappingSpec]+          withType @PostgresqlTypes.Path [mappingSpec]+          withType @PostgresqlTypes.Point [mappingSpec]+          withType @PostgresqlTypes.Polygon [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Int4) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Int8) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 0 0)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 3 3)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 7 3)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 7 0)) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Timestamp) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Timestamptz) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Date) [mappingSpec]+          withType @(PostgresqlTypes.Multirange PostgresqlTypes.Int4) [mappingSpec]+          withType @(PostgresqlTypes.Multirange PostgresqlTypes.Int8) [mappingSpec]+          withType @(PostgresqlTypes.Multirange (PostgresqlTypes.Numeric 0 0)) [mappingSpec]+          withType @(PostgresqlTypes.Multirange (PostgresqlTypes.Numeric 3 3)) [mappingSpec]+          withType @(PostgresqlTypes.Multirange (PostgresqlTypes.Numeric 7 3)) [mappingSpec]+          withType @(PostgresqlTypes.Multirange (PostgresqlTypes.Numeric 7 0)) [mappingSpec]+          withType @(PostgresqlTypes.Multirange PostgresqlTypes.Timestamp) [mappingSpec]+          withType @(PostgresqlTypes.Multirange PostgresqlTypes.Timestamptz) [mappingSpec]+          withType @(PostgresqlTypes.Multirange PostgresqlTypes.Date) [mappingSpec]+          withType @PostgresqlTypes.Text [mappingSpec]+          withType @PostgresqlTypes.Time [mappingSpec]+          withType @PostgresqlTypes.Timestamp [mappingSpec]+          withType @PostgresqlTypes.Timestamptz [mappingSpec]+          withType @PostgresqlTypes.Timetz [mappingSpec]+          withType @PostgresqlTypes.Uuid [mappingSpec]+          withType @(PostgresqlTypes.Varbit 0) [mappingSpec]+          withType @(PostgresqlTypes.Varbit 128) [mappingSpec]+          withType @(PostgresqlTypes.Varchar 0) [mappingSpec]+          withType @(PostgresqlTypes.Varchar 255) [mappingSpec]++      withContainer "postgres:14" do+        withConnection (Just 3) do+          withType @(PostgresqlTypes.Bit 1) [mappingSpec]+          withType @(PostgresqlTypes.Bit 64) [mappingSpec]+          withType @PostgresqlTypes.Bool [mappingSpec]+          withType @PostgresqlTypes.Box [mappingSpec]+          withType @PostgresqlTypes.Bytea [mappingSpec]+          withType @PostgresqlTypes.Char [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 1) [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 64) [mappingSpec]+          withType @PostgresqlTypes.Cidr [mappingSpec]+          withType @PostgresqlTypes.Circle [mappingSpec]+          withType @PostgresqlTypes.Date [mappingSpec]+          withType @PostgresqlTypes.Float4 [mappingSpec]+          withType @PostgresqlTypes.Float8 [mappingSpec]+          withType @PostgresqlTypes.Inet [mappingSpec]+          withType @PostgresqlTypes.Int2 [mappingSpec]+          withType @PostgresqlTypes.Int4 [mappingSpec]+          withType @PostgresqlTypes.Int8 [mappingSpec]+          withType @PostgresqlTypes.Interval [mappingSpec]+          withType @PostgresqlTypes.Json [mappingSpec]+          withType @PostgresqlTypes.Jsonb [mappingSpec]+          withType @PostgresqlTypes.Line [mappingSpec]+          withType @PostgresqlTypes.Lseg [mappingSpec]+          withType @PostgresqlTypes.Macaddr [mappingSpec]+          withType @PostgresqlTypes.Money [mappingSpec]+          withType @(PostgresqlTypes.Numeric 0 0) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 7 0) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 7 2) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 7 7) [mappingSpec]+          withType @PostgresqlTypes.Oid [mappingSpec]+          withType @PostgresqlTypes.Path [mappingSpec]+          withType @PostgresqlTypes.Point [mappingSpec]+          withType @PostgresqlTypes.Polygon [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Int4) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Int8) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 0 0)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 3 3)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 7 3)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 7 0)) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Timestamp) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Timestamptz) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Date) [mappingSpec]+          withType @PostgresqlTypes.Text [mappingSpec]+          withType @PostgresqlTypes.Time [mappingSpec]+          withType @PostgresqlTypes.Timestamp [mappingSpec]+          withType @PostgresqlTypes.Timestamptz [mappingSpec]+          withType @PostgresqlTypes.Timetz [mappingSpec]+          withType @PostgresqlTypes.Uuid [mappingSpec]+          withType @(PostgresqlTypes.Varbit 0) [mappingSpec]+          withType @(PostgresqlTypes.Varbit 128) [mappingSpec]+          withType @(PostgresqlTypes.Varchar 0) [mappingSpec]+          withType @(PostgresqlTypes.Varchar 255) [mappingSpec]++      withContainer "postgres:9" do+        withConnection (Just 3) do+          withType @(PostgresqlTypes.Bit 0) [mappingSpec]+          withType @(PostgresqlTypes.Bit 1) [mappingSpec]+          withType @(PostgresqlTypes.Bit 64) [mappingSpec]+          withType @PostgresqlTypes.Bool [mappingSpec]+          withType @PostgresqlTypes.Box [mappingSpec]+          withType @PostgresqlTypes.Bytea [mappingSpec]+          withType @PostgresqlTypes.Char [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 0) [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 1) [mappingSpec]+          withType @(PostgresqlTypes.Bpchar 64) [mappingSpec]+          withType @PostgresqlTypes.Cidr [mappingSpec]+          withType @PostgresqlTypes.Circle [mappingSpec]+          withType @PostgresqlTypes.Date [mappingSpec]+          withType @PostgresqlTypes.Float4 [mappingSpec]+          withType @PostgresqlTypes.Float8 [mappingSpec]+          withType @PostgresqlTypes.Inet [mappingSpec]+          withType @PostgresqlTypes.Int2 [mappingSpec]+          withType @PostgresqlTypes.Int4 [mappingSpec]+          withType @PostgresqlTypes.Int8 [mappingSpec]+          withType @PostgresqlTypes.Interval [mappingSpec]+          withType @PostgresqlTypes.Json [mappingSpec]+          withType @PostgresqlTypes.Jsonb [mappingSpec]+          withType @PostgresqlTypes.Line [mappingSpec]+          withType @PostgresqlTypes.Lseg [mappingSpec]+          withType @PostgresqlTypes.Macaddr [mappingSpec]+          withType @PostgresqlTypes.Money [mappingSpec]+          withType @(PostgresqlTypes.Numeric 10 0) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 10 2) [mappingSpec]+          withType @(PostgresqlTypes.Numeric 10 7) [mappingSpec]+          withType @PostgresqlTypes.Oid [mappingSpec]+          withType @PostgresqlTypes.Path [mappingSpec]+          withType @PostgresqlTypes.Point [mappingSpec]+          withType @PostgresqlTypes.Polygon [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Int4) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Int8) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 3 3)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 7 3)) [mappingSpec]+          withType @(PostgresqlTypes.Range (PostgresqlTypes.Numeric 7 0)) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Timestamp) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Timestamptz) [mappingSpec]+          withType @(PostgresqlTypes.Range PostgresqlTypes.Date) [mappingSpec]+          withType @PostgresqlTypes.Text [mappingSpec]+          withType @PostgresqlTypes.Time [mappingSpec]+          withType @PostgresqlTypes.Timestamp [mappingSpec]+          withType @PostgresqlTypes.Timestamptz [mappingSpec]+          withType @PostgresqlTypes.Timetz [mappingSpec]+          withType @PostgresqlTypes.Uuid [mappingSpec]+          withType @(PostgresqlTypes.Varbit 0) [mappingSpec]+          withType @(PostgresqlTypes.Varbit 128) [mappingSpec]+          withType @(PostgresqlTypes.Varchar 0) [mappingSpec]+          withType @(PostgresqlTypes.Varchar 255) [mappingSpec]
+ src/integration-tests/Main/Scopes.hs view
@@ -0,0 +1,144 @@+module Main.Scopes where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import qualified Data.ByteString as ByteString+import Data.Function+import Data.Maybe+import Data.Proxy+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import Data.Typeable+import Data.Word+import qualified Database.PostgreSQL.LibPQ as Pq+import Test.Hspec+import qualified TestcontainersPostgresql+import qualified TextBuilder+import Prelude++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+        }++withConnection :: Maybe Int -> SpecWith Pq.Connection -> SpecWith (Text, Word16)+withConnection extraFloatDigits =+  withConnectionPool 100 extraFloatDigits . withTQueueElement clean+  where+    clean connection = pure connection++withConnectionPool :: Int -> Maybe Int -> SpecWith (TQueue Pq.Connection) -> SpecWith (Text, Word16)+withConnectionPool poolSize extraFloatDigits =+  describe name . mapSubject connectionStringByContainerInfo . withPool poolSize acquire release+  where+    name =+      mconcat+        [ "extraFloatDigits: ",+          case extraFloatDigits of+            Just digits -> show digits+            Nothing -> "default"+        ]++    connectionStringByContainerInfo (host, port) =+      ByteString.intercalate " " components+      where+        components =+          [ "host=" <> (Text.Encoding.encodeUtf8 host),+            "port=" <> (fromString . show) port,+            "user=" <> user,+            "password=" <> password,+            "dbname=" <> db+          ]+          where+            user = "postgres"+            password = "postgres"+            db = "postgres"++    acquire connectionString = do+      connection <- Pq.connectdb connectionString+      status <- Pq.status connection+      case status of+        Pq.ConnectionOk -> pure ()+        _ -> do+          message <- Pq.errorMessage connection+          fail ("Failed to connect to database: " <> show message)+      result <-+        Pq.exec+          connection+          ( [ Just "SET client_min_messages TO WARNING",+              Just "SET client_encoding = 'UTF8'",+              Just "SET intervalstyle = 'iso_8601'",+              fmap+                (\digits -> "SET extra_float_digits = " <> TextBuilder.decimal digits)+                extraFloatDigits+            ]+              & catMaybes+              & fmap (<> ";")+              & TextBuilder.intercalate "\n"+              & TextBuilder.toText+              & Text.Encoding.encodeUtf8+          )+      case result of+        Just _ -> pure ()+        Nothing -> do+          message <- Pq.errorMessage connection+          fail ("Failed to set connection parameters: " <> show message)+      pure connection++    release = Pq.finish++withPool ::+  -- | Pool size.+  Int ->+  -- | Acquire.+  (b -> IO a) ->+  -- | Release.+  (a -> IO ()) ->+  SpecWith (TQueue a) ->+  SpecWith b+withPool poolSize acquire release =+  describe ("poolSize: " <> show poolSize) . 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++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
+ src/integration-tests/Main/Scripts.hs view
@@ -0,0 +1,221 @@+module Main.Scripts where++import Control.Monad+import qualified Data.Attoparsec.Text+import Data.Function+import Data.Maybe+import Data.Proxy+import Data.Tagged+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified Database.PostgreSQL.LibPQ as Pq+import qualified PostgresqlTypes.Algebra+import qualified PqProcedures as Procedures+import qualified PtrPeeker+import qualified PtrPoker.Write+import Test.Hspec+import Test.QuickCheck ((.&&.), (===))+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder+import Prelude++mappingSpec ::+  forall a.+  (HasCallStack, QuickCheck.Arbitrary a, Show a, Eq a, PostgresqlTypes.Algebra.IsScalar a) =>+  Proxy a ->+  SpecWith Pq.Connection+mappingSpec _ =+  let typeName = untag (PostgresqlTypes.Algebra.typeName @a)+      maybeBaseOid = untag (PostgresqlTypes.Algebra.baseOid @a)+      maybeArrayOid = untag (PostgresqlTypes.Algebra.arrayOid @a)+      binEnc = PostgresqlTypes.Algebra.binaryEncoder @a+      binDec = PostgresqlTypes.Algebra.binaryDecoder @a+      txtEnc = PostgresqlTypes.Algebra.textualEncoder @a+      txtDec = PostgresqlTypes.Algebra.textualDecoder @a++      getOids connection = do+        case (maybeBaseOid, maybeArrayOid) of+          (Just baseOid, Just arrayOid) ->+            pure (baseOid, arrayOid)+          _ -> do+            Procedures.GetTypeInfoByNameResult {..} <- Procedures.run connection Procedures.GetTypeInfoByNameParams {name = typeName}+            baseOid <- case maybeBaseOid of+              Just oid -> pure oid+              Nothing -> case baseOid of+                Just oid -> pure oid+                Nothing -> fail $ "Base OID not found for type: " <> Text.unpack typeName+            arrayOid <- case maybeArrayOid of+              Just oid -> pure oid+              Nothing -> case arrayOid of+                Just oid -> pure oid+                Nothing -> fail $ "Array OID not found for type: " <> Text.unpack typeName+            pure (baseOid, arrayOid)+   in describe "IsScalar" do+        describe (Text.unpack typeName) do+          describe "Encoding via textualEncoder" do+            describe "And decoding via textualDecoder" do+              it "Should produce the original value" \(connection :: Pq.Connection) ->+                QuickCheck.property \(value :: a) -> do+                  let valueText = TextBuilder.toText (txtEnc value)+                  QuickCheck.idempotentIOProperty do+                    (baseOid, _) <- getOids connection+                    bytes <-+                      Procedures.run+                        connection+                        Procedures.RunRoundtripQueryParams+                          { paramOid = baseOid,+                            paramEncoding = Text.Encoding.encodeUtf8 valueText,+                            paramFormat = Pq.Text,+                            resultFormat = Pq.Text,+                            typeSignature = Nothing+                          }+                    let serverProducedText = Text.Encoding.decodeUtf8 bytes+                        decoding = Data.Attoparsec.Text.parseOnly txtDec serverProducedText+                    pure+                      ( QuickCheck.counterexample+                          ( Text.unpack+                              ( Text.intercalate+                                  "\n"+                                  [ "serverProducedText: " <> serverProducedText,+                                    "encoded: " <> valueText+                                  ]+                              )+                          )+                          (decoding === Right value)+                      )++            describe "And decoding via binaryDecoder" do+              it "Should produce the original value" \(connection :: Pq.Connection) ->+                QuickCheck.property \(value :: a) -> do+                  let valueText = TextBuilder.toText (txtEnc value)+                  QuickCheck.idempotentIOProperty do+                    (baseOid, _) <- getOids connection+                    bytes <-+                      Procedures.run+                        connection+                        Procedures.RunRoundtripQueryParams+                          { paramOid = baseOid,+                            paramEncoding = Text.Encoding.encodeUtf8 valueText,+                            paramFormat = Pq.Text,+                            resultFormat = Pq.Binary,+                            typeSignature = Nothing+                          }+                    let decoding = PtrPeeker.runVariableOnByteString binDec bytes+                    pure+                      ( QuickCheck.counterexample+                          ( Text.unpack+                              ( Text.intercalate+                                  "\n"+                                  [ "encoded: " <> valueText+                                  ]+                              )+                          )+                          (decoding === Right (Right value))+                      )++          describe "Encoding via binaryEncoder" do+            describe "And decoding via textualDecoder" do+              it "Should produce the original value" \(connection :: Pq.Connection) ->+                QuickCheck.property \(value :: a) -> do+                  QuickCheck.idempotentIOProperty do+                    (baseOid, _) <- getOids connection+                    bytes <-+                      Procedures.run+                        connection+                        Procedures.RunRoundtripQueryParams+                          { paramOid = baseOid,+                            paramEncoding = PtrPoker.Write.toByteString (binEnc value),+                            paramFormat = Pq.Binary,+                            resultFormat = Pq.Text,+                            typeSignature = Nothing+                          }+                    let serverProducedText = Text.Encoding.decodeUtf8 bytes+                        decoding = Data.Attoparsec.Text.parseOnly txtDec serverProducedText+                    pure+                      ( QuickCheck.counterexample+                          ("serverProducedText: " <> show serverProducedText)+                          (decoding === Right value)+                      )++            describe "And decoding via binaryDecoder" do+              it "Should produce the original value" \(connection :: Pq.Connection) ->+                QuickCheck.property \(value :: a) -> do+                  QuickCheck.idempotentIOProperty do+                    (baseOid, _) <- getOids connection+                    bytes <-+                      Procedures.run+                        connection+                        Procedures.RunRoundtripQueryParams+                          { paramOid = baseOid,+                            paramEncoding = PtrPoker.Write.toByteString (binEnc value),+                            paramFormat = Pq.Binary,+                            resultFormat = Pq.Binary,+                            typeSignature = Nothing+                          }+                    let decoding = PtrPeeker.runVariableOnByteString binDec bytes+                    pure (decoding === Right (Right value))++            describe "As array" do+              it "Should produce the original value" \(connection :: Pq.Connection) ->+                QuickCheck.property \(value :: [a]) -> do+                  QuickCheck.idempotentIOProperty do+                    (baseOid, arrayOid) <- getOids connection+                    let arrayElementBinEnc value' =+                          let write = binEnc value'+                           in PtrPoker.Write.bInt32 (fromIntegral (PtrPoker.Write.writeSize write)) <> write+                        arrayBinEnc value' =+                          mconcat+                            [ PtrPoker.Write.bWord32 1,+                              PtrPoker.Write.bWord32 0,+                              PtrPoker.Write.bWord32 baseOid,+                              PtrPoker.Write.bInt32 (fromIntegral (length value')),+                              PtrPoker.Write.bWord32 1,+                              foldMap arrayElementBinEnc value'+                            ]+                        arrayElementBinDec = do+                          size <- PtrPeeker.fixed PtrPeeker.beSignedInt4+                          case size of+                            -1 -> error "TODO"+                            _ -> PtrPeeker.forceSize (fromIntegral size) binDec+                        arrayBinDec = do+                          dims <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4+                          _ <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4+                          decodedBaseOid <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4+                          case dims of+                            0 -> pure (decodedBaseOid, Right [])+                            1 -> do+                              length <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4+                              _ <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4+                              values <- replicateM (fromIntegral length) arrayElementBinDec+                              pure (decodedBaseOid, sequence values)+                            _ -> error "Bug"+                    bytes <-+                      Procedures.run+                        connection+                        Procedures.RunRoundtripQueryParams+                          { paramOid = arrayOid,+                            paramEncoding = PtrPoker.Write.toByteString (arrayBinEnc value),+                            paramFormat = Pq.Binary,+                            resultFormat = Pq.Binary,+                            typeSignature = Nothing+                          }+                    let decoding = PtrPeeker.runVariableOnByteString arrayBinDec bytes+                    (decodedBaseOid, decoding) <- case decoding of+                      Left bytesNeeded -> fail $ "More input bytes needed: " <> show bytesNeeded+                      Right decoding -> pure decoding+                    decodedValue <- case decoding of+                      Right value' -> pure value'+                      _ -> fail "Decoding failed 2"+                    pure (decodedBaseOid === baseOid .&&. decodedValue === value)++          describe "Metadata" do+            it "Should match the DB catalogue" \(connection :: Pq.Connection) -> do+              Procedures.GetTypeInfoByNameResult {..} <- Procedures.run connection Procedures.GetTypeInfoByNameParams {name = typeName}+              case (maybeBaseOid, maybeArrayOid) of+                (Just expectedBaseOid, Just expectedArrayOid) -> do+                  shouldBe baseOid (Just expectedBaseOid)+                  shouldBe arrayOid (Just expectedArrayOid)+                _ -> do+                  -- For types without stable OIDs, just verify the OIDs exist+                  shouldSatisfy baseOid isJust+                  shouldSatisfy arrayOid isJust
+ src/jsonifier-aeson/JsonifierAeson.hs view
@@ -0,0 +1,26 @@+-- | Extension of \"jsonifier\" integrating it with \"aeson\".+--+-- Can be imported in the same namespace as "Jsonifier" itself.+module JsonifierAeson where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+import Data.Bifunctor (bimap)+import Jsonifier+import Prelude hiding (null)++aesonValue :: Aeson.Value -> Json+aesonValue = \case+  Aeson.Null -> null+  Aeson.Bool b -> bool b+  Aeson.Number n -> scientificNumber n+  Aeson.String s -> textString s+  Aeson.Array a -> aesonArray a+  Aeson.Object o -> aesonObject o++aesonArray :: Aeson.Array -> Json+aesonArray = array . fmap aesonValue++aesonObject :: Aeson.Object -> Json+aesonObject = object . fmap (bimap Aeson.Key.toText aesonValue) . Aeson.KeyMap.toList
+ src/library/PostgresqlTypes.hs view
@@ -0,0 +1,107 @@+-- |+-- This module re-exports all PostgreSQL types defined in this package. No constructors. No functions.+module PostgresqlTypes+  ( -- * Numeric Types+    Int2,+    Int4,+    Int8,+    Float4,+    Float8,+    Numeric,+    Money,+    Oid,++    -- * Character Types+    Text,+    Varchar,+    Char,+    Bpchar,++    -- * Boolean Type+    Bool,++    -- * Binary Data+    Bytea,++    -- * Date\/Time Types+    Date,+    Time,+    Timestamp,+    Timestamptz,+    Timetz,+    Interval,++    -- * Network Address Types+    Inet,+    Cidr,+    Macaddr,+    Macaddr8,++    -- * Geometric Types+    Point,+    Line,+    Lseg,+    Box,+    Path,+    Polygon,+    Circle,++    -- * Bit String Types+    Bit,+    Varbit,++    -- * UUID Type+    Uuid,++    -- * JSON Types+    Json,+    Jsonb,++    -- * Key-Value Types+    Hstore,++    -- * Range Types+    Range,+    Multirange,+  )+where++import PostgresqlTypes.Bit+import PostgresqlTypes.Bool+import PostgresqlTypes.Box+import PostgresqlTypes.Bpchar+import PostgresqlTypes.Bytea+import PostgresqlTypes.Char+import PostgresqlTypes.Cidr+import PostgresqlTypes.Circle+import PostgresqlTypes.Date+import PostgresqlTypes.Float4+import PostgresqlTypes.Float8+import PostgresqlTypes.Hstore+import PostgresqlTypes.Inet+import PostgresqlTypes.Int2+import PostgresqlTypes.Int4+import PostgresqlTypes.Int8+import PostgresqlTypes.Interval+import PostgresqlTypes.Json+import PostgresqlTypes.Jsonb+import PostgresqlTypes.Line+import PostgresqlTypes.Lseg+import PostgresqlTypes.Macaddr+import PostgresqlTypes.Macaddr8+import PostgresqlTypes.Money+import PostgresqlTypes.Multirange+import PostgresqlTypes.Numeric+import PostgresqlTypes.Oid+import PostgresqlTypes.Path+import PostgresqlTypes.Point+import PostgresqlTypes.Polygon+import PostgresqlTypes.Range+import PostgresqlTypes.Text+import PostgresqlTypes.Time+import PostgresqlTypes.Timestamp+import PostgresqlTypes.Timestamptz+import PostgresqlTypes.Timetz+import PostgresqlTypes.Uuid+import PostgresqlTypes.Varbit+import PostgresqlTypes.Varchar
+ src/library/PostgresqlTypes/Bit.hs view
@@ -0,0 +1,215 @@+module PostgresqlTypes.Bit+  ( Bit,++    -- * Accessors+    toBoolList,+    toBoolVector,++    -- * Constructors+    refineFromBoolList,+    normalizeFromBoolList,+    refineFromBoolVector,+    normalizeFromBoolVector,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Bits as Bits+import qualified Data.ByteString as ByteString+import qualified Data.Text as Text+import qualified Data.Vector.Generic as Vg+import qualified GHC.TypeLits as TypeLits+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @bit@ type. Fixed-length bit string.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-bit.html).+--+-- The type parameter @numBits@ specifies the static length of the bit string.+-- Only bit strings with exactly this length can be represented by this type.+newtype Bit (numBits :: TypeLits.Nat)+  = Bit+      -- | Bit data (packed into bytes)+      ByteString+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar (Bit numBits))+  deriving newtype (Hashable)++instance (TypeLits.KnownNat numBits) => Arbitrary (Bit numBits) where+  arbitrary = do+    let len = fromIntegral (TypeLits.natVal (Proxy @numBits))+    boolList <- QuickCheck.vectorOf len (arbitrary @Bool)+    case refineFromBoolList boolList of+      Nothing -> error "Arbitrary Bit: Generated bit string has incorrect length"+      Just bit -> pure bit++instance (TypeLits.KnownNat numBits) => IsScalar (Bit numBits) where+  schemaName = Tagged Nothing+  typeName = Tagged "bit"+  baseOid = Tagged (Just 1560)+  arrayOid = Tagged (Just 1561)+  typeParams =+    Tagged+      [ Text.pack (show (TypeLits.natVal (Proxy @numBits)))+      ]+  binaryEncoder (Bit bytes) =+    let len = fromIntegral (TypeLits.natVal (Proxy @numBits))+     in mconcat+          [ Write.bInt32 len,+            Write.byteString bytes+          ]+  binaryDecoder = do+    len <- PtrPeeker.fixed PtrPeeker.beSignedInt4+    bytes <- PtrPeeker.remainderAsByteString+    let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numBits))+    if len == expectedLen+      then pure (Right (Bit bytes))+      else+        pure+          ( Left+              ( DecodingError+                  { location = ["Bit"],+                    reason =+                      UnsupportedValueDecodingErrorReason+                        ("Expected bit string of length " <> Text.pack (show expectedLen) <> " but got " <> Text.pack (show len))+                        (TextBuilder.toText (TextBuilder.decimal len))+                  }+              )+          )+  textualEncoder (Bit bytes) =+    let len = fromIntegral (TypeLits.natVal (Proxy @numBits))+        bits = concatMap byteToBits (ByteString.unpack bytes)+        trimmedBits = take len bits+        bitString = map (\b -> if b then '1' else '0') trimmedBits+     in TextBuilder.text (Text.pack bitString)+    where+      byteToBits :: Word8 -> [Bool]+      byteToBits byte = [Bits.testBit byte i | i <- [7, 6, 5, 4, 3, 2, 1, 0]]+  textualDecoder = do+    bitChars <- Attoparsec.takeText+    let bits = map (== '1') (Text.unpack bitChars)+        len = length bits+        expectedLen = fromIntegral (TypeLits.natVal (Proxy @numBits))+    if len /= expectedLen+      then fail ("Expected bit string of length " <> show expectedLen <> " but got " <> show len)+      else do+        let numBytes = (len + 7) `div` 8+            paddedBits = bits ++ replicate (numBytes * 8 - len) False+            bytes = map boolsToByte (chunksOf 8 paddedBits)+        pure (Bit (ByteString.pack bytes))+    where+      boolsToByte :: [Bool] -> Word8+      boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+      chunksOf :: Int -> [a] -> [[a]]+      chunksOf _ [] = []+      chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- * Accessors++-- | Extract the bit string as a list of Bool.+toBoolList :: forall numBits. (TypeLits.KnownNat numBits) => Bit numBits -> [Bool]+toBoolList (Bit bytes) =+  let len = fromIntegral (TypeLits.natVal (Proxy @numBits))+      bits = concatMap byteToBits (ByteString.unpack bytes)+      trimmedBits = take len bits+   in trimmedBits+  where+    byteToBits :: Word8 -> [Bool]+    byteToBits byte = [Bits.testBit byte i | i <- [7, 6, 5, 4, 3, 2, 1, 0]]++-- | Extract the bit string as any vector of Bool.+toBoolVector :: forall numBits vec. (TypeLits.KnownNat numBits, Vg.Vector vec Bool) => Bit numBits -> vec Bool+toBoolVector (Bit bytes) =+  let len = fromIntegral (TypeLits.natVal (Proxy @numBits))+      bits = concatMap byteToBits (ByteString.unpack bytes)+      trimmedBits = take len bits+   in Vg.fromList trimmedBits+  where+    byteToBits :: Word8 -> [Bool]+    byteToBits byte = [Bits.testBit byte i | i <- [7, 6, 5, 4, 3, 2, 1, 0]]++-- * Constructors++-- | Construct a PostgreSQL 'Bit' from a list of Bool with validation.+-- Returns 'Nothing' if the list length doesn't match the expected length.+refineFromBoolList :: forall numBits. (TypeLits.KnownNat numBits) => [Bool] -> Maybe (Bit numBits)+refineFromBoolList bits =+  let len = length bits+      expectedLen = fromIntegral (TypeLits.natVal (Proxy @numBits))+   in if len == expectedLen+        then+          let numBytes = (len + 7) `div` 8+              paddedBits = bits ++ replicate (numBytes * 8 - len) False+              bytes = map boolsToByte (chunksOf 8 paddedBits)+           in Just (Bit (ByteString.pack bytes))+        else Nothing+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Construct a PostgreSQL 'Bit' from a list of Bool.+-- Truncates or pads to match the type-level length.+normalizeFromBoolList :: forall numBits. (TypeLits.KnownNat numBits) => [Bool] -> Bit numBits+normalizeFromBoolList bits =+  let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numBits))+      -- Truncate or pad to the expected length+      adjustedBits = take expectedLen (bits ++ repeat False)+      numBytes = (expectedLen + 7) `div` 8+      paddedBits = adjustedBits ++ replicate (numBytes * 8 - expectedLen) False+      bytes = map boolsToByte (chunksOf 8 paddedBits)+   in Bit (ByteString.pack bytes)+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Construct a PostgreSQL 'Bit' from an unboxed vector of Bool with validation.+-- Returns 'Nothing' if the vector length doesn't match the expected length.+refineFromBoolVector :: forall numBits vec. (TypeLits.KnownNat numBits, Vg.Vector vec Bool) => vec Bool -> Maybe (Bit numBits)+refineFromBoolVector bitVector =+  let len = Vg.length bitVector+      expectedLen = fromIntegral (TypeLits.natVal (Proxy @numBits))+   in if len == expectedLen+        then+          let bits = Vg.toList bitVector+              numBytes = (len + 7) `div` 8+              paddedBits = bits ++ replicate (numBytes * 8 - len) False+              bytes = map boolsToByte (chunksOf 8 paddedBits)+           in Just (Bit (ByteString.pack bytes))+        else Nothing+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Construct a PostgreSQL 'Bit' from an unboxed vector of Bool.+-- Truncates or pads to match the type-level length.+normalizeFromBoolVector :: forall numBits vec. (TypeLits.KnownNat numBits, Vg.Vector vec Bool) => vec Bool -> Bit numBits+normalizeFromBoolVector bitVector =+  let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numBits))+      bits = Vg.toList bitVector+      -- Truncate or pad to the expected length+      adjustedBits = take expectedLen (bits ++ repeat False)+      numBytes = (expectedLen + 7) `div` 8+      paddedBits = adjustedBits ++ replicate (numBytes * 8 - expectedLen) False+      bytes = map boolsToByte (chunksOf 8 paddedBits)+   in Bit (ByteString.pack bytes)+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)
+ src/library/PostgresqlTypes/Bool.hs view
@@ -0,0 +1,55 @@+module PostgresqlTypes.Bool+  ( Bool (..),++    -- * Accessors+    toBool,++    -- * Constructors+    fromBool,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Bool+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (Bool)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write++-- | PostgreSQL @boolean@ type. Logical Bool (@true@/@false@).+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-boolean.html).+newtype Bool = Bool Data.Bool.Bool+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Bool)++instance IsScalar Bool where+  schemaName = Tagged Nothing+  typeName = Tagged "bool"+  baseOid = Tagged (Just 16)+  arrayOid = Tagged (Just 1000)+  typeParams = Tagged []+  binaryEncoder (Bool b) = Write.word8 (if b then 1 else 0)+  binaryDecoder =+    PtrPeeker.fixed do+      b <- PtrPeeker.unsignedInt1+      pure (Right (Bool (b /= 0)))+  textualEncoder (Bool b) = if b then "t" else "f"+  textualDecoder =+    (Bool True <$ Attoparsec.char 't')+      <|> (Bool False <$ Attoparsec.char 'f')+      <|> (Bool True <$ Attoparsec.string "true")+      <|> (Bool False <$ Attoparsec.string "false")++-- * Accessors++-- | Extract the underlying Haskell 'Data.Bool.Bool' value.+toBool :: Bool -> Data.Bool.Bool+toBool (Bool b) = b++-- * Constructors++-- | Construct a PostgreSQL 'Bool' from a Haskell 'Data.Bool.Bool' value.+fromBool :: Data.Bool.Bool -> Bool+fromBool = Bool
+ src/library/PostgresqlTypes/Box.hs view
@@ -0,0 +1,154 @@+module PostgresqlTypes.Box+  ( Box,++    -- * Accessors+    toX1,+    toY1,+    toX2,+    toY2,++    -- * Constructors+    normalizeFromCorners,+    refineFromCorners,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @box@ type. Rectangular box in 2D plane.+--+-- Rectangular box defined by two opposite corners.+-- Stored as four @64@-bit floating point numbers (@x1@,@y1@),(@x2@,@y2@) in PostgreSQL.+-- The box is normalized so that @x1 <= x2@ and @y1 <= y2@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-GEOMETRIC-BOXES).+data Box+  = Box+      -- | Lower-left x coordinate+      Double+      -- | Lower-left y coordinate+      Double+      -- | Upper-right x coordinate+      Double+      -- | Upper-right y coordinate+      Double+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Box)++instance Arbitrary Box where+  arbitrary = do+    x1 <- arbitrary+    y1 <- arbitrary+    x2 <- arbitrary+    y2 <- arbitrary+    pure (normalizeFromCorners x1 y1 x2 y2)++  shrink (Box x1 y1 x2 y2) =+    [ normalizeFromCorners x1' y1' x2' y2'+    | (x1', y1', x2', y2') <- shrink (x1, y1, x2, y2)+    ]++instance Hashable Box where+  hashWithSalt salt (Box x1 y1 x2 y2) =+    salt+      `hashWithSalt` castDoubleToWord64 x1+      `hashWithSalt` castDoubleToWord64 y1+      `hashWithSalt` castDoubleToWord64 x2+      `hashWithSalt` castDoubleToWord64 y2++instance IsScalar Box where+  schemaName = Tagged Nothing+  typeName = Tagged "box"+  baseOid = Tagged (Just 603)+  arrayOid = Tagged (Just 1020)+  typeParams = Tagged []+  binaryEncoder (Box x1 y1 x2 y2) =+    mconcat+      [ Write.bWord64 (castDoubleToWord64 x2),+        Write.bWord64 (castDoubleToWord64 y2),+        Write.bWord64 (castDoubleToWord64 x1),+        Write.bWord64 (castDoubleToWord64 y1)+      ]+  binaryDecoder = do+    x2 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    y2 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    x1 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    y1 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    pure (Right (Box x1 y1 x2 y2))+  textualEncoder (Box x1 y1 x2 y2) =+    -- PostgreSQL returns coordinates as (upper-right),(lower-left)+    -- So we output (x2,y2),(x1,y1)+    mconcat+      [ "(",+        TextBuilder.string (printf "%g" x2),+        ",",+        TextBuilder.string (printf "%g" y2),+        "),(",+        TextBuilder.string (printf "%g" x1),+        ",",+        TextBuilder.string (printf "%g" y1),+        ")"+      ]+  textualDecoder = do+    _ <- Attoparsec.char '('+    x1 <- Attoparsec.double+    _ <- Attoparsec.char ','+    y1 <- Attoparsec.double+    _ <- Attoparsec.char ')'+    _ <- Attoparsec.char ','+    _ <- Attoparsec.char '('+    x2 <- Attoparsec.double+    _ <- Attoparsec.char ','+    y2 <- Attoparsec.double+    _ <- Attoparsec.char ')'+    -- PostgreSQL may return coordinates in any order, normalize to ensure x1 <= x2 and y1 <= y2+    pure (normalizeFromCorners x1 y1 x2 y2)++-- * Accessors++-- | Extract the lower-left x coordinate.+toX1 :: Box -> Double+toX1 (Box x1 _ _ _) = x1++-- | Extract the lower-left y coordinate.+toY1 :: Box -> Double+toY1 (Box _ y1 _ _) = y1++-- | Extract the upper-right x coordinate.+toX2 :: Box -> Double+toX2 (Box _ _ x2 _) = x2++-- | Extract the upper-right y coordinate.+toY2 :: Box -> Double+toY2 (Box _ _ _ y2) = y2++-- * Constructors++-- | Construct a PostgreSQL 'Box' from corners (x1, y1, x2, y2).+-- Normalizes coordinates to ensure lowerX <= upperX and lowerY <= upperY.+normalizeFromCorners :: Double -> Double -> Double -> Double -> Box+normalizeFromCorners x1 y1 x2 y2 =+  if x1 <= x2+    then+      if y1 <= y2+        then Box x1 y1 x2 y2+        else Box x1 y2 x2 y1+    else+      if y1 <= y2+        then Box x2 y1 x1 y2+        else Box x2 y2 x1 y1++-- | Construct a PostgreSQL 'Box' from corners (lowerX, lowerY, upperX, upperY) with validation.+-- Returns 'Nothing' if lowerX > upperX or lowerY > upperY.+refineFromCorners :: Double -> Double -> Double -> Double -> Maybe Box+refineFromCorners x1 y1 x2 y2 =+  if x1 <= x2 && y1 <= y2+    then Just (Box x1 y1 x2 y2)+    else Nothing
+ src/library/PostgresqlTypes/Bpchar.hs view
@@ -0,0 +1,176 @@+module PostgresqlTypes.Bpchar+  ( Bpchar,++    -- * Accessors+    toText,+    toString,++    -- * Constructors+    refineFromText,+    normalizeFromText,+    refineFromString,+    normalizeFromString,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import Data.String+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified GHC.TypeLits as TypeLits+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @bpchar(n)@, @char(n)@, or @character(n)@ type. Fixed-length, blank-padded character string.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-character.html).+--+-- The type parameter @numChars@ specifies the static length of the character string.+-- Only character strings with exactly this length can be represented by this type.+--+-- __Important:__ Do not confuse this with the quoted @\"char\"@ type, which is a special+-- single-byte internal type used in PostgreSQL system catalogs. The quoted @\"char\"@ type+-- is represented by 'PostgresqlTypes.Char.Char', not by @Bpchar 1@.+--+-- * @Bpchar n@ represents @bpchar(n)@, @char(n)@, or @character(n)@ — fixed-length, blank-padded strings+-- * 'PostgresqlTypes.Char.Char' represents @\"char\"@ (quoted) — single-byte internal type+--+-- For example, @char(1)@ in SQL is @Bpchar 1@ in Haskell, while @\"char\"@ in SQL is+-- 'PostgresqlTypes.Char.Char' in Haskell. These are completely different types in PostgreSQL.+newtype Bpchar (numChars :: TypeLits.Nat) = Bpchar Text+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar (Bpchar numChars))+  deriving newtype (Hashable)++instance (TypeLits.KnownNat numChars) => Arbitrary (Bpchar numChars) where+  arbitrary = do+    let len = fromIntegral (TypeLits.natVal (Proxy @numChars))+    charList <- QuickCheck.vectorOf len do+      QuickCheck.suchThat arbitrary (\char -> char /= '\NUL')+    case refineFromString charList of+      Nothing -> error "Arbitrary Bpchar: Generated string has incorrect length"+      Just char -> pure char++instance (TypeLits.KnownNat numChars) => IsScalar (Bpchar numChars) where+  schemaName = Tagged Nothing+  typeName = Tagged "bpchar"+  baseOid = Tagged (Just 1042)+  arrayOid = Tagged (Just 1014)++  typeParams =+    Tagged+      ( let len = TypeLits.natVal (Proxy @numChars)+         in if len == 1+              then [] -- PostgreSQL often displays bpchar(1) / char(1) as just "char" (no length modifier)+              else [Text.pack (show len)] -- bpchar(n)+      )+  binaryEncoder (Bpchar txt) =+    -- PostgreSQL bpchar(n) is stored blank-padded to exactly n characters+    let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+        len = Text.length txt+        paddedTxt =+          if len >= expectedLen+            then Text.take expectedLen txt+            else txt <> Text.replicate (expectedLen - len) " "+     in Write.textUtf8 paddedTxt+  binaryDecoder = do+    bytes <- PtrPeeker.remainderAsByteString+    pure case Text.Encoding.decodeUtf8' bytes of+      Left e ->+        Left+          ( DecodingError+              { location = ["Bpchar"],+                reason =+                  ParsingDecodingErrorReason+                    (fromString (show e))+                    bytes+              }+          )+      Right txt ->+        let len = Text.length txt+            expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+            -- PostgreSQL bpchar(n) may return values with trailing spaces trimmed.+            -- We need to pad them back to the expected length.+            paddedTxt =+              if len >= expectedLen+                then Text.take expectedLen txt+                else txt <> Text.replicate (expectedLen - len) " "+         in Right (Bpchar paddedTxt)+  textualEncoder (Bpchar txt) =+    -- PostgreSQL bpchar(n) is stored blank-padded to exactly n characters+    let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+        len = Text.length txt+        paddedTxt =+          if len >= expectedLen+            then Text.take expectedLen txt+            else txt <> Text.replicate (expectedLen - len) " "+     in TextBuilder.text paddedTxt+  textualDecoder = do+    txt <- Attoparsec.takeText+    let len = Text.length txt+        expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+        -- PostgreSQL bpchar(n) may return values with trailing spaces trimmed.+        -- We need to pad them back to the expected length.+        paddedTxt =+          if len >= expectedLen+            then Text.take expectedLen txt+            else txt <> Text.replicate (expectedLen - len) " "+    pure (Bpchar paddedTxt)++-- * Accessors++-- | Extract the underlying 'Text' value.+toText :: forall numChars. (TypeLits.KnownNat numChars) => Bpchar numChars -> Text+toText (Bpchar txt) = txt++-- | Convert the Bpchar to a String.+toString :: forall numChars. (TypeLits.KnownNat numChars) => Bpchar numChars -> String+toString (Bpchar txt) = Text.unpack txt++-- * Constructors++-- | Construct a PostgreSQL 'Bpchar' from 'Text' with validation.+-- Returns 'Nothing' if the text length doesn't exactly match the expected length.+refineFromText :: forall numChars. (TypeLits.KnownNat numChars) => Text -> Maybe (Bpchar numChars)+refineFromText txt =+  let len = Text.length txt+      expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+   in if len == expectedLen+        then Just (Bpchar txt)+        else Nothing++-- | Construct a PostgreSQL 'Bpchar' from 'Text'.+-- Truncates or pads with spaces to match the type-level length.+normalizeFromText :: forall numChars. (TypeLits.KnownNat numChars) => Text -> Bpchar numChars+normalizeFromText txt =+  let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+      len = Text.length txt+      adjustedTxt =+        if len >= expectedLen+          then Text.take expectedLen txt+          else txt <> Text.replicate (expectedLen - len) " "+   in Bpchar adjustedTxt++-- | Construct a PostgreSQL 'Bpchar' from 'String' with validation.+-- Returns 'Nothing' if the string length doesn't exactly match the expected length.+refineFromString :: forall numChars. (TypeLits.KnownNat numChars) => String -> Maybe (Bpchar numChars)+refineFromString str =+  let len = length str+      expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+   in if len == expectedLen+        then Just (Bpchar (Text.pack str))+        else Nothing++-- | Construct a PostgreSQL 'Bpchar' from 'String'.+-- Truncates or pads with spaces to match the type-level length.+normalizeFromString :: forall numChars. (TypeLits.KnownNat numChars) => String -> Bpchar numChars+normalizeFromString str =+  let expectedLen = fromIntegral (TypeLits.natVal (Proxy @numChars))+      -- Truncate or pad with spaces to the expected length+      adjustedStr = take expectedLen (str ++ repeat ' ')+   in Bpchar (Text.pack adjustedStr)
+ src/library/PostgresqlTypes/Bytea.hs view
@@ -0,0 +1,78 @@+module PostgresqlTypes.Bytea+  ( Bytea (..),++    -- * Accessors+    toByteString,++    -- * Constructors+    fromByteString,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.ByteString as ByteString+import qualified Data.Text as Text+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @bytea@ type. Binary data ("byte array").+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-binary.html).+newtype Bytea = Bytea ByteString+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Bytea)++instance IsScalar Bytea where+  schemaName = Tagged Nothing+  typeName = Tagged "bytea"+  baseOid = Tagged (Just 17)+  arrayOid = Tagged (Just 1001)+  typeParams = Tagged []+  binaryEncoder (Bytea bs) =+    Write.byteString bs+  binaryDecoder =+    Right . Bytea <$> PtrPeeker.remainderAsByteString+  textualEncoder (Bytea bs) =+    "\\x" <> foldMap TextBuilder.hexadecimal (ByteString.unpack bs)+  textualDecoder = do+    _ <- Attoparsec.string "\\x"+    hexText <- Attoparsec.takeText+    case parseHexBytes hexText of+      Left err -> fail err+      Right bytes -> pure (Bytea bytes)+    where+      parseHexBytes :: Text -> Either String ByteString+      parseHexBytes t = ByteString.pack <$> parseHexPairs (Text.unpack t)+      parseHexPairs :: [Char] -> Either String [Word8]+      parseHexPairs [] = Right []+      parseHexPairs [_] = Left "Odd number of hex digits"+      parseHexPairs (a : b : rest) = do+        byte <- hexPairToByte a b+        (byte :) <$> parseHexPairs rest+      hexPairToByte :: Char -> Char -> Either String Word8+      hexPairToByte a b = do+        high <- hexDigitToWord8 a+        low <- hexDigitToWord8 b+        pure (high * 16 + low)+      hexDigitToWord8 :: Char -> Either String Word8+      hexDigitToWord8 c+        | c >= '0' && c <= '9' = Right (fromIntegral (ord c - ord '0'))+        | c >= 'a' && c <= 'f' = Right (fromIntegral (ord c - ord 'a' + 10))+        | c >= 'A' && c <= 'F' = Right (fromIntegral (ord c - ord 'A' + 10))+        | otherwise = Left ("Invalid hex digit: " ++ [c])++-- * Accessors++-- | Extract the underlying 'ByteString' value.+toByteString :: Bytea -> ByteString+toByteString (Bytea bs) = bs++-- * Constructors++-- | Construct a PostgreSQL 'Bytea' from a 'ByteString' value.+fromByteString :: ByteString -> Bytea+fromByteString = Bytea
+ src/library/PostgresqlTypes/Char.hs view
@@ -0,0 +1,111 @@+module PostgresqlTypes.Char+  ( Char,++    -- * Accessors+    toWord8,+    toChar,++    -- * Constructors+    refineFromWord8,+    normalizeFromWord8,+    refineFromChar,+    normalizeFromChar,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Char+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (Char)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @\"char\"@ type (note the quotes). Single-byte internal PostgreSQL type.+--+-- This is a special PostgreSQL type that uses only 1 byte of storage and can store+-- a single ASCII character (values 0-127). It is primarily used in PostgreSQL system+-- catalogs as a simplistic enumeration type and is not intended for general-purpose use.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-character.html).+--+-- __Important distinction:__ This type represents the quoted @\"char\"@ type in PostgreSQL,+-- which is completely different from @char(n)@, @character(n)@, or @bpchar(n)@:+--+-- * @\"char\"@ (this type) — single-byte internal type, 1 byte storage, used in system catalogs+-- * @char(n)@, @character(n)@, @bpchar(n)@ — fixed-length blank-padded strings, represented by 'PostgresqlTypes.Bpchar.Bpchar'+--+-- For example, @\"char\"@ in SQL is 'Char' in Haskell, while @char(1)@ in SQL is+-- @'PostgresqlTypes.Bpchar.Bpchar' 1@ in Haskell. Despite the similar names,+-- these are entirely different types in PostgreSQL.+newtype Char = Char Word8+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Char)++instance Arbitrary Char where+  arbitrary =+    Char <$> QuickCheck.choose (0, 127)++instance IsScalar Char where+  schemaName = Tagged Nothing+  typeName = Tagged "char"+  baseOid = Tagged (Just 18)+  arrayOid = Tagged (Just 1002)+  typeSignature = Tagged "\"char\""+  binaryEncoder (Char base) =+    Write.word8 base+  binaryDecoder =+    Right . Char <$> PtrPeeker.fixed PtrPeeker.unsignedInt1+  textualEncoder (Char base) =+    TextBuilder.unicodeCodepoint (fromIntegral base)+  textualDecoder = do+    -- PostgreSQL may return empty string for \NUL or stripped spaces+    maybeC <- Attoparsec.option Nothing (Just <$> Attoparsec.anyChar)+    case maybeC of+      Nothing -> pure (Char 0) -- Empty input means \NUL+      Just c -> do+        let charOrd = ord c+        if charOrd > 127+          then fail "Invalid char: value > 127"+          else pure (Char (fromIntegral charOrd))++-- * Accessors++-- | Extract the underlying 'Word8' value.+toWord8 :: Char -> Word8+toWord8 = coerce++-- | Convert PostgreSQL 'Char' to Haskell 'Data.Char.Char'.+toChar :: Char -> Data.Char.Char+toChar (Char word8) = Data.Char.chr (fromIntegral word8)++-- * Constructors++-- | Construct a PostgreSQL 'Char' from 'Word8' with validation.+-- Returns 'Nothing' if the value is greater than 127.+refineFromWord8 :: Word8 -> Maybe Char+refineFromWord8 word8 =+  if word8 > 127+    then Nothing+    else Just (Char word8)++-- | Construct a PostgreSQL 'Char' from 'Word8', clamping to valid range.+-- Values greater than 127 have the high bit cleared.+normalizeFromWord8 :: Word8 -> Char+normalizeFromWord8 word8 = Char (clearBit word8 7)++-- | Construct a PostgreSQL 'Char' from Haskell 'Data.Char.Char' with validation.+-- Returns 'Nothing' if the character's code point is greater than 127.+refineFromChar :: Data.Char.Char -> Maybe Char+refineFromChar char =+  let ord = Data.Char.ord char+   in if ord > 127+        then Nothing+        else Just (Char (fromIntegral ord))++-- | Construct a PostgreSQL 'Char' from Haskell 'Data.Char.Char'.+-- Turns invalid chars into '\NUL'.+normalizeFromChar :: Data.Char.Char -> Char+normalizeFromChar = fromMaybe (Char 0) . refineFromChar
+ src/library/PostgresqlTypes/Cidr.hs view
@@ -0,0 +1,397 @@+module PostgresqlTypes.Cidr+  ( Cidr,++    -- * Accessors+    fold,+    refineToV4,+    refineToV6,++    -- * Constructors+    normalizeFromV4,+    normalizeFromV6,+    refineFromV4,+    refineFromV6,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import Data.Bits+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (fold)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @cidr@ type.+--+-- Holds an IPv4 or IPv6 network specification (network address + netmask) where host bits must be zero.+-- If you want to store individual host addresses with optional netmasks, use the @inet@ type instead.+--+-- The input format for this type is @address/y@ where @address@ is an IPv4 or IPv6 network address (with host bits zeroed) and @y@ is the number of bits in the netmask. The @/y@ portion is required for @cidr@ type.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-net-types.html#DATATYPE-CIDR).+data Cidr+  = V4Cidr+      -- | IPv4 network address stored as 32-bit big-endian word (host bits must be zero).+      Word32+      -- | Network mask length (0-32).+      Word8+  | V6Cidr+      -- | First 32 bits of IPv6 network address in big-endian order.+      Word32+      -- | Second 32 bits of IPv6 network address in big-endian order.+      Word32+      -- | Third 32 bits of IPv6 network address in big-endian order.+      Word32+      -- | Fourth 32 bits of IPv6 network address in big-endian order.+      Word32+      -- | Network mask length (0-128).+      Word8+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Cidr)++instance Arbitrary Cidr where+  arbitrary = do+    isIPv4 <- arbitrary+    if isIPv4+      then do+        addr <- arbitrary+        netmask <- QuickCheck.choose (0, 32)+        pure (normalizeFromV4 addr netmask)+      else do+        w1 <- arbitrary+        w2 <- arbitrary+        w3 <- arbitrary+        w4 <- arbitrary+        netmask <- QuickCheck.choose (0, 128)+        pure (normalizeFromV6 w1 w2 w3 w4 netmask)++  shrink = \case+    V4Cidr addr netmask ->+      [ normalizeFromV4 addr' netmask'+      | addr' <- shrink addr,+        netmask' <- shrink netmask,+        netmask' <= 32+      ]+    V6Cidr w1 w2 w3 w4 netmask ->+      [ normalizeFromV6 w1' w2' w3' w4' netmask'+      | (w1', w2', w3', w4') <- shrink (w1, w2, w3, w4),+        netmask' <- shrink netmask,+        netmask' <= 128+      ]++instance Hashable Cidr where+  hashWithSalt salt = \case+    V4Cidr addr netmask -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` addr `hashWithSalt` netmask+    V6Cidr w1 w2 w3 w4 netmask -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` w1 `hashWithSalt` w2 `hashWithSalt` w3 `hashWithSalt` w4 `hashWithSalt` netmask++instance IsScalar Cidr where+  schemaName = Tagged Nothing+  typeName = Tagged "cidr"+  baseOid = Tagged (Just 650)+  arrayOid = Tagged (Just 651)+  typeParams = Tagged []++  binaryEncoder = \case+    V4Cidr addr netmask ->+      mconcat+        [ Write.word8 2, -- IPv4 address family+          Write.word8 netmask,+          Write.word8 1, -- is_cidr flag (1 for cidr)+          Write.word8 4, -- address length (4 bytes for IPv4)+          Write.bWord32 addr -- IPv4 network address+        ]+    V6Cidr w1 w2 w3 w4 netmask ->+      mconcat+        [ Write.word8 3, -- IPv6 address family for CIDR+          Write.word8 netmask,+          Write.word8 1, -- is_cidr flag (1 for cidr)+          Write.word8 16, -- address length (16 bytes for IPv6)+          Write.bWord32 w1,+          Write.bWord32 w2,+          Write.bWord32 w3,+          Write.bWord32 w4+        ]++  binaryDecoder = do+    (family, netmask, isCidrFlag, addrLen) <-+      PtrPeeker.fixed do+        (,,,)+          <$> PtrPeeker.unsignedInt1+          <*> PtrPeeker.unsignedInt1+          <*> PtrPeeker.unsignedInt1+          <*> PtrPeeker.unsignedInt1++    runExceptT do+      when (isCidrFlag /= 1) do+        throwError (DecodingError ["is-cidr"] (UnexpectedValueDecodingErrorReason "1" (TextBuilder.toText (TextBuilder.decimal isCidrFlag))))++      case family of+        2 -> do+          -- IPv4+          when (addrLen /= 4) do+            throwError (DecodingError ["address-length"] (UnexpectedValueDecodingErrorReason "4" (TextBuilder.toText (TextBuilder.decimal addrLen))))+          addr <- lift do+            PtrPeeker.fixed PtrPeeker.beUnsignedInt4+          pure (V4Cidr addr (fromIntegral netmask))+        3 -> do+          -- IPv6+          when (addrLen /= 16) do+            throwError (DecodingError ["address-length"] (UnexpectedValueDecodingErrorReason "16" (TextBuilder.toText (TextBuilder.decimal addrLen))))+          lift do+            PtrPeeker.fixed do+              V6Cidr+                <$> PtrPeeker.beUnsignedInt4+                <*> PtrPeeker.beUnsignedInt4+                <*> PtrPeeker.beUnsignedInt4+                <*> PtrPeeker.beUnsignedInt4+                <*> pure (fromIntegral netmask)+        _ -> do+          throwError (DecodingError ["address-family"] (UnexpectedValueDecodingErrorReason "2 or 3" (TextBuilder.toText (TextBuilder.decimal family))))++  textualEncoder = \case+    V4Cidr addr netmask ->+      let a = ((addr `shiftR` 24) .&. 0xFF)+          b = ((addr `shiftR` 16) .&. 0xFF)+          c = ((addr `shiftR` 8) .&. 0xFF)+          d = (addr .&. 0xFF)+       in mconcat+            [ TextBuilder.decimal a,+              ".",+              TextBuilder.decimal b,+              ".",+              TextBuilder.decimal c,+              ".",+              TextBuilder.decimal d,+              "/",+              TextBuilder.decimal netmask+            ]+    V6Cidr w1 w2 w3 w4 netmask ->+      -- Convert 32-bit words to proper IPv6 hex representation+      let toHex w =+            let h1 = fromIntegral ((w `shiftR` 16) .&. 0xFFFF) :: Word16+                h2 = fromIntegral (w .&. 0xFFFF) :: Word16+             in TextBuilder.hexadecimal h1 <> ":" <> TextBuilder.hexadecimal h2+       in toHex w1+            <> ":"+            <> toHex w2+            <> ":"+            <> toHex w3+            <> ":"+            <> toHex w4+            <> "/"+            <> TextBuilder.decimal netmask++  textualDecoder = parseV6 <|> parseV4+    where+      parseV4 = do+        a <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '.'+        b <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '.'+        c <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '.'+        d <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '/'+        netmask <- Attoparsec.decimal :: Attoparsec.Parser Word8+        let addr = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d+        pure (normalizeFromV4 addr netmask)++      parseV6 = do+        -- Try to parse compressed IPv6 (with ::)+        parseCompressedV6 <|> parseFullV6++      parseFullV6 = do+        groups <- parseHexGroup `Attoparsec.sepBy1` Attoparsec.char ':'+        when (length groups /= 8) (fail "Expected 8 groups")+        _ <- Attoparsec.char '/'+        netmask <- Attoparsec.decimal :: Attoparsec.Parser Word8+        case groups of+          [h1, h2, h3, h4, h5, h6, h7, h8] -> do+            let w1 = fromIntegral h1 `shiftL` 16 .|. fromIntegral h2+                w2 = fromIntegral h3 `shiftL` 16 .|. fromIntegral h4+                w3 = fromIntegral h5 `shiftL` 16 .|. fromIntegral h6+                w4 = fromIntegral h7 `shiftL` 16 .|. fromIntegral h8+            pure (normalizeFromV6 w1 w2 w3 w4 netmask)+          _ -> fail "Expected 8 groups"++      parseCompressedV6 = do+        -- Check if starts with ::+        startsWithDoubleColon <- Attoparsec.option False (True <$ Attoparsec.string "::")+        before <-+          if startsWithDoubleColon+            then pure []+            else parseHexGroup `Attoparsec.sepBy1` Attoparsec.char ':'+        -- Check for :: in the middle or if we already found it at start+        hasDoubleColon <-+          if startsWithDoubleColon+            then pure True+            else Attoparsec.option False (True <$ Attoparsec.string "::")+        after <-+          if hasDoubleColon+            then parseHexGroup `Attoparsec.sepBy` Attoparsec.char ':'+            else pure []+        -- If no :: was found, this isn't compressed format+        when (not hasDoubleColon) (fail "Not a compressed IPv6 address")+        _ <- Attoparsec.char '/'+        netmask <- Attoparsec.decimal :: Attoparsec.Parser Word8+        -- Expand to 8 groups, filling middle with zeros+        let totalGroups = length before + length after+        when (totalGroups > 7) (fail "Too many groups in compressed IPv6")+        let zeros = replicate (8 - totalGroups) 0+            allGroups = before ++ zeros ++ after+        case allGroups of+          [h1, h2, h3, h4, h5, h6, h7, h8] -> do+            let w1 = fromIntegral h1 `shiftL` 16 .|. fromIntegral h2+                w2 = fromIntegral h3 `shiftL` 16 .|. fromIntegral h4+                w3 = fromIntegral h5 `shiftL` 16 .|. fromIntegral h6+                w4 = fromIntegral h7 `shiftL` 16 .|. fromIntegral h8+            pure (normalizeFromV6 w1 w2 w3 w4 netmask)+          _ -> fail "Expected 8 groups after expansion"++      parseHexGroup = Attoparsec.hexadecimal @Word16++-- * Accessors++-- |+-- Pattern match on 'Cidr' type.+fold ::+  -- | Function to handle IPv4 network case.+  --+  -- Takes the IPv4 network address as 'Word32' and the netmask as 'Word8' both in big-endian order.+  (Word32 -> Word8 -> a) ->+  -- | Function to handle IPv6 network case.+  --+  -- Takes the four 32-bit words of the IPv6 network address in big-endian order and the netmask as 'Word8'.+  (Word32 -> Word32 -> Word32 -> Word32 -> Word8 -> a) ->+  (Cidr -> a)+fold fV4 fV6 = \case+  V4Cidr addr netmask -> fV4 addr netmask+  V6Cidr w1 w2 w3 w4 netmask -> fV6 w1 w2 w3 w4 netmask++-- | Refine an IPv4 'Cidr' value from a 32-bit network address and an 8-bit netmask, both in big-endian order.+refineToV4 :: Cidr -> Maybe (Word32, Word8)+refineToV4 = \case+  V4Cidr addr netmask -> Just (addr, netmask)+  V6Cidr {} -> Nothing++-- | Refine an IPv6 'Cidr' value from four 32-bit words representing the network address and an 8-bit netmask, all in big-endian order.+refineToV6 :: Cidr -> Maybe (Word32, Word32, Word32, Word32, Word8)+refineToV6 = \case+  V4Cidr {} -> Nothing+  V6Cidr w1 w2 w3 w4 netmask -> Just (w1, w2, w3, w4, netmask)++-- * Constructors++-- |+-- Construct an IPv4 'Cidr' value from a 32-bit address and an 8-bit netmask, both in big-endian order.+--+-- The netmask is clamped to be in the range 0-32.+-- Host bits are automatically zeroed to ensure a valid network address.+normalizeFromV4 ::+  -- | IPv4 address as a 32-bit big-endian word.+  Word32 ->+  -- | Network mask length (0-32).+  Word8 ->+  Cidr+normalizeFromV4 addr netmask =+  let clampedNetmask = min 32 netmask+      hostBits = 32 - fromIntegral clampedNetmask+      networkMask = if hostBits >= 32 then 0 else complement ((1 `shiftL` hostBits) - 1)+      networkAddr = addr .&. networkMask+   in V4Cidr networkAddr clampedNetmask++-- |+-- Construct an IPv6 'Cidr' value from four 32-bit words representing the address and an 8-bit netmask, all in big-endian order.+--+-- The netmask is clamped to be in the range 0-128.+-- Host bits are automatically zeroed to ensure a valid network address.+normalizeFromV6 ::+  -- | First 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Second 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Third 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Fourth 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Network mask length (0-128).+  Word8 ->+  Cidr+normalizeFromV6 w1 w2 w3 w4 netmask =+  let clampedNetmask = min 128 netmask+      nm = fromIntegral clampedNetmask+      (nw1, nw2, nw3, nw4) = applyV6Mask nm w1 w2 w3 w4+   in V6Cidr nw1 nw2 nw3 nw4 clampedNetmask++-- | Refine an IPv4 'Cidr' value from a 32-bit address and an 8-bit netmask, both in big-endian order.+--+-- Returns 'Nothing' if the netmask is out of range (greater than 32) or if host bits are not zero.+refineFromV4 ::+  -- | IPv4 address as a 32-bit big-endian word.+  Word32 ->+  -- | Network mask length (0-32).+  Word8 ->+  Maybe Cidr+refineFromV4 addr netmask+  | netmask > 32 = Nothing+  | otherwise =+      let hostBits = 32 - fromIntegral netmask+          networkMask = if hostBits >= 32 then 0 else complement ((1 `shiftL` hostBits) - 1)+          networkAddr = addr .&. networkMask+       in if networkAddr == addr+            then Just (V4Cidr addr netmask)+            else Nothing++-- | Refine an IPv6 'Cidr' value from four 32-bit words representing the address and an 8-bit netmask, all in big-endian order.+--+-- Returns 'Nothing' if the netmask is out of range (greater than 128) or if host bits are not zero.+refineFromV6 ::+  -- | First 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Second 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Third 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Fourth 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Network mask length (0-128).+  Word8 ->+  Maybe Cidr+refineFromV6 w1 w2 w3 w4 netmask+  | netmask > 128 = Nothing+  | otherwise =+      let (nw1, nw2, nw3, nw4) = applyV6Mask (fromIntegral netmask) w1 w2 w3 w4+       in if (nw1, nw2, nw3, nw4) == (w1, w2, w3, w4)+            then Just (V6Cidr w1 w2 w3 w4 netmask)+            else Nothing++-- | Helper function to apply IPv6 network mask by zeroing out host bits.+--+-- Takes a netmask length (0-128) and four 32-bit words representing the IPv6 address.+-- Returns the four 32-bit words with host bits zeroed according to the netmask.+--+-- The masking is applied word by word, starting from the most significant word.+-- Each word represents 32 bits, so:+-- - netmask 0-32 affects only w1+-- - netmask 33-64 affects w1 and w2+-- - netmask 65-96 affects w1, w2, and w3+-- - netmask 97-128 affects all four words+applyV6Mask :: Int -> Word32 -> Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32)+applyV6Mask netmask w1 w2 w3 w4+  | netmask <= 0 = (0, 0, 0, 0)+  | netmask >= 128 = (w1, w2, w3, w4)+  | netmask >= 96 = (w1, w2, w3, maskWord (netmask - 96) w4)+  | netmask >= 64 = (w1, w2, maskWord (netmask - 64) w3, 0)+  | netmask >= 32 = (w1, maskWord (netmask - 32) w2, 0, 0)+  | otherwise = (maskWord netmask w1, 0, 0, 0)+  where+    maskWord bits word+      | bits <= 0 = 0+      | bits >= 32 = word+      | otherwise =+          let hostBits = 32 - bits+              networkMask = complement ((1 `shiftL` hostBits) - 1)+           in word .&. networkMask
+ src/library/PostgresqlTypes/Circle.hs view
@@ -0,0 +1,127 @@+module PostgresqlTypes.Circle+  ( Circle,++    -- * Accessors+    toCenterX,+    toCenterY,+    toRadius,++    -- * Constructors+    refineFromCenterAndRadius,+    normalizeFromCenterAndRadius,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @circle@ type. Circle in 2D plane.+--+-- Represents a circle with center coordinates and radius.+-- Gets stored as three @64@-bit floating point numbers (@x@,@y@,@radius@) in PostgreSQL.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-CIRCLE).+data Circle+  = Circle+      -- | Center x coordinate+      Double+      -- | Center y coordinate+      Double+      -- | Circle radius (must be non-negative)+      Double+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Circle)++instance Arbitrary Circle where+  arbitrary = do+    x <- arbitrary+    y <- arbitrary+    r <- QuickCheck.suchThat arbitrary (>= 0)+    pure (Circle x y r)+  shrink (Circle x y r) = do+    x' <- shrink x+    y' <- shrink y+    r' <- abs <$> shrink r+    pure (Circle x' y' r')++instance Hashable Circle where+  hashWithSalt salt (Circle x y r) =+    salt+      `hashWithSalt` castDoubleToWord64 x+      `hashWithSalt` castDoubleToWord64 y+      `hashWithSalt` castDoubleToWord64 r++instance IsScalar Circle where+  schemaName = Tagged Nothing+  typeName = Tagged "circle"+  baseOid = Tagged (Just 718)+  arrayOid = Tagged (Just 719)+  typeParams = Tagged []+  binaryEncoder (Circle x y r) =+    mconcat+      [ Write.bWord64 (castDoubleToWord64 x),+        Write.bWord64 (castDoubleToWord64 y),+        Write.bWord64 (castDoubleToWord64 r)+      ]+  binaryDecoder = PtrPeeker.fixed do+    x <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+    y <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+    r <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+    pure (Right (Circle x y r))+  textualEncoder (Circle x y r) =+    mconcat+      [ "<(",+        TextBuilder.string (printf "%g" x),+        ",",+        TextBuilder.string (printf "%g" y),+        "),",+        TextBuilder.string (printf "%g" r),+        ">"+      ]+  textualDecoder = do+    _ <- Attoparsec.char '<'+    _ <- Attoparsec.char '('+    x <- Attoparsec.double+    _ <- Attoparsec.char ','+    y <- Attoparsec.double+    _ <- Attoparsec.char ')'+    _ <- Attoparsec.char ','+    r <- Attoparsec.double+    _ <- Attoparsec.char '>'+    pure (Circle x y r)++-- * Accessors++-- | Extract the center x coordinate.+toCenterX :: Circle -> Double+toCenterX (Circle x _ _) = x++-- | Extract the center y coordinate.+toCenterY :: Circle -> Double+toCenterY (Circle _ y _) = y++-- | Extract the radius.+toRadius :: Circle -> Double+toRadius (Circle _ _ r) = r++-- * Constructors++-- | Construct a PostgreSQL 'Circle' from (x, y, radius) with validation.+-- Returns 'Nothing' if radius is negative.+refineFromCenterAndRadius :: Double -> Double -> Double -> Maybe Circle+refineFromCenterAndRadius x y r =+  if r < 0+    then Nothing+    else Just (Circle x y r)++-- | Construct a PostgreSQL 'Circle' from (x, y, radius).+-- Makes radius non-negative by taking absolute value.+normalizeFromCenterAndRadius :: Double -> Double -> Double -> Circle+normalizeFromCenterAndRadius x y r = Circle x y (abs r)
+ src/library/PostgresqlTypes/Date.hs view
@@ -0,0 +1,174 @@+module PostgresqlTypes.Date+  ( Date,++    -- * Accessors+    toDay,++    -- * Constructors+    refineFromDay,+    normalizeFromDay,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Time as Time+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @date@ type. Calendar date (year, month, day).+--+-- Range: @4713 BC@ to @5874897 AD@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-datetime.html#DATATYPE-DATE).+newtype Date+  = -- | Days since PostgreSQL epoch (2000-01-01).+    Date Int32+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Date)++-- | PostgreSQL date range: 4713 BC to 5874897 AD.+--+-- Minimum date: 4713 BC January 1 = -4712-01-01 in ISO format.+--+-- Maximum date: 5874897 AD December 31 = 5874897-12-31 in ISO format.+instance Bounded Date where+  minBound = unsafeFromDay minDay+  maxBound = unsafeFromDay maxDay++-- | Custom Arbitrary instance that generates dates within PostgreSQL's supported range.+-- PostgreSQL supports dates from 4713 BC to 5874897 AD.+instance Arbitrary Date where+  arbitrary =+    QuickCheck.frequency+      [ ( 99,+          let minBase = coerce (minBound @Date)+              maxBase = coerce (maxBound @Date)+           in Date <$> QuickCheck.choose (minBase, maxBase)+        ),+        ( 1,+          do+            y <- QuickCheck.choose (-1, 1)+            m <- QuickCheck.choose (1, 12)+            d <- QuickCheck.choose (1, 31)+            pure (unsafeFromDay (Time.fromGregorian y m d))+        )+      ]++instance IsScalar Date where+  schemaName = Tagged Nothing+  typeName = Tagged "date"+  baseOid = Tagged (Just 1082)+  arrayOid = Tagged (Just 1182)+  typeParams = Tagged []+  binaryEncoder (Date days) = Write.bInt32 days+  binaryDecoder = do+    days <- PtrPeeker.fixed PtrPeeker.beSignedInt4+    pure (Right (Date days))+  textualEncoder date =+    let day = toDay date+        (y, m, d) = Time.toGregorian day+        (y', bc) =+          if y <= 0+            then (negate y + 1, True)+            else (y, False)+     in mconcat+          [ if y' > 9999+              then TextBuilder.decimal y'+              else TextBuilder.fixedLengthDecimal 4 y',+            "-",+            TextBuilder.fixedLengthDecimal 2 m,+            "-",+            TextBuilder.fixedLengthDecimal 2 d,+            if bc then " BC" else ""+          ]+  textualDecoder = do+    -- Parse year (may have more than 4 digits for extreme dates)+    y <- Attoparsec.decimal+    _ <- Attoparsec.char '-'+    m <- twoDigits+    _ <- Attoparsec.char '-'+    d <- twoDigits+    -- Check for BC suffix+    bc <- Attoparsec.option False (True <$ (Attoparsec.skipSpace *> Attoparsec.string "BC"))+    let year = if bc then negate y + 1 else y+    -- Try to use fromGregorianValid for normal dates, fallback to custom calculation for extreme dates+    case Time.fromGregorianValid year m d of+      Just day -> pure (unsafeFromDay day)+      Nothing ->+        -- For extreme dates outside time library's range, compute days directly+        -- This is a simplified calculation that may not be perfectly accurate for all historical dates+        -- but matches PostgreSQL's handling of extreme dates+        let yearsSinceEpoch = year - 2000+            daysFromYears = fromIntegral yearsSinceEpoch * 365 + fromIntegral (yearsSinceEpoch `div` 4)+            getDaysInMonth mon =+              case mon of+                1 -> (31 :: Int)+                2 -> if isLeapYear year then (29 :: Int) else (28 :: Int)+                3 -> (31 :: Int)+                4 -> (30 :: Int)+                5 -> (31 :: Int)+                6 -> (30 :: Int)+                7 -> (31 :: Int)+                8 -> (31 :: Int)+                9 -> (30 :: Int)+                10 -> (31 :: Int)+                11 -> (30 :: Int)+                12 -> (31 :: Int)+                _ -> (0 :: Int)+            monthDays = foldl' (+) 0 [if mon < m then getDaysInMonth mon else 0 | mon <- [1 .. 12]]+         in pure (Date (daysFromYears + fromIntegral monthDays + fromIntegral d - 1))+    where+      twoDigits = do+        a <- Attoparsec.digit+        b <- Attoparsec.digit+        pure (digitToInt a * 10 + digitToInt b)+      isLeapYear y = (y `mod` 4 == 0 && y `mod` 100 /= 0) || (y `mod` 400 == 0)++-- | Mapping to @daterange@ type.+instance IsRangeElement Date where+  rangeTypeName = Tagged "daterange"+  rangeBaseOid = Tagged (Just 3912)+  rangeArrayOid = Tagged (Just 3913)++-- | Mapping to @datemultirange@ type.+instance IsMultirangeElement Date where+  multirangeTypeName = Tagged "datemultirange"+  multirangeBaseOid = Tagged (Just 4535)+  multirangeArrayOid = Tagged (Just 6155)++-- | PostgreSQL epoch is 2000-01-01+postgresEpoch :: Time.Day+postgresEpoch = Time.fromGregorian 2000 1 1++-- * Accessors++-- | Convert Date to Day+toDay :: Date -> Time.Day+toDay (Date days) = Time.addDays (fromIntegral days) postgresEpoch++-- * Constructors++refineFromDay :: Time.Day -> Maybe Date+refineFromDay day+  | day < minDay || day > maxDay = Nothing+  | otherwise = Just (unsafeFromDay day)++normalizeFromDay :: Time.Day -> Date+normalizeFromDay day+  | day < minDay = minBound+  | day > maxDay = maxBound+  | otherwise = unsafeFromDay day++unsafeFromDay :: Time.Day -> Date+unsafeFromDay day = Date (fromIntegral (Time.diffDays day postgresEpoch))++minDay :: Time.Day+minDay = Time.fromGregorian (-4712) 1 1++maxDay :: Time.Day+maxDay = Time.fromGregorian 5874897 12 31
+ src/library/PostgresqlTypes/Float4.hs view
@@ -0,0 +1,53 @@+module PostgresqlTypes.Float4+  ( Float4 (..),++    -- * Accessors+    toFloat,++    -- * Constructors+    fromFloat,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castFloatToWord32, castWord32ToFloat)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @float4@ type. 4-byte floating-point number. 6 decimal digits precision.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-numeric.html#DATATYPE-FLOAT).+newtype Float4 = Float4 Float+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Float4)++instance IsScalar Float4 where+  schemaName = Tagged Nothing+  typeName = Tagged "float4"+  baseOid = Tagged (Just 700)+  arrayOid = Tagged (Just 1021)+  typeParams = Tagged []+  binaryEncoder (Float4 x) = Write.bWord32 (castFloatToWord32 x)+  binaryDecoder = PtrPeeker.fixed (Right . Float4 . castWord32ToFloat <$> PtrPeeker.beUnsignedInt4)+  textualEncoder (Float4 x) = TextBuilder.string (printf "%g" x)+  textualDecoder =+    (Float4 (0 / 0) <$ Attoparsec.string "NaN")+      <|> (Float4 (1 / 0) <$ Attoparsec.string "Infinity")+      <|> (Float4 (-1 / 0) <$ Attoparsec.string "-Infinity")+      <|> (Float4 . realToFrac <$> Attoparsec.double)++-- * Accessors++-- | Extract the underlying 'Float' value.+toFloat :: Float4 -> Float+toFloat (Float4 f) = f++-- * Constructors++-- | Construct a PostgreSQL 'Float4' from a 'Float' value.+fromFloat :: Float -> Float4+fromFloat = Float4
+ src/library/PostgresqlTypes/Float8.hs view
@@ -0,0 +1,53 @@+module PostgresqlTypes.Float8+  ( Float8 (..),++    -- * Accessors+    toDouble,++    -- * Constructors+    fromDouble,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @float8@ type. 8-byte floating-point number. 15 decimal digits precision.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-numeric.html#DATATYPE-FLOAT).+newtype Float8 = Float8 Double+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Float8)++instance IsScalar Float8 where+  schemaName = Tagged Nothing+  typeName = Tagged "float8"+  baseOid = Tagged (Just 701)+  arrayOid = Tagged (Just 1022)+  typeParams = Tagged []+  binaryEncoder (Float8 x) = Write.bWord64 (castDoubleToWord64 x)+  binaryDecoder = PtrPeeker.fixed (Right . Float8 . castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+  textualEncoder (Float8 x) = TextBuilder.string (printf "%g" x)+  textualDecoder =+    (Float8 (0 / 0) <$ Attoparsec.string "NaN")+      <|> (Float8 (1 / 0) <$ Attoparsec.string "Infinity")+      <|> (Float8 (-1 / 0) <$ Attoparsec.string "-Infinity")+      <|> (Float8 <$> Attoparsec.double)++-- * Accessors++-- | Extract the underlying 'Double' value.+toDouble :: Float8 -> Double+toDouble (Float8 d) = d++-- * Constructors++-- | Construct a PostgreSQL 'Float8' from a 'Double' value.+fromDouble :: Double -> Float8+fromDouble = Float8
+ src/library/PostgresqlTypes/Hstore.hs view
@@ -0,0 +1,189 @@+module PostgresqlTypes.Hstore+  ( Hstore,++    -- * Accessors+    toMap,++    -- * Constructors+    refineFromMap,+    normalizeFromMap,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.ByteString as ByteString+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (hGetContents)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @hstore@ type. Key-value store where keys are text and values are optional text.+--+-- Hstore is a key-value store where both keys and values are text strings.+-- Values can be NULL (represented as Nothing in Haskell).+-- Keys must be unique and cannot be NULL.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/hstore.html).+newtype Hstore = Hstore (Map.Map Text (Maybe Text))+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Hstore)++instance Arbitrary Hstore where+  arbitrary = do+    -- Generate a list of key-value pairs+    pairs <- QuickCheck.listOf do+      key <- Text.pack <$> QuickCheck.listOf1 (QuickCheck.suchThat arbitrary (\c -> c /= '\NUL' && c /= '=' && c /= '>' && c /= '"' && c /= '\\' && c /= ' ' && c /= ',' && c /= '\n' && c /= '\r' && c /= '\t'))+      value <-+        QuickCheck.oneof+          [ pure Nothing,+            Just . Text.pack <$> QuickCheck.listOf (QuickCheck.suchThat arbitrary (\c -> c /= '\NUL'))+          ]+      pure (key, value)+    pure (Hstore (Map.fromList pairs))+  shrink (Hstore base) =+    Hstore . Map.fromList <$> shrink (Map.toList base)++instance IsScalar Hstore where+  schemaName = Tagged Nothing+  typeName = Tagged "hstore"+  baseOid = Tagged Nothing+  arrayOid = Tagged Nothing+  typeParams = Tagged []+  binaryEncoder (Hstore m) = do+    -- Binary format:+    -- 4 bytes: number of key-value pairs (int32)+    -- For each pair:+    --   4 bytes: key length (int32)+    --   N bytes: key data (UTF-8)+    --   4 bytes: value length (int32), -1 for NULL+    --   M bytes: value data (UTF-8) if not NULL+    Write.bInt32 (fromIntegral (Map.size m))+      <> foldMap encodePair (Map.toList m)+    where+      encodePair (key, maybeValue) =+        let keyBytes = Text.Encoding.encodeUtf8 key+            keyLen = fromIntegral (ByteString.length keyBytes)+         in Write.bInt32 keyLen+              <> Write.byteString keyBytes+              <> case maybeValue of+                Nothing -> Write.bInt32 (-1)+                Just value ->+                  let valueBytes = Text.Encoding.encodeUtf8 value+                      valueLen = fromIntegral (ByteString.length valueBytes)+                   in Write.bInt32 valueLen <> Write.byteString valueBytes++  binaryDecoder = runExceptT do+    pairCount <- lift $ PtrPeeker.fixed PtrPeeker.beSignedInt4+    pairs <- replicateM (fromIntegral pairCount) decodePair+    pure (Hstore (Map.fromList pairs))+    where+      decodePair = do+        keyLen <- lift $ PtrPeeker.fixed PtrPeeker.beSignedInt4+        when (keyLen < 0) do+          throwError (DecodingError ["key-length"] (UnsupportedValueDecodingErrorReason "Key length must be non-negative" (TextBuilder.toText (TextBuilder.decimal keyLen))))+        keyBytes <- lift $ PtrPeeker.forceSize (fromIntegral keyLen) PtrPeeker.remainderAsByteString+        case Text.Encoding.decodeUtf8' keyBytes of+          Left e ->+            throwError+              ( DecodingError+                  { location = ["hstore", "key"],+                    reason = ParsingDecodingErrorReason (fromString (show e)) keyBytes+                  }+              )+          Right key -> do+            valueLen <- lift $ PtrPeeker.fixed PtrPeeker.beSignedInt4+            if valueLen == -1+              then pure (key, Nothing)+              else do+                when (valueLen < 0) do+                  throwError (DecodingError ["value-length"] (UnsupportedValueDecodingErrorReason "Value length must be non-negative or -1 for NULL" (TextBuilder.toText (TextBuilder.decimal valueLen))))+                valueBytes <- lift $ PtrPeeker.forceSize (fromIntegral valueLen) PtrPeeker.remainderAsByteString+                case Text.Encoding.decodeUtf8' valueBytes of+                  Left e ->+                    throwError+                      ( DecodingError+                          { location = ["hstore", "value"],+                            reason = ParsingDecodingErrorReason (fromString (show e)) valueBytes+                          }+                      )+                  Right value -> pure (key, Just value)++  textualEncoder (Hstore m) =+    if Map.null m+      then mempty+      else mconcat $ intersperse (TextBuilder.text ", ") $ map encodePair (Map.toList m)+    where+      encodePair (key, maybeValue) =+        TextBuilder.char '"'+          <> TextBuilder.text (escapeText key)+          <> TextBuilder.text "\"=>"+          <> case maybeValue of+            Nothing -> TextBuilder.text "NULL"+            Just value ->+              TextBuilder.char '"'+                <> TextBuilder.text (escapeText value)+                <> TextBuilder.char '"'+      escapeText = Text.concatMap escapeChar+      escapeChar c = case c of+        '\\' -> "\\\\"+        '"' -> "\\\""+        _ -> Text.singleton c++  textualDecoder = do+    pairs <- Attoparsec.sepBy pairParser (Attoparsec.string ", " <|> Attoparsec.string ",")+    pure (Hstore (Map.fromList pairs))+    where+      pairParser = do+        key <- quotedString+        _ <- Attoparsec.string "=>"+        value <- nullValue <|> (Just <$> quotedString)+        pure (key, value)+      quotedString = do+        _ <- Attoparsec.char '"'+        chars <- many (escapedChar <|> normalChar)+        _ <- Attoparsec.char '"'+        pure (Text.pack chars)+      escapedChar = do+        _ <- Attoparsec.char '\\'+        Attoparsec.anyChar+      normalChar = Attoparsec.satisfy (\c -> c /= '"' && c /= '\\')+      nullValue = do+        _ <- Attoparsec.string "NULL"+        pure Nothing++-- * Accessors++-- | Extract the underlying 'Map.Map Text (Maybe Text)'.+toMap :: Hstore -> Map.Map Text (Maybe Text)+toMap (Hstore m) = m++-- * Constructors++-- | Construct from Haskell 'Map.Map Text (Maybe Text)' with validation.+-- Returns 'Nothing' if any key or value contains null characters (not supported by PostgreSQL).+refineFromMap :: Map.Map Text (Maybe Text) -> Maybe Hstore+refineFromMap m =+  if any hasNul (Map.keys m) || any (maybe False hasNul) (Map.elems m)+    then Nothing+    else Just (Hstore m)+  where+    hasNul = Text.elem '\NUL'++-- | Construct from Haskell 'Map.Map Text (Maybe Text)'.+-- Strips null characters to ensure PostgreSQL compatibility.+normalizeFromMap :: Map.Map Text (Maybe Text) -> Hstore+normalizeFromMap m =+  Hstore+    ( Map.fromList+        [ (stripNul k, fmap stripNul v)+        | (k, v) <- Map.toList m+        ]+    )+  where+    stripNul = Text.replace "\NUL" ""
+ src/library/PostgresqlTypes/Inet.hs view
@@ -0,0 +1,347 @@+module PostgresqlTypes.Inet+  ( Inet,++    -- * Accessors+    fold,+    refineToV4,+    refineToV6,++    -- * Constructors+    normalizeFromV4,+    normalizeFromV6,+    refineFromV4,+    refineFromV6,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import Data.Bits+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (fold)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @inet@ type.+--+-- Holds an IPv4 or IPv6 host address, and optionally its subnet, all in one field. The subnet is represented by the number of network address bits present in the host address (the “netmask”). If the netmask is 32 and the address is IPv4, then the value does not indicate a subnet, only a single host. In IPv6, the address length is 128 bits, so 128 bits specify a unique host address. Note that if you want to accept only networks, you should use the @cidr@ type rather than @inet@.+--+-- The input format for this type is @address/y@ where @address@ is an IPv4 or IPv6 address and @y@ is the number of bits in the netmask. If the @/y@ portion is omitted, the netmask is taken to be 32 for IPv4 or 128 for IPv6, so the value represents just a single host. On display, the @/y@ portion is suppressed if the netmask specifies a single host.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-net-types.html#DATATYPE-INET).+data Inet+  = V4Inet+      -- | IPv4 address stored as 32-bit big-endian word.+      Word32+      -- | Network mask length (0-32).+      Word8+  | V6Inet+      -- | First 32 bits of IPv6 address in big-endian order.+      Word32+      -- | Second 32 bits of IPv6 address in big-endian order.+      Word32+      -- | Third 32 bits of IPv6 address in big-endian order.+      Word32+      -- | Fourth 32 bits of IPv6 address in big-endian order.+      Word32+      -- | Network mask length (0-128).+      Word8+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Inet)++instance Arbitrary Inet where+  arbitrary = do+    isIPv4 <- arbitrary+    if isIPv4+      then+        V4Inet+          <$> arbitrary+          <*> QuickCheck.choose (0, 32)+      else+        V6Inet+          <$> arbitrary+          <*> arbitrary+          <*> arbitrary+          <*> arbitrary+          <*> QuickCheck.choose (0, 128)++  shrink = \case+    V4Inet addr netmask ->+      [ V4Inet addr' netmask'+      | addr' <- shrink addr,+        netmask' <- shrink netmask,+        netmask' <= 32+      ]+    V6Inet w1 w2 w3 w4 netmask ->+      [ V6Inet w1' w2' w3' w4' netmask'+      | (w1', w2', w3', w4') <- shrink (w1, w2, w3, w4),+        netmask' <- shrink netmask,+        netmask' <= 128+      ]++instance Hashable Inet where+  hashWithSalt salt = \case+    V4Inet addr netmask -> salt `hashWithSalt` (0 :: Int) `hashWithSalt` addr `hashWithSalt` netmask+    V6Inet w1 w2 w3 w4 netmask -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` w1 `hashWithSalt` w2 `hashWithSalt` w3 `hashWithSalt` w4 `hashWithSalt` netmask++instance IsScalar Inet where+  schemaName = Tagged Nothing+  typeName = Tagged "inet"+  baseOid = Tagged (Just 869)+  arrayOid = Tagged (Just 1041)+  typeParams = Tagged []++  binaryEncoder = \case+    V4Inet addr netmask ->+      mconcat+        [ Write.word8 2, -- IPv4 address family+          Write.word8 netmask,+          Write.word8 0, -- is_cidr flag (0 for inet)+          Write.word8 4, -- address length (4 bytes for IPv4)+          Write.bWord32 addr -- IPv4 address+        ]+    V6Inet w1 w2 w3 w4 netmask ->+      mconcat+        [ Write.word8 3, -- IPv6 address family for INET (different from CIDR)+          Write.word8 netmask,+          Write.word8 0, -- is_cidr flag (0 for inet)+          Write.word8 16, -- address length (16 bytes for IPv6)+          Write.bWord32 w1,+          Write.bWord32 w2,+          Write.bWord32 w3,+          Write.bWord32 w4+        ]++  binaryDecoder = do+    (family, netmask, isCidrFlag, addrLen) <-+      PtrPeeker.fixed do+        (,,,)+          <$> PtrPeeker.unsignedInt1+          <*> PtrPeeker.unsignedInt1+          <*> PtrPeeker.unsignedInt1+          <*> PtrPeeker.unsignedInt1++    runExceptT do+      when (isCidrFlag /= 0) do+        throwError (DecodingError ["is-cidr"] (UnexpectedValueDecodingErrorReason "0" (TextBuilder.toText (TextBuilder.decimal isCidrFlag))))++      case family of+        2 -> do+          -- IPv4+          when (addrLen /= 4) do+            throwError (DecodingError ["address-length"] (UnexpectedValueDecodingErrorReason "4" (TextBuilder.toText (TextBuilder.decimal addrLen))))+          addr <- lift do+            PtrPeeker.fixed PtrPeeker.beUnsignedInt4+          pure (V4Inet addr (fromIntegral netmask))+        3 -> do+          -- IPv6+          when (addrLen /= 16) do+            throwError (DecodingError ["address-length"] (UnexpectedValueDecodingErrorReason "16" (TextBuilder.toText (TextBuilder.decimal addrLen))))+          lift do+            PtrPeeker.fixed do+              V6Inet+                <$> PtrPeeker.beUnsignedInt4+                <*> PtrPeeker.beUnsignedInt4+                <*> PtrPeeker.beUnsignedInt4+                <*> PtrPeeker.beUnsignedInt4+                <*> pure (fromIntegral netmask)+        _ -> do+          throwError (DecodingError ["address-family"] (UnexpectedValueDecodingErrorReason "2 or 10" (TextBuilder.toText (TextBuilder.decimal family))))++  textualEncoder = \case+    V4Inet addr netmask ->+      let a = ((addr `shiftR` 24) .&. 0xFF)+          b = ((addr `shiftR` 16) .&. 0xFF)+          c = ((addr `shiftR` 8) .&. 0xFF)+          d = (addr .&. 0xFF)+       in mconcat+            [ TextBuilder.decimal a,+              ".",+              TextBuilder.decimal b,+              ".",+              TextBuilder.decimal c,+              ".",+              TextBuilder.decimal d,+              if netmask == 32+                then mempty+                else "/" <> TextBuilder.decimal netmask+            ]+    V6Inet w1 w2 w3 w4 netmask ->+      -- Convert 32-bit words to proper IPv6 hex representation+      let toHex w =+            let h1 = fromIntegral ((w `shiftR` 16) .&. 0xFFFF) :: Word16+                h2 = fromIntegral (w .&. 0xFFFF) :: Word16+             in TextBuilder.hexadecimal h1 <> ":" <> TextBuilder.hexadecimal h2+          ipStr =+            toHex w1+              <> ":"+              <> toHex w2+              <> ":"+              <> toHex w3+              <> ":"+              <> toHex w4+       in if netmask == 128+            then ipStr -- Host address without explicit netmask+            else ipStr <> "/" <> TextBuilder.decimal netmask -- Host address with netmask+  textualDecoder = parseV6 <|> parseV4+    where+      parseV4 = do+        a <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '.'+        b <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '.'+        c <- Attoparsec.decimal @Word32+        _ <- Attoparsec.char '.'+        d <- Attoparsec.decimal @Word32+        let addr = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d+        netmask <- optional (Attoparsec.char '/' *> (Attoparsec.decimal :: Attoparsec.Parser Word8))+        pure (V4Inet addr (fromMaybe 32 netmask))+      parseV6 = do+        -- Try to parse compressed IPv6 (with ::)+        parseCompressedV6 <|> parseFullV6++      parseFullV6 = do+        groups <- parseHexGroup `Attoparsec.sepBy1` Attoparsec.char ':'+        when (length groups /= 8) (fail "Expected 8 groups")+        case groups of+          [h1, h2, h3, h4, h5, h6, h7, h8] -> do+            let w1 = fromIntegral h1 `shiftL` 16 .|. fromIntegral h2+                w2 = fromIntegral h3 `shiftL` 16 .|. fromIntegral h4+                w3 = fromIntegral h5 `shiftL` 16 .|. fromIntegral h6+                w4 = fromIntegral h7 `shiftL` 16 .|. fromIntegral h8+            netmask <- optional (Attoparsec.char '/' *> (Attoparsec.decimal :: Attoparsec.Parser Word8))+            pure (V6Inet w1 w2 w3 w4 (fromMaybe 128 netmask))+          _ -> fail "Expected 8 groups"++      parseCompressedV6 = do+        -- Check if starts with ::+        startsWithDoubleColon <- Attoparsec.option False (True <$ Attoparsec.string "::")+        before <-+          if startsWithDoubleColon+            then pure []+            else parseHexGroup `Attoparsec.sepBy1` Attoparsec.char ':'+        -- Check for :: in the middle or if we already found it at start+        hasDoubleColon <-+          if startsWithDoubleColon+            then pure True+            else Attoparsec.option False (True <$ Attoparsec.string "::")+        after <-+          if hasDoubleColon+            then parseHexGroup `Attoparsec.sepBy` Attoparsec.char ':'+            else pure []+        -- If no :: was found, this isn't compressed format+        when (not hasDoubleColon) (fail "Not a compressed IPv6 address")+        -- Expand to 8 groups, filling middle with zeros+        let totalGroups = length before + length after+        when (totalGroups > 7) (fail "Too many groups in compressed IPv6")+        let zeros = replicate (8 - totalGroups) 0+            allGroups = before ++ zeros ++ after+        case allGroups of+          [h1, h2, h3, h4, h5, h6, h7, h8] -> do+            let w1 = fromIntegral h1 `shiftL` 16 .|. fromIntegral h2+                w2 = fromIntegral h3 `shiftL` 16 .|. fromIntegral h4+                w3 = fromIntegral h5 `shiftL` 16 .|. fromIntegral h6+                w4 = fromIntegral h7 `shiftL` 16 .|. fromIntegral h8+            netmask <- optional (Attoparsec.char '/' *> (Attoparsec.decimal :: Attoparsec.Parser Word8))+            pure (V6Inet w1 w2 w3 w4 (fromMaybe 128 netmask))+          _ -> fail "Expected 8 groups after expansion"++      parseHexGroup = Attoparsec.hexadecimal @Word16++-- * Accessors++-- |+-- Pattern match on 'Inet' type.+fold ::+  -- | Function to handle IPv4 address case.+  --+  -- Takes the IPv4 address as 'Word32' and the netmask as 'Word8' both in big-endian order.+  (Word32 -> Word8 -> a) ->+  -- | Function to handle IPv6 address case.+  --+  -- Takes the four 32-bit words of the IPv6 address in big-endian order and the netmask as 'Word8'.+  (Word32 -> Word32 -> Word32 -> Word32 -> Word8 -> a) ->+  (Inet -> a)+fold fV4 fV6 = \case+  V4Inet addr netmask -> fV4 addr netmask+  V6Inet w1 w2 w3 w4 netmask -> fV6 w1 w2 w3 w4 netmask++-- | Refine an IPv4 'Inet' value from a 32-bit address and an 8-bit netmask, both in big-endian order.+refineToV4 :: Inet -> Maybe (Word32, Word8)+refineToV4 = \case+  V4Inet addr netmask -> Just (addr, netmask)+  V6Inet {} -> Nothing++-- | Refine an IPv6 'Inet' value from four 32-bit words representing the address and an 8-bit netmask, all in big-endian order.+refineToV6 :: Inet -> Maybe (Word32, Word32, Word32, Word32, Word8)+refineToV6 = \case+  V4Inet {} -> Nothing+  V6Inet w1 w2 w3 w4 netmask -> Just (w1, w2, w3, w4, netmask)++-- * Constructors++-- |+-- Construct an IPv4 'Inet' value from a 32-bit address and an 8-bit netmask, both in big-endian order.+--+-- The netmask is clamped to be in the range 0-32.+normalizeFromV4 ::+  -- | IPv4 address as a 32-bit big-endian word.+  Word32 ->+  -- | Network mask length (0-32).+  Word8 ->+  Inet+normalizeFromV4 addr netmask =+  V4Inet addr (min 32 netmask)++-- |+-- Construct an IPv6 'Inet' value from four 32-bit words representing the address and an 8-bit netmask, all in big-endian order.+--+-- The netmask is clamped to be in the range 0-128.+normalizeFromV6 ::+  -- | First 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Second 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Third 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Fourth 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Network mask length (0-128).+  Word8 ->+  Inet+normalizeFromV6 w1 w2 w3 w4 netmask =+  V6Inet w1 w2 w3 w4 (min 128 netmask)++-- | Refine an IPv4 'Inet' value from a 32-bit address and an 8-bit netmask, both in big-endian order.+--+-- Returns 'Nothing' if the netmask is out of range (greater than 32).+refineFromV4 ::+  -- | IPv4 address as a 32-bit big-endian word.+  Word32 ->+  -- | Network mask length (0-32).+  Word8 ->+  Maybe Inet+refineFromV4 addr netmask+  | netmask <= 32 = Just (V4Inet addr netmask)+  | otherwise = Nothing++-- | Refine an IPv6 'Inet' value from four 32-bit words representing the address and an 8-bit netmask, all in big-endian order.+--+-- Returns 'Nothing' if the netmask is out of range (greater than 128).+refineFromV6 ::+  -- | First 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Second 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Third 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Fourth 32 bits of IPv6 address in big-endian order.+  Word32 ->+  -- | Network mask length (0-128).+  Word8 ->+  Maybe Inet+refineFromV6 w1 w2 w3 w4 netmask+  | netmask <= 128 = Just (V6Inet w1 w2 w3 w4 netmask)+  | otherwise = Nothing
+ src/library/PostgresqlTypes/Int2.hs view
@@ -0,0 +1,50 @@+module PostgresqlTypes.Int2+  ( Int2 (..),++    -- * Accessors+    toInt16,++    -- * Constructors+    fromInt16,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @int2@ type. 2-byte signed integer.+--+-- Range: @-32768@ to @+32767@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-numeric.html#DATATYPE-INT).+newtype Int2 = Int2 Int16+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Int2)++instance IsScalar Int2 where+  schemaName = Tagged Nothing+  typeName = Tagged "int2"+  baseOid = Tagged (Just 21)+  arrayOid = Tagged (Just 1005)+  typeParams = Tagged []+  binaryEncoder (Int2 x) = Write.bInt16 x+  binaryDecoder = PtrPeeker.fixed (Right . Int2 <$> PtrPeeker.beSignedInt2)+  textualEncoder (Int2 x) = TextBuilder.decimal x+  textualDecoder = Int2 <$> Attoparsec.signed Attoparsec.decimal++-- * Accessors++-- | Extract the underlying 'Int16' value.+toInt16 :: Int2 -> Int16+toInt16 (Int2 i) = i++-- * Constructors++-- | Construct a PostgreSQL 'Int2' from an 'Int16' value.+fromInt16 :: Int16 -> Int2+fromInt16 = Int2
+ src/library/PostgresqlTypes/Int4.hs view
@@ -0,0 +1,62 @@+module PostgresqlTypes.Int4+  ( Int4 (..),++    -- * Accessors+    toInt32,++    -- * Constructors+    fromInt32,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @int4@ type. 4-byte signed integer.+--+-- Range: @-2147483648@ to @+2147483647@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-numeric.html#DATATYPE-INT).+newtype Int4 = Int4 Int32+  deriving newtype (Eq, Ord, Hashable, Arbitrary, Enum, Bounded)+  deriving (Show, Read, IsString) via (ViaIsScalar Int4)++instance IsScalar Int4 where+  schemaName = Tagged Nothing+  typeName = Tagged "int4"+  baseOid = Tagged (Just 23)+  arrayOid = Tagged (Just 1007)+  typeParams = Tagged []+  binaryEncoder (Int4 x) = Write.bInt32 x+  binaryDecoder = PtrPeeker.fixed (Right . Int4 <$> PtrPeeker.beSignedInt4)+  textualEncoder (Int4 x) = TextBuilder.decimal x+  textualDecoder = Int4 <$> Attoparsec.signed Attoparsec.decimal++-- | Mapping to @int4range@ type.+instance IsRangeElement Int4 where+  rangeTypeName = Tagged "int4range"+  rangeBaseOid = Tagged (Just 3904)+  rangeArrayOid = Tagged (Just 3905)++-- | Mapping to @int4multirange@ type.+instance IsMultirangeElement Int4 where+  multirangeTypeName = Tagged "int4multirange"+  multirangeBaseOid = Tagged (Just 4451)+  multirangeArrayOid = Tagged (Just 6150)++-- * Accessors++-- | Extract the underlying 'Int32' value.+toInt32 :: Int4 -> Int32+toInt32 (Int4 i) = i++-- * Constructors++-- | Construct a PostgreSQL 'Int4' from an 'Int32' value.+fromInt32 :: Int32 -> Int4+fromInt32 = Int4
+ src/library/PostgresqlTypes/Int8.hs view
@@ -0,0 +1,62 @@+module PostgresqlTypes.Int8+  ( Int8 (..),++    -- * Accessors+    toInt64,++    -- * Constructors+    fromInt64,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (Int8)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @int8@ type. 8-byte signed integer.+--+-- Range: @-9223372036854775808@ to @+9223372036854775807@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-numeric.html#DATATYPE-INT).+newtype Int8 = Int8 Int64+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Int8)++instance IsScalar Int8 where+  schemaName = Tagged Nothing+  typeName = Tagged "int8"+  baseOid = Tagged (Just 20)+  arrayOid = Tagged (Just 1016)+  typeParams = Tagged []+  binaryEncoder (Int8 x) = Write.bInt64 x+  binaryDecoder = PtrPeeker.fixed (Right . Int8 <$> PtrPeeker.beSignedInt8)+  textualEncoder (Int8 x) = TextBuilder.decimal x+  textualDecoder = Int8 <$> Attoparsec.signed Attoparsec.decimal++-- | Mapping to @int8range@ type.+instance IsRangeElement Int8 where+  rangeTypeName = Tagged "int8range"+  rangeBaseOid = Tagged (Just 3926)+  rangeArrayOid = Tagged (Just 3927)++-- | Mapping to @int8multirange@ type.+instance IsMultirangeElement Int8 where+  multirangeTypeName = Tagged "int8multirange"+  multirangeBaseOid = Tagged (Just 4536)+  multirangeArrayOid = Tagged (Just 6157)++-- * Accessors++-- | Extract the underlying 'Int64' value.+toInt64 :: Int8 -> Int64+toInt64 (Int8 i) = i++-- * Constructors++-- | Construct a PostgreSQL 'Int8' from an 'Int64' value.+fromInt64 :: Int64 -> Int8+fromInt64 = Int8
+ src/library/PostgresqlTypes/Interval.hs view
@@ -0,0 +1,365 @@+module PostgresqlTypes.Interval+  ( Interval,++    -- * Accessors+    toMonths,+    toDays,+    toMicroseconds,+    normalizeToMicrosecondsInTotal,+    normalizeToDiffTime,++    -- * Constructors+    normalizeFromMonthsDaysAndMicroseconds,+    normalizeFromMicrosecondsInTotal,+    normalizeFromDiffTime,+    refineFromMonthsDaysAndMicroseconds,+    refineFromMicrosecondsInTotal,+    refineFromDiffTime,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @interval@ type. Time span with separate components for months, days, and microseconds with individual signs.+--+-- Stored as three components: months, days, and microseconds, each with their own sign.+--+-- For a simpler representation, use the 'normalizeToMicrosecondsInTotal' and 'normalizeFromMicrosecondsInTotal'/'refineFromMicrosecondsInTotal' functions+-- to work with a single microseconds value.+--+-- Range: @-178000000@ years to @178000000@ years.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-datetime.html#DATATYPE-INTERVAL-INPUT).+data Interval+  = Interval+      -- | Months.+      Int32+      -- | Days.+      Int32+      -- | Microseconds.+      Int64+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Interval)++instance Bounded Interval where+  minBound = Interval (-178000000 * 12) 0 0+  maxBound = Interval (178000000 * 12) 0 0++instance Arbitrary Interval where+  arbitrary = do+    micros <- QuickCheck.choose (-999_999, 999_999)+    days <- QuickCheck.choose (-daysPerMonth, daysPerMonth)+    months <- QuickCheck.choose (toMonths (minBound @Interval), toMonths (maxBound @Interval))+    pure (max minBound (min maxBound (Interval months days micros)))++instance Hashable Interval where+  hashWithSalt salt (Interval months days micros) =+    salt `hashWithSalt` months `hashWithSalt` days `hashWithSalt` micros++instance IsScalar Interval where+  schemaName = Tagged Nothing+  typeName = Tagged "interval"+  baseOid = Tagged (Just 1186)+  arrayOid = Tagged (Just 1187)+  typeParams = Tagged []+  binaryEncoder (Interval months days micros) =+    mconcat [Write.bInt64 micros, Write.bInt32 days, Write.bInt32 months]+  binaryDecoder = PtrPeeker.fixed do+    micros <- PtrPeeker.beSignedInt8+    days <- PtrPeeker.beSignedInt4+    months <- PtrPeeker.beSignedInt4+    pure (Right (Interval months days micros))++  -- Renders in "format with designators" of ISO-8601 as per [the Postgres documentation](https://www.postgresql.org/docs/current/datatype-datetime.html#DATATYPE-INTERVAL-INPUT).+  --+  -- >P quantity unit [ quantity unit ...] [ T [ quantity unit ...]]+  textualEncoder (Interval months days micros) =+    let monthsSign = if months < 0 then "-" else ""+        daysSign = if days < 0 then "-" else ""+        microsSign = if micros < 0 then "-" else ""+        absMonths = abs months+        absDays = abs days+        yearsPart =+          if absMonths >= 12+            then monthsSign <> TextBuilder.decimal (absMonths `div` 12) <> "Y"+            else mempty+        monthsPart =+          if absMonths `mod` 12 /= 0+            then monthsSign <> TextBuilder.decimal (absMonths `mod` 12) <> "M"+            else mempty+        daysPart =+          if absDays /= 0+            then daysSign <> TextBuilder.decimal absDays <> "D"+            else mempty++        totalMicros = abs micros+        hours = totalMicros `div` (60 * 60 * 1000000)+        remainingMicros = totalMicros `mod` (60 * 60 * 1000000)+        minutes = remainingMicros `div` (60 * 1000000)+        seconds = remainingMicros `mod` (60 * 1000000)++        hoursPart =+          if hours /= 0+            then microsSign <> TextBuilder.decimal hours <> "H"+            else mempty+        minutesPart =+          if minutes /= 0+            then microsSign <> TextBuilder.decimal minutes <> "M"+            else mempty+        secondsPart =+          if seconds /= 0+            then+              microsSign+                <> if seconds `mod` 1000000 == 0+                  then TextBuilder.decimal (seconds `div` 1000000) <> "S"+                  else+                    TextBuilder.decimal (seconds `div` 1000000)+                      <> "."+                      <> TextBuilder.fixedLengthDecimal 6 (seconds `mod` 1000000)+                      <> "S"+            else mempty++        timePart = hoursPart <> minutesPart <> secondsPart+        tPrefix = if timePart /= mempty then "T" else mempty+        datePart = yearsPart <> monthsPart <> daysPart+     in if datePart == mempty && timePart == mempty+          then "PT0S"+          else "P" <> datePart <> tPrefix <> timePart++  -- Parse ISO-8601 duration format: P[n]Y[n]M[n]DT[n]H[n]M[n]S+  -- Also parse PostgreSQL's native interval format: "N years M mons D days HH:MM:SS.micros"+  textualDecoder = parseISO8601Format <|> parsePostgresFormat+    where+      -- Shared parser for signed numbers+      parseSignedNumber = do+        sign <- Attoparsec.option 1 (((-1) <$ Attoparsec.char '-') <|> (1 <$ Attoparsec.char '+'))+        n <- Attoparsec.decimal :: Attoparsec.Parser Integer+        pure (sign, n)++      -- Parse PostgreSQL's native format like "130331443 years 4 mons 4 days 00:00:00.334796"+      -- or simpler forms like "00:00:00" or "1 day"+      parsePostgresFormat = do+        -- Try to parse date components first+        (years, months, days) <- parsePostgresDatePart (0 :: Integer) (0 :: Integer) (0 :: Integer)+        -- Parse time part HH:MM:SS.micros (optional)+        micros <- Attoparsec.option 0 parsePostgresTime+        let totalMonths = fromIntegral (years * 12 + months)+            totalDays = fromIntegral days+        pure (Interval totalMonths totalDays micros)++      parsePostgresDatePart years months days = do+        -- Peek to see if we have a number or time separator coming+        mc <- Attoparsec.peekChar+        case mc of+          Nothing -> pure (years, months, days)+          Just '-' -> do+            -- Check if this is a negative date component or the start of negative time+            -- Try to parse as a date component, if it fails, treat as time+            result <- optional $ Attoparsec.try parseUnitValue'+            case result of+              Just (y', m', d') -> parsePostgresDatePart (years + y') (months + m') (days + d')+              Nothing -> pure (years, months, days) -- Not a date component, must be time+          Just '+' -> do+            -- Explicit positive sign - parse as date component+            result <- optional $ Attoparsec.try parseUnitValue'+            case result of+              Just (y', m', d') -> parsePostgresDatePart (years + y') (months + m') (days + d')+              Nothing -> pure (years, months, days)+          Just c | isDigit c -> do+            -- Use try so that if this isn't a date component, we backtrack+            result <- optional $ Attoparsec.try $ do+              n <- Attoparsec.decimal :: Attoparsec.Parser Integer+              mc2 <- Attoparsec.peekChar+              case mc2 of+                Just ' ' -> do+                  Attoparsec.skipSpace+                  unit <- Attoparsec.takeWhile1 isAlpha+                  Attoparsec.skipSpace+                  pure (n, unit)+                _ -> fail "Not a date component"+            case result of+              Just (n, unit) ->+                case unit of+                  "year" -> parsePostgresDatePart (years + n) months days+                  "years" -> parsePostgresDatePart (years + n) months days+                  "mon" -> parsePostgresDatePart years (months + n) days+                  "mons" -> parsePostgresDatePart years (months + n) days+                  "day" -> parsePostgresDatePart years months (days + n)+                  "days" -> parsePostgresDatePart years months (days + n)+                  _ -> fail ("Unknown interval unit: " ++ Text.unpack unit)+              Nothing -> pure (years, months, days) -- Not a date component, probably time+          Just _ -> pure (years, months, days) -- Something else, stop+      parseUnitValue' = do+        (sign, n) <- parseSignedNumber+        Attoparsec.skipSpace+        unit <- Attoparsec.takeWhile1 isAlpha+        Attoparsec.skipSpace+        case unit of+          "year" -> pure (sign * n, 0, 0)+          "years" -> pure (sign * n, 0, 0)+          "mon" -> pure (0, sign * n, 0)+          "mons" -> pure (0, sign * n, 0)+          "day" -> pure (0, 0, sign * n)+          "days" -> pure (0, 0, sign * n)+          _ -> fail ("Unknown interval unit: " ++ Text.unpack unit)++      parsePostgresTime = do+        sign <- Attoparsec.option 1 (((-1) <$ Attoparsec.char '-') <|> (1 <$ Attoparsec.char '+'))+        hours <- Attoparsec.decimal+        _ <- Attoparsec.char ':'+        mins <- Attoparsec.decimal+        _ <- Attoparsec.char ':'+        secs <- Attoparsec.decimal+        micros <-+          Attoparsec.option+            0+            ( do+                _ <- Attoparsec.char '.'+                digits <- Attoparsec.takeWhile1 isDigit+                let paddedDigits = take 6 (Text.unpack digits ++ repeat '0')+                    microsVal = foldl' (\acc d -> acc * 10 + fromIntegral (digitToInt d)) 0 paddedDigits+                pure microsVal+            )+        let totalMicros = hours * 3600_000_000 + mins * 60_000_000 + secs * 1_000_000 + micros+        pure (sign * totalMicros)++      parseISO8601Format = do+        _ <- Attoparsec.char 'P'+        -- Parse date part+        (years, monthsPart, daysPart) <- parseDatePart (0 :: Integer) (0 :: Integer) (0 :: Integer)+        -- Parse time part (optional)+        (hours, mins, secs, microsPart) <-+          Attoparsec.option (0, 0, 0, 0) (Attoparsec.char 'T' *> parseTimePart 0 0 0 0)+        let totalMonths = fromIntegral (years * 12 + monthsPart)+            totalDays = fromIntegral daysPart+            totalMicros = fromIntegral $ hours * 3600_000_000 + mins * 60_000_000 + secs * 1_000_000 + microsPart+        pure (Interval totalMonths totalDays totalMicros)++      parseDatePart years months days = do+        mc <- Attoparsec.peekChar+        case mc of+          Just 'T' -> pure (years, months, days)+          Nothing -> pure (years, months, days)+          Just c | isDigit c || c == '-' -> do+            (sign, n) <- parseSignedNumber+            designator <- Attoparsec.satisfy (`elem` ['Y', 'M', 'D'])+            case designator of+              'Y' -> parseDatePart (years + sign * n) months days+              'M' -> parseDatePart years (months + sign * n) days+              'D' -> parseDatePart years months (days + sign * n)+              _ -> fail "Unexpected designator"+          _ -> pure (years, months, days)+      parseTimePart hours mins secs micros = do+        mc <- Attoparsec.peekChar+        case mc of+          Nothing -> pure (hours, mins, secs, micros)+          Just c | isDigit c || c == '-' -> do+            (sign, n) <- parseSignedNumber+            -- Check for fractional seconds+            hasFraction <- Attoparsec.option False (True <$ Attoparsec.char '.')+            if hasFraction+              then do+                fracDigits <- Attoparsec.takeWhile1 isDigit+                _ <- Attoparsec.char 'S'+                let paddedDigits = take 6 (Text.unpack fracDigits ++ repeat '0')+                    microsFrac = foldl' (\acc d -> acc * 10 + fromIntegral (digitToInt d)) 0 paddedDigits :: Integer+                    totalMicrosForSecs = (sign * n) * 1_000_000 + sign * microsFrac+                parseTimePart hours mins secs (micros + totalMicrosForSecs)+              else do+                designator <- Attoparsec.satisfy (`elem` ['H', 'M', 'S'])+                case designator of+                  'H' -> parseTimePart (hours + (sign * n)) mins secs micros+                  'M' -> parseTimePart hours (mins + (sign * n)) secs micros+                  'S' -> parseTimePart hours mins (secs + (sign * n)) micros+                  _ -> fail "Unexpected time designator"+          _ -> pure (hours, mins, secs, micros)++-- * Accessors++-- | Extract the months component.+toMonths :: Interval -> Int32+toMonths (Interval months _ _) = months++-- | Extract the days component.+toDays :: Interval -> Int32+toDays (Interval _ days _) = days++-- | Extract the microseconds component.+toMicroseconds :: Interval -> Int64+toMicroseconds (Interval _ _ micros) = micros++-- | Convert interval to total microseconds, approximating months as 30 days and days as 24 hours.+normalizeToMicrosecondsInTotal :: Interval -> Integer+normalizeToMicrosecondsInTotal (Interval months days micros) =+  fromIntegral micros + microsPerDay * (fromIntegral days + daysPerMonth * fromIntegral months)++-- | Convert interval to 'DiffTime', approximating months as 30 days and days as 24 hours.+normalizeToDiffTime :: Interval -> DiffTime+normalizeToDiffTime = picosecondsToDiffTime . (1_000_000 *) . normalizeToMicrosecondsInTotal++-- * Constructors++-- | Construct 'Interval' from months, days, and microseconds components, clamping to valid range.+normalizeFromMonthsDaysAndMicroseconds :: Int32 -> Int32 -> Int64 -> Interval+normalizeFromMonthsDaysAndMicroseconds months days micros =+  let interval = Interval months days micros+   in max minBound (min maxBound interval)++-- | Try to construct 'Interval' from months, days, and microseconds components, failing if out of range.+refineFromMonthsDaysAndMicroseconds :: Int32 -> Int32 -> Int64 -> Maybe Interval+refineFromMonthsDaysAndMicroseconds months days micros =+  let interval = Interval months days micros+   in if interval >= minBound && interval <= maxBound+        then Just interval+        else Nothing++-- | Construct 'Interval' from total microseconds, approximating months as 30 days and days as 24 hours, clamping to valid range.+normalizeFromMicrosecondsInTotal :: Integer -> Interval+normalizeFromMicrosecondsInTotal microseconds =+  let interval = unsafeFromMicrosecondsInTotal microseconds+   in max minBound (min maxBound interval)++-- | Try to construct 'Interval' from total microseconds, approximating months as 30 days and days as 24 hours, failing if out of range or if the conversion is lossy.+refineFromMicrosecondsInTotal :: Integer -> Maybe Interval+refineFromMicrosecondsInTotal microseconds =+  let interval = unsafeFromMicrosecondsInTotal microseconds+   in if interval >= minBound && interval <= maxBound && normalizeToMicrosecondsInTotal interval == microseconds+        then Just interval+        else Nothing++-- | Construct 'Interval' from 'DiffTime', approximating months as 30 days and days as 24 hours, clamping to valid range and losing sub-microsecond precision.+normalizeFromDiffTime :: DiffTime -> Interval+normalizeFromDiffTime = normalizeFromMicrosecondsInTotal . (`div` 1_000_000) . diffTimeToPicoseconds++-- | Try to construct 'Interval' from 'DiffTime', approximating months as 30 days and days as 24 hours, failing if out of range or if precision is lost.+refineFromDiffTime :: DiffTime -> Maybe Interval+refineFromDiffTime diffTime =+  let picoseconds = diffTimeToPicoseconds diffTime+      (microseconds, remainder) = divMod picoseconds 1_000_000+   in if remainder == 0+        then refineFromMicrosecondsInTotal microseconds+        else Nothing++-- * Internal helpers++unsafeFromMicrosecondsInTotal :: Integer -> Interval+unsafeFromMicrosecondsInTotal =+  evalState $ do+    micros <- fromIntegral <$> state (swap . flip divMod microsPerDay)+    days <- fromIntegral <$> state (swap . flip divMod daysPerMonth)+    months <- fromIntegral <$> get+    pure (Interval months days micros)++microsPerDay :: (Num a) => a+microsPerDay = 1_000_000 * 60 * 60 * 24++daysPerMonth :: (Num a) => a+daysPerMonth = 30
+ src/library/PostgresqlTypes/Json.hs view
@@ -0,0 +1,114 @@+module PostgresqlTypes.Json+  ( Json,++    -- * Accessors+    toAesonValue,++    -- * Constructors+    normalizeFromAesonValue,+    refineFromAesonValue,+  )+where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+import qualified Data.Aeson.Text as Aeson.Text+import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified Jsonifier+import qualified JsonifierAeson+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified TextBuilder++-- | PostgreSQL @json@ type.+--+-- Stores JSON data as text, unlike @jsonb@ which stores+-- it in a binary format. This means @json@ preserves the exact textual+-- representation including whitespace and key ordering.+-- However it is less efficient for both storage and processing.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-json.html).+newtype Json = Json Aeson.Value+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Json)++instance Arbitrary Json where+  arbitrary = normalizeFromAesonValue <$> arbitrary+  shrink = fmap Json . shrink . toAesonValue++instance IsScalar Json where+  schemaName = Tagged Nothing+  typeName = Tagged "json"+  baseOid = Tagged (Just 114)+  arrayOid = Tagged (Just 199)+  typeParams = Tagged []+  binaryEncoder =+    -- JSON type stores as UTF-8 text without version byte prefix+    Jsonifier.toWrite . JsonifierAeson.aesonValue . toAesonValue+  binaryDecoder = do+    jsonBytes <- PtrPeeker.remainderAsByteString+    pure+      ( bimap+          ( \string ->+              DecodingError+                { location = ["json"],+                  reason =+                    ParsingDecodingErrorReason+                      (fromString string)+                      jsonBytes+                }+          )+          Json+          (Aeson.eitherDecodeStrict jsonBytes)+      )+  textualEncoder =+    TextBuilder.lazyText . Aeson.Text.encodeToLazyText . toAesonValue+  textualDecoder = do+    jsonText <- Attoparsec.takeText+    case Aeson.eitherDecodeStrict (Text.Encoding.encodeUtf8 jsonText) of+      Left err -> fail err+      Right value -> pure (Json value)++-- * Accessors++-- | Extract the underlying 'Aeson.Value'.+toAesonValue :: Json -> Aeson.Value+toAesonValue (Json value) = value++-- * Constructors++-- | Construct from Aeson Value while failing if any of its strings or object keys contain null characters.+refineFromAesonValue :: Aeson.Value -> Maybe Json+refineFromAesonValue = fmap Json . validateValue+  where+    validateValue = \case+      Aeson.String string -> Aeson.String <$> validateText string+      Aeson.Object object -> Aeson.Object <$> validateObject object+      Aeson.Array array -> Aeson.Array <$> validateArray array+      other -> pure other+    validateText text =+      if Text.elem '\NUL' text+        then Nothing+        else Just text+    validateObject = Aeson.KeyMap.traverseWithKey (\key value -> validateKey key *> validateValue value)+    validateArray = traverse validateValue+    validateKey = fmap Aeson.Key.fromText . validateText . Aeson.Key.toText++-- | Construct from Aeson Value by filtering out null characters from every string and object key.+normalizeFromAesonValue :: Aeson.Value -> Json+normalizeFromAesonValue = Json . updateValue+  where+    updateValue = \case+      Aeson.String string -> Aeson.String (updateText string)+      Aeson.Object object -> Aeson.Object (updateObject object)+      Aeson.Array array -> Aeson.Array (updateArray array)+      other -> other+    updateText = Text.replace "\NUL" ""+    updateObject = Aeson.KeyMap.mapKeyVal updateKey updateValue+    updateArray = fmap updateValue+    updateKey = Aeson.Key.fromText . updateText . Aeson.Key.toText
+ src/library/PostgresqlTypes/Jsonb.hs view
@@ -0,0 +1,126 @@+module PostgresqlTypes.Jsonb+  ( Jsonb,++    -- * Accessors+    toAesonValue,++    -- * Constructors+    normalizeFromAesonValue,+    refineFromAesonValue,+  )+where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+import qualified Data.Aeson.Text as Aeson.Text+import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified Jsonifier+import qualified JsonifierAeson+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @jsonb@ type. Binary JSON data.+--+-- A more efficient representation than @json@, allowing for faster processing and smaller storage size.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-json.html).+newtype Jsonb = Jsonb Aeson.Value+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Jsonb)++instance Arbitrary Jsonb where+  arbitrary = normalizeFromAesonValue <$> arbitrary+  shrink = fmap Jsonb . shrink . toAesonValue++instance IsScalar Jsonb where+  schemaName = Tagged Nothing+  typeName = Tagged "jsonb"+  baseOid = Tagged (Just 3802)+  arrayOid = Tagged (Just 3807)+  typeParams = Tagged []+  binaryEncoder =+    mappend (Write.word8 1) . Jsonifier.toWrite . JsonifierAeson.aesonValue . toAesonValue+  binaryDecoder = do+    firstByte <- PtrPeeker.fixed PtrPeeker.unsignedInt1+    case firstByte of+      1 -> do+        remainingBytes <- PtrPeeker.remainderAsByteString+        pure+          ( bimap+              ( \string ->+                  DecodingError+                    { location = ["json"],+                      reason =+                        ParsingDecodingErrorReason+                          (fromString string)+                          remainingBytes+                    }+              )+              Jsonb+              (Aeson.eitherDecodeStrict remainingBytes)+          )+      _ ->+        pure+          ( Left+              ( DecodingError+                  { location = ["json-encoding-format"],+                    reason =+                      UnexpectedValueDecodingErrorReason+                        "1"+                        (TextBuilder.toText (TextBuilder.decimal firstByte))+                  }+              )+          )+  textualEncoder =+    TextBuilder.lazyText . Aeson.Text.encodeToLazyText . toAesonValue+  textualDecoder = do+    jsonText <- Attoparsec.takeText+    case Aeson.eitherDecodeStrict (Text.Encoding.encodeUtf8 jsonText) of+      Left err -> fail err+      Right value -> pure (Jsonb value)++-- * Accessors++-- | Extract the underlying 'Aeson.Value'.+toAesonValue :: Jsonb -> Aeson.Value+toAesonValue (Jsonb value) = value++-- * Constructors++-- | Construct from Aeson Value while failing if any of its strings or object keys contain null characters.+refineFromAesonValue :: Aeson.Value -> Maybe Jsonb+refineFromAesonValue = fmap Jsonb . validateValue+  where+    validateValue = \case+      Aeson.String string -> Aeson.String <$> validateText string+      Aeson.Object object -> Aeson.Object <$> validateObject object+      Aeson.Array array -> Aeson.Array <$> validateArray array+      other -> pure other+    validateText text =+      if Text.elem '\NUL' text+        then Nothing+        else Just text+    validateObject = Aeson.KeyMap.traverseWithKey (\key value -> validateKey key *> validateValue value)+    validateArray = traverse validateValue+    validateKey = fmap Aeson.Key.fromText . validateText . Aeson.Key.toText++-- | Construct from Aeson Value by filtering out null characters from every string and object key.+normalizeFromAesonValue :: Aeson.Value -> Jsonb+normalizeFromAesonValue = Jsonb . updateValue+  where+    updateValue = \case+      Aeson.String string -> Aeson.String (updateText string)+      Aeson.Object object -> Aeson.Object (updateObject object)+      Aeson.Array array -> Aeson.Array (updateArray array)+      other -> other+    updateText = Text.replace "\NUL" ""+    updateObject = Aeson.KeyMap.mapKeyVal updateKey updateValue+    updateArray = fmap updateValue+    updateKey = Aeson.Key.fromText . updateText . Aeson.Key.toText
+ src/library/PostgresqlTypes/Line.hs view
@@ -0,0 +1,128 @@+module PostgresqlTypes.Line+  ( Line,++    -- * Accessors+    toA,+    toB,+    toC,++    -- * Constructors+    refineFromEquation,+    normalizeFromEquation,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @line@ type. Infinite line in 2D plane.+--+-- The line is represented by the linear equation @Ax + By + C = 0@.+-- Stored as three @64@-bit floating point numbers (@A@, @B@, @C@).+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-LINE).+data Line+  = Line+      -- | A coefficient+      Double+      -- | B coefficient+      Double+      -- | C coefficient+      Double+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Line)++instance Arbitrary Line where+  arbitrary = do+    -- Ensure at least one of A or B is non-zero+    (a, b) <-+      QuickCheck.suchThat+        ((,) <$> arbitrary <*> arbitrary)+        (\(a, b) -> not (a == 0 && b == 0))+    c <- arbitrary+    pure (Line a b c)+  shrink (Line a b c) =+    [ Line a' b' c'+    | (a', b', c') <- shrink (a, b, c),+      not (a' == 0 && b' == 0) -- Ensure shrunk values are also valid+    ]++instance Hashable Line where+  hashWithSalt salt (Line a b c) =+    salt+      `hashWithSalt` castDoubleToWord64 a+      `hashWithSalt` castDoubleToWord64 b+      `hashWithSalt` castDoubleToWord64 c++instance IsScalar Line where+  schemaName = Tagged Nothing+  typeName = Tagged "line"+  baseOid = Tagged (Just 628)+  arrayOid = Tagged (Just 629)+  typeParams = Tagged []+  binaryEncoder (Line a b c) =+    mconcat+      [ Write.bWord64 (castDoubleToWord64 a),+        Write.bWord64 (castDoubleToWord64 b),+        Write.bWord64 (castDoubleToWord64 c)+      ]+  binaryDecoder = do+    a <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    b <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    c <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    pure (Right (Line a b c))+  textualEncoder (Line a b c) =+    "{"+      <> TextBuilder.string (printf "%g" a)+      <> ","+      <> TextBuilder.string (printf "%g" b)+      <> ","+      <> TextBuilder.string (printf "%g" c)+      <> "}"+  textualDecoder = do+    _ <- Attoparsec.char '{'+    a <- Attoparsec.double+    _ <- Attoparsec.char ','+    b <- Attoparsec.double+    _ <- Attoparsec.char ','+    c <- Attoparsec.double+    _ <- Attoparsec.char '}'+    pure (Line a b c)++-- * Accessors++-- | Extract the A coefficient from Ax + By + C = 0.+toA :: Line -> Double+toA (Line a _ _) = a++-- | Extract the B coefficient from Ax + By + C = 0.+toB :: Line -> Double+toB (Line _ b _) = b++-- | Extract the C coefficient from Ax + By + C = 0.+toC :: Line -> Double+toC (Line _ _ c) = c++-- * Constructors++-- | Construct a PostgreSQL 'Line' from equation coefficients A, B, C with validation.+-- Returns 'Nothing' if both A and B are zero (invalid line).+refineFromEquation :: Double -> Double -> Double -> Maybe Line+refineFromEquation a b c = do+  when (a == 0 && b == 0) empty+  pure (Line a b c)++-- | Construct a PostgreSQL 'Line' from equation coefficients A, B, C.+-- Defaults to vertical line when A and B equal 0.+normalizeFromEquation :: Double -> Double -> Double -> Line+normalizeFromEquation a b c =+  if a == 0 && b == 0+    then Line 1 0 c+    else Line a b c
+ src/library/PostgresqlTypes/Lseg.hs view
@@ -0,0 +1,124 @@+module PostgresqlTypes.Lseg+  ( Lseg (..),++    -- * Accessors+    toX1,+    toY1,+    toX2,+    toY2,++    -- * Constructors+    fromEndpoints,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @lseg@ type. Line segment in 2D plane.+--+-- The line segment is defined by two endpoints, each with (@x@,@y@) coordinates.+-- Stored as four @64@-bit floating point numbers: (@x1@, @y1@, @x2@, @y2@).+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-LSEG).+data Lseg+  = Lseg+      -- | X coordinate of first endpoint+      Double+      -- | Y coordinate of first endpoint+      Double+      -- | X coordinate of second endpoint+      Double+      -- | Y coordinate of second endpoint+      Double+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Lseg)++instance Arbitrary Lseg where+  arbitrary = Lseg <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+  shrink (Lseg x1 y1 x2 y2) =+    [Lseg x1' y1' x2' y2' | (x1', y1', x2', y2') <- shrink (x1, y1, x2, y2)]++instance Hashable Lseg where+  hashWithSalt salt (Lseg x1 y1 x2 y2) =+    salt+      `hashWithSalt` castDoubleToWord64 x1+      `hashWithSalt` castDoubleToWord64 y1+      `hashWithSalt` castDoubleToWord64 x2+      `hashWithSalt` castDoubleToWord64 y2++instance IsScalar Lseg where+  schemaName = Tagged Nothing+  typeName = Tagged "lseg"+  baseOid = Tagged (Just 601)+  arrayOid = Tagged (Just 1018)+  typeParams = Tagged []+  binaryEncoder (Lseg x1 y1 x2 y2) =+    mconcat+      [ Write.bWord64 (castDoubleToWord64 x1),+        Write.bWord64 (castDoubleToWord64 y1),+        Write.bWord64 (castDoubleToWord64 x2),+        Write.bWord64 (castDoubleToWord64 y2)+      ]+  binaryDecoder = do+    x1 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    y1 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    x2 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    y2 <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    pure (Right (Lseg x1 y1 x2 y2))+  textualEncoder (Lseg x1 y1 x2 y2) =+    "[("+      <> TextBuilder.string (printf "%g" x1)+      <> ","+      <> TextBuilder.string (printf "%g" y1)+      <> "),"+      <> "("+      <> TextBuilder.string (printf "%g" x2)+      <> ","+      <> TextBuilder.string (printf "%g" y2)+      <> ")]"+  textualDecoder = do+    _ <- Attoparsec.char '['+    _ <- Attoparsec.char '('+    x1 <- Attoparsec.double+    _ <- Attoparsec.char ','+    y1 <- Attoparsec.double+    _ <- Attoparsec.char ')'+    _ <- Attoparsec.char ','+    _ <- Attoparsec.char '('+    x2 <- Attoparsec.double+    _ <- Attoparsec.char ','+    y2 <- Attoparsec.double+    _ <- Attoparsec.char ')'+    _ <- Attoparsec.char ']'+    pure (Lseg x1 y1 x2 y2)++-- * Accessors++-- | Extract the X coordinate of the first endpoint.+toX1 :: Lseg -> Double+toX1 (Lseg x1 _ _ _) = x1++-- | Extract the Y coordinate of the first endpoint.+toY1 :: Lseg -> Double+toY1 (Lseg _ y1 _ _) = y1++-- | Extract the X coordinate of the second endpoint.+toX2 :: Lseg -> Double+toX2 (Lseg _ _ x2 _) = x2++-- | Extract the Y coordinate of the second endpoint.+toY2 :: Lseg -> Double+toY2 (Lseg _ _ _ y2) = y2++-- * Constructors++-- | Construct a PostgreSQL 'Lseg' from endpoint coordinates.+fromEndpoints :: Double -> Double -> Double -> Double -> Lseg+fromEndpoints x1 y1 x2 y2 = Lseg x1 y1 x2 y2
+ src/library/PostgresqlTypes/Macaddr.hs view
@@ -0,0 +1,158 @@+module PostgresqlTypes.Macaddr+  ( Macaddr (..),++    -- * Accessors+    toByte1,+    toByte2,+    toByte3,+    toByte4,+    toByte5,+    toByte6,++    -- * Constructors+    fromBytes,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @macaddr@ type. MAC (Media Access Control) address.+--+-- Represents a @6@-byte MAC address, typically used in networking.+-- The format is six groups of two hexadecimal digits, separated by colons.+-- Example: @01:23:45:67:89:ab@+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-net-types.html#DATATYPE-MACADDR).+data Macaddr+  = Macaddr+      Word8+      Word8+      Word8+      Word8+      Word8+      Word8+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Macaddr)++instance Arbitrary Macaddr where+  arbitrary = do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    e <- arbitrary+    f <- arbitrary+    pure (Macaddr a b c d e f)+  shrink (Macaddr a b c d e f) =+    [ Macaddr a' b' c' d' e' f'+    | a' <- shrink a,+      b' <- shrink b,+      c' <- shrink c,+      d' <- shrink d,+      e' <- shrink e,+      f' <- shrink f+    ]++instance Hashable Macaddr where+  hashWithSalt salt (Macaddr a b c d e f) =+    salt `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e `hashWithSalt` f++instance IsScalar Macaddr where+  schemaName = Tagged Nothing+  typeName = Tagged "macaddr"+  baseOid = Tagged (Just 829)+  arrayOid = Tagged (Just 1040)+  typeParams = Tagged []+  binaryEncoder (Macaddr a b c d e f) =+    mconcat+      [ Write.word8 a,+        Write.word8 b,+        Write.word8 c,+        Write.word8 d,+        Write.word8 e,+        Write.word8 f+      ]+  binaryDecoder =+    PtrPeeker.fixed+      ( Right+          <$> ( Macaddr+                  <$> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+              )+      )+  textualEncoder (Macaddr a b c d e f) =+    (TextBuilder.intercalate ":")+      [ TextBuilder.hexadecimal a,+        TextBuilder.hexadecimal b,+        TextBuilder.hexadecimal c,+        TextBuilder.hexadecimal d,+        TextBuilder.hexadecimal e,+        TextBuilder.hexadecimal f+      ]+  textualDecoder = do+    a <- hexByte+    _ <- Attoparsec.char ':'+    b <- hexByte+    _ <- Attoparsec.char ':'+    c <- hexByte+    _ <- Attoparsec.char ':'+    d <- hexByte+    _ <- Attoparsec.char ':'+    e <- hexByte+    _ <- Attoparsec.char ':'+    f <- hexByte+    pure (Macaddr a b c d e f)+    where+      hexByte = do+        h1 <- hexDigit+        h2 <- hexDigit+        pure (h1 * 16 + h2)+      hexDigit =+        (\c -> fromIntegral (ord c - ord '0'))+          <$> Attoparsec.satisfy (\c -> c >= '0' && c <= '9')+          <|> (\c -> fromIntegral (ord c - ord 'a' + 10))+            <$> Attoparsec.satisfy (\c -> c >= 'a' && c <= 'f')+          <|> (\c -> fromIntegral (ord c - ord 'A' + 10))+            <$> Attoparsec.satisfy (\c -> c >= 'A' && c <= 'F')++-- * Accessors++-- | Extract the first byte of the MAC address.+toByte1 :: Macaddr -> Word8+toByte1 (Macaddr a _ _ _ _ _) = a++-- | Extract the second byte of the MAC address.+toByte2 :: Macaddr -> Word8+toByte2 (Macaddr _ b _ _ _ _) = b++-- | Extract the third byte of the MAC address.+toByte3 :: Macaddr -> Word8+toByte3 (Macaddr _ _ c _ _ _) = c++-- | Extract the fourth byte of the MAC address.+toByte4 :: Macaddr -> Word8+toByte4 (Macaddr _ _ _ d _ _) = d++-- | Extract the fifth byte of the MAC address.+toByte5 :: Macaddr -> Word8+toByte5 (Macaddr _ _ _ _ e _) = e++-- | Extract the sixth byte of the MAC address.+toByte6 :: Macaddr -> Word8+toByte6 (Macaddr _ _ _ _ _ f) = f++-- * Constructors++-- | Construct a PostgreSQL 'Macaddr' from 6 bytes.+fromBytes :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Macaddr+fromBytes = Macaddr
+ src/library/PostgresqlTypes/Macaddr8.hs view
@@ -0,0 +1,194 @@+module PostgresqlTypes.Macaddr8+  ( Macaddr8 (..),++    -- * Accessors+    toByte1,+    toByte2,+    toByte3,+    toByte4,+    toByte5,+    toByte6,+    toByte7,+    toByte8,++    -- * Constructors+    fromBytes,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @macaddr8@ type. 8-byte MAC (Media Access Control) address in EUI-64 format.+--+-- The format is eight groups of two hexadecimal digits, separated by colons.+-- Example: @01:23:45:67:89:ab:cd:ef@+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-net-types.html#DATATYPE-MACADDR8).+data Macaddr8+  = Macaddr8+      -- | First byte+      Word8+      -- | Second byte+      Word8+      -- | Third byte+      Word8+      -- | Fourth byte+      Word8+      -- | Fifth byte+      Word8+      -- | Sixth byte+      Word8+      -- | Seventh byte+      Word8+      -- | Eighth byte+      Word8+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Macaddr8)++instance Arbitrary Macaddr8 where+  arbitrary = do+    bytes <- replicateM 8 arbitrary+    -- Ensure not all bytes are zero as that might be invalid+    if all (== 0) bytes+      then pure (Macaddr8 0 0 0 0 0 0 0 1) -- Use a valid non-zero MAC+      else case bytes of+        [a, b, c, d, e, f, g, h] -> pure (Macaddr8 a b c d e f g h)+        _ -> error "impossible case"+  shrink (Macaddr8 a b c d e f g h) =+    [ Macaddr8 a' b' c' d' e' f' g' h'+    | (a', b', c', d', e', f', g', h') <- shrink (a, b, c, d, e, f, g, h),+      not (a' == 0 && b' == 0 && c' == 0 && d' == 0 && e' == 0 && f' == 0 && g' == 0 && h' == 0)+    ]++instance Hashable Macaddr8 where+  hashWithSalt salt (Macaddr8 a b c d e f g h) =+    salt+      `hashWithSalt` a+      `hashWithSalt` b+      `hashWithSalt` c+      `hashWithSalt` d+      `hashWithSalt` e+      `hashWithSalt` f+      `hashWithSalt` g+      `hashWithSalt` h++instance IsScalar Macaddr8 where+  schemaName = Tagged Nothing+  typeName = Tagged "macaddr8"+  baseOid = Tagged (Just 774)+  arrayOid = Tagged (Just 775)+  typeParams = Tagged []+  binaryEncoder (Macaddr8 a b c d e f g h) =+    mconcat+      [ Write.word8 a,+        Write.word8 b,+        Write.word8 c,+        Write.word8 d,+        Write.word8 e,+        Write.word8 f,+        Write.word8 g,+        Write.word8 h+      ]+  binaryDecoder =+    PtrPeeker.fixed+      ( Right+          <$> ( Macaddr8+                  <$> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+                  <*> PtrPeeker.unsignedInt1+              )+      )+  textualEncoder (Macaddr8 a b c d e f g h) =+    TextBuilder.intercalate ":" $+      [ formatByte a,+        formatByte b,+        formatByte c,+        formatByte d,+        formatByte e,+        formatByte f,+        formatByte g,+        formatByte h+      ]+    where+      formatByte :: Word8 -> TextBuilder.TextBuilder+      formatByte x = TextBuilder.string (printf "%02x" x)+  textualDecoder = do+    a <- hexByte+    _ <- Attoparsec.char ':'+    b <- hexByte+    _ <- Attoparsec.char ':'+    c <- hexByte+    _ <- Attoparsec.char ':'+    d <- hexByte+    _ <- Attoparsec.char ':'+    e <- hexByte+    _ <- Attoparsec.char ':'+    f <- hexByte+    _ <- Attoparsec.char ':'+    g <- hexByte+    _ <- Attoparsec.char ':'+    h <- hexByte+    pure (Macaddr8 a b c d e f g h)+    where+      hexByte = do+        h1 <- hexDigit+        h2 <- hexDigit+        pure (h1 * 16 + h2)+      hexDigit =+        (\c -> fromIntegral (ord c - ord '0'))+          <$> Attoparsec.satisfy (\c -> c >= '0' && c <= '9')+          <|> (\c -> fromIntegral (ord c - ord 'a' + 10))+            <$> Attoparsec.satisfy (\c -> c >= 'a' && c <= 'f')+          <|> (\c -> fromIntegral (ord c - ord 'A' + 10))+            <$> Attoparsec.satisfy (\c -> c >= 'A' && c <= 'F')++-- * Accessors++-- | Extract the first byte of the MAC address.+toByte1 :: Macaddr8 -> Word8+toByte1 (Macaddr8 a _ _ _ _ _ _ _) = a++-- | Extract the second byte of the MAC address.+toByte2 :: Macaddr8 -> Word8+toByte2 (Macaddr8 _ b _ _ _ _ _ _) = b++-- | Extract the third byte of the MAC address.+toByte3 :: Macaddr8 -> Word8+toByte3 (Macaddr8 _ _ c _ _ _ _ _) = c++-- | Extract the fourth byte of the MAC address.+toByte4 :: Macaddr8 -> Word8+toByte4 (Macaddr8 _ _ _ d _ _ _ _) = d++-- | Extract the fifth byte of the MAC address.+toByte5 :: Macaddr8 -> Word8+toByte5 (Macaddr8 _ _ _ _ e _ _ _) = e++-- | Extract the sixth byte of the MAC address.+toByte6 :: Macaddr8 -> Word8+toByte6 (Macaddr8 _ _ _ _ _ f _ _) = f++-- | Extract the seventh byte of the MAC address.+toByte7 :: Macaddr8 -> Word8+toByte7 (Macaddr8 _ _ _ _ _ _ g _) = g++-- | Extract the eighth byte of the MAC address.+toByte8 :: Macaddr8 -> Word8+toByte8 (Macaddr8 _ _ _ _ _ _ _ h) = h++-- * Constructors++-- | Construct a PostgreSQL 'Macaddr8' from 8 bytes.+fromBytes :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Macaddr8+fromBytes = Macaddr8
+ src/library/PostgresqlTypes/Money.hs view
@@ -0,0 +1,86 @@+module PostgresqlTypes.Money+  ( Money (..),++    -- * Accessors+    toInt64,++    -- * Constructors+    fromInt64,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @money@ type. Currency amount.+--+-- The money type stores currency amounts as a 64-bit signed integer.+-- The scale (number of decimal places) is determined by the database's+-- currency locale settings, typically @2@ decimal places for most currencies.+--+-- Range: @-92233720368547758.08@ to @+92233720368547758.07@.+--+-- Note: The textual representation includes a currency symbol (e.g., @$1.23@) and currently does not support localization.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-money.html).+newtype Money = Money Int64+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Money)++instance IsScalar Money where+  schemaName = Tagged Nothing+  typeName = Tagged "money"+  baseOid = Tagged (Just 790)+  arrayOid = Tagged (Just 791)+  typeParams = Tagged []+  binaryEncoder (Money x) = Write.bInt64 x+  binaryDecoder = PtrPeeker.fixed (Right . Money <$> PtrPeeker.beSignedInt8)+  textualEncoder (Money x) =+    -- Format as currency with 2 decimal places and $ symbol+    -- PostgreSQL's money type typically displays with currency symbol+    let isNegative = x < 0+        absValue = abs x+        dollars = quot absValue 100+        cents = rem absValue 100+        centsText =+          if cents < 10+            then "0" <> TextBuilder.decimal cents+            else TextBuilder.decimal cents+        signPrefix = if isNegative then "-" else ""+     in signPrefix <> "$" <> TextBuilder.decimal dollars <> "." <> centsText+  textualDecoder = do+    isNegative <- (True <$ Attoparsec.char '-') <|> pure False+    _ <- Attoparsec.char '$'+    -- Parse dollars (may include commas as thousands separators)+    dollarsText <- Attoparsec.takeWhile1 (\c -> isDigit c || c == ',')+    let dollarsStr = filter (/= ',') (Text.unpack dollarsText)+    dollars <- case readMaybe dollarsStr of+      Just n -> pure (n :: Int64)+      Nothing -> fail "Invalid dollar amount"+    _ <- Attoparsec.char '.'+    -- Parse exactly 2 cents digits+    centsDigit1 <- Attoparsec.digit+    centsDigit2 <- Attoparsec.digit+    let cents = fromIntegral (digitToInt centsDigit1 * 10 + digitToInt centsDigit2) :: Int64+        value = dollars * 100 + cents+    pure (Money (if isNegative then negate value else value))++-- * Accessors++-- | Extract the underlying 'Int64' value.+-- This represents the raw monetary value in the smallest currency unit+-- (e.g., cents for USD, where 123 represents $1.23).+toInt64 :: Money -> Int64+toInt64 (Money i) = i++-- * Constructors++-- | Construct a PostgreSQL 'Money' from an 'Int64' value.+fromInt64 :: Int64 -> Money+fromInt64 = Money
+ src/library/PostgresqlTypes/Multirange.hs view
@@ -0,0 +1,175 @@+module PostgresqlTypes.Multirange+  ( Multirange,++    -- * Accessors+    toRangeList,+    toRangeVector,++    -- * Constructors+    normalizeFromRangeList,+    refineFromRangeList,+  )+where++import qualified BaseExtras.List+import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Range (Range)+import qualified PostgresqlTypes.Range as Range+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified QuickCheckExtras.Gen+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- |+-- Normalized representation of a multirange, which is a collection of non-overlapping, non-adjacent ranges.+--+-- PostgreSQL multirange types store multiple ranges as a single value, automatically normalizing them+-- by combining overlapping and adjacent ranges. The ranges are stored in sorted order.+--+-- The following standard types are supported via the 'IsMultirangeElement' instances:+--+-- - @int4multirange@ - @Multirange Int4@+-- - @int8multirange@ - @Multirange Int8@+-- - @nummultirange@ - @Multirange Numeric@+-- - @tsmultirange@ - @Multirange Timestamp@+-- - @tstzmultirange@ - @Multirange Timestamptz@+-- - @datemultirange@ - @Multirange Date@+--+-- You can also define your own.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/rangetypes.html#RANGETYPES-MULTIRANGE).+newtype Multirange a = Multirange (Vector (Range a))+  deriving stock (Eq, Functor)+  deriving (Show, Read, IsString) via (ViaIsScalar (Multirange a))++instance (IsMultirangeElement a) => IsScalar (Multirange a) where+  schemaName = Tagged Nothing+  typeName = retag (multirangeTypeName @a)+  baseOid = retag (multirangeBaseOid @a)+  arrayOid = retag (multirangeArrayOid @a)+  typeParams = retag (typeParams @(Range a))+  binaryEncoder = \case+    Multirange ranges ->+      mconcat+        [ Write.bWord32 (fromIntegral (Vector.length ranges)),+          foldMap renderRange ranges+        ]+    where+      renderRange range =+        let write = binaryEncoder range+         in Write.bWord32 (fromIntegral (Write.writeSize write)) <> write++  binaryDecoder = runExceptT do+    numRanges <- lift do+      PtrPeeker.fixed PtrPeeker.beUnsignedInt4+    ranges <- replicateM (fromIntegral numRanges) do+      size <- lift do+        PtrPeeker.fixed PtrPeeker.beSignedInt4+      when (size < 0) do+        throwError (DecodingError ["range-size"] (UnsupportedValueDecodingErrorReason "Expecting >= 0" (TextBuilder.toText (TextBuilder.decimal size))))+      ExceptT do+        PtrPeeker.forceSize (fromIntegral size) do+          binaryDecoder @(Range a)+    pure (Multirange (Vector.fromList ranges))++  textualEncoder = \case+    Multirange ranges ->+      mconcat+        [ "{",+          TextBuilder.intercalate "," (Vector.toList (Vector.map (textualEncoder @(Range a)) ranges)),+          "}"+        ]+  textualDecoder = do+    _ <- Attoparsec.char '{'+    Attoparsec.skipSpace+    ranges <- (textualDecoder @(Range a)) `Attoparsec.sepBy` (Attoparsec.skipSpace >> Attoparsec.char ',' >> Attoparsec.skipSpace)+    Attoparsec.skipSpace+    _ <- Attoparsec.char '}'+    Attoparsec.skipSpace+    pure (Multirange (Vector.fromList ranges))++instance (IsRangeElement a, Arbitrary a, Ord a) => Arbitrary (Multirange a) where+  arbitrary = do+    size <- QuickCheck.getSize+    QuickCheck.frequency+      [ ( 1,+          pure (Multirange Vector.empty)+        ),+        ( max 1 size,+          do+            lowerInfinity <- arbitrary+            upperInfinity <- arbitrary+            numRanges <- QuickCheck.chooseInt (0, max 0 size)+            let numBounds =+                  numRanges * 2 + bool 1 0 lowerInfinity + bool 1 0 upperInfinity+            bounds <- QuickCheckExtras.Gen.setOfSize numBounds (arbitrary @a)+            let preparedBounds =+                  mconcat+                    [ if lowerInfinity then [Nothing] else [],+                      fmap Just (Set.toList bounds),+                      if upperInfinity then [Nothing] else []+                    ]+                pairs =+                  BaseExtras.List.toPairs preparedBounds+                ranges =+                  fmap (uncurry Range.normalizeBounded) pairs :: [Range a]++            pure+              (Multirange (Vector.fromList ranges))+        )+      ]++instance (Hashable a) => Hashable (Multirange a) where+  hashWithSalt salt (Multirange ranges) = hashWithSalt salt (Vector.toList ranges)++-- | Create a list of ranges from a multirange.+toRangeList :: Multirange a -> [Range a]+toRangeList (Multirange ranges) = Vector.toList ranges++-- | Create a vector of ranges from a multirange.+toRangeVector :: Multirange a -> Vector (Range a)+toRangeVector (Multirange ranges) = ranges++-- | Create a multirange from a list of ranges.+-- Performs the same normalization as PostgreSQL:+-- 1. Removes empty ranges+-- 2. Sorts ranges by their lower bounds+-- 3. Merges overlapping and adjacent ranges+normalizeFromRangeList :: (Ord a) => [Range a] -> Multirange a+normalizeFromRangeList = Multirange . Vector.fromList . mergeRanges . sortRanges . filterNonEmpty+  where+    -- Step 1: Remove empty ranges+    filterNonEmpty = filter (not . Range.isEmpty)++    -- Step 2: Sort ranges by their lower bound+    sortRanges = sort++    -- Step 3: Merge overlapping and adjacent ranges+    mergeRanges [] = []+    mergeRanges [r] = [r]+    mergeRanges (r1 : r2 : rs) =+      case Range.mergeIfOverlappingOrAdjacent r1 r2 of+        Just merged -> mergeRanges (merged : rs)+        Nothing -> r1 : mergeRanges (r2 : rs)++-- | Attempt to create a multirange from a list of ranges.+-- Returns 'Nothing' if the input list is not already normalized.+refineFromRangeList :: (Ord a) => [Range a] -> Maybe (Multirange a)+refineFromRangeList ranges =+  -- Check if the input is already normalized by comparing against the normalized version.+  -- A more efficient implementation would check properties directly:+  -- 1. No empty ranges+  -- 2. Ranges are sorted+  -- 3. No adjacent or overlapping ranges+  -- However, the current approach is simpler and correct.+  let Multirange normalized = normalizeFromRangeList ranges+      unnormalized = Vector.fromList ranges+   in if unnormalized == normalized+        then Just (Multirange normalized)+        else Nothing
+ src/library/PostgresqlTypes/Numeric.hs view
@@ -0,0 +1,362 @@+-- Reference implementation for numeric type in PostgreSQL:+--+-- - Sign flags: https://github.com/postgres/postgres/blob/6bca4b50d000e840cad17a9dd6cb46785fb2cedb/src/backend/utils/adt/numeric.c#L201-L203+module PostgresqlTypes.Numeric+  ( Numeric,++    -- * Accessors+    isNaN,+    isPosInfinity,+    isNegInfinity,+    normalizeToScientific,+    refineToScientific,++    -- * Constructors+    nan,+    posInfinity,+    negInfinity,+    normalizeFromScientific,+    refineFromScientific,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified GHC.TypeLits as TypeLits+import PostgresqlTypes.Algebra+import qualified PostgresqlTypes.Numeric.Integer as Integer+import qualified PostgresqlTypes.Numeric.Scientific as Scientific+import PostgresqlTypes.Prelude hiding (isNaN)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @numeric@ or @decimal@ type. Arbitrary or specific precision decimal number.+--+-- Use @Numeric 0 0@ to represent @numeric@ without precision/scale constraints (arbitrary precision).+--+-- Up to @131072@ digits before decimal point, up to @16383@ digits after decimal point.+--+-- On the Haskell end the 'Scientific.Scientific' type fits almost well with a few corner cases of it not supporting @NaN@, @Infinity@ and @-Infinity@ values, which Postgres does support.+-- Please notice that @Infinity@ and @-Infinity@ values are not supported by Postgres versions lower than 14.+--+-- The type parameters @precision@ and @scale@ specify the static precision and scale of the numeric value.+-- Only numeric values conforming to these constraints can be represented by this type.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-numeric.html#DATATYPE-NUMERIC-DECIMAL).+data Numeric (precision :: TypeLits.Nat) (scale :: TypeLits.Nat)+  = NegInfinityNumeric+  | ScientificNumeric Scientific.Scientific+  | PosInfinityNumeric+  | NanNumeric+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar (Numeric precision scale))++instance (TypeLits.KnownNat precision, TypeLits.KnownNat scale) => Arbitrary (Numeric precision scale) where+  arbitrary =+    let prec = fromIntegral (TypeLits.natVal (Proxy @precision)) :: Int+        sc = fromIntegral (TypeLits.natVal (Proxy @scale)) :: Int+        intDigits = max 0 (prec - sc)+     in if prec == 0 && sc == 0+          then+            -- Arbitrary precision numeric: generate any Scientific value or special values+            QuickCheck.frequency+              [ (1, pure NanNumeric),+                (1, pure NegInfinityNumeric),+                (1, pure PosInfinityNumeric),+                (47, ScientificNumeric . Scientific.normalize <$> arbitrary)+              ]+          else+            if sc > prec+              then+                -- Invalid configuration: scale cannot be greater than precision+                pure NanNumeric+              else+                -- From PostgreSQL docs:+                -- Note that an infinity can only be stored in an unconstrained numeric column, because it notionally exceeds any finite precision limit.+                QuickCheck.frequency+                  [ (1, pure NanNumeric),+                    ( 49,+                      do+                        -- Generate value respecting precision and scale constraints+                        -- Precision p, scale s means: at most p total digits, s after decimal point+                        -- At this point sc <= prec (sc > prec is handled above), so intDigits is non-negative.++                        -- Generate a value with appropriate number of digits+                        negative <- arbitrary @Bool+                        -- Generate integer part (up to intDigits digits)+                        intPart <-+                          if intDigits > 0+                            then QuickCheck.choose (0, 10 ^ intDigits - 1)+                            else pure 0+                        -- Generate fractional part (up to sc digits)+                        fracPart <-+                          if sc > 0+                            then QuickCheck.choose (0, 10 ^ sc - 1)+                            else pure 0+                        let unsignedCoefficient = intPart * (10 ^ sc) + fracPart+                            coefficient = if negative then negate unsignedCoefficient else unsignedCoefficient+                            scientific = Scientific.scientific coefficient (negate (fromIntegral sc))+                        pure (ScientificNumeric scientific)+                    )+                  ]++instance Hashable (Numeric precision scale) where+  hashWithSalt salt = \case+    NegInfinityNumeric -> salt `hashWithSalt` (0 :: Int)+    ScientificNumeric s -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` s+    PosInfinityNumeric -> salt `hashWithSalt` (2 :: Int)+    NanNumeric -> salt `hashWithSalt` (3 :: Int)++instance (TypeLits.KnownNat precision, TypeLits.KnownNat scale) => IsScalar (Numeric precision scale) where+  schemaName = Tagged Nothing+  typeName = Tagged "numeric"+  baseOid = Tagged (Just 1700)+  arrayOid = Tagged (Just 1231)+  typeParams =+    Tagged+      ( let prec = TypeLits.natVal (Proxy @precision)+            sc = TypeLits.natVal (Proxy @scale)+         in case (prec, sc) of+              (0, 0) -> [] -- No type modifiers for arbitrary precision numeric+              (p, 0) -> [Text.pack (show p)] -- numeric(precision)+              (p, s) -> [Text.pack (show p), Text.pack (show s)] -- numeric(precision, scale)+      )++  binaryEncoder = \case+    ScientificNumeric x ->+      mconcat+        [ Write.bWord16 (fromIntegral componentsAmount),+          Write.bWord16 (fromIntegral pointIndex),+          flag,+          Write.bWord16 (fromIntegral trimmedExponent),+          foldMap Write.bWord16 components+        ]+      where+        componentsAmount =+          length components+        coefficient =+          Scientific.coefficient x+        exponent =+          Scientific.base10Exponent x+        components =+          Integer.extractComponents tunedCoefficient+        pointIndex =+          componentsAmount + (tunedExponent `div` 4) - 1+        (tunedCoefficient, tunedExponent) =+          case mod exponent 4 of+            0 -> (coefficient, exponent)+            x -> (coefficient * 10 ^ x, exponent - x)+        trimmedExponent =+          if tunedExponent >= 0+            then 0+            else negate tunedExponent+        flag =+          if coefficient < 0+            then Write.bWord16 0x4000+            else Write.bWord16 0x0000+    NanNumeric ->+      mconcat+        [ Write.bWord16 0x0000, -- componentsAmount+          Write.bWord16 0x0000, -- pointIndex+          Write.bWord16 0xC000, -- flag for NaN+          Write.bWord16 0x0000 -- trimmedExponent+        ]+    PosInfinityNumeric ->+      mconcat+        [ Write.bWord16 0x0000, -- componentsAmount+          Write.bWord16 0x0000, -- pointIndex+          Write.bWord16 0xD000, -- flag for +Infinity+          Write.bWord16 0x0000 -- trimmedExponent+        ]+    NegInfinityNumeric ->+      mconcat+        [ Write.bWord16 0x0000, -- componentsAmount+          Write.bWord16 0x0000, -- pointIndex+          Write.bWord16 0xF000, -- flag for -Infinity+          Write.bWord16 0x0000 -- trimmedExponent+        ]++  binaryDecoder =+    let prec = fromIntegral (TypeLits.natVal (Proxy @precision))+        sc = fromIntegral (TypeLits.natVal (Proxy @scale))+     in do+          (componentsAmount, pointIndex, flag, _trimmedExponent) <- PtrPeeker.fixed do+            componentsAmount <- fromIntegral <$> PtrPeeker.beSignedInt2+            pointIndex <- PtrPeeker.beSignedInt2+            flag <- PtrPeeker.beUnsignedInt2+            trimmedExponent <- PtrPeeker.beSignedInt2+            pure (componentsAmount, pointIndex, flag, trimmedExponent)++          coefficient <- PtrPeeker.fixed do+            foldl' (\l r -> l * 10000 + fromIntegral r) 0+              <$> replicateM componentsAmount PtrPeeker.beSignedInt2++          pure+            let byCoefficient coefficient =+                  let exponent = (fromIntegral pointIndex + 1 - componentsAmount) * 4+                      scientific = Scientific.scientific coefficient exponent+                   in if prec == 0 && sc == 0+                        then Right (ScientificNumeric scientific)+                        else+                          if Scientific.validateNumericPrecisionScale prec sc scientific+                            then Right (ScientificNumeric scientific)+                            else+                              Left+                                DecodingError+                                  { location = ["precision-scale-validation"],+                                    reason =+                                      UnexpectedValueDecodingErrorReason+                                        (TextBuilder.toText ("value within precision=" <> TextBuilder.decimal prec <> ", scale=" <> TextBuilder.decimal sc))+                                        (Text.pack (Scientific.formatScientific Scientific.Fixed Nothing scientific))+                                  }+             in case flag of+                  0x0000 -> byCoefficient coefficient+                  0x4000 -> byCoefficient (negate coefficient)+                  0xC000 -> Right NanNumeric+                  0xD000 -> Right PosInfinityNumeric+                  0xF000 -> Right NegInfinityNumeric+                  _ ->+                    Left+                      DecodingError+                        { location = ["flag"],+                          reason =+                            UnexpectedValueDecodingErrorReason+                              "0x0000, 0x4000, 0xC000, 0xD000, or 0xF000"+                              (Text.toUpper (TextBuilder.toText (TextBuilder.prefixedHexadecimal flag)))+                        }++  textualEncoder =+    let prec = fromIntegral (TypeLits.natVal (Proxy @precision)) :: Int+        sc = fromIntegral (TypeLits.natVal (Proxy @scale)) :: Int+     in \case+          ScientificNumeric scientific ->+            if sc == 0 && prec /= 0+              then TextBuilder.string (Scientific.formatScientific Scientific.Fixed (Just 0) scientific)+              else TextBuilder.string (Scientific.formatScientific Scientific.Fixed Nothing scientific)+          NanNumeric ->+            "NaN"+          NegInfinityNumeric ->+            "-Infinity"+          PosInfinityNumeric ->+            "Infinity"++  textualDecoder =+    let prec = fromIntegral (TypeLits.natVal (Proxy @precision)) :: Int+        sc = fromIntegral (TypeLits.natVal (Proxy @scale)) :: Int+     in asum+          [ if prec == 0 && sc == 0+              then ScientificNumeric <$> Attoparsec.scientific+              else do+                scientific <- Attoparsec.scientific+                if Scientific.validateNumericPrecisionScale prec sc scientific+                  then pure (ScientificNumeric scientific)+                  else fail ("Value does not satisfy the \"precision=" <> show prec <> ", scale=" <> show sc <> "\" constraints: " <> show scientific),+            NanNumeric <$ Attoparsec.string "NaN",+            NegInfinityNumeric <$ Attoparsec.string "-Infinity",+            NegInfinityNumeric <$ Attoparsec.string "-inf",+            PosInfinityNumeric <$ Attoparsec.string "Infinity",+            PosInfinityNumeric <$ Attoparsec.string "inf"+          ]++-- | Mapping to @numrange@ type.+instance (TypeLits.KnownNat precision, TypeLits.KnownNat scale) => IsRangeElement (Numeric precision scale) where+  rangeTypeName = Tagged "numrange"+  rangeBaseOid = Tagged (Just 3906)+  rangeArrayOid = Tagged (Just 3907)++-- | Mapping to @nummultirange@ type.+instance (TypeLits.KnownNat precision, TypeLits.KnownNat scale) => IsMultirangeElement (Numeric precision scale) where+  multirangeTypeName = Tagged "nummultirange"+  multirangeBaseOid = Tagged (Just 4532)+  multirangeArrayOid = Tagged (Just 6151)++-- | Checks if the 'Numeric' value is 'Infinity'.+isPosInfinity :: Numeric precision scale -> Bool+isPosInfinity = \case+  PosInfinityNumeric -> True+  _ -> False++-- | Checks if the 'Numeric' value is '-Infinity'.+isNegInfinity :: Numeric precision scale -> Bool+isNegInfinity = \case+  NegInfinityNumeric -> True+  _ -> False++-- | Checks if the 'Numeric' value is 'NaN'.+isNaN :: Numeric precision scale -> Bool+isNaN = \case+  NanNumeric -> True+  _ -> False++-- | Represents '+Infinity' value for 'Numeric' type.+posInfinity :: Numeric precision scale+posInfinity = PosInfinityNumeric++-- | Represents '-Infinity' value for 'Numeric' type.+negInfinity :: Numeric precision scale+negInfinity = NegInfinityNumeric++-- | Represents 'NaN' value for 'Numeric' type.+nan :: Numeric precision scale+nan = NanNumeric++-- | Normalizes a 'Numeric' value to 'Scientific.Scientific'.+--+-- Special values like 'NaN', 'Infinity', and '-Infinity' are normalized to 0.+normalizeToScientific :: Numeric precision scale -> Scientific.Scientific+normalizeToScientific = \case+  ScientificNumeric s -> s+  NanNumeric -> 0+  PosInfinityNumeric -> 0+  NegInfinityNumeric -> 0++-- | Normalizes a 'Scientific.Scientific' value to 'Numeric' with given precision and scale.+--+-- Clamps to the specified precision and scale.+--+-- If both precision and scale are 0, clamps to the PostgreSQL numeric limits.+normalizeFromScientific ::+  forall precision scale.+  (TypeLits.KnownNat precision, TypeLits.KnownNat scale) =>+  Scientific.Scientific ->+  Numeric precision scale+normalizeFromScientific s =+  let prec = fromIntegral (TypeLits.natVal (Proxy @precision)) :: Int+      sc = fromIntegral (TypeLits.natVal (Proxy @scale)) :: Int+   in if prec == 0 && sc == 0+        then ScientificNumeric (Scientific.clampToPostgresNumericLimits s)+        else+          if sc > prec+            then NanNumeric -- Invalid configuration: scale cannot exceed precision+            else ScientificNumeric (Scientific.clampToPrecisionAndScale prec sc s)++-- | Converts a 'Numeric' value to 'Scientific.Scientific' if possible.+-- Returns 'Nothing' for special values like 'NanNumeric', 'PosInfinityNumeric', and 'NegInfinityNumeric'.+refineToScientific :: Numeric precision scale -> Maybe Scientific.Scientific+refineToScientific = \case+  ScientificNumeric s -> Just s+  _ -> Nothing++-- | Converts a 'Scientific.Scientific' value to 'Numeric' with validation.+-- Returns 'Nothing' if the value does not fit within the specified precision and scale constraints.+refineFromScientific :: forall precision scale. (TypeLits.KnownNat precision, TypeLits.KnownNat scale) => Scientific.Scientific -> Maybe (Numeric precision scale)+refineFromScientific s =+  let prec = fromIntegral (TypeLits.natVal (Proxy @precision)) :: Int+      sc = fromIntegral (TypeLits.natVal (Proxy @scale)) :: Int+   in if prec == 0 && sc == 0+        then+          -- Validate against PostgreSQL limits for arbitrary precision numeric+          if Scientific.validatePostgresNumericLimits s+            then Just (ScientificNumeric s)+            else Nothing+        else+          if sc > prec+            then Nothing -- Invalid configuration: scale cannot exceed precision+            else+              if Scientific.validateNumericPrecisionScale prec sc s+                then Just (ScientificNumeric s)+                else Nothing
+ src/library/PostgresqlTypes/Numeric/Integer.hs view
@@ -0,0 +1,20 @@+-- | Utilities for Integer.+module PostgresqlTypes.Numeric.Integer where++import PostgresqlTypes.Prelude++-- | Count the number of digits in an integer (more efficiently)+countDigits :: Integer -> Int+countDigits 0 = 1+countDigits n = go (abs n) 0+  where+    go 0 acc = acc+    go x acc = go (x `div` 10) (acc + 1)++{-# INLINE extractComponents #-}+extractComponents :: Integer -> [Word16]+extractComponents =+  (reverse .) . (. abs) . unfoldr $ \case+    0 -> Nothing+    x -> case divMod x 10000 of+      (d, m) -> Just (fromIntegral m, d)
+ src/library/PostgresqlTypes/Numeric/Scientific.hs view
@@ -0,0 +1,181 @@+-- | Utilities for Scientific.+module PostgresqlTypes.Numeric.Scientific where++import qualified Data.Scientific as Scientific+import qualified PostgresqlTypes.Numeric.Integer as Integer+import PostgresqlTypes.Prelude++-- | Validates that a Scientific value fits within the given precision and scale constraints.+-- Returns True if the value is valid, False otherwise.+--+-- For NUMERIC(precision, scale):+-- - precision: total number of significant digits+-- - scale: number of digits after decimal point+-- - Maximum integer digits: precision - scale+validateNumericPrecisionScale :: Int -> Int -> Scientific.Scientific -> Bool+validateNumericPrecisionScale prec sc s =+  let coeff = Scientific.coefficient s+      exp = Scientific.base10Exponent s++      -- Normalize the scientific to remove trailing zeros from the coefficient+      -- This ensures we get a canonical representation for scale checking+      normalized = Scientific.normalize s+      normExp = Scientific.base10Exponent normalized++      -- First check: the actual scale (digits after decimal) must not exceed declared scale+      -- A negative exponent indicates digits after decimal point+      -- We use the normalized representation to get the true scale+      actualScale = if normExp < 0 then abs normExp else 0+      scaleValid = actualScale <= sc++      -- We need to count significant digits+      -- Significant digits are all non-zero digits plus any zeros between them or after the first non-zero digit+      -- For a value like 123.45, that's 5 significant digits+      -- For a value like 0.0012, that's 2 significant digits (leading zeros don't count)+      -- For a value like 120, that's 3 significant digits (trailing zeros do count)++      -- Normalize to scale for precision check+      targetExp = negate sc+      scaledForPrecision =+        if exp >= targetExp+          then Scientific.scientific coeff exp+          else+            -- Need to round/truncate to the target scale+            let shift = targetExp - exp+                divisor = 10 ^ shift+             in Scientific.scientific (coeff `div` divisor) targetExp++      scaledCoeff = Scientific.coefficient scaledForPrecision++      -- Count significant digits: for a value normalized to scale digits after decimal point,+      -- significant digits are all digits in the coefficient (excluding leading zeros if coefficient < 10^scale)+      -- But we need to handle the case where abs(coeff) < 10^scale (leading zeros)+      absCoeff = abs scaledCoeff++      -- If coefficient is 0, we have 1 significant digit+      sigDigits =+        if absCoeff == 0+          then 1+          else+            let totalDigitsInCoeff = Integer.countDigits absCoeff+             in -- If the coefficient has fewer digits than scale, there are leading zeros+                -- e.g., for 0.0012 with scale=4, coeff=12, scale=4, but totalDigits=2+                -- The significant digits are just the digits in coeff+                -- For 123.45 with scale=2, coeff=12345, totalDigits=5, sigDigits=5+                totalDigitsInCoeff+   in scaleValid && sigDigits <= prec++-- | Validates that a Scientific value fits within PostgreSQL's numeric type limits:+-- - Up to 131072 digits before decimal point+-- - Up to 16383 digits after decimal point+validatePostgresNumericLimits :: Scientific.Scientific -> Bool+validatePostgresNumericLimits s =+  let coeff = Scientific.coefficient s+      exp = Scientific.base10Exponent s+      absCoeff = abs coeff++      -- If coefficient is 0, it's always valid+      -- Otherwise, calculate digits before and after decimal point+      (digitsBefore, digitsAfter) =+        if absCoeff == 0+          then (0, 0)+          else+            let totalDigits = Integer.countDigits absCoeff+             in -- Exponent tells us where the decimal point is+                -- Positive exponent means more digits before decimal+                -- Negative exponent means digits after decimal+                if exp >= 0+                  then (totalDigits + exp, 0)+                  else+                    let absExp = abs exp+                     in if absExp >= totalDigits+                          then (0, absExp) -- All digits are after decimal (e.g., 0.00123)+                          else (totalDigits - absExp, absExp) -- Some before, some after+   in digitsBefore <= 131072 && digitsAfter <= 16383++-- | Clamp a Scientific value to fit within precision and scale constraints.+-- Rounds the value to the specified scale and clamps the magnitude to fit precision.+clampToPrecisionAndScale :: Int -> Int -> Scientific.Scientific -> Scientific.Scientific+clampToPrecisionAndScale prec sc s =+  let -- First, round to the correct scale+      rounded = roundToScale sc s+      coeff = Scientific.coefficient rounded+      -- Calculate maximum absolute coefficient for given precision+      -- When scaled by 10^sc, max is 10^prec - 1+      maxCoeff = 10 ^ prec - 1+   in if abs coeff > maxCoeff+        then Scientific.scientific (if coeff < 0 then negate maxCoeff else maxCoeff) (negate sc)+        else rounded++-- | Clamp a Scientific value to fit within PostgreSQL numeric limits:+-- - Up to 131072 digits before decimal point+-- - Up to 16383 digits after decimal point+clampToPostgresNumericLimits :: Scientific.Scientific -> Scientific.Scientific+clampToPostgresNumericLimits s =+  let exp = Scientific.base10Exponent s++      -- First clamp the scale (digits after decimal) to 16383+      maxScale = 16383+      clampedToScale =+        if exp < negate maxScale+          then roundToScale maxScale s+          else s++      -- Now clamp the integer part to 131072 digits+      coeff' = Scientific.coefficient clampedToScale+      exp' = Scientific.base10Exponent clampedToScale+      absCoeff' = abs coeff'++      maxDigitsBefore = 131072+   in if absCoeff' == 0+        then clampedToScale+        else+          let totalDigits = Integer.countDigits absCoeff'+              -- Calculate how many digits are before decimal point+              digitsBefore =+                if exp' >= 0+                  then totalDigits + exp'+                  else max 0 (totalDigits + exp')+           in if digitsBefore > maxDigitsBefore+                then+                  -- Need to clamp: reduce coefficient to fit maxDigitsBefore+                  -- Calculate the maximum coefficient that fits+                  let digitsAfter = if exp' < 0 then min maxScale (abs exp') else 0+                      maxTotalDigits = maxDigitsBefore + digitsAfter+                      excessDigits = totalDigits - maxTotalDigits+                      clampedCoeff = absCoeff' `div` (10 ^ excessDigits)+                      signedClampedCoeff = if coeff' < 0 then negate clampedCoeff else clampedCoeff+                   in Scientific.scientific signedClampedCoeff exp'+                else clampedToScale++-- | Round a Scientific value to a specific scale (number of decimal places)+-- Uses round ties away from zero (PostgreSQL numeric rounding behavior)+roundToScale :: Int -> Scientific.Scientific -> Scientific.Scientific+roundToScale sc s =+  let currentExp = Scientific.base10Exponent s+      targetExp = negate sc+      coeff = Scientific.coefficient s+   in if currentExp == targetExp+        then s -- Already at exact target scale+        else+          if currentExp > targetExp+            then+              -- Need to add decimal places: scale up coefficient+              let scaleDiff = currentExp - targetExp+                  scaledCoeff = coeff * (10 ^ scaleDiff)+               in Scientific.scientific scaledCoeff targetExp+            else+              -- Need to round: convert to the target scale+              let scaleDiff = targetExp - currentExp+                  divisor = 10 ^ scaleDiff+                  (quotient, remainder) = abs coeff `divMod` divisor+                  absRemainder = abs remainder+                  -- Round ties away from zero (PostgreSQL behavior)+                  -- If remainder * 2 >= divisor, round away from zero+                  roundedQuotient =+                    if absRemainder * 2 >= divisor+                      then quotient + 1+                      else quotient+                  -- Apply sign+                  finalQuotient = if coeff < 0 then negate roundedQuotient else roundedQuotient+               in Scientific.scientific finalQuotient targetExp
+ src/library/PostgresqlTypes/Oid.hs view
@@ -0,0 +1,50 @@+module PostgresqlTypes.Oid+  ( Oid (..),++    -- * Accessors+    toWord32,++    -- * Constructors+    fromWord32,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @oid@ type. Object identifier.+--+-- Range: @0@ to @4294967295@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-oid.html).+newtype Oid = Oid Word32+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Oid)++instance IsScalar Oid where+  schemaName = Tagged Nothing+  typeName = Tagged "oid"+  baseOid = Tagged (Just 26)+  arrayOid = Tagged (Just 1028)+  typeParams = Tagged []+  binaryEncoder (Oid x) = Write.bWord32 x+  binaryDecoder = PtrPeeker.fixed (Right . Oid <$> PtrPeeker.beUnsignedInt4)+  textualEncoder (Oid x) = TextBuilder.decimal x+  textualDecoder = Oid <$> Attoparsec.decimal++-- * Accessors++-- | Extract the underlying 'Word32' value.+toWord32 :: Oid -> Word32+toWord32 (Oid w) = w++-- * Constructors++-- | Construct a PostgreSQL 'Oid' from a 'Word32' value.+fromWord32 :: Word32 -> Oid+fromWord32 = Oid
+ src/library/PostgresqlTypes/Path.hs view
@@ -0,0 +1,146 @@+module PostgresqlTypes.Path+  ( Path,++    -- * Accessors+    toClosed,+    toPointList,+    toPointVector,++    -- * Constructors+    refineFromPointList,+    refineFromPointVector,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Vector.Unboxed as UnboxedVector+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @path@ type. Geometric path in 2D plane (open or closed).+--+-- Represented as a series of connected points, which can be either open or closed.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-PATH).+data Path+  = Path+      -- | Whether the path is closed+      Bool+      -- | Points in the path+      (UnboxedVector.Vector (Double, Double))+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Path)++instance Arbitrary Path where+  arbitrary = do+    closed <- arbitrary+    size <- QuickCheck.getSize+    -- Paths need at least 1 point+    numPoints <- QuickCheck.chooseInt (1, max 1 size)+    points <- UnboxedVector.replicateM numPoints arbitrary+    pure (Path closed points)+  shrink (Path closed points) =+    [ Path closed' points'+    | (closed', points') <- shrink (closed, points),+      UnboxedVector.length points' >= 1+    ]++instance Hashable Path where+  hashWithSalt salt (Path closed points) =+    salt `hashWithSalt` closed `hashWithSalt` UnboxedVector.toList points++instance IsScalar Path where+  schemaName = Tagged Nothing+  typeName = Tagged "path"+  baseOid = Tagged (Just 602)+  arrayOid = Tagged (Just 1019)+  typeParams = Tagged []+  binaryEncoder (Path closed points) =+    let closedByte = if closed then 1 else 0 :: Word8+        numPoints = fromIntegral (UnboxedVector.length points) :: Int32+        pointsEncoded = UnboxedVector.foldMap encodePoint points+     in mconcat+          [ Write.word8 closedByte,+            Write.bInt32 numPoints,+            pointsEncoded+          ]+    where+      encodePoint (x, y) =+        mconcat+          [ Write.bWord64 (castDoubleToWord64 x),+            Write.bWord64 (castDoubleToWord64 y)+          ]+  binaryDecoder = do+    (closedByte, numPoints) <- PtrPeeker.fixed do+      (,) <$> PtrPeeker.unsignedInt1 <*> PtrPeeker.beSignedInt4+    points <- UnboxedVector.replicateM (fromIntegral numPoints) decodePoint+    let closed = closedByte /= 0+    pure (Right (Path closed points))+    where+      decodePoint = PtrPeeker.fixed do+        x <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+        y <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+        pure (x, y)+  textualEncoder (Path closed points) =+    let openChar = if closed then "(" else "["+        closeChar = if closed then ")" else "]"+        pointsStr = TextBuilder.intercalateMap "," encodePoint (UnboxedVector.toList points)+     in openChar <> pointsStr <> closeChar+    where+      encodePoint (x, y) =+        "(" <> TextBuilder.string (printf "%g" x) <> "," <> TextBuilder.string (printf "%g" y) <> ")"+  textualDecoder = do+    closed <-+      True+        <$ Attoparsec.char '('+        <|> False+          <$ Attoparsec.char '['+    points <- parsePoint `Attoparsec.sepBy1` Attoparsec.char ','+    _ <- Attoparsec.char (if closed then ')' else ']')+    pure (Path closed (UnboxedVector.fromList points))+    where+      parsePoint = do+        _ <- Attoparsec.char '('+        x <- Attoparsec.double+        _ <- Attoparsec.char ','+        y <- Attoparsec.double+        _ <- Attoparsec.char ')'+        pure (x, y)++-- * Accessors++-- | Extract whether the path is closed.+toClosed :: Path -> Bool+toClosed (Path closed _) = closed++-- | Extract the path points as a list.+toPointList :: Path -> [(Double, Double)]+toPointList (Path _ points) = UnboxedVector.toList points++-- | Extract the path points as an unboxed vector.+toPointVector :: Path -> UnboxedVector.Vector (Double, Double)+toPointVector (Path _ points) = points++-- * Constructors++-- | Construct a PostgreSQL 'Path' from closed flag and points list with validation.+-- Returns 'Nothing' if the list is empty.+refineFromPointList :: Bool -> [(Double, Double)] -> Maybe Path+refineFromPointList closed points =+  case points of+    [] -> Nothing+    _ -> Just (Path closed (UnboxedVector.fromList points))++-- | Construct a PostgreSQL 'Path' from closed flag and points vector with validation.+-- Returns 'Nothing' if the vector is empty.+refineFromPointVector :: Bool -> UnboxedVector.Vector (Double, Double) -> Maybe Path+refineFromPointVector closed points =+  if UnboxedVector.length points >= 1+    then Just (Path closed points)+    else Nothing
+ src/library/PostgresqlTypes/Point.hs view
@@ -0,0 +1,84 @@+module PostgresqlTypes.Point+  ( Point (..),++    -- * Accessors+    toX,+    toY,++    -- * Constructors+    fromCoordinates,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @point@ type. Geometric point in 2D plane.+--+-- Represented with (@x@,@y@) coordinates.+-- Stored as two @64@-bit floating point numbers (@float8@) in PostgreSQL.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-GEOMETRIC-POINTS).+data Point+  = Point+      -- | X coordinate+      Double+      -- | Y coordinate+      Double+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Point)++instance Arbitrary Point where+  arbitrary = Point <$> arbitrary <*> arbitrary+  shrink (Point x y) = [Point x' y' | (x', y') <- shrink (x, y)]++instance Hashable Point where+  hashWithSalt salt (Point x y) =+    salt `hashWithSalt` castDoubleToWord64 x `hashWithSalt` castDoubleToWord64 y++instance IsScalar Point where+  schemaName = Tagged Nothing+  typeName = Tagged "point"+  baseOid = Tagged (Just 600)+  arrayOid = Tagged (Just 1017)+  typeParams = Tagged []+  binaryEncoder (Point x y) =+    mconcat+      [ Write.bWord64 (castDoubleToWord64 x),+        Write.bWord64 (castDoubleToWord64 y)+      ]+  binaryDecoder = do+    x <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    y <- PtrPeeker.fixed (castWord64ToDouble <$> PtrPeeker.beUnsignedInt8)+    pure (Right (Point x y))+  textualEncoder (Point x y) =+    "(" <> TextBuilder.string (printf "%g" x) <> "," <> TextBuilder.string (printf "%g" y) <> ")"+  textualDecoder = do+    _ <- Attoparsec.char '('+    x <- Attoparsec.double+    _ <- Attoparsec.char ','+    y <- Attoparsec.double+    _ <- Attoparsec.char ')'+    pure (Point x y)++-- * Accessors++-- | Extract the x coordinate.+toX :: Point -> Double+toX (Point x _) = x++-- | Extract the y coordinate.+toY :: Point -> Double+toY (Point _ y) = y++-- * Constructors++-- | Construct a PostgreSQL 'Point' from coordinates x and y.+fromCoordinates :: Double -> Double -> Point+fromCoordinates x y = Point x y
+ src/library/PostgresqlTypes/Polygon.hs view
@@ -0,0 +1,121 @@+module PostgresqlTypes.Polygon+  ( Polygon,++    -- * Accessors+    toPointList,+    toPointVector,++    -- * Constructors+    refineFromPointList,+    refineFromPointVector,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Vector.Unboxed as UnboxedVector+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @polygon@ type. Closed geometric path in 2D plane.+--+-- Represented as a series of vertices (points).+-- The polygon is automatically closed (the last point connects to the first).+-- Stored as the number of points followed by the point coordinates.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-geometric.html#DATATYPE-POLYGON).+newtype Polygon+  = Polygon (UnboxedVector.Vector (Double, Double))+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Polygon)++instance Arbitrary Polygon where+  arbitrary = do+    size <- QuickCheck.getSize+    -- Polygons need at least 3 points+    numPoints <- QuickCheck.choose (3, max 3 size)+    points <- UnboxedVector.fromList <$> QuickCheck.vectorOf numPoints arbitrary+    pure (Polygon points)++  shrink (Polygon points) = [Polygon points' | points' <- shrink points, UnboxedVector.length points' >= 3]++instance Hashable Polygon where+  hashWithSalt salt (Polygon points) =+    salt `hashWithSalt` UnboxedVector.toList points++instance IsScalar Polygon where+  schemaName = Tagged Nothing+  typeName = Tagged "polygon"+  baseOid = Tagged (Just 604)+  arrayOid = Tagged (Just 1027)+  typeParams = Tagged []+  binaryEncoder (Polygon points) =+    let numPoints = fromIntegral (UnboxedVector.length points) :: Int32+        pointsEncoded = UnboxedVector.foldMap encodePoint points+     in mconcat+          [ Write.bInt32 numPoints,+            pointsEncoded+          ]+    where+      encodePoint (x, y) =+        mconcat+          [ Write.bWord64 (castDoubleToWord64 x),+            Write.bWord64 (castDoubleToWord64 y)+          ]+  binaryDecoder = do+    numPoints <- PtrPeeker.fixed PtrPeeker.beSignedInt4+    points <- UnboxedVector.replicateM (fromIntegral numPoints) decodePoint+    pure (Right (Polygon points))+    where+      decodePoint = PtrPeeker.fixed do+        x <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+        y <- castWord64ToDouble <$> PtrPeeker.beUnsignedInt8+        pure (x, y)+  textualEncoder (Polygon points) =+    "(" <> TextBuilder.intercalateMap "," encodePoint (UnboxedVector.toList points) <> ")"+    where+      encodePoint (x, y) =+        "(" <> TextBuilder.string (printf "%g" x) <> "," <> TextBuilder.string (printf "%g" y) <> ")"+  textualDecoder = do+    _ <- Attoparsec.char '('+    points <- parsePoint `Attoparsec.sepBy1` Attoparsec.char ','+    _ <- Attoparsec.char ')'+    pure (Polygon (UnboxedVector.fromList points))+    where+      parsePoint = do+        _ <- Attoparsec.char '('+        x <- Attoparsec.double+        _ <- Attoparsec.char ','+        y <- Attoparsec.double+        _ <- Attoparsec.char ')'+        pure (x, y)++-- * Accessors++-- | Extract the polygon points as a list.+toPointList :: Polygon -> [(Double, Double)]+toPointList (Polygon points) = UnboxedVector.toList points++-- | Extract the polygon points as an unboxed vector.+toPointVector :: Polygon -> UnboxedVector.Vector (Double, Double)+toPointVector (Polygon points) = points++-- * Constructors++-- | Construct a PostgreSQL 'Polygon' from a list of points with validation.+-- Returns 'Nothing' if there are fewer than 3 points.+refineFromPointList :: [(Double, Double)] -> Maybe Polygon+refineFromPointList = refineFromPointVector . UnboxedVector.fromList++-- | Construct a PostgreSQL 'Polygon' from an unboxed vector of points with validation.+-- Returns 'Nothing' if there are fewer than 3 points.+refineFromPointVector :: UnboxedVector.Vector (Double, Double) -> Maybe Polygon+refineFromPointVector vector =+  if UnboxedVector.length vector >= 3+    then Just (Polygon vector)+    else Nothing
+ src/library/PostgresqlTypes/Prelude.hs view
@@ -0,0 +1,85 @@+module 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.Error.Class as Exports+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 Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Except as Exports hiding (liftCallCC, liftListen, liftPass)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftListen, liftPass)+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+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.Functor.Invariant as Exports+import Data.Hashable as Exports (Hashable (..))+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.Profunctor as Exports (Profunctor (..))+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.Time as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.UUID as Exports (UUID)+import Data.Unique as Exports+import Data.Vector as Exports (Vector)+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.ForeignPtr.Unsafe as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports hiding (alignment, sizeOf)+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (groupWith, inline, lazy, sortWith)+import GHC.IO.Exception as Exports+import Numeric as Exports+import Numeric.Natural as Exports (Natural)+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Test.QuickCheck as Exports (Arbitrary (..), Property, Testable (..))+import Test.QuickCheck.Instances ()+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import TextBuilder as Exports (TextBuilder)+import Unsafe.Coerce as Exports+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, (.))
+ src/library/PostgresqlTypes/Range.hs view
@@ -0,0 +1,279 @@+module PostgresqlTypes.Range+  ( Range,++    -- * Accessors+    isEmpty,+    fold,++    -- * Constructors+    empty,+    unbounded,+    normalizeBounded,+    refineBounded,++    -- ** Combinators+    mergeIfOverlappingOrAdjacent,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (empty, fold)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- |+-- Normalized representation of a range in the @[inclusiveLowerBound,exclusiveUpperBound)@ form.+--+-- Although PostgreSQL has the concept of inclusive and exclusive bounds in ranges in reality it always normalizes the range values to one form.+-- The lower bound is inclusive and the upper bound is exclusive with one exception: if the lower bound is infinity then it is treated as exclusive.+-- There is also another special value: empty.+--+-- The following standard types are supported via the 'IsRangeElement' instances:+--+-- - @int4range@ - @Range Int4@+-- - @int8range@ - @Range Int8@+-- - @numrange@ - @Range Numeric@+-- - @tsrange@ - @Range Timestamp@+-- - @tstzrange@ - @Range Timestamptz@+-- - @daterange@ - @Range Date@+--+-- You can also define your own.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/rangetypes.html).+data Range a+  = EmptyRange+  | BoundedRange (Maybe a) (Maybe a)+  deriving stock (Eq, Functor)+  deriving (Show, Read, IsString) via (ViaIsScalar (Range a))++instance (IsRangeElement a) => IsScalar (Range a) where+  schemaName = Tagged Nothing+  typeName = retag (rangeTypeName @a)+  baseOid = retag (rangeBaseOid @a)+  arrayOid = retag (rangeArrayOid @a)+  typeParams = retag (typeParams @a)+  binaryEncoder = \case+    EmptyRange ->+      Write.word8 0b00000001+    BoundedRange lowerValue upperValue ->+      mconcat+        [ Write.word8+            ( (if null lowerValue then 0b00001000 else 0b00000010)+                .|. (if null upperValue then 0b00010000 else 0)+            ),+          foldMap renderBound lowerValue,+          foldMap renderBound upperValue+        ]+    where+      renderBound bound =+        let write = binaryEncoder bound+         in Write.bWord32 (fromIntegral (Write.writeSize write)) <> write++  binaryDecoder = runExceptT do+    flags <- lift do+      PtrPeeker.fixed PtrPeeker.unsignedInt1+    let emptyRange = testBit flags 0+        lowerInclusive = testBit flags 1+        upperInclusive = testBit flags 2+        lowerInfinite = testBit flags 3+        upperInfinite = testBit flags 4+    if emptyRange+      then pure EmptyRange+      else do+        lowerValue <- decodeBound lowerInfinite+        upperValue <- decodeBound upperInfinite++        when (isJust lowerValue && not lowerInclusive) do+          throwError (DecodingError ["lower-value"] (UnsupportedValueDecodingErrorReason "Lower bound cannot be exclusive when it is not infinite" (TextBuilder.toText (TextBuilder.decimal flags))))++        when (isJust upperValue && upperInclusive) do+          throwError (DecodingError ["upper-value"] (UnsupportedValueDecodingErrorReason "Upper bound cannot be inclusive" (TextBuilder.toText (TextBuilder.decimal flags))))++        case (lowerValue, upperValue) of+          (Just lv, Just uv) ->+            when (lv >= uv) do+              throwError (DecodingError ["upper-value"] (UnsupportedValueDecodingErrorReason "Upper value is smaller than the lower one" (TextBuilder.toText (TextBuilder.decimal flags))))+          _ -> pure ()++        pure (BoundedRange lowerValue upperValue)+    where+      decodeBound infinite =+        if infinite+          then pure Nothing+          else+            Just <$> do+              size <- lift do+                PtrPeeker.fixed PtrPeeker.beSignedInt4+              when (size < 0) do+                throwError (DecodingError ["bound-size"] (UnsupportedValueDecodingErrorReason "Expecting >= 0" (TextBuilder.toText (TextBuilder.decimal size))))+              ExceptT do+                PtrPeeker.forceSize (fromIntegral size) do+                  binaryDecoder @a++  textualEncoder = \case+    EmptyRange -> "empty"+    BoundedRange lowerValue upperValue ->+      mconcat+        [ case lowerValue of+            Nothing -> "("+            Just lowerValue -> "[" <> textualEncoder lowerValue,+          ",",+          case upperValue of+            Nothing -> ")"+            Just upperValue -> textualEncoder upperValue <> ")"+        ]+  textualDecoder =+    parseEmpty <|> parseBounded+    where+      parseEmpty = EmptyRange <$ Attoparsec.string "empty"+      parseBounded = do+        lowerBracket <- Attoparsec.satisfy (\c -> c == '[' || c == '(')+        Attoparsec.skipSpace+        lowerValue <-+          if lowerBracket == '['+            then Just <$> parseElement+            else pure Nothing+        Attoparsec.skipSpace+        _ <- Attoparsec.char ','+        upperValue <- optional parseElement+        _ <- Attoparsec.char ')'+        pure (BoundedRange lowerValue upperValue)++      -- Parse element that might be quoted by PostgreSQL (for extreme dates)+      parseElement =+        quotedElement <|> textualDecoder @a+        where+          quotedElement = Attoparsec.char '"' *> textualDecoder @a <* Attoparsec.char '"'++instance (Arbitrary a, Ord a) => Arbitrary (Range a) where+  arbitrary =+    QuickCheck.frequency+      [ (1, pure EmptyRange),+        ( 10,+          do+            value1 <- QuickCheck.frequency [(1, pure Nothing), (10, Just <$> arbitrary)]+            value2 <-+              QuickCheck.frequency+                [ (1, pure Nothing),+                  ( 10,+                    Just <$> case value1 of+                      Nothing -> arbitrary+                      Just value1 -> QuickCheck.suchThat arbitrary (/= value1)+                  )+                ]+            pure if value1 < value2 then BoundedRange value1 value2 else BoundedRange value2 value1+        )+      ]++instance (Hashable a) => Hashable (Range a) where+  hashWithSalt salt = \case+    EmptyRange -> salt `hashWithSalt` (0 :: Int)+    BoundedRange lower upper -> salt `hashWithSalt` (1 :: Int) `hashWithSalt` lower `hashWithSalt` upper++instance (Ord a) => Ord (Range a) where+  compare EmptyRange EmptyRange = EQ+  compare EmptyRange (BoundedRange _ _) = LT+  compare (BoundedRange _ _) EmptyRange = GT+  compare (BoundedRange lower1 upper1) (BoundedRange lower2 upper2) =+    case compareBounds lower1 lower2 of+      EQ -> compareBounds upper1 upper2+      other -> other+    where+      compareBounds Nothing Nothing = EQ+      compareBounds Nothing (Just _) = LT+      compareBounds (Just _) Nothing = GT+      compareBounds (Just v1) (Just v2) = compare v1 v2++isEmpty :: Range a -> Bool+isEmpty = \case+  EmptyRange -> True+  BoundedRange _ _ -> False++-- | Pattern matching on 'Range'.+fold ::+  -- | Empty range case.+  b ->+  -- | Bounded range case.+  (Maybe a -> Maybe a -> b) ->+  (Range a -> b)+fold emptyCase boundedCase = \case+  EmptyRange -> emptyCase+  BoundedRange lower upper -> boundedCase lower upper++-- | Constructs an empty range.+empty :: Range a+empty = EmptyRange++-- | Constructs a range without bounds (infinity to infinity).+unbounded :: Range a+unbounded = BoundedRange Nothing Nothing++-- | Constructs a bounded range normalizing the bounds.+-- If the lower bound is not less than the upper bound, returns 'empty'.+normalizeBounded :: (Ord a) => Maybe a -> Maybe a -> Range a+normalizeBounded = \case+  Just lower -> \case+    Just upper ->+      if lower < upper+        then BoundedRange (Just lower) (Just upper)+        else EmptyRange+    Nothing -> BoundedRange (Just lower) Nothing+  Nothing -> \case+    Just upper -> BoundedRange Nothing (Just upper)+    Nothing -> BoundedRange Nothing Nothing++-- | Constructs a bounded range refining the bounds.+-- If the lower bound is not less than the upper bound, returns 'Nothing'.+refineBounded :: (Ord a) => Maybe a -> Maybe a -> Maybe (Range a)+refineBounded = \case+  Just lower -> \case+    Just upper ->+      if lower < upper+        then Just (BoundedRange (Just lower) (Just upper))+        else Nothing+    Nothing -> Just (BoundedRange (Just lower) Nothing)+  Nothing -> \case+    Just upper -> Just (BoundedRange Nothing (Just upper))+    Nothing -> Just (BoundedRange Nothing Nothing)++-- | Merge two ranges if they are overlapping or adjacent.+-- Returns 'Just' the merged range if they overlap or are adjacent, 'Nothing' otherwise.+--+-- Ranges are normalized as [lower, upper) (inclusive lower, exclusive upper).+-- Two ranges are adjacent if one ends exactly where the other begins.+-- Two ranges overlap if they share any values.+mergeIfOverlappingOrAdjacent :: (Ord a) => Range a -> Range a -> Maybe (Range a)+mergeIfOverlappingOrAdjacent = \case+  EmptyRange -> Just+  BoundedRange lower1 upper1 -> \case+    EmptyRange -> Just (BoundedRange lower1 upper1)+    BoundedRange lower2 upper2 ->+      -- Check if ranges overlap or are adjacent:+      -- r1 = [lower1, upper1), r2 = [lower2, upper2)+      -- They overlap or are adjacent if upper1 >= lower2+      case (upper1, lower2) of+        -- r1 extends to infinity, so always overlaps with or is adjacent to r2+        (Nothing, _) -> Just (BoundedRange lower1 Nothing)+        -- r2 starts from -infinity+        -- If we're processing in sorted order, this shouldn't happen+        -- (lower1 can't be >= -infinity when lower2 is -infinity)+        (Just _, Nothing) ->+          -- However, if it does occur, these ranges must overlap+          -- Result is (-infinity, max(upper1, upper2))+          Just (BoundedRange Nothing (maxBound upper1 upper2))+        (Just u1, Just l2) ->+          -- Both bounds are finite+          -- Overlapping: u1 > l2 (r1 extends into r2)+          -- Adjacent: u1 == l2 (r1 ends exactly where r2 begins)+          if u1 >= l2+            then Just (BoundedRange lower1 (maxBound upper1 upper2))+            else Nothing+  where+    -- Helper to get the max of two Maybe bounds (Nothing represents infinity)+    maxBound Nothing _ = Nothing+    maxBound _ Nothing = Nothing+    maxBound (Just a) (Just b) = Just (max a b)
+ src/library/PostgresqlTypes/Text.hs view
@@ -0,0 +1,88 @@+module PostgresqlTypes.Text+  ( Text,++    -- * Accessors+    toText,++    -- * Constructors+    normalizeFromText,+    refineFromText,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import Data.String+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude hiding (Text)+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @text@ type. Variable-length character string with no null-characters.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-character.html).+newtype Text = Text Text.Text+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Text)++instance Arbitrary Text where+  arbitrary =+    Text <$> do+      charList <- QuickCheck.listOf do+        QuickCheck.suchThat arbitrary (\char -> char /= '\NUL')+      pure (Text.pack charList)+  shrink (Text base) =+    Text . Text.pack <$> shrink (Text.unpack base)++instance IsScalar Text where+  schemaName = Tagged Nothing+  typeName = Tagged "text"+  baseOid = Tagged (Just 25)+  arrayOid = Tagged (Just 1009)+  typeParams = Tagged []+  binaryEncoder (Text base) = Write.textUtf8 base+  binaryDecoder = do+    bytes <- PtrPeeker.remainderAsByteString+    case Text.Encoding.decodeUtf8' bytes of+      Left e ->+        pure+          ( Left+              ( DecodingError+                  { location = [],+                    reason =+                      ParsingDecodingErrorReason+                        (fromString (show e))+                        bytes+                  }+              )+          )+      Right base -> pure (Right (Text base))+  textualEncoder (Text base) = TextBuilder.text base+  textualDecoder = Text <$> Attoparsec.takeText++-- * Accessors++-- | Extract the underlying 'Data.Text.Text' value.+toText :: Text -> Text.Text+toText (Text t) = t++-- * Constructors++-- | Construct a PostgreSQL 'Text' from a 'Data.Text.Text' value.+--+-- Strips null characters to ensure PostgreSQL compatibility.+normalizeFromText :: Text.Text -> Text+normalizeFromText = Text . Text.replace "\NUL" ""++-- | Construct a PostgreSQL 'Text' from a 'Data.Text.Text' value.+--+-- Returns 'Nothing' if the text contains null characters (not supported by PostgreSQL).+refineFromText :: Text.Text -> Maybe Text+refineFromText text =+  if Text.elem '\NUL' text+    then Nothing+    else Just (Text text)
+ src/library/PostgresqlTypes/Time.hs view
@@ -0,0 +1,124 @@+module PostgresqlTypes.Time+  ( Time,++    -- * Accessors+    toMicroseconds,+    toTimeOfDay,++    -- * Constructors+    normalizeFromMicroseconds,+    refineFromTimeOfDay,+    normalizeFromTimeOfDay,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Time as Time+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @time@ type. Time of day (without time zone).+--+-- Gets stored as microseconds since midnight (@00:00:00@).+--+-- Range: @00:00:00@ to @24:00:00@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-datetime.html#DATATYPE-TIME).+newtype Time = Time Int64+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Time)++instance Arbitrary Time where+  arbitrary = Time <$> QuickCheck.choose (toMicroseconds minBound, toMicroseconds maxBound)++instance IsScalar Time where+  schemaName = Tagged Nothing+  typeName = Tagged "time"+  baseOid = Tagged (Just 1083)+  arrayOid = Tagged (Just 1183)+  typeParams = Tagged []+  binaryEncoder (Time microseconds) = Write.bInt64 microseconds+  binaryDecoder = PtrPeeker.fixed (Right . Time <$> PtrPeeker.beSignedInt8)+  textualEncoder (Time microseconds) =+    let diffTime = fromIntegral microseconds / 1_000_000+        timeOfDay = Time.timeToTimeOfDay diffTime+     in TextBuilder.string (Time.formatTime Time.defaultTimeLocale "%H:%M:%S%Q" timeOfDay)+  textualDecoder = do+    h <- twoDigits+    _ <- Attoparsec.char ':'+    m <- twoDigits+    -- Seconds are optional+    s <- Attoparsec.option 0 (Attoparsec.char ':' *> parseSeconds)+    if h < 25 && m < 60 && s < 61_000_000+      then+        let microseconds = fromIntegral h * 3600_000_000 + fromIntegral m * 60_000_000 + s+         in pure (Time microseconds)+      else fail "Invalid time"+    where+      twoDigits = do+        a <- Attoparsec.digit+        b <- Attoparsec.digit+        pure (digitToInt a * 10 + digitToInt b)+      parseSeconds = do+        secs <- twoDigits+        micros <- Attoparsec.option 0 parseFraction+        pure (fromIntegral secs * 1_000_000 + micros)+      parseFraction = do+        _ <- Attoparsec.char '.'+        digits <- Attoparsec.takeWhile1 isDigit+        -- Pad or truncate to 6 digits for microseconds+        let paddedDigits = take 6 (Text.unpack digits ++ repeat '0')+            micros = foldl' (\acc c -> acc * 10 + fromIntegral (digitToInt c)) 0 paddedDigits+        pure micros++instance Bounded Time where+  minBound = Time 0+  maxBound = Time (24 * 60 * 60 * 1_000_000) -- 24 hours in microseconds++-- * Accessors++-- | Extract the underlying microseconds value.+toMicroseconds :: Time -> Int64+toMicroseconds (Time microseconds) = microseconds++-- | Convert PostgreSQL 'Time' to 'Time.TimeOfDay'.+toTimeOfDay :: Time -> Time.TimeOfDay+toTimeOfDay (Time microseconds) =+  let diffTime = fromIntegral microseconds / 1_000_000+   in Time.timeToTimeOfDay diffTime++-- * Constructors++-- | Construct a PostgreSQL 'Time' from microseconds, clamping to valid range.+normalizeFromMicroseconds :: Int64 -> Time+normalizeFromMicroseconds microseconds =+  if microseconds < 0+    then Time 0+    else+      if microseconds > 86_400_000_000+        then Time 86_400_000_000+        else Time microseconds++-- | Convert from 'Time.TimeOfDay' to PostgreSQL 'Time' with validation.+-- Returns 'Nothing' if the value is outside the valid range.+refineFromTimeOfDay :: Time.TimeOfDay -> Maybe Time+refineFromTimeOfDay timeOfDay =+  let diffTime = Time.timeOfDayToTime timeOfDay+      microseconds = round (diffTime * 1_000_000)+      time = Time microseconds+   in if microseconds >= 0 && microseconds <= 86_400_000_000 && toTimeOfDay time == timeOfDay+        then Just time+        else Nothing++-- | Convert from 'Time.TimeOfDay' to PostgreSQL 'Time', clamping to valid range.+normalizeFromTimeOfDay :: Time.TimeOfDay -> Time+normalizeFromTimeOfDay timeOfDay =+  let diffTime = Time.timeOfDayToTime timeOfDay+      microseconds = round (diffTime * 1_000_000)+   in normalizeFromMicroseconds microseconds
+ src/library/PostgresqlTypes/Timestamp.hs view
@@ -0,0 +1,239 @@+module PostgresqlTypes.Timestamp+  ( Timestamp,++    -- * Accessors+    toMicroseconds,+    toLocalTime,++    -- * Constructors+    normalizeFromMicroseconds,+    normalizeFromLocalTime,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Time as Time+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @timestamp@ type. Date and time (without time zone).+--+-- Gets stored as microseconds since PostgreSQL epoch.+--+-- Range: @4713 BC@ to @294276 AD@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-datetime.html#DATATYPE-DATETIME).+newtype Timestamp = Timestamp Int64+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Timestamp)++instance Arbitrary Timestamp where+  arbitrary = Timestamp <$> QuickCheck.choose (minMicroseconds, maxMicroseconds)++instance IsScalar Timestamp where+  schemaName = Tagged Nothing+  typeName = Tagged "timestamp"+  baseOid = Tagged (Just 1114)+  arrayOid = Tagged (Just 1115)+  typeParams = Tagged []+  binaryEncoder (Timestamp micros) = Write.bInt64 micros+  binaryDecoder = do+    microseconds <- PtrPeeker.fixed PtrPeeker.beSignedInt8+    pure (Right (Timestamp microseconds))+  textualEncoder (toLocalTime -> localTime) =+    formatTimestampForPostgreSQL localTime+  textualDecoder = do+    -- Parse date part+    y <- Attoparsec.decimal+    _ <- Attoparsec.char '-'+    m <- twoDigits+    _ <- Attoparsec.char '-'+    d <- twoDigits+    -- Space or T separator+    _ <- Attoparsec.satisfy (\c -> c == ' ' || c == 'T')+    -- Parse time part+    h <- twoDigits+    _ <- Attoparsec.char ':'+    mi <- twoDigits+    _ <- Attoparsec.char ':'+    s <- twoDigits+    micros <- Attoparsec.option 0 parseFraction+    -- Check for BC suffix+    bc <- Attoparsec.option False (True <$ (Attoparsec.skipSpace *> Attoparsec.string "BC"))+    let year = if bc then negate y + 1 else y+    case Time.fromGregorianValid year m d of+      Just day -> do+        let timeOfDay = Time.TimeOfDay h mi (fromIntegral s + fromIntegral micros / 1_000_000)+            localTime = Time.LocalTime day timeOfDay+        pure (normalizeFromLocalTime localTime)+      Nothing ->+        -- For extreme dates, compute directly from PostgreSQL epoch+        -- This is a simplified calculation for extreme timestamps+        let yearsSinceEpoch = year - 2000+            daysFromYears = fromIntegral yearsSinceEpoch * 365 + fromIntegral (yearsSinceEpoch `div` 4)+            getDaysInMonth mon =+              case mon of+                1 -> (31 :: Int)+                2 -> if isLeapYear year then (29 :: Int) else (28 :: Int)+                3 -> (31 :: Int)+                4 -> (30 :: Int)+                5 -> (31 :: Int)+                6 -> (30 :: Int)+                7 -> (31 :: Int)+                8 -> (31 :: Int)+                9 -> (30 :: Int)+                10 -> (31 :: Int)+                11 -> (30 :: Int)+                12 -> (31 :: Int)+                _ -> (0 :: Int)+            monthDays = foldl' (+) 0 [if mon < m then getDaysInMonth mon else 0 | mon <- [1 .. 12]]+            totalDays = daysFromYears + fromIntegral monthDays + fromIntegral d - 1+            dayMicros = totalDays * 86400_000_000+            timeMicros = fromIntegral h * 3600_000_000 + fromIntegral mi * 60_000_000 + fromIntegral s * 1_000_000 + fromIntegral micros+         in pure (Timestamp (dayMicros + timeMicros))+    where+      twoDigits = do+        a <- Attoparsec.digit+        b <- Attoparsec.digit+        pure (digitToInt a * 10 + digitToInt b)+      parseFraction = do+        _ <- Attoparsec.char '.'+        digits <- Attoparsec.takeWhile1 isDigit+        let paddedDigits = take 6 (Text.unpack digits ++ repeat '0')+            micros = foldl' (\acc c -> acc * 10 + digitToInt c) 0 paddedDigits+        pure micros+      isLeapYear yr = (yr `mod` 4 == 0 && yr `mod` 100 /= 0) || (yr `mod` 400 == 0)++-- | Mapping to @tsrange@ type.+instance IsRangeElement Timestamp where+  rangeTypeName = Tagged "tsrange"+  rangeBaseOid = Tagged (Just 3908)+  rangeArrayOid = Tagged (Just 3909)++-- | Mapping to @tsmultirange@ type.+instance IsMultirangeElement Timestamp where+  multirangeTypeName = Tagged "tsmultirange"+  multirangeBaseOid = Tagged (Just 4533)+  multirangeArrayOid = Tagged (Just 6152)++-- * Accessors++-- | Convert PostgreSQL 'Timestamp' to microseconds since epoch.+toMicroseconds :: Timestamp -> Int64+toMicroseconds (Timestamp micros) = micros++-- | Convert PostgreSQL 'Timestamp' to 'Time.LocalTime'.+toLocalTime :: Timestamp -> Time.LocalTime+toLocalTime (Timestamp micros) =+  let diffTime = fromIntegral micros / 1_000_000+   in Time.addLocalTime diffTime postgresTimestampEpoch++-- * Constructors++-- | Construct a PostgreSQL 'Timestamp' from microseconds since epoch by clamping the values out of range.+normalizeFromMicroseconds :: Int64 -> Timestamp+normalizeFromMicroseconds micros =+  if micros < minMicroseconds+    then Timestamp minMicroseconds+    else+      if micros > maxMicroseconds+        then Timestamp maxMicroseconds+        else Timestamp micros++-- | Construct a PostgreSQL 'Timestamp' from 'Time.LocalTime'.+normalizeFromLocalTime :: Time.LocalTime -> Timestamp+normalizeFromLocalTime localTime =+  let diffTime = Time.diffLocalTime localTime postgresTimestampEpoch+      micros = round (diffTime * 1_000_000)+   in normalizeFromMicroseconds micros++-- | Format a LocalTime for PostgreSQL timestamp text format.+-- PostgreSQL requires specific formatting for extreme dates:+-- - Years must be 4-digit zero-padded for AD dates+-- - BC dates use "YYYY-MM-DD HH:MM:SS BC" format+-- - Microseconds must be properly formatted+formatTimestampForPostgreSQL :: Time.LocalTime -> TextBuilder+formatTimestampForPostgreSQL localTime =+  let day = Time.localDay localTime+      timeOfDay = Time.localTimeOfDay localTime+      (year, month, dayOfMonth) = Time.toGregorian day+      timeBuilder = formatTimeOfDay timeOfDay+   in if year <= 0+        then+          -- For BC dates (year <= 0), PostgreSQL expects format like "0001-01-01 00:00:00 BC"+          -- Note: year 0 is 1 BC, year -1 is 2 BC, etc.+          let bcYear = negate (1 - year)+           in mconcat+                [ if bcYear <= 999+                    then TextBuilder.fixedLengthDecimal 4 (bcYear :: Integer)+                    else TextBuilder.decimal (bcYear :: Integer),+                  "-",+                  TextBuilder.fixedLengthDecimal 2 (fromIntegral month :: Integer),+                  "-",+                  TextBuilder.fixedLengthDecimal 2 (fromIntegral dayOfMonth :: Integer),+                  " ",+                  timeBuilder,+                  " BC"+                ]+        else+          -- For AD dates (year > 0), use zero-padded 4-digit year+          mconcat+            [ if year <= 999+                then TextBuilder.fixedLengthDecimal 4 (year :: Integer)+                else TextBuilder.decimal (year :: Integer),+              "-",+              TextBuilder.fixedLengthDecimal 2 (fromIntegral month :: Integer),+              "-",+              TextBuilder.fixedLengthDecimal 2 (fromIntegral dayOfMonth :: Integer),+              " ",+              timeBuilder+            ]+  where+    formatTimeOfDay :: Time.TimeOfDay -> TextBuilder+    formatTimeOfDay tod =+      let h = Time.todHour tod :: Int+          m = Time.todMin tod :: Int+          pico = Time.todSec tod+          -- Convert from Pico to microseconds+          totalMicros = round (toRational pico * 1000000) :: Integer+          secs = totalMicros `div` 1000000 :: Integer+          micros = totalMicros `mod` 1000000 :: Integer+       in if micros == 0+            then+              mconcat+                [ TextBuilder.fixedLengthDecimal 2 (fromIntegral h :: Integer),+                  ":",+                  TextBuilder.fixedLengthDecimal 2 (fromIntegral m :: Integer),+                  ":",+                  TextBuilder.fixedLengthDecimal 2 secs+                ]+            else+              mconcat+                [ TextBuilder.fixedLengthDecimal 2 (fromIntegral h :: Integer),+                  ":",+                  TextBuilder.fixedLengthDecimal 2 (fromIntegral m :: Integer),+                  ":",+                  TextBuilder.fixedLengthDecimal 2 secs,+                  ".",+                  TextBuilder.fixedLengthDecimal 6 micros+                ]++-- * Constants++-- PostgreSQL timestamp epoch is 2000-01-01 00:00:00+postgresTimestampEpoch :: Time.LocalTime+postgresTimestampEpoch = Time.LocalTime (Time.fromGregorian 2000 1 1) Time.midnight++-- PostgreSQL's actual documented timestamp range: 4713 BC to 294276 AD+-- Do not artificially restrict to avoid edge cases - let the tests expose real issues+minMicroseconds :: Int64+minMicroseconds = -210866803200000000 -- 4713 BC January 1 00:00:00++maxMicroseconds :: Int64+maxMicroseconds = 9214646400000000000 -- 294276 AD December 31 23:59:59.999999
+ src/library/PostgresqlTypes/Timestamptz.hs view
@@ -0,0 +1,250 @@+module PostgresqlTypes.Timestamptz+  ( Timestamptz,++    -- * Accessors+    toMicroseconds,+    toUtcTime,++    -- * Constructors+    normalizeFromMicroseconds,+    normalizeFromUtcTime,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Time as Time+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @timestamptz@ type. Date and time with time zone.+--+-- Gets stored as microseconds since PostgreSQL epoch, implying UTC timezone.+--+-- Range: @4713 BC@ to @294276 AD@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-datetime.html#DATATYPE-TIMEZONES).+newtype Timestamptz = Timestamptz Int64+  deriving newtype (Eq, Ord, Hashable)+  deriving (Show, Read, IsString) via (ViaIsScalar Timestamptz)++instance Arbitrary Timestamptz where+  arbitrary = Timestamptz <$> QuickCheck.choose (minMicroseconds, maxMicroseconds)++instance IsScalar Timestamptz where+  schemaName = Tagged Nothing+  typeName = Tagged "timestamptz"+  baseOid = Tagged (Just 1184)+  arrayOid = Tagged (Just 1185)+  typeParams = Tagged []+  binaryEncoder (Timestamptz micros) = Write.bInt64 micros+  binaryDecoder = do+    microseconds <- PtrPeeker.fixed PtrPeeker.beSignedInt8+    pure (Right (Timestamptz microseconds))+  textualEncoder (toUtcTime -> utcTime) =+    formatTimestamptzForPostgreSQL utcTime+  textualDecoder = do+    -- Parse date part+    y <- Attoparsec.decimal+    _ <- Attoparsec.char '-'+    m <- twoDigits+    _ <- Attoparsec.char '-'+    d <- twoDigits+    -- Space or T separator+    _ <- Attoparsec.satisfy (\c -> c == ' ' || c == 'T')+    -- Parse time part+    h <- twoDigits+    _ <- Attoparsec.char ':'+    mi <- twoDigits+    _ <- Attoparsec.char ':'+    s <- twoDigits+    micros <- Attoparsec.option 0 parseFraction+    -- Parse timezone offset+    tzOffsetMinutes <- parseTimezone+    -- Check for BC suffix+    bc <- Attoparsec.option False (True <$ (Attoparsec.skipSpace *> Attoparsec.string "BC"))+    let year = if bc then negate y + 1 else y+    case Time.fromGregorianValid year m d of+      Just day -> do+        let timeOfDay = Time.TimeOfDay h mi (fromIntegral s + fromIntegral micros / 1_000_000)+            localTime = Time.LocalTime day timeOfDay+            timeZone = Time.minutesToTimeZone tzOffsetMinutes+            utcTime = Time.localTimeToUTC timeZone localTime+        pure (normalizeFromUtcTime utcTime)+      Nothing ->+        -- For extreme dates, compute directly from PostgreSQL epoch+        let yearsSinceEpoch = year - 2000+            daysFromYears = fromIntegral yearsSinceEpoch * 365 + fromIntegral (yearsSinceEpoch `div` 4)+            getDaysInMonth mon =+              case mon of+                1 -> (31 :: Int)+                2 -> if isLeapYear year then (29 :: Int) else (28 :: Int)+                3 -> (31 :: Int)+                4 -> (30 :: Int)+                5 -> (31 :: Int)+                6 -> (30 :: Int)+                7 -> (31 :: Int)+                8 -> (31 :: Int)+                9 -> (30 :: Int)+                10 -> (31 :: Int)+                11 -> (30 :: Int)+                12 -> (31 :: Int)+                _ -> (0 :: Int)+            monthDays = foldl' (+) 0 [if mon < m then getDaysInMonth mon else 0 | mon <- [1 .. 12]]+            totalDays = daysFromYears + fromIntegral monthDays + fromIntegral d - 1+            dayMicros = totalDays * 86400_000_000+            timeMicros = fromIntegral h * 3600_000_000 + fromIntegral mi * 60_000_000 + fromIntegral s * 1_000_000 + fromIntegral micros+            tzAdjustment = fromIntegral tzOffsetMinutes * (-60_000_000) -- Subtract offset to get UTC+         in pure (Timestamptz (dayMicros + timeMicros + tzAdjustment))+    where+      twoDigits = do+        a <- Attoparsec.digit+        b <- Attoparsec.digit+        pure (digitToInt a * 10 + digitToInt b)+      parseFraction = do+        _ <- Attoparsec.char '.'+        digits <- Attoparsec.takeWhile1 isDigit+        let paddedDigits = take 6 (Text.unpack digits ++ repeat '0')+            micros = foldl' (\acc c -> acc * 10 + digitToInt c) 0 paddedDigits+        pure micros+      parseTimezone =+        (0 <$ Attoparsec.char 'Z')+          <|> do+            sign <- (1 <$ Attoparsec.char '+') <|> ((-1) <$ Attoparsec.char '-')+            h <- twoDigits+            mi <- Attoparsec.option 0 (Attoparsec.option ':' (Attoparsec.char ':') *> twoDigits)+            pure (sign * (h * 60 + mi))+      isLeapYear yr = (yr `mod` 4 == 0 && yr `mod` 100 /= 0) || (yr `mod` 400 == 0)++-- | Mapping to @tstzrange@ type.+instance IsRangeElement Timestamptz where+  rangeTypeName = Tagged "tstzrange"+  rangeBaseOid = Tagged (Just 3910)+  rangeArrayOid = Tagged (Just 3911)++-- | Mapping to @tstzmultirange@ type.+instance IsMultirangeElement Timestamptz where+  multirangeTypeName = Tagged "tstzmultirange"+  multirangeBaseOid = Tagged (Just 4534)+  multirangeArrayOid = Tagged (Just 6153)++-- * Accessors++-- | Convert PostgreSQL 'Timestamptz' to microseconds since epoch.+toMicroseconds :: Timestamptz -> Int64+toMicroseconds (Timestamptz micros) = micros++-- | Convert PostgreSQL 'Timestamptz' to 'Time.UTCTime'.+toUtcTime :: Timestamptz -> Time.UTCTime+toUtcTime (Timestamptz micros) =+  let diffTime = fromIntegral micros / 1_000_000+   in Time.addUTCTime diffTime postgresUtcEpoch++-- * Constructors++-- | Construct a PostgreSQL 'Timestamptz' from microseconds since epoch by clamping the values out of range.+normalizeFromMicroseconds :: Int64 -> Timestamptz+normalizeFromMicroseconds micros =+  if micros < minMicroseconds+    then Timestamptz minMicroseconds+    else+      if micros > maxMicroseconds+        then Timestamptz maxMicroseconds+        else Timestamptz micros++-- | Construct a PostgreSQL 'Timestamptz' from 'Time.UTCTime'.+normalizeFromUtcTime :: Time.UTCTime -> Timestamptz+normalizeFromUtcTime utcTime =+  let diffTime = Time.diffUTCTime utcTime postgresUtcEpoch+      micros = round (diffTime * 1_000_000)+   in normalizeFromMicroseconds micros++-- | Format a UTCTime for PostgreSQL timestamptz text format.+-- PostgreSQL requires specific formatting for extreme dates:+-- - Years must be 4-digit zero-padded for AD dates+-- - BC dates use "YYYY-MM-DD HH:MM:SS+0000 BC" format+-- - Always includes +0000 timezone for UTC+-- - Microseconds must be properly formatted+formatTimestamptzForPostgreSQL :: Time.UTCTime -> TextBuilder+formatTimestamptzForPostgreSQL utcTime =+  let day = Time.utctDay utcTime+      diffTime = Time.utctDayTime utcTime+      (year, month, dayOfMonth) = Time.toGregorian day+      -- Convert DiffTime to hours, minutes, seconds, microseconds+      totalSecs = floor (toRational diffTime) :: Integer+      totalMicros = round (toRational diffTime * 1000000) :: Integer+      micros = totalMicros `mod` 1000000 :: Integer+      secs = totalSecs `mod` 60 :: Integer+      totalMins = totalSecs `div` 60 :: Integer+      mins = totalMins `mod` 60 :: Integer+      hours = totalMins `div` 60 :: Integer+      timeBuilder =+        if micros == 0+          then+            mconcat+              [ TextBuilder.fixedLengthDecimal 2 (hours :: Integer),+                ":",+                TextBuilder.fixedLengthDecimal 2 (mins :: Integer),+                ":",+                TextBuilder.fixedLengthDecimal 2 (secs :: Integer)+              ]+          else+            mconcat+              [ TextBuilder.fixedLengthDecimal 2 (hours :: Integer),+                ":",+                TextBuilder.fixedLengthDecimal 2 (mins :: Integer),+                ":",+                TextBuilder.fixedLengthDecimal 2 (secs :: Integer),+                ".",+                TextBuilder.fixedLengthDecimal 6 (micros :: Integer)+              ]+   in if year <= 0+        then+          -- For BC dates (year <= 0), PostgreSQL expects format like "0001-01-01 00:00:00+0000 BC"+          -- Note: year 0 is 1 BC, year -1 is 2 BC, etc.+          let bcYear = negate (1 - year)+           in mconcat+                [ if bcYear <= 999+                    then TextBuilder.fixedLengthDecimal 4 (bcYear :: Integer)+                    else TextBuilder.decimal (bcYear :: Integer),+                  "-",+                  TextBuilder.fixedLengthDecimal 2 (fromIntegral month :: Integer),+                  "-",+                  TextBuilder.fixedLengthDecimal 2 (fromIntegral dayOfMonth :: Integer),+                  " ",+                  timeBuilder,+                  "+0000 BC"+                ]+        else+          -- For AD dates (year > 0), use zero-padded 4-digit year+          mconcat+            [ if year <= 999+                then TextBuilder.fixedLengthDecimal 4 (year :: Integer)+                else TextBuilder.decimal (year :: Integer),+              "-",+              TextBuilder.fixedLengthDecimal 2 (fromIntegral month :: Integer),+              "-",+              TextBuilder.fixedLengthDecimal 2 (fromIntegral dayOfMonth :: Integer),+              " ",+              timeBuilder,+              "+0000"+            ]++-- * Constants++-- PostgreSQL timestamptz epoch is 2000-01-01 00:00:00 UTC+postgresUtcEpoch :: Time.UTCTime+postgresUtcEpoch = Time.UTCTime (Time.fromGregorian 2000 1 1) 0++-- PostgreSQL's actual documented timestamptz range: 4713 BC to 294276 AD+-- Do not artificially restrict to avoid edge cases - let the tests expose real issues+minMicroseconds :: Int64+minMicroseconds = -210866803200000000 -- 4713 BC January 1 00:00:00 UTC++maxMicroseconds :: Int64+maxMicroseconds = 9214646400000000000 -- 294276 AD December 31 23:59:59.999999 UTC
+ src/library/PostgresqlTypes/Timetz.hs view
@@ -0,0 +1,161 @@+module PostgresqlTypes.Timetz+  ( Timetz,++    -- * Accessors+    toTimeInMicroseconds,+    toTimeZoneInSeconds,+    toTimeOfDay,+    normalizeToTimeZone,+    refineToTimeZone,++    -- * Constructors+    normalizeFromTimeInMicrosecondsAndOffsetInSeconds,+    normalizeFromTimeOfDayAndTimeZone,+    refineFromTimeInMicrosecondsAndOffsetInSeconds,+    refineFromTimeOfDayAndTimeZone,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Time as TimeLib+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import qualified PostgresqlTypes.Timetz.Offset as Offset+import qualified PostgresqlTypes.Timetz.Time as Time+import PostgresqlTypes.Via+import qualified PtrPeeker++-- | PostgreSQL @timetz@ type. Time of day with time zone.+--+-- Stored as microseconds since midnight and time zone offset in seconds.+--+-- Low value: @00:00:00+1559@. High value: @24:00:00-1559@.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-datetime.html#DATATYPE-TIMEZONES).+data Timetz+  = Timetz+      -- | Time as microseconds since midnight (00:00:00)+      Time.TimetzTime+      -- | Timezone offset in seconds (positive is east of UTC, negative is west of UTC)+      Offset.TimetzOffset+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar Timetz)++instance Arbitrary Timetz where+  arbitrary = do+    time <- arbitrary+    offset <- arbitrary+    pure (Timetz time offset)++instance Hashable Timetz where+  hashWithSalt salt (Timetz time offset) =+    salt `hashWithSalt` Time.toMicroseconds time `hashWithSalt` Offset.toSeconds offset++instance IsScalar Timetz where+  schemaName = Tagged Nothing+  typeName = Tagged "timetz"+  baseOid = Tagged (Just 1266)+  arrayOid = Tagged (Just 1270)+  typeParams = Tagged []++  binaryEncoder (Timetz time offset) =+    mconcat+      [ Time.binaryEncoder time,+        Offset.binaryEncoder offset+      ]++  binaryDecoder =+    PtrPeeker.fixed do+      time <- Time.binaryDecoder+      offset <- Offset.binaryDecoder+      pure (Timetz <$> time <*> offset)++  -- Format:+  -- 23:59:59-15:59:59+  -- 24:00:00-15:59:59+  -- 00:00:00+15:59:59+  textualEncoder (Timetz time offset) =+    Time.renderInTextFormat time <> Offset.renderInTextFormat offset+  textualDecoder = do+    -- Parse time part: HH:MM:SS[.microseconds]+    h <- twoDigits+    _ <- Attoparsec.char ':'+    m <- twoDigits+    _ <- Attoparsec.char ':'+    s <- twoDigits+    micros <- Attoparsec.option 0 parseFraction+    -- Parse time zone offset: [+-]HH[:MM[:SS]]+    -- PostgreSQL omits minutes and seconds when they are zero+    sign <- (1 <$ Attoparsec.char '+') <|> ((-1) <$ Attoparsec.char '-')+    tzH <- twoDigits+    tzM <- Attoparsec.option 0 (Attoparsec.char ':' *> twoDigits)+    tzS <- Attoparsec.option 0 (Attoparsec.char ':' *> twoDigits)+    -- Build time and offset+    let timeMicros = fromIntegral h * 3600_000_000 + fromIntegral m * 60_000_000 + fromIntegral s * 1_000_000 + micros+        -- Note: PostgreSQL stores offset with inverted sign (positive means west of UTC)+        offsetSeconds = negate sign * (fromIntegral tzH * 3600 + fromIntegral tzM * 60 + fromIntegral tzS)+    case (Time.refineFromMicroseconds timeMicros, Offset.refineFromSeconds offsetSeconds) of+      (Just time, Just offset) -> pure (Timetz time offset)+      _ -> fail "Invalid timetz value"+    where+      twoDigits = do+        a <- Attoparsec.digit+        b <- Attoparsec.digit+        pure (digitToInt a * 10 + digitToInt b)+      parseFraction = do+        _ <- Attoparsec.char '.'+        digits <- Attoparsec.takeWhile1 isDigit+        let paddedDigits = take 6 (Text.unpack digits ++ repeat '0')+            micros = foldl' (\acc c -> acc * 10 + fromIntegral (digitToInt c)) 0 paddedDigits+        pure micros++-- * Accessors++-- | Extract time in microseconds since midnight.+toTimeInMicroseconds :: Timetz -> Int64+toTimeInMicroseconds (Timetz time _) = Time.toMicroseconds time++-- | Extract time zone offset in seconds.+toTimeZoneInSeconds :: Timetz -> Int32+toTimeZoneInSeconds (Timetz _ offset) = Offset.toSeconds offset++-- | Extract time of day.+toTimeOfDay :: Timetz -> TimeLib.TimeOfDay+toTimeOfDay (Timetz time _) = Time.toTimeOfDay time++-- | Extract time zone rounding the offset in seconds to the nearest minute, because that's the precision supported by 'TimeLib.TimeZone'.+normalizeToTimeZone :: Timetz -> TimeLib.TimeZone+normalizeToTimeZone (Timetz _ offset) = Offset.normalizeToTimeZone offset++-- | Try to extract time zone, failing if the offset in seconds is not a multiple of 60.+refineToTimeZone :: Timetz -> Maybe TimeLib.TimeZone+refineToTimeZone (Timetz _ offset) = Offset.refineToTimeZone offset++-- * Constructors++-- | Construct 'Timetz' from time in microseconds since midnight and time zone offset in seconds, clamping the out of range values.+normalizeFromTimeInMicrosecondsAndOffsetInSeconds :: Int64 -> Int32 -> Timetz+normalizeFromTimeInMicrosecondsAndOffsetInSeconds microseconds offset =+  Timetz (Time.normalizeFromMicroseconds microseconds) (Offset.normalizeFromSeconds offset)++-- | Construct 'Timetz' from 'TimeLib.TimeOfDay' and 'TimeLib.TimeZone', clamping the out of range values.+normalizeFromTimeOfDayAndTimeZone :: TimeLib.TimeOfDay -> TimeLib.TimeZone -> Timetz+normalizeFromTimeOfDayAndTimeZone timeOfDay timeZone =+  let time = Time.normalizeFromTimeOfDay timeOfDay+      offset = Offset.normalizeFromTimeZone timeZone+   in Timetz time offset++-- | Try to construct 'Timetz' from time in microseconds since midnight and time zone offset in seconds, failing if out of range.+refineFromTimeInMicrosecondsAndOffsetInSeconds :: Int64 -> Int32 -> Maybe Timetz+refineFromTimeInMicrosecondsAndOffsetInSeconds microseconds offset = do+  time <- Time.refineFromMicroseconds microseconds+  offset <- Offset.refineFromSeconds offset+  pure (Timetz time offset)++-- | Try to construct 'Timetz' from 'TimeLib.TimeOfDay' and 'TimeLib.TimeZone', failing if out of range.+refineFromTimeOfDayAndTimeZone :: TimeLib.TimeOfDay -> TimeLib.TimeZone -> Maybe Timetz+refineFromTimeOfDayAndTimeZone timeOfDay timeZone = do+  time <- Time.refineFromTimeOfDay timeOfDay+  offset <- Offset.refineFromTimeZone timeZone+  pure (Timetz time offset)
+ src/library/PostgresqlTypes/Timetz/Offset.hs view
@@ -0,0 +1,106 @@+module PostgresqlTypes.Timetz.Offset where++import qualified Data.Time as Time+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder+import qualified TimeExtras.TimeZone as TimeZone++-- | Offset component of the @timetz@ type.+newtype TimetzOffset = TimetzOffset Int32+  deriving newtype (Eq, Ord, Show)++instance Arbitrary TimetzOffset where+  arbitrary = TimetzOffset <$> QuickCheck.choose (toSeconds minBound, toSeconds maxBound)++instance Bounded TimetzOffset where+  minBound = TimetzOffset (negate extemeInSeconds)+  maxBound = TimetzOffset extemeInSeconds++-- | @15:59:59@+extemeInSeconds :: Int32+extemeInSeconds =+  59 + 59 * 60 + 15 * 60 * 60++toSeconds :: TimetzOffset -> Int32+toSeconds (TimetzOffset seconds) = seconds++refineToTimeZone :: TimetzOffset -> Maybe Time.TimeZone+refineToTimeZone =+  TimeZone.refineFromSeconds . fromIntegral . toSeconds++normalizeToTimeZone :: TimetzOffset -> Time.TimeZone+normalizeToTimeZone =+  TimeZone.normalizeFromSeconds . fromIntegral . toSeconds++refineFromSeconds :: Int32 -> Maybe TimetzOffset+refineFromSeconds seconds+  | seconds >= toSeconds minBound && seconds <= toSeconds maxBound = Just (TimetzOffset seconds)+  | otherwise = Nothing++refineFromTimeZone :: Time.TimeZone -> Maybe TimetzOffset+refineFromTimeZone (Time.TimeZone minutes _ _) =+  let seconds = fromIntegral (minutes * 60)+   in refineFromSeconds seconds++-- | Clamp seconds to the valid range.+normalizeFromSeconds :: Int32 -> TimetzOffset+normalizeFromSeconds seconds =+  if seconds < toSeconds minBound+    then minBound+    else+      if seconds > toSeconds maxBound+        then maxBound+        else TimetzOffset seconds++normalizeFromTimeZone :: Time.TimeZone -> TimetzOffset+normalizeFromTimeZone (Time.TimeZone minutes _ _) =+  let seconds = fromIntegral (minutes * 60)+   in normalizeFromSeconds seconds++renderInTextFormat :: TimetzOffset -> TextBuilder.TextBuilder+renderInTextFormat (TimetzOffset seconds) =+  let (sign, seconds') = if seconds < 0 then ("+", negate seconds) else ("-", seconds)+      (minutes, seconds'') = divMod seconds' 60+      (hours, minutes') = divMod minutes 60+   in mconcat+        [ sign,+          TextBuilder.fixedLengthDecimal 2 hours,+          ":",+          TextBuilder.fixedLengthDecimal 2 minutes',+          ":",+          TextBuilder.fixedLengthDecimal 2 seconds''+        ]++binaryEncoder :: TimetzOffset -> Write.Write+binaryEncoder (TimetzOffset seconds) =+  Write.bInt32 seconds++binaryDecoder :: PtrPeeker.Fixed (Either DecodingError TimetzOffset)+binaryDecoder =+  PtrPeeker.beSignedInt4 <&> \int ->+    if int < toSeconds minBound+      then+        Left+          DecodingError+            { location = [],+              reason =+                UnsupportedValueDecodingErrorReason+                  "Value is less than minimum bound"+                  (TextBuilder.toText (TextBuilder.decimal int))+            }+      else+        if int > toSeconds maxBound+          then+            Left+              DecodingError+                { location = [],+                  reason =+                    UnsupportedValueDecodingErrorReason+                      "Value is greater than maximum bound"+                      (TextBuilder.toText (TextBuilder.decimal int))+                }+          else Right (TimetzOffset int)
+ src/library/PostgresqlTypes/Timetz/Time.hs view
@@ -0,0 +1,117 @@+module PostgresqlTypes.Timetz.Time where++import qualified Data.Time as Time+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder+import qualified TimeExtras.TimeOfDay as TimeOfDay++-- | Time component of the @timetz@ type.+newtype TimetzTime = TimetzTime Int64+  deriving newtype (Eq, Ord, Show)++instance Arbitrary TimetzTime where+  arbitrary = TimetzTime <$> QuickCheck.choose (toMicroseconds minBound, toMicroseconds maxBound)++instance Bounded TimetzTime where+  minBound = TimetzTime 0+  maxBound = TimetzTime 86_400_000_000++toMicroseconds :: TimetzTime -> Int64+toMicroseconds (TimetzTime microseconds) = microseconds++toTimeOfDay :: TimetzTime -> Time.TimeOfDay+toTimeOfDay =+  TimeOfDay.fromMicroseconds . fromIntegral . toMicroseconds++refineFromMicroseconds :: Int64 -> Maybe TimetzTime+refineFromMicroseconds microseconds+  | microseconds >= toMicroseconds minBound && microseconds <= toMicroseconds maxBound = Just (TimetzTime microseconds)+  | otherwise = Nothing++refineFromPicoseconds :: Integer -> Maybe TimetzTime+refineFromPicoseconds picoseconds =+  let (microseconds, picoseconds') = divMod picoseconds 1_000_000+   in if picoseconds' == 0+        then refineFromMicroseconds (fromIntegral microseconds)+        else Nothing++refineFromTimeOfDay :: Time.TimeOfDay -> Maybe TimetzTime+refineFromTimeOfDay (Time.TimeOfDay hours minutes picoseconds) =+  let MkFixed picoseconds' = picoseconds+      picoseconds'' = fromIntegral ((hours * 60 + minutes) * 60) * 1_000_000_000_000 + picoseconds'+   in refineFromPicoseconds picoseconds''++-- | Clamp the overflow values to the valid range.+normalizeFromMicroseconds :: Int64 -> TimetzTime+normalizeFromMicroseconds microseconds =+  if microseconds < toMicroseconds minBound+    then minBound+    else+      if microseconds > toMicroseconds maxBound+        then maxBound+        else TimetzTime microseconds++normalizeFromPicoseconds :: Integer -> TimetzTime+normalizeFromPicoseconds picoseconds =+  let microseconds = fromIntegral (mod (div picoseconds 1_000_000) 86_400_000_000)+   in TimetzTime microseconds++normalizeFromTimeOfDay :: Time.TimeOfDay -> TimetzTime+normalizeFromTimeOfDay (Time.TimeOfDay hours minutes picoseconds) =+  let MkFixed picoseconds' = picoseconds+      picoseconds'' = fromIntegral ((hours * 60 + minutes) * 60) * 1_000_000_000_000 + picoseconds'+   in normalizeFromPicoseconds picoseconds''++renderInTextFormat :: TimetzTime -> TextBuilder.TextBuilder+renderInTextFormat (TimetzTime microseconds) =+  -- Handle the special case of 24:00:00 (86400000000 microseconds)+  if microseconds == 86_400_000_000+    then "24:00:00"+    else+      let (seconds, microseconds') = divMod microseconds 1_000_000+          (minutes, seconds') = divMod seconds 60+          (hours, minutes') = divMod minutes 60+       in mconcat+            [ TextBuilder.fixedLengthDecimal 2 hours,+              ":",+              TextBuilder.fixedLengthDecimal 2 minutes',+              ":",+              TextBuilder.fixedLengthDecimal 2 seconds',+              if microseconds' == 0+                then ""+                else "." <> TextBuilder.fixedLengthDecimal 6 microseconds'+            ]++binaryEncoder :: TimetzTime -> Write.Write+binaryEncoder (TimetzTime microseconds) =+  Write.bInt64 microseconds++binaryDecoder :: PtrPeeker.Fixed (Either DecodingError TimetzTime)+binaryDecoder =+  PtrPeeker.beSignedInt8 <&> \int ->+    if int < toMicroseconds minBound+      then+        Left+          DecodingError+            { location = [],+              reason =+                UnsupportedValueDecodingErrorReason+                  "Value is less than minimum bound"+                  (TextBuilder.toText (TextBuilder.decimal int))+            }+      else+        if int > toMicroseconds maxBound+          then+            Left+              DecodingError+                { location = [],+                  reason =+                    UnsupportedValueDecodingErrorReason+                      "Value is greater than maximum bound"+                      (TextBuilder.toText (TextBuilder.decimal int))+                }+          else Right (TimetzTime int)
+ src/library/PostgresqlTypes/Uuid.hs view
@@ -0,0 +1,70 @@+module PostgresqlTypes.Uuid+  ( Uuid (..),++    -- * Accessors+    toUUID,++    -- * Constructors+    fromUUID,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.UUID+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified TextBuilder++-- | PostgreSQL @uuid@ type. Universally unique identifier.+--+-- Isomorphic to 'Data.UUID.UUID'.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-uuid.html).+newtype Uuid = Uuid Data.UUID.UUID+  deriving newtype (Eq, Ord, Hashable, Arbitrary)+  deriving (Show, Read, IsString) via (ViaIsScalar Uuid)++instance IsScalar Uuid where+  schemaName = Tagged Nothing+  typeName = Tagged "uuid"+  baseOid = Tagged (Just 2950)+  arrayOid = Tagged (Just 2951)+  typeParams = Tagged []+  binaryEncoder (Uuid uuid) =+    case Data.UUID.toWords uuid of+      (w1, w2, w3, w4) ->+        mconcat+          [ Write.bWord32 w1,+            Write.bWord32 w2,+            Write.bWord32 w3,+            Write.bWord32 w4+          ]+  binaryDecoder = PtrPeeker.fixed do+    (Right . Uuid)+      <$> ( Data.UUID.fromWords+              <$> PtrPeeker.beUnsignedInt4+              <*> PtrPeeker.beUnsignedInt4+              <*> PtrPeeker.beUnsignedInt4+              <*> PtrPeeker.beUnsignedInt4+          )+  textualEncoder = TextBuilder.text . Data.UUID.toText . coerce+  textualDecoder = do+    uuidText <- Attoparsec.takeText+    case Data.UUID.fromText uuidText of+      Nothing -> fail "Invalid UUID format"+      Just uuid -> pure (Uuid uuid)++-- * Accessors++-- | Extract the underlying 'Data.UUID.UUID' value.+toUUID :: Uuid -> Data.UUID.UUID+toUUID (Uuid uuid) = uuid++-- * Constructors++-- | Construct a PostgreSQL 'Uuid' from a 'Data.UUID.UUID' value.+fromUUID :: Data.UUID.UUID -> Uuid+fromUUID = Uuid
+ src/library/PostgresqlTypes/Varbit.hs view
@@ -0,0 +1,219 @@+module PostgresqlTypes.Varbit+  ( Varbit,++    -- * Accessors+    toBoolList,+    toBoolVector,++    -- * Constructors+    refineFromBoolList,+    normalizeFromBoolList,+    refineFromBoolVector,+    normalizeFromBoolVector,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Bits as Bits+import qualified Data.ByteString as ByteString+import qualified Data.Text as Text+import qualified Data.Vector.Generic as Vg+import qualified GHC.TypeLits as TypeLits+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @varbit(n)@ type. Variable-length bit string with limit.+--+-- Similar to @bit@ but with a variable length up to the specified maximum.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-bit.html).+--+-- The type parameter @maxLen@ specifies the static maximum length of the bit string.+-- Bit strings up to this length can be represented by this type.+data Varbit (maxLen :: TypeLits.Nat)+  = Varbit+      -- | Actual number of bits+      Int32+      -- | Bit data (packed into bytes)+      ByteString+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar (Varbit maxLen))++instance (TypeLits.KnownNat maxLen) => Arbitrary (Varbit maxLen) where+  arbitrary = do+    let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+    len <- QuickCheck.chooseInt (0, maxLen) -- Variable length up to max+    bits <- QuickCheck.vectorOf len (arbitrary :: QuickCheck.Gen Bool)+    case refineFromBoolList bits of+      Nothing -> error "Arbitrary Varbit: Generated bit string exceeds maximum length"+      Just varbit -> pure varbit+  shrink varbit =+    let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+        bits = toBoolList varbit+        shrunkBitsList = shrink bits+     in mapMaybe refineFromBoolList [b | b <- shrunkBitsList, length b <= maxLen]++instance Hashable (Varbit maxLen) where+  hashWithSalt salt (Varbit len bytes) = salt `hashWithSalt` len `hashWithSalt` bytes++instance (TypeLits.KnownNat maxLen) => IsScalar (Varbit maxLen) where+  schemaName = Tagged Nothing+  typeName = Tagged "varbit"+  baseOid = Tagged (Just 1562)+  arrayOid = Tagged (Just 1563)+  typeParams =+    Tagged [Text.pack (show (TypeLits.natVal (Proxy @maxLen)))]+  binaryEncoder (Varbit len bytes) =+    Write.bInt32 len <> Write.byteString bytes+  binaryDecoder =+    let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+     in do+          len <- PtrPeeker.fixed PtrPeeker.beSignedInt4+          bytes <- PtrPeeker.remainderAsByteString++          pure+            if len <= maxLen+              then Right (Varbit len bytes)+              else+                Left+                  ( DecodingError+                      { location = ["Varbit"],+                        reason =+                          UnsupportedValueDecodingErrorReason+                            ("Varbit length " <> Text.pack (show len) <> " exceeds maximum " <> Text.pack (show maxLen))+                            (TextBuilder.toText (TextBuilder.decimal len))+                      }+                  )+  textualEncoder (Varbit len bytes) =+    let bits = concatMap byteToBits (ByteString.unpack bytes)+        trimmedBits = take (fromIntegral len) bits+        bitString = map (\b -> if b then '1' else '0') trimmedBits+     in TextBuilder.text (Text.pack bitString)+    where+      byteToBits :: Word8 -> [Bool]+      byteToBits byte = [Bits.testBit byte i | i <- [7, 6, 5, 4, 3, 2, 1, 0]]+  textualDecoder =+    let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+     in do+          bitText <- Attoparsec.takeWhile (\c -> c == '0' || c == '1')+          let len = Text.length bitText+          when (len > maxLen) do+            fail ("Varbit length " <> show len <> " exceeds maximum " <> show maxLen)+          let boolList = map (== '1') (Text.unpack bitText)+              numBytes = (len + 7) `div` 8+              paddedBoolList = boolList ++ replicate (numBytes * 8 - len) False+              bytes = map boolsToByte (chunksOf 8 paddedBoolList)+          pure (Varbit (fromIntegral len) (ByteString.pack bytes))+    where+      boolsToByte :: [Bool] -> Word8+      boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+      chunksOf :: Int -> [a] -> [[a]]+      chunksOf _ [] = []+      chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- * Accessors++-- | Extract the bit string as a list of Bool.+toBoolList :: forall maxLen. (TypeLits.KnownNat maxLen) => Varbit maxLen -> [Bool]+toBoolList (Varbit len bytes) =+  let bits = concatMap byteToBits (ByteString.unpack bytes)+      trimmedBits = take (fromIntegral len) bits+   in trimmedBits+  where+    byteToBits :: Word8 -> [Bool]+    byteToBits byte = [Bits.testBit byte i | i <- [7, 6, 5, 4, 3, 2, 1, 0]]++-- | Extract the bit string as an unboxed vector of Bool.+toBoolVector :: forall maxLen vec. (TypeLits.KnownNat maxLen, Vg.Vector vec Bool) => Varbit maxLen -> vec Bool+toBoolVector (Varbit len bytes) =+  let bits = concatMap byteToBits (ByteString.unpack bytes)+      trimmedBits = take (fromIntegral len) bits+   in Vg.fromList trimmedBits+  where+    byteToBits :: Word8 -> [Bool]+    byteToBits byte = [Bits.testBit byte i | i <- [7, 6, 5, 4, 3, 2, 1, 0]]++-- * Constructors++-- | Construct a PostgreSQL 'Varbit' from a list of Bool with validation.+-- Returns 'Nothing' if the list length exceeds the maximum length.+refineFromBoolList :: forall maxLen. (TypeLits.KnownNat maxLen) => [Bool] -> Maybe (Varbit maxLen)+refineFromBoolList bits =+  let len = length bits+      maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+   in if len <= maxLen+        then+          let numBytes = (len + 7) `div` 8+              paddedBits = bits ++ replicate (numBytes * 8 - len) False+              bytes = map boolsToByte (chunksOf 8 paddedBits)+           in Just (Varbit (fromIntegral len) (ByteString.pack bytes))+        else Nothing+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Construct a PostgreSQL 'Varbit' from a list of Bool.+-- Truncates to the maximum length if necessary.+normalizeFromBoolList :: forall maxLen. (TypeLits.KnownNat maxLen) => [Bool] -> Varbit maxLen+normalizeFromBoolList bits =+  let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+      truncatedBits = take maxLen bits+      actualLen = length truncatedBits+      numBytes = (actualLen + 7) `div` 8+      paddedBits = truncatedBits ++ replicate (numBytes * 8 - actualLen) False+      bytes = map boolsToByte (chunksOf 8 paddedBits)+   in Varbit (fromIntegral actualLen) (ByteString.pack bytes)+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Construct a PostgreSQL 'Varbit' from an unboxed vector of Bool with validation.+-- Returns 'Nothing' if the vector length exceeds the maximum length.+refineFromBoolVector :: forall maxLen vec. (TypeLits.KnownNat maxLen, Vg.Vector vec Bool) => vec Bool -> Maybe (Varbit maxLen)+refineFromBoolVector bitVector =+  let bits = Vg.toList bitVector+      len = fromIntegral (Vg.length bitVector)+      maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+   in if len <= maxLen+        then+          let numBytes = (len + 7) `div` 8+              paddedBits = bits ++ replicate (numBytes * 8 - len) False+              bytes = map boolsToByte (chunksOf 8 paddedBits)+           in Just (Varbit (fromIntegral len) (ByteString.pack bytes))+        else Nothing+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Construct a PostgreSQL 'Varbit' from an unboxed vector of Bool.+-- Truncates to the maximum length if necessary.+normalizeFromBoolVector :: forall maxLen vec. (TypeLits.KnownNat maxLen, Vg.Vector vec Bool) => vec Bool -> Varbit maxLen+normalizeFromBoolVector bitVector =+  let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+      bits = Vg.toList bitVector+      truncatedBits = take maxLen bits+      actualLen = length truncatedBits+      numBytes = (actualLen + 7) `div` 8+      paddedBits = truncatedBits ++ replicate (numBytes * 8 - actualLen) False+      bytes = map boolsToByte (chunksOf 8 paddedBits)+   in Varbit (fromIntegral actualLen) (ByteString.pack bytes)+  where+    boolsToByte :: [Bool] -> Word8+    boolsToByte bs = foldl (\acc (i, b) -> if b then Bits.setBit acc i else acc) 0 (zip [7, 6, 5, 4, 3, 2, 1, 0] bs)+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf _ [] = []+    chunksOf n xs = take n xs : chunksOf n (drop n xs)
+ src/library/PostgresqlTypes/Varchar.hs view
@@ -0,0 +1,124 @@+module PostgresqlTypes.Varchar+  ( Varchar,++    -- * Accessors+    toText,++    -- * Constructors+    refineFromText,+    normalizeFromText,+  )+where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified GHC.TypeLits as TypeLits+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude+import PostgresqlTypes.Via+import qualified PtrPeeker+import qualified PtrPoker.Write as Write+import qualified Test.QuickCheck as QuickCheck+import qualified TextBuilder++-- | PostgreSQL @varchar(n)@ type. Variable-length character string with limit.+--+-- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-character.html).+--+-- The type parameter @maxLen@ specifies the static maximum length of the character string.+-- Character strings up to this length can be represented by this type.+newtype Varchar (maxLen :: TypeLits.Nat) = Varchar Text.Text+  deriving stock (Eq, Ord)+  deriving (Show, Read, IsString) via (ViaIsScalar (Varchar maxLen))+  deriving newtype (Hashable)++instance (TypeLits.KnownNat maxLen) => Arbitrary (Varchar maxLen) where+  arbitrary = do+    let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+    len <- QuickCheck.chooseInt (0, maxLen)+    charList <- QuickCheck.vectorOf len do+      QuickCheck.suchThat arbitrary (\char -> char /= '\NUL')+    pure (Varchar (Text.pack charList))+  shrink (Varchar base) =+    let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+        shrunk = Text.pack <$> shrink (Text.unpack base)+     in [Varchar txt | txt <- shrunk, Text.length txt <= maxLen]++instance (TypeLits.KnownNat maxLen) => IsScalar (Varchar maxLen) where+  schemaName = Tagged Nothing+  typeName = Tagged "varchar"+  baseOid = Tagged (Just 1043)+  arrayOid = Tagged (Just 1015)+  typeParams =+    Tagged [Text.pack (show (TypeLits.natVal (Proxy @maxLen)))]+  binaryEncoder (Varchar base) = Write.textUtf8 base+  binaryDecoder = do+    bytes <- PtrPeeker.remainderAsByteString+    pure case Text.Encoding.decodeUtf8' bytes of+      Left _ ->+        Left+          ( DecodingError+              { location = ["Varchar"],+                reason =+                  ParsingDecodingErrorReason+                    "Invalid UTF-8 in Varchar"+                    bytes+              }+          )+      Right base ->+        let len = Text.length base+            maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+         in if len <= maxLen+              then Right (Varchar base)+              else+                Left+                  ( DecodingError+                      { location = ["Varchar"],+                        reason =+                          UnsupportedValueDecodingErrorReason+                            ("Varchar string length " <> Text.pack (show len) <> " exceeds maximum " <> Text.pack (show maxLen))+                            ( if len > 100+                                then Text.take 100 base <> "..."+                                else base+                            )+                      }+                  )+  textualEncoder (Varchar base) = TextBuilder.text base+  textualDecoder = do+    text <- Attoparsec.takeText+    let len = Text.length text+        maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+    if len <= maxLen+      then pure (Varchar text)+      else fail ("Varchar string length " <> show len <> " exceeds maximum " <> show maxLen)++-- * Accessors++-- | Extract the underlying 'Text' value.+toText :: forall maxLen. (TypeLits.KnownNat maxLen) => Varchar maxLen -> Text+toText (Varchar text) = text++-- * Constructors++-- | Construct a PostgreSQL 'Varchar' from 'Text' with validation.+-- Returns 'Nothing' if the text contains NUL characters or exceeds the maximum length.+refineFromText :: forall maxLen. (TypeLits.KnownNat maxLen) => Text -> Maybe (Varchar maxLen)+refineFromText text =+  let len = Text.length text+      maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+   in if Text.elem '\NUL' text+        then Nothing+        else+          if len <= maxLen+            then Just (Varchar text)+            else Nothing++-- | Construct a PostgreSQL 'Varchar' from 'Text', normalizing invalid values.+-- Removes NUL characters and truncates to the maximum length.+normalizeFromText :: forall maxLen. (TypeLits.KnownNat maxLen) => Text -> Varchar maxLen+normalizeFromText text =+  let maxLen = fromIntegral (TypeLits.natVal (Proxy @maxLen))+      cleanedText = Text.replace "\NUL" "" text+      truncatedText = Text.take maxLen cleanedText+   in Varchar truncatedText
+ src/library/PostgresqlTypes/Via.hs view
@@ -0,0 +1,6 @@+module PostgresqlTypes.Via+  ( module PostgresqlTypes.Via.IsScalar,+  )+where++import PostgresqlTypes.Via.IsScalar
+ src/library/PostgresqlTypes/Via/IsScalar.hs view
@@ -0,0 +1,26 @@+module PostgresqlTypes.Via.IsScalar where++import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Text as Text+import PostgresqlTypes.Algebra+import PostgresqlTypes.Prelude++newtype ViaIsScalar a = ViaIsScalar a+  deriving newtype (Eq, Ord, Arbitrary, IsScalar)++instance (IsScalar a) => Show (ViaIsScalar a) where+  showsPrec d (ViaIsScalar a) = showsPrec d (textualEncoder a)++instance (IsScalar a) => Read (ViaIsScalar a) where+  readsPrec d str =+    [ (ViaIsScalar a, rest)+    | (txt, rest) <- readsPrec d str,+      let parsed = Attoparsec.parseOnly (textualDecoder @a <* Attoparsec.endOfInput) txt,+      Right a <- [parsed]+    ]++instance (IsScalar a) => IsString (ViaIsScalar a) where+  fromString string =+    case Attoparsec.parseOnly (textualDecoder @a <* Attoparsec.endOfInput) (Text.pack string) of+      Left err -> error ("ViaIsScalar fromString: failed to parse: " <> err)+      Right a -> ViaIsScalar a
+ src/pq-procedures/PqProcedures.hs view
@@ -0,0 +1,8 @@+module PqProcedures+  ( module PqProcedures.Procedures,+    module PqProcedures.Algebra,+  )+where++import PqProcedures.Algebra+import PqProcedures.Procedures
+ src/pq-procedures/PqProcedures/Algebra.hs view
@@ -0,0 +1,7 @@+module PqProcedures.Algebra where++import qualified Database.PostgreSQL.LibPQ as Pq+import Prelude++class Procedure params result | params -> result where+  run :: Pq.Connection -> params -> IO result
+ src/pq-procedures/PqProcedures/Procedures.hs view
@@ -0,0 +1,10 @@+module PqProcedures.Procedures+  ( module PqProcedures.Procedures.GetTypeInfoByName,+    module PqProcedures.Procedures.RunRoundtripQuery,+    module PqProcedures.Procedures.RunStatement,+  )+where++import PqProcedures.Procedures.GetTypeInfoByName+import PqProcedures.Procedures.RunRoundtripQuery+import PqProcedures.Procedures.RunStatement
+ src/pq-procedures/PqProcedures/Procedures/GetTypeInfoByName.hs view
@@ -0,0 +1,61 @@+module PqProcedures.Procedures.GetTypeInfoByName+  ( GetTypeInfoByNameParams (..),+    GetTypeInfoByNameResult (..),+  )+where++import Data.Maybe+import Data.Text (Text)+import qualified Data.Text.Encoding as Text.Encoding+import Data.Word+import qualified Database.PostgreSQL.LibPQ as Pq+import PqProcedures.Algebra+import PqProcedures.Procedures.RunStatement+import qualified PtrPeeker+import Prelude++newtype GetTypeInfoByNameParams = GetTypeInfoByNameParams+  { name :: Text+  }++data GetTypeInfoByNameResult = GetTypeInfoByNameResult+  { baseOid :: Maybe Word32,+    arrayOid :: Maybe Word32+  }++instance Procedure GetTypeInfoByNameParams GetTypeInfoByNameResult where+  run connection GetTypeInfoByNameParams {name} = do+    run+      connection+      RunStatementParams+        { sql =+            "SELECT t.oid AS base_oid, t.typarray AS array_oid\n\+            \FROM pg_type t\n\+            \WHERE t.typname = $1\n\+            \LIMIT 1",+          params =+            [ Just+                ( 25, -- OID of TEXT+                  Text.Encoding.encodeUtf8 name,+                  Pq.Binary+                )+            ],+          resultFormat = Pq.Binary+        }+      >>= processPqResult++processPqResult :: Pq.Result -> IO GetTypeInfoByNameResult+processPqResult result = do+  baseOid <- readOid 0 0+  arrayOid <- readOid 0 1+  pure GetTypeInfoByNameResult {baseOid, arrayOid}+  where+    readOid x y =+      Pq.getvalue result x y >>= \case+        Nothing -> pure Nothing+        Just bs ->+          case PtrPeeker.runVariableOnByteString decoder bs of+            Left _err -> fail ("Failed to read OID from database, data: " <> show bs)+            Right value -> pure (Just value)+      where+        decoder = PtrPeeker.fixed PtrPeeker.beUnsignedInt4
+ src/pq-procedures/PqProcedures/Procedures/RunRoundtripQuery.hs view
@@ -0,0 +1,44 @@+module PqProcedures.Procedures.RunRoundtripQuery+  ( RunRoundtripQueryParams (..),+    RunRoundtripQueryResult,+  )+where++import qualified Data.ByteString as ByteString+import Data.Maybe+import qualified Data.Text as Text+import Data.Word+import qualified Database.PostgreSQL.LibPQ as Pq+import PqProcedures.Algebra+import PqProcedures.Procedures.RunStatement+import Prelude++data RunRoundtripQueryParams = RunRoundtripQueryParams+  { paramOid :: Word32,+    paramEncoding :: ByteString.ByteString,+    paramFormat :: Pq.Format,+    resultFormat :: Pq.Format,+    typeSignature :: Maybe Text.Text+  }++type RunRoundtripQueryResult = ByteString.ByteString++instance Procedure RunRoundtripQueryParams RunRoundtripQueryResult where+  run connection (RunRoundtripQueryParams {..}) = do+    let sql = case typeSignature of+          Nothing -> "SELECT $1"+          Just sig -> "SELECT $1::" <> sig+    pqResult <-+      run+        connection+        RunStatementParams+          { sql = sql,+            params =+              [ Just (paramOid, paramEncoding, paramFormat)+              ],+            resultFormat = resultFormat+          }+    bytes <- Pq.getvalue pqResult 0 0+    case bytes of+      Nothing -> fail "getvalue produced no bytes"+      Just bytes -> pure bytes
+ src/pq-procedures/PqProcedures/Procedures/RunStatement.hs view
@@ -0,0 +1,56 @@+module PqProcedures.Procedures.RunStatement+  ( RunStatementParams (..),+    RunStatementResult,+  )+where++import qualified Data.ByteString as ByteString+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import Data.Word+import qualified Database.PostgreSQL.LibPQ as Pq+import PqProcedures.Algebra+import TextBuilder (TextBuilder)+import qualified TextBuilder+import Prelude++data RunStatementParams = RunStatementParams+  { sql :: Text.Text,+    -- | Params+    params ::+      [ Maybe+          ( Word32,+            ByteString.ByteString,+            Pq.Format+          )+      ],+    -- | Result format.+    resultFormat :: Pq.Format+  }++type RunStatementResult = Pq.Result++instance Procedure RunStatementParams RunStatementResult where+  run connection (RunStatementParams sql params resultFormat) = do+    result <-+      Pq.execParams+        connection+        (Text.Encoding.encodeUtf8 sql)+        (fmap (fmap (\(oid, encoding, format) -> (Pq.Oid (fromIntegral oid), encoding, format))) params)+        resultFormat+    result <- case result of+      Nothing -> do+        m <- Pq.errorMessage connection+        failWithSql "No result" (maybe "" Text.Encoding.decodeUtf8 m)+      Just result -> pure result+    resultErrorField <- Pq.resultErrorField result Pq.DiagMessagePrimary+    case resultErrorField of+      Nothing -> pure ()+      Just err -> failWithSql "Error field present" (Text.Encoding.decodeUtf8 err)+    pure result+    where+      failWithSql :: Text -> Text -> IO a+      failWithSql msg reason =+        fail (Text.unpack (msg <> "\nDue to:\n\t\t" <> reason <> "\nQuery:\n\t\t" <> sql))
+ src/time-extras/TimeExtras/TimeOfDay.hs view
@@ -0,0 +1,32 @@+module TimeExtras.TimeOfDay where++import Control.Monad+import Data.Fixed+import Data.Time+import Prelude++fromMicroseconds :: Int -> TimeOfDay+fromMicroseconds microseconds =+  -- Handle the special case of 24:00:00 (86400000000 microseconds)+  if microseconds == 86_400_000_000+    then TimeOfDay 24 0 0+    else+      let (minutes, microseconds') = divMod microseconds 60_000_000+          (hours, minutes') = divMod minutes 60+          picoseconds = MkFixed (fromIntegral microseconds' * 1_000_000)+       in TimeOfDay hours minutes' picoseconds++normalizeToMicroseconds :: TimeOfDay -> Int+normalizeToMicroseconds (TimeOfDay hours minutes picoseconds) =+  let MkFixed picoseconds' = picoseconds+      microseconds = div picoseconds' 1_000_000+      microseconds' = fromIntegral ((hours * 60 + minutes) * 60) * 1_000_000 + fromIntegral microseconds+   in microseconds'++refineToMicroseconds :: TimeOfDay -> Maybe Int+refineToMicroseconds (TimeOfDay hours minutes picoseconds) = do+  let MkFixed picoseconds' = picoseconds+      (microseconds, remainder) = divMod picoseconds' 1_000_000+  guard (remainder == 0)+  let microseconds' = fromIntegral ((hours * 60 + minutes) * 60) * 1_000_000 + fromIntegral microseconds+  pure microseconds'
+ src/time-extras/TimeExtras/TimeZone.hs view
@@ -0,0 +1,40 @@+module TimeExtras.TimeZone where++import Data.Time+import Prelude++fromMinutes :: Int -> TimeZone+fromMinutes = minutesToTimeZone++-- |+-- Normalize, canonicalize, compress.+normalizeFromSeconds :: Int -> TimeZone+normalizeFromSeconds seconds =+  if seconds < 0+    then fromSignerAndAbsSeconds negate (negate seconds)+    else fromSignerAndAbsSeconds id seconds+  where+    fromSignerAndAbsSeconds signer seconds =+      let minutes = signer (div seconds 60)+       in fromMinutes minutes++-- |+-- Compile, distill, rectify seconds. Extract from seconds.+refineFromSeconds :: Int -> Maybe TimeZone+refineFromSeconds seconds =+  if seconds < 0+    then fromSignerAndAbsSeconds negate (negate seconds)+    else fromSignerAndAbsSeconds id seconds+  where+    fromSignerAndAbsSeconds signer seconds =+      let (minutes, remainder) = divMod seconds 60+       in if remainder == 0+            then Just (fromMinutes (signer minutes))+            else Nothing++toMinutes :: TimeZone -> Int+toMinutes (TimeZone minutes _ _) = minutes++-- | Dilute.+toSeconds :: TimeZone -> Int+toSeconds (TimeZone minutes _ _) = minutes * 60
+ src/unit-tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/unit-tests/PostgresqlTypes/BitSpec.hs view
@@ -0,0 +1,77 @@+module PostgresqlTypes.BitSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Vector.Unboxed as VU+import qualified PostgresqlTypes.Bit as Bit+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Bit.Bit 0))+    Scripts.testShowRead (Proxy @(Bit.Bit 1))+    Scripts.testShowRead (Proxy @(Bit.Bit 8))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Bit.Bit 0))+    Scripts.testIsScalar (Proxy @(Bit.Bit 1))+    Scripts.testIsScalar (Proxy @(Bit.Bit 64))++  describe "Bit 8" do+    describe "Constructors" do+      describe "normalizeFromBoolList" do+        it "creates Bit from list of correct length" do+          let bit = Bit.normalizeFromBoolList @8 [True, False, True, False, True, False, True, False]+          Bit.toBoolList bit `shouldBe` [True, False, True, False, True, False, True, False]++        it "truncates list longer than required" do+          let bit = Bit.normalizeFromBoolList @8 [True, False, True, False, True, False, True, False, True, True]+          length (Bit.toBoolList bit) `shouldBe` 8++        it "pads list shorter than required" do+          let bit = Bit.normalizeFromBoolList @8 [True, False, True]+          length (Bit.toBoolList bit) `shouldBe` 8++      describe "refineFromBoolList" do+        it "rejects list with incorrect length" do+          Bit.refineFromBoolList @8 [True, False, True] `shouldBe` Nothing+          Bit.refineFromBoolList @8 (replicate 10 True) `shouldBe` Nothing++        it "accepts list with correct length" do+          let result = Bit.refineFromBoolList @8 (replicate 8 True)+          result `shouldSatisfy` isJust++      describe "normalizeFromBoolVector" do+        it "creates Bit from vector" do+          let vec = VU.fromList [True, False, True, False, True, False, True, False]+              bit = Bit.normalizeFromBoolVector @8 vec+          Bit.toBoolVector bit `shouldBe` vec++    describe "Accessors" do+      describe "toBoolList" do+        it "extracts Bool list" do+          let bit = Bit.normalizeFromBoolList @8 [True, True, False, False, True, True, False, False]+          Bit.toBoolList bit `shouldBe` [True, True, False, False, True, True, False, False]++      describe "toBoolVector" do+        it "extracts Bool vector" do+          let bools = [True, False, True, False, True, False, True, False]+              bit = Bit.normalizeFromBoolList @8 bools+          VU.toList (Bit.toBoolVector bit) `shouldBe` bools++    describe "Property Tests" do+      it "roundtrips through toBoolList and normalizeFromBoolList" do+        property \(bit :: Bit.Bit 8) ->+          let bools = Bit.toBoolList bit+              bit' = Bit.normalizeFromBoolList @8 bools+           in bit' === bit++      it "roundtrips through toBoolVector and normalizeFromBoolVector" do+        property \(bit :: Bit.Bit 8) ->+          let vec = Bit.toBoolVector bit :: VU.Vector Bool+              bit' = Bit.normalizeFromBoolVector @8 vec+           in bit' === bit
+ src/unit-tests/PostgresqlTypes/BoolSpec.hs view
@@ -0,0 +1,49 @@+module PostgresqlTypes.BoolSpec (spec) where++import qualified Data.Bool+import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Bool as Bool+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Bool.Bool)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Bool.Bool)++  describe "Constructors" do+    describe "fromBool" do+      it "creates Bool from True" do+        let pgBool = Bool.fromBool True+        Bool.toBool pgBool `shouldBe` True++      it "creates Bool from False" do+        let pgBool = Bool.fromBool False+        Bool.toBool pgBool `shouldBe` False++  describe "Accessors" do+    describe "toBool" do+      it "extracts True correctly" do+        let pgBool = Bool.fromBool True+        Bool.toBool pgBool `shouldBe` True++      it "extracts False correctly" do+        let pgBool = Bool.fromBool False+        Bool.toBool pgBool `shouldBe` False++  describe "Property Tests" do+    it "roundtrips through toBool and fromBool" do+      property \(b :: Data.Bool.Bool) ->+        let pgBool = Bool.fromBool b+         in Bool.toBool pgBool === b++    it "roundtrips through fromBool and toBool" do+      property \(pgBool :: Bool.Bool) ->+        let b = Bool.toBool pgBool+            pgBool' = Bool.fromBool b+         in pgBool' === pgBool
+ src/unit-tests/PostgresqlTypes/BoxSpec.hs view
@@ -0,0 +1,51 @@+module PostgresqlTypes.BoxSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Box as Box+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Box.Box)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Box.Box)++  describe "Constructors" do+    describe "normalizeFromCorners" do+      it "normalizes corners to ensure x1<=x2 and y1<=y2" $ property \x1 y1 x2 y2 -> do+        let box = Box.normalizeFromCorners x1 y1 x2 y2+        Box.toX1 box <= Box.toX2 box .&&. Box.toY1 box <= Box.toY2 box++      it "creates Box from corner coordinates" do+        -- Assuming normalizeFromCorners x1 y1 x2 y2+        let box = Box.normalizeFromCorners 1.0 2.0 3.0 4.0+            x1 = Box.toX1 box+            y1 = Box.toY1 box+            x2 = Box.toX2 box+            y2 = Box.toY2 box+        -- Behavior depends on normalization logic (usually HighRight, LowLeft or similar)+        -- Just checking values exist and match one of inputs+        [x1, x2] `shouldContain` [1.0, 3.0]+        [y1, y2] `shouldContain` [2.0, 4.0]++  describe "Accessors" do+    describe "toX1 / toY1 / toX2 / toY2" do+      it "extracts coordinates" do+        let box = Box.normalizeFromCorners 1.0 2.0 3.0 4.0+        -- Just ensuring it runs and returns values+        Box.toX1 box `shouldSatisfy` const True++  describe "Property Tests" do+    it "roundtrips through accessors and constructor (normalization aware)" do+      property $ \(box :: Box.Box) ->+        let x1 = Box.toX1 box+            y1 = Box.toY1 box+            x2 = Box.toX2 box+            y2 = Box.toY2 box+            box' = Box.normalizeFromCorners x1 y1 x2 y2+         in box' === box
+ src/unit-tests/PostgresqlTypes/BpcharSpec.hs view
@@ -0,0 +1,67 @@+module PostgresqlTypes.BpcharSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Text as Text+import qualified PostgresqlTypes.Bpchar as Bpchar+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Bpchar.Bpchar 1))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Bpchar.Bpchar 1))+    Scripts.testIsScalar (Proxy @(Bpchar.Bpchar 42))++  describe "Bpchar 10" do+    describe "Constructors" do+      describe "normalizeFromText" do+        it "truncates text exceeding max length" do+          let bpchar = Bpchar.normalizeFromText @10 "Hello World!"+          Text.length (Bpchar.toText bpchar) `shouldBe` 10++        it "pads text shorter than max length" do+          let bpchar = Bpchar.normalizeFromText @10 "Hello"+          Bpchar.toText bpchar `shouldBe` "Hello     "++        it "preserves characters including null" do+          let bpchar = Bpchar.normalizeFromText @10 "hel\NULlo"+          -- normalizeFromText doesn't strip null characters, it just truncates/pads+          -- The null character is preserved in the first 10 characters+          Text.length (Bpchar.toText bpchar) `shouldBe` 10++      describe "refineFromText" do+        it "rejects text exceeding max length" do+          Bpchar.refineFromText @10 "Hello World!" `shouldBe` Nothing++        it "rejects text with null characters" do+          Bpchar.refineFromText @10 "hel\NULlo" `shouldBe` Nothing++        it "accepts valid text with exact length" do+          let result = Bpchar.refineFromText @10 "HelloWorld"+          result `shouldSatisfy` isJust+          fmap Bpchar.toText result `shouldBe` Just "HelloWorld"++    describe "Accessors" do+      describe "toText" do+        it "extracts text value (padded)" do+          let bpchar = Bpchar.normalizeFromText @10 "test"+          Bpchar.toText bpchar `shouldBe` "test      "++    describe "Property Tests" do+      it "normalizeFromText is idempotent" do+        property \(t :: Text.Text) ->+          let normalized1 = Bpchar.normalizeFromText @10 t+              normalized2 = Bpchar.normalizeFromText @10 (Bpchar.toText normalized1)+           in normalized1 === normalized2++      it "refineFromText succeeds for valid bpchars" do+        property \(bpchar :: Bpchar.Bpchar 10) ->+          let t = Bpchar.toText bpchar+              refined = Bpchar.refineFromText @10 t+           in refined === Just bpchar
+ src/unit-tests/PostgresqlTypes/ByteaSpec.hs view
@@ -0,0 +1,52 @@+module PostgresqlTypes.ByteaSpec (spec) where++import qualified Data.ByteString as ByteString+import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Bytea as Bytea+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Bytea.Bytea)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Bytea.Bytea)++  describe "Constructors" do+    describe "fromByteString" do+      it "creates Bytea from ByteString" do+        let bs = ByteString.pack [1, 2, 3, 4, 5]+            pgBytea = Bytea.fromByteString bs+        Bytea.toByteString pgBytea `shouldBe` bs++      it "creates Bytea from empty ByteString" do+        let bs = ByteString.empty+            pgBytea = Bytea.fromByteString bs+        Bytea.toByteString pgBytea `shouldBe` bs++      it "preserves binary data" do+        let bs = ByteString.pack [0, 255, 128, 1, 127]+            pgBytea = Bytea.fromByteString bs+        Bytea.toByteString pgBytea `shouldBe` bs++  describe "Accessors" do+    describe "toByteString" do+      it "extracts ByteString value" do+        let bs = ByteString.pack [10, 20, 30]+            pgBytea = Bytea.fromByteString bs+        Bytea.toByteString pgBytea `shouldBe` bs++  describe "Property Tests" do+    it "roundtrips through toByteString and fromByteString" do+      property \(bs :: ByteString.ByteString) ->+        let pgBytea = Bytea.fromByteString bs+         in Bytea.toByteString pgBytea === bs++    it "roundtrips through fromByteString and toByteString" do+      property \(pgBytea :: Bytea.Bytea) ->+        let bs = Bytea.toByteString pgBytea+            pgBytea' = Bytea.fromByteString bs+         in pgBytea' === pgBytea
+ src/unit-tests/PostgresqlTypes/CharSpec.hs view
@@ -0,0 +1,71 @@+module PostgresqlTypes.CharSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import Data.Word+import qualified PostgresqlTypes.Char as PgChar+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude hiding (Char)++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @PgChar.Char)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @PgChar.Char)++  describe "Constructors" do+    describe "normalizeFromWord8" do+      it "creates Char from ASCII byte" do+        let pgChar = PgChar.normalizeFromWord8 65 -- 'A'+        PgChar.toWord8 pgChar `shouldBe` 65++      it "clears bit 7 for values above 127" do+        let pgChar = PgChar.normalizeFromWord8 200 -- Binary: 11001000+        PgChar.toWord8 pgChar `shouldBe` 72 -- Binary: 01001000 (bit 7 cleared)+    describe "refineFromWord8" do+      it "accepts ASCII values (0-127)" do+        let result = PgChar.refineFromWord8 65+        result `shouldSatisfy` isJust+        fmap PgChar.toWord8 result `shouldBe` Just 65++      it "rejects values above 127" do+        PgChar.refineFromWord8 128 `shouldBe` Nothing+        PgChar.refineFromWord8 255 `shouldBe` Nothing++    describe "normalizeFromChar" do+      it "creates Char from Haskell Char" do+        let pgChar = PgChar.normalizeFromChar 'A'+        PgChar.toChar pgChar `shouldBe` 'A'++    describe "refineFromChar" do+      it "accepts ASCII characters" do+        let result = PgChar.refineFromChar 'Z'+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toWord8" do+      it "extracts Word8 value" do+        let pgChar = PgChar.normalizeFromWord8 42+        PgChar.toWord8 pgChar `shouldBe` 42++    describe "toChar" do+      it "extracts Haskell Char" do+        let pgChar = PgChar.normalizeFromChar 'B'+        PgChar.toChar pgChar `shouldBe` 'B'++  describe "Property Tests" do+    it "roundtrips through toWord8 and normalizeFromWord8 for valid ASCII" do+      property \(w :: Word8) ->+        w <= 127 ==>+          let pgChar = PgChar.normalizeFromWord8 w+           in PgChar.toWord8 pgChar === w++    it "roundtrips through normalizeFromWord8 and toWord8" do+      property \(pgChar :: PgChar.Char) ->+        let w = PgChar.toWord8 pgChar+            pgChar' = PgChar.normalizeFromWord8 w+         in pgChar' === pgChar
+ src/unit-tests/PostgresqlTypes/CidrSpec.hs view
@@ -0,0 +1,290 @@+module PostgresqlTypes.CidrSpec (spec) where++import Data.Bits+import Data.Data (Proxy (Proxy))+import Data.Maybe+import Data.Word+import qualified PostgresqlTypes.Cidr as Cidr+import Test.Hspec+import Test.QuickCheck hiding ((.&.))+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Cidr.Cidr)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Cidr.Cidr)++  describe "IPv4 Constructors" do+    describe "normalizeFromV4" do+      it "clamps netmask values above maximum (32)" do+        let cidr = Cidr.normalizeFromV4 0xC0A80000 50+            (_, netmask) = fromJust (Cidr.refineToV4 cidr)+        netmask `shouldBe` 32++      it "accepts netmask at maximum (32)" do+        let cidr = Cidr.normalizeFromV4 0xC0A80000 32+            (_, netmask) = fromJust (Cidr.refineToV4 cidr)+        netmask `shouldBe` 32++      it "accepts netmask at minimum (0)" do+        let cidr = Cidr.normalizeFromV4 0xC0A80000 0+            (_, netmask) = fromJust (Cidr.refineToV4 cidr)+        netmask `shouldBe` 0++      it "zeros out host bits for /24 network" do+        let cidr = Cidr.normalizeFromV4 0xC0A80001 24 -- 192.168.0.1/24+            (addr, netmask) = fromJust (Cidr.refineToV4 cidr)+        addr `shouldBe` 0xC0A80000 -- Should be 192.168.0.0+        netmask `shouldBe` 24++      it "preserves network address when host bits are already zero" do+        let addr = 0xC0A80000 -- 192.168.0.0+            cidr = Cidr.normalizeFromV4 addr 24+            (addr', netmask) = fromJust (Cidr.refineToV4 cidr)+        addr' `shouldBe` addr+        netmask `shouldBe` 24++    describe "refineFromV4" do+      it "rejects netmask values above maximum (32)" do+        Cidr.refineFromV4 0xC0A80000 33 `shouldBe` Nothing++      it "accepts netmask at maximum (32)" do+        let result = Cidr.refineFromV4 0xC0A80000 32+        result `shouldSatisfy` isJust++      it "accepts netmask at minimum (0)" do+        let result = Cidr.refineFromV4 0x00000000 0+        result `shouldSatisfy` isJust++      it "rejects address with non-zero host bits" do+        let result = Cidr.refineFromV4 0xC0A80001 24 -- 192.168.0.1/24+        result `shouldBe` Nothing++      it "accepts address with zero host bits" do+        let addr = 0xC0A80000 -- 192.168.0.0/24+            result = Cidr.refineFromV4 addr 24+        case result of+          Just cidr -> do+            let (addr', netmask) = fromJust (Cidr.refineToV4 cidr)+            addr' `shouldBe` addr+            netmask `shouldBe` 24+          Nothing -> expectationFailure "Expected Just but got Nothing"++  describe "IPv6 Constructors" do+    describe "normalizeFromV6" do+      it "clamps netmask values above maximum (128)" do+        let cidr = Cidr.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 200+            (_, _, _, _, netmask) = fromJust (Cidr.refineToV6 cidr)+        netmask `shouldBe` 128++      it "accepts netmask at maximum (128)" do+        let cidr = Cidr.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 128+            (_, _, _, _, netmask) = fromJust (Cidr.refineToV6 cidr)+        netmask `shouldBe` 128++      it "accepts netmask at minimum (0)" do+        let cidr = Cidr.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 0+            (_, _, _, _, netmask) = fromJust (Cidr.refineToV6 cidr)+        netmask `shouldBe` 0++      it "zeros out host bits for /64 network" do+        let cidr = Cidr.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 64 -- 2001:db8::/64 with host bits+            (w1, w2, w3, w4, netmask) = fromJust (Cidr.refineToV6 cidr)+        w1 `shouldBe` 0x20010DB8+        w2 `shouldBe` 0x00000000+        w3 `shouldBe` 0x00000000+        w4 `shouldBe` 0x00000000 -- Host bits should be zero+        netmask `shouldBe` 64++      it "preserves network address when host bits are already zero" do+        let w1 = 0x20010DB8+            w2 = 0x00000000+            w3 = 0x00000000+            w4 = 0x00000000+            cidr = Cidr.normalizeFromV6 w1 w2 w3 w4 64+            (w1', w2', w3', w4', netmask) = fromJust (Cidr.refineToV6 cidr)+        w1' `shouldBe` w1+        w2' `shouldBe` w2+        w3' `shouldBe` w3+        w4' `shouldBe` w4+        netmask `shouldBe` 64++    describe "refineFromV6" do+      it "rejects netmask values above maximum (128)" do+        Cidr.refineFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 129 `shouldBe` Nothing++      it "accepts netmask at maximum (128)" do+        let result = Cidr.refineFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 128+        result `shouldSatisfy` isJust++      it "accepts netmask at minimum (0)" do+        let result = Cidr.refineFromV6 0x00000000 0x00000000 0x00000000 0x00000000 0+        result `shouldSatisfy` isJust++      it "rejects address with non-zero host bits" do+        let result = Cidr.refineFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 64 -- Has host bits+        result `shouldBe` Nothing++      it "accepts address with zero host bits" do+        let w1 = 0x20010DB8+            w2 = 0x00000000+            w3 = 0x00000000+            w4 = 0x00000000+            result = Cidr.refineFromV6 w1 w2 w3 w4 64+        case result of+          Just cidr -> do+            let (w1', w2', w3', w4', netmask) = fromJust (Cidr.refineToV6 cidr)+            w1' `shouldBe` w1+            w2' `shouldBe` w2+            w3' `shouldBe` w3+            w4' `shouldBe` w4+            netmask `shouldBe` 64+          Nothing -> expectationFailure "Expected Just but got Nothing"++  describe "Accessors" do+    describe "refineToV4" do+      it "extracts IPv4 network address and netmask" do+        let addr = 0xC0A80000 -- 192.168.0.0+            cidr = Cidr.normalizeFromV4 addr 24+            result = Cidr.refineToV4 cidr+        case result of+          Just (addr', netmask) -> do+            addr' `shouldBe` addr+            netmask `shouldBe` 24+          Nothing -> expectationFailure "Expected Just for IPv4"++      it "returns Nothing for IPv6 address" do+        let cidr = Cidr.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 64+        Cidr.refineToV4 cidr `shouldBe` Nothing++    describe "refineToV6" do+      it "extracts IPv6 network address and netmask" do+        let w1 = 0x20010DB8+            w2 = 0x00000000+            w3 = 0x00000000+            w4 = 0x00000000+            cidr = Cidr.normalizeFromV6 w1 w2 w3 w4 64+            result = Cidr.refineToV6 cidr+        case result of+          Just (w1', w2', w3', w4', netmask) -> do+            w1' `shouldBe` w1+            w2' `shouldBe` w2+            w3' `shouldBe` w3+            w4' `shouldBe` w4+            netmask `shouldBe` 64+          Nothing -> expectationFailure "Expected Just for IPv6"++      it "returns Nothing for IPv4 address" do+        let cidr = Cidr.normalizeFromV4 0xC0A80000 24+        Cidr.refineToV6 cidr `shouldBe` Nothing++    describe "fold" do+      it "handles IPv4 case" do+        let cidr = Cidr.normalizeFromV4 0xC0A80000 24+            result =+              Cidr.fold+                (\addr netmask -> Left (addr, netmask))+                (\_ _ _ _ _ -> Right ())+                cidr+        result `shouldBe` Left (0xC0A80000, 24)++      it "handles IPv6 case" do+        let cidr = Cidr.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000000 64+            result =+              Cidr.fold+                (\_ _ -> Left ())+                (\w1 w2 w3 w4 netmask -> Right (w1, w2, w3, w4, netmask))+                cidr+        result `shouldBe` Right (0x20010DB8, 0x00000000, 0x00000000, 0x00000000, 64)++  describe "Property Tests" do+    it "normalizeFromV4 always zeros host bits" do+      property \addr netmask ->+        let cidr = Cidr.normalizeFromV4 addr netmask+            (addr', _) = fromJust (Cidr.refineToV4 cidr)+            clampedNetmask = min 32 netmask+            hostBits = 32 - fromIntegral clampedNetmask+            networkMask = if hostBits >= 32 then 0 else complement ((1 `shiftL` hostBits) - 1)+            expectedAddr = addr .&. networkMask+         in addr' === expectedAddr++    it "normalizeFromV6 always zeros host bits" do+      property \w1 w2 w3 w4 netmask ->+        let cidr = Cidr.normalizeFromV6 w1 w2 w3 w4 netmask+            (w1', w2', w3', w4', _) = fromJust (Cidr.refineToV6 cidr)+            -- Verify host bits are zero by attempting to refine+            refined = Cidr.refineFromV6 w1' w2' w3' w4' (min 128 netmask)+         in isJust refined === True++    it "normalizeFromV4 is idempotent" do+      property \addr netmask ->+        let normalized1 = Cidr.normalizeFromV4 addr netmask+            (addr', netmask') = fromJust (Cidr.refineToV4 normalized1)+            normalized2 = Cidr.normalizeFromV4 addr' netmask'+         in normalized1 === normalized2++    it "normalizeFromV6 is idempotent" do+      property \w1 w2 w3 w4 netmask ->+        let normalized1 = Cidr.normalizeFromV6 w1 w2 w3 w4 netmask+            (w1', w2', w3', w4', netmask') = fromJust (Cidr.refineToV6 normalized1)+            normalized2 = Cidr.normalizeFromV6 w1' w2' w3' w4' netmask'+         in normalized1 === normalized2++    it "refineFromV4 accepts only valid network addresses" do+      property \addr netmask ->+        let result = Cidr.refineFromV4 addr netmask+            isValid =+              netmask <= 32+                && ( let hostBits = 32 - fromIntegral netmask+                         networkMask = if hostBits >= 32 then 0 else complement ((1 `shiftL` hostBits) - 1)+                         networkAddr = addr .&. networkMask+                      in networkAddr == addr+                   )+         in isJust result === isValid++    it "refineFromV6 accepts only valid network addresses" do+      property \w1 w2 w3 w4 netmask ->+        netmask <= 128 ==>+          let result = Cidr.refineFromV6 w1 w2 w3 w4 netmask+              normalized = Cidr.normalizeFromV6 w1 w2 w3 w4 netmask+              (nw1, nw2, nw3, nw4, _) = fromJust (Cidr.refineToV6 normalized)+           in isJust result === ((w1, w2, w3, w4) == (nw1, nw2, nw3, nw4))++    it "refineToV4 roundtrips with normalizeFromV4" do+      property \addr (netmask :: Word8) ->+        netmask <= 32 ==>+          let cidr = Cidr.normalizeFromV4 addr netmask+              result = Cidr.refineToV4 cidr+              (addr', netmask') = fromJust result+              -- The address should be normalized (host bits zero)+              clampedNetmask = min 32 netmask+              hostBits = 32 - fromIntegral clampedNetmask+              networkMask = if hostBits >= 32 then 0 else complement ((1 `shiftL` hostBits) - 1)+              expectedAddr = addr .&. networkMask+           in (addr', netmask') === (expectedAddr, clampedNetmask)++    it "refineToV6 roundtrips with normalizeFromV6" do+      property \w1 w2 w3 w4 (netmask :: Word8) ->+        netmask <= 128 ==>+          let cidr = Cidr.normalizeFromV6 w1 w2 w3 w4 netmask+              result = Cidr.refineToV6 cidr+              (_, _, _, _, netmask') = fromJust result+           in netmask' === min 128 netmask++    it "fold correctly identifies IPv4" do+      property \addr (netmask :: Word8) ->+        netmask <= 32 ==>+          let cidr = Cidr.normalizeFromV4 addr netmask+              isV4 = Cidr.fold (\_ _ -> True) (\_ _ _ _ _ -> False) cidr+           in isV4 === True++    it "fold correctly identifies IPv6" do+      property \w1 w2 w3 w4 (netmask :: Word8) ->+        netmask <= 128 ==>+          let cidr = Cidr.normalizeFromV6 w1 w2 w3 w4 netmask+              isV6 = Cidr.fold (\_ _ -> False) (\_ _ _ _ _ -> True) cidr+           in isV6 === True
+ src/unit-tests/PostgresqlTypes/CircleSpec.hs view
@@ -0,0 +1,67 @@+module PostgresqlTypes.CircleSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified PostgresqlTypes.Circle as Circle+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Circle.Circle)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Circle.Circle)++  describe "Constructors" do+    describe "normalizeFromCenterAndRadius" do+      it "creates Circle from center and radius" do+        let circle = Circle.normalizeFromCenterAndRadius 3.0 4.0 5.0+            x = Circle.toCenterX circle+            y = Circle.toCenterY circle+            r = Circle.toRadius circle+        (x, y, r) `shouldBe` (3.0, 4.0, 5.0)++      it "takes absolute value of negative radius" do+        let circle = Circle.normalizeFromCenterAndRadius 0.0 0.0 (-5.0)+            r = Circle.toRadius circle+        r `shouldBe` 5.0++    describe "refineFromCenterAndRadius" do+      it "rejects negative radius" do+        Circle.refineFromCenterAndRadius 0.0 0.0 (-1.0) `shouldBe` Nothing++      it "accepts zero radius" do+        let result = Circle.refineFromCenterAndRadius 0.0 0.0 0.0+        result `shouldSatisfy` isJust++      it "accepts positive radius" do+        let result = Circle.refineFromCenterAndRadius 1.0 2.0 3.0+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toCenterX, toCenterY, toRadius" do+      it "extract center coordinates and radius" do+        let circle = Circle.normalizeFromCenterAndRadius 2.5 3.5 4.5+            x = Circle.toCenterX circle+            y = Circle.toCenterY circle+            r = Circle.toRadius circle+        (x, y, r) `shouldBe` (2.5, 3.5, 4.5)++  describe "Property Tests" do+    it "roundtrips through toCenterAndRadius and normalizeFromCenterAndRadius" do+      property \circle ->+        let x = Circle.toCenterX circle+            y = Circle.toCenterY circle+            r = Circle.toRadius circle+            circle' = Circle.normalizeFromCenterAndRadius x y r+         in circle' === circle++    it "normalizeFromCenterAndRadius ensures non-negative radius" do+      property \x y r ->+        let circle = Circle.normalizeFromCenterAndRadius x y r+            r' = Circle.toRadius circle+         in r' >= 0
+ src/unit-tests/PostgresqlTypes/DateSpec.hs view
@@ -0,0 +1,91 @@+module PostgresqlTypes.DateSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Time as Time+import qualified PostgresqlTypes.Date as Date+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Date.Date)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Date.Date)++  describe "Constructors" do+    describe "normalizeFromDay" do+      it "clamps dates below minimum" do+        let tooEarly = Time.fromGregorian (-5000) 1 1+            date = Date.normalizeFromDay tooEarly+        date `shouldBe` minBound++      it "clamps dates above maximum" do+        let tooLate = Time.fromGregorian 6000000 12 31+            date = Date.normalizeFromDay tooLate+        date `shouldBe` maxBound++      it "accepts dates within range" do+        let day = Time.fromGregorian 2023 6 15+            date = Date.normalizeFromDay day+        Date.toDay date `shouldBe` day++      it "accepts minimum date" do+        let minDay = Time.fromGregorian (-4712) 1 1+            date = Date.normalizeFromDay minDay+        Date.toDay date `shouldBe` minDay++    describe "refineFromDay" do+      it "rejects dates below minimum" do+        let tooEarly = Time.fromGregorian (-5000) 1 1+        Date.refineFromDay tooEarly `shouldBe` Nothing++      it "rejects dates above maximum" do+        let tooLate = Time.fromGregorian 6000000 12 31+        Date.refineFromDay tooLate `shouldBe` Nothing++      it "accepts dates within range" do+        let day = Time.fromGregorian 2023 6 15+            result = Date.refineFromDay day+        result `shouldSatisfy` isJust+        fmap Date.toDay result `shouldBe` Just day++      it "accepts minimum date" do+        let minDay = Time.fromGregorian (-4712) 1 1+            result = Date.refineFromDay minDay+        result `shouldSatisfy` isJust++      it "accepts maximum date" do+        let maxDay = Time.fromGregorian 5874897 12 31+            result = Date.refineFromDay maxDay+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toDay" do+      it "extracts Day value" do+        let day = Time.fromGregorian 2023 6 15+            date = Date.normalizeFromDay day+        Date.toDay date `shouldBe` day++  describe "Property Tests" do+    it "normalizeFromDay is idempotent" do+      property \(day :: Time.Day) ->+        let normalized1 = Date.normalizeFromDay day+            normalized2 = Date.normalizeFromDay (Date.toDay normalized1)+         in normalized1 === normalized2++    it "refineFromDay succeeds for valid dates" do+      property \(date :: Date.Date) ->+        let day = Date.toDay date+            refined = Date.refineFromDay day+         in refined === Just date++    it "toDay . normalizeFromDay preserves valid dates" do+      property \(date :: Date.Date) ->+        let day = Date.toDay date+            restored = Date.normalizeFromDay day+         in restored === date
+ src/unit-tests/PostgresqlTypes/Float4Spec.hs view
@@ -0,0 +1,48 @@+module PostgresqlTypes.Float4Spec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Float4 as Float4+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Float4.Float4)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Float4.Float4)++  describe "Constructors" do+    describe "fromFloat" do+      it "creates Float4 from positive Float" do+        let pgFloat = Float4.fromFloat 3.14+        Float4.toFloat pgFloat `shouldBe` 3.14++      it "creates Float4 from negative Float" do+        let pgFloat = Float4.fromFloat (-3.14)+        Float4.toFloat pgFloat `shouldBe` (-3.14)++      it "creates Float4 from zero" do+        let pgFloat = Float4.fromFloat 0+        Float4.toFloat pgFloat `shouldBe` 0++  describe "Accessors" do+    describe "toFloat" do+      it "extracts Float value" do+        let pgFloat = Float4.fromFloat 1.5+        Float4.toFloat pgFloat `shouldBe` 1.5++  describe "Property Tests" do+    it "roundtrips through toFloat and fromFloat" do+      property \(f :: Float) ->+        let pgFloat = Float4.fromFloat f+         in Float4.toFloat pgFloat === f++    it "roundtrips through fromFloat and toFloat" do+      property \(pgFloat :: Float4.Float4) ->+        let f = Float4.toFloat pgFloat+            pgFloat' = Float4.fromFloat f+         in pgFloat' === pgFloat
+ src/unit-tests/PostgresqlTypes/Float8Spec.hs view
@@ -0,0 +1,48 @@+module PostgresqlTypes.Float8Spec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Float8 as Float8+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Float8.Float8)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Float8.Float8)++  describe "Constructors" do+    describe "fromDouble" do+      it "creates Float8 from positive Double" do+        let pgFloat = Float8.fromDouble 3.14159265358979+        Float8.toDouble pgFloat `shouldBe` 3.14159265358979++      it "creates Float8 from negative Double" do+        let pgFloat = Float8.fromDouble (-3.14159265358979)+        Float8.toDouble pgFloat `shouldBe` (-3.14159265358979)++      it "creates Float8 from zero" do+        let pgFloat = Float8.fromDouble 0+        Float8.toDouble pgFloat `shouldBe` 0++  describe "Accessors" do+    describe "toDouble" do+      it "extracts Double value" do+        let pgFloat = Float8.fromDouble 1.5+        Float8.toDouble pgFloat `shouldBe` 1.5++  describe "Property Tests" do+    it "roundtrips through toDouble and fromDouble" do+      property \(d :: Double) ->+        let pgFloat = Float8.fromDouble d+         in Float8.toDouble pgFloat === d++    it "roundtrips through fromDouble and toDouble" do+      property \(pgFloat :: Float8.Float8) ->+        let d = Float8.toDouble pgFloat+            pgFloat' = Float8.fromDouble d+         in pgFloat' === pgFloat
+ src/unit-tests/PostgresqlTypes/HstoreSpec.hs view
@@ -0,0 +1,54 @@+module PostgresqlTypes.HstoreSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified Data.Map.Strict as Map+import qualified PostgresqlTypes.Hstore as Hstore+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Hstore.Hstore)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Hstore.Hstore)++  describe "Constructors" do+    describe "normalizeFromMap" do+      it "creates Hstore from Map" do+        let m = Map.fromList [("key1", Just "value1"), ("key2", Just "value2")]+            hstore = Hstore.normalizeFromMap m+        Hstore.toMap hstore `shouldBe` m++      it "creates Hstore from empty Map" do+        let m = Map.empty+            hstore = Hstore.normalizeFromMap m+        Hstore.toMap hstore `shouldBe` m++      it "handles NULL values" do+        let m = Map.fromList [("key", Nothing)]+            hstore = Hstore.normalizeFromMap m+        Hstore.toMap hstore `shouldBe` m++  describe "Accessors" do+    describe "toMap" do+      it "extracts Map" do+        let m = Map.fromList [("test", Just "data")]+            hstore = Hstore.normalizeFromMap m+        Hstore.toMap hstore `shouldBe` m++  describe "Property Tests" do+    it "roundtrips through toMap and normalizeFromMap" do+      property \(hstore :: Hstore.Hstore) ->+        let m = Hstore.toMap hstore+            hstore' = Hstore.normalizeFromMap m+         in hstore' === hstore++    it "roundtrips through normalizeFromMap and toMap" do+      property \(hstore :: Hstore.Hstore) ->+        let m = Hstore.toMap hstore+            hstore' = Hstore.normalizeFromMap m+         in hstore' === hstore
+ src/unit-tests/PostgresqlTypes/InetSpec.hs view
@@ -0,0 +1,232 @@+module PostgresqlTypes.InetSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import Data.Word+import qualified PostgresqlTypes.Inet as Inet+import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Inet.Inet)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Inet.Inet)++  describe "IPv4 Constructors" do+    describe "normalizeFromV4" do+      it "clamps netmask values above maximum (32)" do+        let inet = Inet.normalizeFromV4 0x7F000001 50+            (_, netmask) = fromJust (Inet.refineToV4 inet)+        netmask `shouldBe` 32++      it "accepts netmask at maximum (32)" do+        let inet = Inet.normalizeFromV4 0x7F000001 32+            (_, netmask) = fromJust (Inet.refineToV4 inet)+        netmask `shouldBe` 32++      it "accepts netmask at minimum (0)" do+        let inet = Inet.normalizeFromV4 0x7F000001 0+            (_, netmask) = fromJust (Inet.refineToV4 inet)+        netmask `shouldBe` 0++      it "preserves address and netmask within valid range" do+        let addr = 0xC0A80001 -- 192.168.0.1+            inet = Inet.normalizeFromV4 addr 24+            (addr', netmask) = fromJust (Inet.refineToV4 inet)+        addr' `shouldBe` addr+        netmask `shouldBe` 24++    describe "refineFromV4" do+      it "rejects netmask values above maximum (32)" do+        Inet.refineFromV4 0x7F000001 33 `shouldBe` Nothing++      it "accepts netmask at maximum (32)" do+        let result = Inet.refineFromV4 0x7F000001 32+        result `shouldSatisfy` isJust++      it "accepts netmask at minimum (0)" do+        let result = Inet.refineFromV4 0x7F000001 0+        result `shouldSatisfy` isJust++      it "preserves address and netmask for valid values" do+        let addr = 0xC0A80001 -- 192.168.0.1+            result = Inet.refineFromV4 addr 24+        case result of+          Just inet -> do+            let (addr', netmask) = fromJust (Inet.refineToV4 inet)+            addr' `shouldBe` addr+            netmask `shouldBe` 24+          Nothing -> expectationFailure "Expected Just but got Nothing"++    describe "IPv6 Constructors" do+      describe "normalizeFromV6" do+        it "clamps netmask values above maximum (128)" do+          let inet = Inet.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 200+              (_, _, _, _, netmask) = fromJust (Inet.refineToV6 inet)+          netmask `shouldBe` 128++        it "accepts netmask at maximum (128)" do+          let inet = Inet.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 128+              (_, _, _, _, netmask) = fromJust (Inet.refineToV6 inet)+          netmask `shouldBe` 128++        it "accepts netmask at minimum (0)" do+          let inet = Inet.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 0+              (_, _, _, _, netmask) = fromJust (Inet.refineToV6 inet)+          netmask `shouldBe` 0++        it "preserves address and netmask within valid range" do+          let w1 = 0x20010DB8+              w2 = 0x00000000+              w3 = 0x00000000+              w4 = 0x00000001+              inet = Inet.normalizeFromV6 w1 w2 w3 w4 64+              (w1', w2', w3', w4', netmask) = fromJust (Inet.refineToV6 inet)+          w1' `shouldBe` w1+          w2' `shouldBe` w2+          w3' `shouldBe` w3+          w4' `shouldBe` w4+          netmask `shouldBe` 64++      describe "refineFromV6" do+        it "rejects netmask values above maximum (128)" do+          Inet.refineFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 129 `shouldBe` Nothing++        it "accepts netmask at maximum (128)" do+          let result = Inet.refineFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 128+          result `shouldSatisfy` isJust++        it "accepts netmask at minimum (0)" do+          let result = Inet.refineFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 0+          result `shouldSatisfy` isJust++        it "preserves address and netmask for valid values" do+          let w1 = 0x20010DB8+              w2 = 0x00000000+              w3 = 0x00000000+              w4 = 0x00000001+              result = Inet.refineFromV6 w1 w2 w3 w4 64+          case result of+            Just inet -> do+              let (w1', w2', w3', w4', netmask) = fromJust (Inet.refineToV6 inet)+              w1' `shouldBe` w1+              w2' `shouldBe` w2+              w3' `shouldBe` w3+              w4' `shouldBe` w4+              netmask `shouldBe` 64+            Nothing -> expectationFailure "Expected Just but got Nothing"++    describe "Accessors" do+      describe "refineToV4" do+        it "extracts IPv4 address and netmask" do+          let addr = 0xC0A80001 -- 192.168.0.1+              inet = Inet.normalizeFromV4 addr 24+              result = Inet.refineToV4 inet+          case result of+            Just (addr', netmask) -> do+              addr' `shouldBe` addr+              netmask `shouldBe` 24+            Nothing -> expectationFailure "Expected Just for IPv4"++        it "returns Nothing for IPv6 address" do+          let inet = Inet.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 64+          Inet.refineToV4 inet `shouldBe` Nothing++      describe "refineToV6" do+        it "extracts IPv6 address and netmask" do+          let w1 = 0x20010DB8+              w2 = 0x00000000+              w3 = 0x00000000+              w4 = 0x00000001+              inet = Inet.normalizeFromV6 w1 w2 w3 w4 64+              result = Inet.refineToV6 inet+          case result of+            Just (w1', w2', w3', w4', netmask) -> do+              w1' `shouldBe` w1+              w2' `shouldBe` w2+              w3' `shouldBe` w3+              w4' `shouldBe` w4+              netmask `shouldBe` 64+            Nothing -> expectationFailure "Expected Just for IPv6"++        it "returns Nothing for IPv4 address" do+          let inet = Inet.normalizeFromV4 0xC0A80001 24+          Inet.refineToV6 inet `shouldBe` Nothing++      describe "fold" do+        it "handles IPv4 case" do+          let inet = Inet.normalizeFromV4 0x7F000001 8+              result =+                Inet.fold+                  (\addr netmask -> Left (addr, netmask))+                  (\_ _ _ _ _ -> Right ())+                  inet+          result `shouldBe` Left (0x7F000001, 8)++        it "handles IPv6 case" do+          let inet = Inet.normalizeFromV6 0x20010DB8 0x00000000 0x00000000 0x00000001 64+              result =+                Inet.fold+                  (\_ _ -> Left ())+                  (\w1 w2 w3 w4 netmask -> Right (w1, w2, w3, w4, netmask))+                  inet+          result `shouldBe` Right (0x20010DB8, 0x00000000, 0x00000000, 0x00000001, 64)++    describe "Property Tests" do+      it "normalizeFromV4 is idempotent for valid netmasks" do+        QuickCheck.property \addr netmask ->+          let normalized1 = Inet.normalizeFromV4 addr netmask+              (addr', netmask') = fromJust (Inet.refineToV4 normalized1)+              normalized2 = Inet.normalizeFromV4 addr' netmask'+           in normalized1 === normalized2++      it "normalizeFromV6 is idempotent for valid netmasks" do+        QuickCheck.property \w1 w2 w3 w4 netmask ->+          let normalized1 = Inet.normalizeFromV6 w1 w2 w3 w4 netmask+              (w1', w2', w3', w4', netmask') = fromJust (Inet.refineToV6 normalized1)+              normalized2 = Inet.normalizeFromV6 w1' w2' w3' w4' netmask'+           in normalized1 === normalized2++      it "refineFromV4 accepts only valid netmasks" do+        QuickCheck.property \addr netmask ->+          let result = Inet.refineFromV4 addr netmask+           in isJust result === (netmask <= 32)++      it "refineFromV6 accepts only valid netmasks" do+        QuickCheck.property \w1 w2 w3 w4 netmask ->+          let result = Inet.refineFromV6 w1 w2 w3 w4 netmask+           in isJust result === (netmask <= 128)++      it "refineToV4 roundtrips with normalizeFromV4" do+        QuickCheck.property \addr (netmask :: Word8) ->+          netmask <= 32 ==>+            let inet = Inet.normalizeFromV4 addr netmask+                result = Inet.refineToV4 inet+             in result === Just (addr, netmask)++      it "refineToV6 roundtrips with normalizeFromV6" do+        QuickCheck.property \w1 w2 w3 w4 (netmask :: Word8) ->+          netmask <= 128 ==>+            let inet = Inet.normalizeFromV6 w1 w2 w3 w4 netmask+                result = Inet.refineToV6 inet+             in result === Just (w1, w2, w3, w4, netmask)++      it "fold correctly identifies IPv4" do+        QuickCheck.property \addr (netmask :: Word8) ->+          netmask <= 32 ==>+            let inet = Inet.normalizeFromV4 addr netmask+                isV4 = Inet.fold (\_ _ -> True) (\_ _ _ _ _ -> False) inet+             in isV4 === True++      it "fold correctly identifies IPv6" do+        QuickCheck.property \w1 w2 w3 w4 (netmask :: Word8) ->+          netmask <= 128 ==>+            let inet = Inet.normalizeFromV6 w1 w2 w3 w4 netmask+                isV6 = Inet.fold (\_ _ -> False) (\_ _ _ _ _ -> True) inet+             in isV6 === True
+ src/unit-tests/PostgresqlTypes/Int2Spec.hs view
@@ -0,0 +1,52 @@+module PostgresqlTypes.Int2Spec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Int+import qualified PostgresqlTypes.Int2 as Int2+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Int2.Int2)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Int2.Int2)++  describe "Constructors" do+    describe "fromInt16" do+      it "creates Int2 from positive Int16" do+        let pgInt = Int2.fromInt16 42+        Int2.toInt16 pgInt `shouldBe` 42++      it "creates Int2 from negative Int16" do+        let pgInt = Int2.fromInt16 (-42)+        Int2.toInt16 pgInt `shouldBe` (-42)++      it "creates Int2 from minimum Int16" do+        let pgInt = Int2.fromInt16 (-32768)+        Int2.toInt16 pgInt `shouldBe` (-32768)++      it "creates Int2 from maximum Int16" do+        let pgInt = Int2.fromInt16 32767+        Int2.toInt16 pgInt `shouldBe` 32767++  describe "Accessors" do+    describe "toInt16" do+      it "extracts Int16 value" do+        let pgInt = Int2.fromInt16 123+        Int2.toInt16 pgInt `shouldBe` 123++  describe "Property Tests" do+    it "roundtrips through toInt16 and fromInt16" do+      property \(i :: Int16) ->+        let pgInt = Int2.fromInt16 i+         in Int2.toInt16 pgInt === i++    it "roundtrips through fromInt16 and toInt16" do+      property \(pgInt :: Int2.Int2) ->+        let i = Int2.toInt16 pgInt+            pgInt' = Int2.fromInt16 i+         in pgInt' === pgInt
+ src/unit-tests/PostgresqlTypes/Int4Spec.hs view
@@ -0,0 +1,52 @@+module PostgresqlTypes.Int4Spec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Int+import qualified PostgresqlTypes.Int4 as Int4+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Int4.Int4)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Int4.Int4)++  describe "Constructors" do+    describe "fromInt32" do+      it "creates Int4 from positive Int32" do+        let pgInt = Int4.fromInt32 42+        Int4.toInt32 pgInt `shouldBe` 42++      it "creates Int4 from negative Int32" do+        let pgInt = Int4.fromInt32 (-42)+        Int4.toInt32 pgInt `shouldBe` (-42)++      it "creates Int4 from minimum Int32" do+        let pgInt = Int4.fromInt32 (-2147483648)+        Int4.toInt32 pgInt `shouldBe` (-2147483648)++      it "creates Int4 from maximum Int32" do+        let pgInt = Int4.fromInt32 2147483647+        Int4.toInt32 pgInt `shouldBe` 2147483647++  describe "Accessors" do+    describe "toInt32" do+      it "extracts Int32 value" do+        let pgInt = Int4.fromInt32 12345+        Int4.toInt32 pgInt `shouldBe` 12345++  describe "Property Tests" do+    it "roundtrips through toInt32 and fromInt32" do+      property \(i :: Int32) ->+        let pgInt = Int4.fromInt32 i+         in Int4.toInt32 pgInt === i++    it "roundtrips through fromInt32 and toInt32" do+      property \(pgInt :: Int4.Int4) ->+        let i = Int4.toInt32 pgInt+            pgInt' = Int4.fromInt32 i+         in pgInt' === pgInt
+ src/unit-tests/PostgresqlTypes/Int8Spec.hs view
@@ -0,0 +1,52 @@+module PostgresqlTypes.Int8Spec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Int+import qualified PostgresqlTypes.Int8 as Int8+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Int8.Int8)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Int8.Int8)++  describe "Constructors" do+    describe "fromInt64" do+      it "creates Int8 from positive Int64" do+        let pgInt = Int8.fromInt64 42+        Int8.toInt64 pgInt `shouldBe` 42++      it "creates Int8 from negative Int64" do+        let pgInt = Int8.fromInt64 (-42)+        Int8.toInt64 pgInt `shouldBe` (-42)++      it "creates Int8 from minimum Int64" do+        let pgInt = Int8.fromInt64 (-9223372036854775808)+        Int8.toInt64 pgInt `shouldBe` (-9223372036854775808)++      it "creates Int8 from maximum Int64" do+        let pgInt = Int8.fromInt64 9223372036854775807+        Int8.toInt64 pgInt `shouldBe` 9223372036854775807++  describe "Accessors" do+    describe "toInt64" do+      it "extracts Int64 value" do+        let pgInt = Int8.fromInt64 123456789+        Int8.toInt64 pgInt `shouldBe` 123456789++  describe "Property Tests" do+    it "roundtrips through toInt64 and fromInt64" do+      property \(i :: Int64) ->+        let pgInt = Int8.fromInt64 i+         in Int8.toInt64 pgInt === i++    it "roundtrips through fromInt64 and toInt64" do+      property \(pgInt :: Int8.Int8) ->+        let i = Int8.toInt64 pgInt+            pgInt' = Int8.fromInt64 i+         in pgInt' === pgInt
+ src/unit-tests/PostgresqlTypes/IntervalSpec.hs view
@@ -0,0 +1,257 @@+module PostgresqlTypes.IntervalSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Int+import Data.Maybe+import qualified Data.Time as Time+import qualified PostgresqlTypes.Interval as Interval+import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Interval.Interval)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Interval.Interval)++  describe "Constructors" do+    describe "normalizeFromMonthsDaysAndMicroseconds" do+      it "clamps months values below minimum" do+        -- Use a value that's actually below minBound, not overflowed+        let minMonths = Interval.toMonths (minBound :: Interval.Interval)+            interval = Interval.normalizeFromMonthsDaysAndMicroseconds (minMonths - 1000) 0 0+        Interval.toMonths interval `shouldBe` minMonths++      it "clamps months values above maximum" do+        -- Use a value that's actually above maxBound, not overflowed+        let maxMonths = Interval.toMonths (maxBound :: Interval.Interval)+            interval = Interval.normalizeFromMonthsDaysAndMicroseconds (maxMonths + 1000) 0 0+        Interval.toMonths interval `shouldBe` maxMonths++      it "accepts valid values within range" do+        let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 12 5 1_000_000+        Interval.toMonths interval `shouldBe` 12+        Interval.toDays interval `shouldBe` 5+        Interval.toMicroseconds interval `shouldBe` 1_000_000++    describe "refineFromMonthsDaysAndMicroseconds" do+      it "rejects months values below minimum" do+        let minMonths = Interval.toMonths (minBound :: Interval.Interval)+        Interval.refineFromMonthsDaysAndMicroseconds (minMonths - 1) 0 0 `shouldBe` Nothing++      it "rejects months values above maximum" do+        let maxMonths = Interval.toMonths (maxBound :: Interval.Interval)+        Interval.refineFromMonthsDaysAndMicroseconds (maxMonths + 1) 0 0 `shouldBe` Nothing++      it "accepts minimum months value" do+        let minMonths = Interval.toMonths (minBound :: Interval.Interval)+            result = Interval.refineFromMonthsDaysAndMicroseconds minMonths 0 0+        result `shouldSatisfy` isJust++      it "accepts maximum months value" do+        let maxMonths = Interval.toMonths (maxBound :: Interval.Interval)+            result = Interval.refineFromMonthsDaysAndMicroseconds maxMonths 0 0+        result `shouldSatisfy` isJust++      it "accepts valid values within range" do+        let result = Interval.refineFromMonthsDaysAndMicroseconds 12 5 1_000_000+        result `shouldSatisfy` isJust++      describe "normalizeFromMicrosecondsInTotal" do+        it "clamps values below minimum" do+          let minMicros = Interval.normalizeToMicrosecondsInTotal (minBound :: Interval.Interval)+              interval = Interval.normalizeFromMicrosecondsInTotal (minMicros - 1_000_000)+          interval `shouldBe` (minBound :: Interval.Interval)++        it "clamps values above maximum" do+          let maxMicros = Interval.normalizeToMicrosecondsInTotal (maxBound :: Interval.Interval)+              interval = Interval.normalizeFromMicrosecondsInTotal (maxMicros + 1_000_000)+          interval `shouldBe` (maxBound :: Interval.Interval)++        it "accepts valid values within range" do+          let microseconds = 1_000_000_000 -- ~11.5 days+              interval = Interval.normalizeFromMicrosecondsInTotal microseconds+          Interval.normalizeToMicrosecondsInTotal interval `shouldBe` microseconds++      describe "refineFromMicrosecondsInTotal" do+        it "rejects values below minimum" do+          let minMicros = Interval.normalizeToMicrosecondsInTotal (minBound :: Interval.Interval)+          Interval.refineFromMicrosecondsInTotal (minMicros - 1) `shouldBe` Nothing++        it "rejects values above maximum" do+          let maxMicros = Interval.normalizeToMicrosecondsInTotal (maxBound :: Interval.Interval)+          Interval.refineFromMicrosecondsInTotal (maxMicros + 1) `shouldBe` Nothing++        it "accepts minimum value" do+          let minMicros = Interval.normalizeToMicrosecondsInTotal (minBound :: Interval.Interval)+              result = Interval.refineFromMicrosecondsInTotal minMicros+          result `shouldSatisfy` isJust++        it "accepts maximum value" do+          let maxMicros = Interval.normalizeToMicrosecondsInTotal (maxBound :: Interval.Interval)+              result = Interval.refineFromMicrosecondsInTotal maxMicros+          result `shouldSatisfy` isJust++        it "accepts valid values within range" do+          let result = Interval.refineFromMicrosecondsInTotal 1_000_000_000+          result `shouldSatisfy` isJust++      describe "normalizeFromDiffTime" do+        it "clamps extreme negative DiffTime" do+          let minMicros = Interval.normalizeToMicrosecondsInTotal (minBound :: Interval.Interval)+              extremeDiffTime = Time.picosecondsToDiffTime ((minMicros - 1_000_000) * 1_000_000)+              interval = Interval.normalizeFromDiffTime extremeDiffTime+          interval `shouldBe` (minBound :: Interval.Interval)++        it "clamps extreme positive DiffTime" do+          let maxMicros = Interval.normalizeToMicrosecondsInTotal (maxBound :: Interval.Interval)+              extremeDiffTime = Time.picosecondsToDiffTime ((maxMicros + 1_000_000) * 1_000_000)+              interval = Interval.normalizeFromDiffTime extremeDiffTime+          interval `shouldBe` (maxBound :: Interval.Interval)++        it "loses sub-microsecond precision" do+          let diffTimeWithSubMicro = Time.picosecondsToDiffTime 1_000_500 -- 1.0005 microseconds+              interval = Interval.normalizeFromDiffTime diffTimeWithSubMicro+          -- Integer division truncates, so 1_000_500 / 1_000_000 = 1 microsecond+          Interval.normalizeToMicrosecondsInTotal interval `shouldBe` 1++      describe "refineFromDiffTime" do+        it "rejects DiffTime with sub-microsecond precision" do+          let diffTimeWithSubMicro = Time.picosecondsToDiffTime 1_000_500+          Interval.refineFromDiffTime diffTimeWithSubMicro `shouldBe` Nothing++        it "accepts DiffTime without sub-microsecond precision" do+          let diffTimeNoSubMicro = Time.picosecondsToDiffTime 1_000_000+              result = Interval.refineFromDiffTime diffTimeNoSubMicro+          result `shouldSatisfy` isJust++        it "rejects out of range DiffTime" do+          let maxMicros = Interval.normalizeToMicrosecondsInTotal (maxBound :: Interval.Interval)+              outOfRange = Time.picosecondsToDiffTime ((maxMicros + 1) * 1_000_000)+          Interval.refineFromDiffTime outOfRange `shouldBe` Nothing++    describe "Accessors" do+      describe "toMonths" do+        it "extracts months component" do+          let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 12 0 0+          Interval.toMonths interval `shouldBe` 12++      describe "toDays" do+        it "extracts days component" do+          let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 0 5 0+          Interval.toDays interval `shouldBe` 5++      describe "toMicroseconds" do+        it "extracts microseconds component" do+          let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 0 0 1_000_000+          Interval.toMicroseconds interval `shouldBe` 1_000_000++      describe "normalizeToMicrosecondsInTotal" do+        it "converts interval to total microseconds" do+          let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 1 1 1_000_000+              -- 1 month = 30 days, 1 day = 86400 seconds+              expectedMicros = (30 + 1) * 86400 * 1_000_000 + 1_000_000+          Interval.normalizeToMicrosecondsInTotal interval `shouldBe` expectedMicros++      describe "normalizeToDiffTime" do+        it "converts interval to DiffTime" do+          let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 0 1 0+              diffTime = Interval.normalizeToDiffTime interval+              -- 1 day = 86400 seconds+              expectedPicos = 86400 * 1_000_000_000_000+          Time.diffTimeToPicoseconds diffTime `shouldBe` expectedPicos++    describe "Edge cases" do+      it "handles minimum bound interval" do+        let interval = minBound :: Interval.Interval+        -- Verify that minBound is actually set to the expected minimum months value+        Interval.toMonths interval `shouldBe` (-2136000000)++      it "handles maximum bound interval" do+        let interval = maxBound :: Interval.Interval+        -- Verify that maxBound is actually set to the expected maximum months value+        Interval.toMonths interval `shouldBe` 2136000000++      it "handles zero interval" do+        let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 0 0 0+        Interval.toMonths interval `shouldBe` 0+        Interval.toDays interval `shouldBe` 0+        Interval.toMicroseconds interval `shouldBe` 0++    describe "Conversion instances" do+      describe "IsSome (Int32, Int32, Int64) Interval" do+        it "converts valid values" do+          let result = Interval.refineFromMonthsDaysAndMicroseconds 12 5 1_000_000+          result `shouldSatisfy` isJust++        it "rejects out-of-range values" do+          let maxMonths = Interval.toMonths (maxBound :: Interval.Interval)+              result = Interval.refineFromMonthsDaysAndMicroseconds (maxMonths + 1) 0 0+          result `shouldBe` Nothing++        it "roundtrips valid values" do+          QuickCheck.property \(interval :: Interval.Interval) ->+            let months = Interval.toMonths interval+                days = Interval.toDays interval+                microseconds = Interval.toMicroseconds interval+                restored = Interval.refineFromMonthsDaysAndMicroseconds months days microseconds+             in restored === Just interval++      describe "IsMany (Int32, Int32, Int64) Interval" do+        it "normalizes out-of-range values" do+          let maxMonths = Interval.toMonths (maxBound :: Interval.Interval)+              interval = Interval.normalizeFromMonthsDaysAndMicroseconds (maxMonths + 100) 0 0+          -- Value should be clamped+          Interval.toMonths interval `shouldBe` maxMonths++    describe "Property-based tests" do+      it "normalizeFrom* followed by refineFrom* is identity for components" do+        QuickCheck.property \(months :: Int32, days :: Int32, microseconds :: Int64) ->+          let normalized = Interval.normalizeFromMonthsDaysAndMicroseconds months days microseconds+              months' = Interval.toMonths normalized+              days' = Interval.toDays normalized+              microseconds' = Interval.toMicroseconds normalized+              projected = Interval.refineFromMonthsDaysAndMicroseconds months' days' microseconds'+           in projected === Just normalized++      it "normalizeToMicrosecondsInTotal followed by normalizeFromMicrosecondsInTotal preserves lossy conversion" do+        QuickCheck.property \(interval :: Interval.Interval) ->+          let microseconds = Interval.normalizeToMicrosecondsInTotal interval+              restored = Interval.normalizeFromMicrosecondsInTotal microseconds+           in Interval.normalizeToMicrosecondsInTotal restored === microseconds++      it "Eq is reflexive" do+        QuickCheck.property \(interval :: Interval.Interval) ->+          interval === interval++      it "Eq is symmetric" do+        QuickCheck.property \(i1 :: Interval.Interval, i2 :: Interval.Interval) ->+          (i1 == i2) === (i2 == i1)++      it "Ord is consistent with Eq" do+        QuickCheck.property \(i1 :: Interval.Interval, i2 :: Interval.Interval) ->+          (i1 == i2) === (compare i1 i2 == EQ)++      it "Ord is transitive" do+        QuickCheck.property \(i1 :: Interval.Interval, i2 :: Interval.Interval, i3 :: Interval.Interval) ->+          ((i1 <= i2) && (i2 <= i3)) ==> (i1 <= i3)++      it "Ord is total" do+        QuickCheck.property \(i1 :: Interval.Interval, i2 :: Interval.Interval) ->+          (i1 <= i2) .||. (i2 <= i1)++    describe "Boundary value tests" do+      it "handles microsecond precision" do+        let interval = Interval.normalizeFromMonthsDaysAndMicroseconds 0 0 1+        Interval.toMicroseconds interval `shouldBe` 1++      it "handles negative components" do+        let interval = Interval.normalizeFromMonthsDaysAndMicroseconds (-1) (-1) (-1)+        Interval.toMonths interval `shouldBe` (-1)+        Interval.toDays interval `shouldBe` (-1)+        Interval.toMicroseconds interval `shouldBe` (-1)
+ src/unit-tests/PostgresqlTypes/JsonSpec.hs view
@@ -0,0 +1,60 @@+module PostgresqlTypes.JsonSpec (spec) where++import qualified Data.Aeson as Aeson+import Data.Data (Proxy (Proxy))+import qualified Data.Vector as Vector+import qualified PostgresqlTypes.Json as Json+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Json.Json)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Json.Json)++  describe "Constructors" do+    describe "fromValue" do+      it "creates Json from Aeson Value (Null)" do+        let jsonVal = Json.normalizeFromAesonValue Aeson.Null+        Json.toAesonValue jsonVal `shouldBe` Aeson.Null++      it "creates Json from Aeson Value (Bool)" do+        let jsonVal = Json.normalizeFromAesonValue (Aeson.Bool True)+        Json.toAesonValue jsonVal `shouldBe` Aeson.Bool True++      it "creates Json from Aeson Value (Number)" do+        let jsonVal = Json.normalizeFromAesonValue (Aeson.Number 42)+        Json.toAesonValue jsonVal `shouldBe` Aeson.Number 42++      it "creates Json from Aeson Value (String)" do+        let jsonVal = Json.normalizeFromAesonValue (Aeson.String "hello")+        Json.toAesonValue jsonVal `shouldBe` Aeson.String "hello"++      it "creates Json from Aeson Value (Array)" do+        let value = Aeson.Array (Vector.fromList [Aeson.Number 1, Aeson.Number 2])+            jsonVal = Json.normalizeFromAesonValue value+        Json.toAesonValue jsonVal `shouldBe` value++      it "creates Json from Aeson Value (Object)" do+        let value = Aeson.object ["key" Aeson..= ("value" :: String)]+            jsonVal = Json.normalizeFromAesonValue value+        Json.toAesonValue jsonVal `shouldBe` value++  describe "Accessors" do+    describe "toValue" do+      it "extracts Aeson Value" do+        let value = Aeson.object ["test" Aeson..= (123 :: Int)]+            jsonVal = Json.normalizeFromAesonValue value+        Json.toAesonValue jsonVal `shouldBe` value++  describe "Property Tests" do+    it "roundtrips through fromValue and toValue" do+      property \(jsonVal :: Json.Json) ->+        let value = Json.toAesonValue jsonVal+            jsonVal' = Json.normalizeFromAesonValue value+         in jsonVal' === jsonVal
+ src/unit-tests/PostgresqlTypes/JsonbSpec.hs view
@@ -0,0 +1,51 @@+module PostgresqlTypes.JsonbSpec (spec) where++import qualified Data.Aeson as Aeson+import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified PostgresqlTypes.Jsonb as Jsonb+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Jsonb.Jsonb)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Jsonb.Jsonb)++  describe "Constructors" do+    describe "normalizeFromValue" do+      it "creates Jsonb from Aeson Value (Null)" do+        let jsonb = Jsonb.normalizeFromAesonValue Aeson.Null+        Jsonb.toAesonValue jsonb `shouldBe` Aeson.Null++      it "creates Jsonb from Aeson Value (Bool)" do+        let jsonb = Jsonb.normalizeFromAesonValue (Aeson.Bool True)+        Jsonb.toAesonValue jsonb `shouldBe` Aeson.Bool True++      it "creates Jsonb from Aeson Value (Number)" do+        let jsonb = Jsonb.normalizeFromAesonValue (Aeson.Number 42)+        Jsonb.toAesonValue jsonb `shouldBe` Aeson.Number 42++    describe "refineFromValue" do+      it "accepts valid Aeson Value" do+        let result = Jsonb.refineFromAesonValue Aeson.Null+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toValue" do+      it "extracts Aeson Value" do+        let value = Aeson.object ["test" Aeson..= (123 :: Int)]+            jsonb = Jsonb.normalizeFromAesonValue value+        Jsonb.toAesonValue jsonb `shouldBe` value++  describe "Property Tests" do+    it "roundtrips through normalizeFromValue and toValue" do+      property \(jsonb :: Jsonb.Jsonb) ->+        let value = Jsonb.toAesonValue jsonb+            jsonb' = Jsonb.normalizeFromAesonValue value+         in jsonb' === jsonb
+ src/unit-tests/PostgresqlTypes/LineSpec.hs view
@@ -0,0 +1,59 @@+module PostgresqlTypes.LineSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified PostgresqlTypes.Line as Line+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Line.Line)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Line.Line)++  describe "Constructors" do+    describe "normalizeFromEquation" do+      it "creates Line from equation coefficients" do+        let line = Line.normalizeFromEquation 1.0 2.0 3.0+            a = Line.toA line+            b = Line.toB line+            c = Line.toC line+        (a, b, c) `shouldBe` (1.0, 2.0, 3.0)++      it "normalizes invalid equations (A=0, B=0)" do+        let line = Line.normalizeFromEquation 0.0 0.0 5.0+            a = Line.toA line+            b = Line.toB line+        -- PostgreSQL normalizes to A=1, B=0, C=0 for invalid lines+        a /= 0 || b /= 0 `shouldBe` True++    describe "refineFromEquation" do+      it "rejects equations where A=0 and B=0" do+        Line.refineFromEquation 0.0 0.0 5.0 `shouldBe` Nothing++      it "accepts valid equations" do+        let result = Line.refineFromEquation 1.0 2.0 3.0+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toA, toB, toC" do+      it "extract equation coefficients" do+        let line = Line.normalizeFromEquation 2.0 (-3.0) 4.0+            a = Line.toA line+            b = Line.toB line+            c = Line.toC line+        (a, b, c) `shouldBe` (2.0, -3.0, 4.0)++  describe "Property Tests" do+    it "roundtrips through toA/toB/toC and normalizeFromEquation" do+      property \(line :: Line.Line) ->+        let a = Line.toA line+            b = Line.toB line+            c = Line.toC line+            line' = Line.normalizeFromEquation a b c+         in line' === line
+ src/unit-tests/PostgresqlTypes/LsegSpec.hs view
@@ -0,0 +1,42 @@+module PostgresqlTypes.LsegSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Lseg as Lseg+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Lseg.Lseg)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Lseg.Lseg)++  describe "Constructors" do+    describe "fromEndpoints" do+      it "creates Lseg from two points (4 params)" do+        let lseg = Lseg.fromEndpoints 0.0 0.0 3.0 4.0+        Lseg.toX1 lseg `shouldBe` 0.0+        Lseg.toY1 lseg `shouldBe` 0.0+        Lseg.toX2 lseg `shouldBe` 3.0+        Lseg.toY2 lseg `shouldBe` 4.0++      it "creates Lseg with coincident endpoints" do+        let lseg = Lseg.fromEndpoints 1.0 1.0 1.0 1.0+        (Lseg.toX1 lseg, Lseg.toY1 lseg, Lseg.toX2 lseg, Lseg.toY2 lseg) `shouldBe` (1.0, 1.0, 1.0, 1.0)++  describe "Accessors" do+    it "extracts individual coordinates" do+      let lseg = Lseg.fromEndpoints 1.5 2.5 3.5 4.5+      Lseg.toX1 lseg `shouldBe` 1.5+      Lseg.toY1 lseg `shouldBe` 2.5+      Lseg.toX2 lseg `shouldBe` 3.5+      Lseg.toY2 lseg `shouldBe` 4.5++  describe "Property Tests" do+    it "roundtrips through accessors and fromEndpoints" do+      property \(lseg :: Lseg.Lseg) ->+        let lseg' = Lseg.fromEndpoints (Lseg.toX1 lseg) (Lseg.toY1 lseg) (Lseg.toX2 lseg) (Lseg.toY2 lseg)+         in lseg' === lseg
+ src/unit-tests/PostgresqlTypes/Macaddr8Spec.hs view
@@ -0,0 +1,66 @@+module PostgresqlTypes.Macaddr8Spec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Word+import qualified PostgresqlTypes.Macaddr8 as Macaddr8+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Macaddr8.Macaddr8)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Macaddr8.Macaddr8)++  describe "Constructors" do+    describe "fromBytes" do+      it "creates Macaddr8 from 8 bytes" do+        let macaddr8 = Macaddr8.fromBytes 0x01 0x23 0x45 0x67 0x89 0xAB 0xCD 0xEF+        Macaddr8.toByte1 macaddr8 `shouldBe` 0x01+        Macaddr8.toByte2 macaddr8 `shouldBe` 0x23+        Macaddr8.toByte3 macaddr8 `shouldBe` 0x45+        Macaddr8.toByte4 macaddr8 `shouldBe` 0x67+        Macaddr8.toByte5 macaddr8 `shouldBe` 0x89+        Macaddr8.toByte6 macaddr8 `shouldBe` 0xAB+        Macaddr8.toByte7 macaddr8 `shouldBe` 0xCD+        Macaddr8.toByte8 macaddr8 `shouldBe` 0xEF++      it "creates Macaddr8 from all zeros" do+        let macaddr8 = Macaddr8.fromBytes 0 0 0 0 0 0 0 0+        (Macaddr8.toByte1 macaddr8, Macaddr8.toByte2 macaddr8, Macaddr8.toByte3 macaddr8, Macaddr8.toByte4 macaddr8)+          `shouldBe` (0, 0, 0, 0)+        (Macaddr8.toByte5 macaddr8, Macaddr8.toByte6 macaddr8, Macaddr8.toByte7 macaddr8, Macaddr8.toByte8 macaddr8)+          `shouldBe` (0, 0, 0, 0)++      it "creates Macaddr8 from all 0xFF" do+        let macaddr8 = Macaddr8.fromBytes 0xFF 0xFF 0xFF 0xFF 0xFF 0xFF 0xFF 0xFF+        (Macaddr8.toByte1 macaddr8, Macaddr8.toByte2 macaddr8, Macaddr8.toByte3 macaddr8, Macaddr8.toByte4 macaddr8)+          `shouldBe` (0xFF, 0xFF, 0xFF, 0xFF)+        (Macaddr8.toByte5 macaddr8, Macaddr8.toByte6 macaddr8, Macaddr8.toByte7 macaddr8, Macaddr8.toByte8 macaddr8)+          `shouldBe` (0xFF, 0xFF, 0xFF, 0xFF)++  describe "Accessors" do+    it "extracts individual bytes" do+      let macaddr8 = Macaddr8.fromBytes 0x12 0x34 0x56 0x78 0x9A 0xBC 0xDE 0xF0+      Macaddr8.toByte1 macaddr8 `shouldBe` 0x12+      Macaddr8.toByte2 macaddr8 `shouldBe` 0x34+      Macaddr8.toByte3 macaddr8 `shouldBe` 0x56+      Macaddr8.toByte4 macaddr8 `shouldBe` 0x78+      Macaddr8.toByte5 macaddr8 `shouldBe` 0x9A+      Macaddr8.toByte6 macaddr8 `shouldBe` 0xBC+      Macaddr8.toByte7 macaddr8 `shouldBe` 0xDE+      Macaddr8.toByte8 macaddr8 `shouldBe` 0xF0++  describe "Property Tests" do+    it "roundtrips through accessors and fromBytes" do+      property \(b1 :: Word8, b2 :: Word8, b3 :: Word8, b4 :: Word8, b5 :: Word8, b6 :: Word8, b7 :: Word8, b8 :: Word8) ->+        let macaddr8 = Macaddr8.fromBytes b1 b2 b3 b4 b5 b6 b7 b8+         in (Macaddr8.toByte1 macaddr8, Macaddr8.toByte2 macaddr8, Macaddr8.toByte3 macaddr8, Macaddr8.toByte4 macaddr8, Macaddr8.toByte5 macaddr8, Macaddr8.toByte6 macaddr8, Macaddr8.toByte7 macaddr8, Macaddr8.toByte8 macaddr8) === (b1, b2, b3, b4, b5, b6, b7, b8)++    it "roundtrips through fromBytes and accessors" do+      property \(macaddr8 :: Macaddr8.Macaddr8) ->+        let macaddr8' = Macaddr8.fromBytes (Macaddr8.toByte1 macaddr8) (Macaddr8.toByte2 macaddr8) (Macaddr8.toByte3 macaddr8) (Macaddr8.toByte4 macaddr8) (Macaddr8.toByte5 macaddr8) (Macaddr8.toByte6 macaddr8) (Macaddr8.toByte7 macaddr8) (Macaddr8.toByte8 macaddr8)+         in macaddr8' === macaddr8
+ src/unit-tests/PostgresqlTypes/MacaddrSpec.hs view
@@ -0,0 +1,62 @@+module PostgresqlTypes.MacaddrSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Word+import qualified PostgresqlTypes.Macaddr as Macaddr+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Macaddr.Macaddr)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Macaddr.Macaddr)++  describe "Constructors" do+    describe "fromBytes" do+      it "creates Macaddr from 6 bytes" do+        let macaddr = Macaddr.fromBytes 0x01 0x23 0x45 0x67 0x89 0xAB+        Macaddr.toByte1 macaddr `shouldBe` 0x01+        Macaddr.toByte2 macaddr `shouldBe` 0x23+        Macaddr.toByte3 macaddr `shouldBe` 0x45+        Macaddr.toByte4 macaddr `shouldBe` 0x67+        Macaddr.toByte5 macaddr `shouldBe` 0x89+        Macaddr.toByte6 macaddr `shouldBe` 0xAB++      it "creates Macaddr from all zeros" do+        let macaddr = Macaddr.fromBytes 0 0 0 0 0 0+        (Macaddr.toByte1 macaddr, Macaddr.toByte2 macaddr, Macaddr.toByte3 macaddr)+          `shouldBe` (0, 0, 0)+        (Macaddr.toByte4 macaddr, Macaddr.toByte5 macaddr, Macaddr.toByte6 macaddr)+          `shouldBe` (0, 0, 0)++      it "creates Macaddr from all 0xFF" do+        let macaddr = Macaddr.fromBytes 0xFF 0xFF 0xFF 0xFF 0xFF 0xFF+        (Macaddr.toByte1 macaddr, Macaddr.toByte2 macaddr, Macaddr.toByte3 macaddr)+          `shouldBe` (0xFF, 0xFF, 0xFF)+        (Macaddr.toByte4 macaddr, Macaddr.toByte5 macaddr, Macaddr.toByte6 macaddr)+          `shouldBe` (0xFF, 0xFF, 0xFF)++  describe "Accessors" do+    it "extracts individual bytes" do+      let macaddr = Macaddr.fromBytes 0x12 0x34 0x56 0x78 0x9A 0xBC+      Macaddr.toByte1 macaddr `shouldBe` 0x12+      Macaddr.toByte2 macaddr `shouldBe` 0x34+      Macaddr.toByte3 macaddr `shouldBe` 0x56+      Macaddr.toByte4 macaddr `shouldBe` 0x78+      Macaddr.toByte5 macaddr `shouldBe` 0x9A+      Macaddr.toByte6 macaddr `shouldBe` 0xBC++  describe "Property Tests" do+    it "roundtrips through accessors and fromBytes" do+      property \(b1 :: Word8, b2 :: Word8, b3 :: Word8, b4 :: Word8, b5 :: Word8, b6 :: Word8) ->+        let macaddr = Macaddr.fromBytes b1 b2 b3 b4 b5 b6+         in (Macaddr.toByte1 macaddr, Macaddr.toByte2 macaddr, Macaddr.toByte3 macaddr, Macaddr.toByte4 macaddr, Macaddr.toByte5 macaddr, Macaddr.toByte6 macaddr) === (b1, b2, b3, b4, b5, b6)++    it "roundtrips through fromBytes and accessors" do+      property \(macaddr :: Macaddr.Macaddr) ->+        let macaddr' = Macaddr.fromBytes (Macaddr.toByte1 macaddr) (Macaddr.toByte2 macaddr) (Macaddr.toByte3 macaddr) (Macaddr.toByte4 macaddr) (Macaddr.toByte5 macaddr) (Macaddr.toByte6 macaddr)+         in macaddr' === macaddr
+ src/unit-tests/PostgresqlTypes/MoneySpec.hs view
@@ -0,0 +1,48 @@+module PostgresqlTypes.MoneySpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Int+import qualified PostgresqlTypes.Money as Money+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Money.Money)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Money.Money)++  describe "Constructors" do+    describe "fromInt64" do+      it "creates Money from positive Int64" do+        let pgMoney = Money.fromInt64 12345+        Money.toInt64 pgMoney `shouldBe` 12345++      it "creates Money from negative Int64" do+        let pgMoney = Money.fromInt64 (-12345)+        Money.toInt64 pgMoney `shouldBe` (-12345)++      it "creates Money from zero" do+        let pgMoney = Money.fromInt64 0+        Money.toInt64 pgMoney `shouldBe` 0++  describe "Accessors" do+    describe "toInt64" do+      it "extracts Int64 value representing cents" do+        let pgMoney = Money.fromInt64 9999+        Money.toInt64 pgMoney `shouldBe` 9999++  describe "Property Tests" do+    it "roundtrips through toInt64 and fromInt64" do+      property \(i :: Int64) ->+        let pgMoney = Money.fromInt64 i+         in Money.toInt64 pgMoney === i++    it "roundtrips through fromInt64 and toInt64" do+      property \(pgMoney :: Money.Money) ->+        let i = Money.toInt64 pgMoney+            pgMoney' = Money.fromInt64 i+         in pgMoney' === pgMoney
+ src/unit-tests/PostgresqlTypes/MultirangeSpec.hs view
@@ -0,0 +1,42 @@+module PostgresqlTypes.MultirangeSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Int4 as Int4+import qualified PostgresqlTypes.Multirange as Multirange+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Multirange.Multirange Int4.Int4))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Multirange.Multirange Int4.Int4))++  describe "Multirange Int4" do+    it "has Eq instance" do+      property \(mr1 :: Multirange.Multirange Int4.Int4) ->+        (mr1 == mr1) `shouldBe` True++    it "has Functor instance - fmap id = id" do+      property \(multirange :: Multirange.Multirange Int4.Int4) ->+        fmap id multirange === multirange++    it "has Functor instance - composition law" do+      property \(multirange :: Multirange.Multirange Int4.Int4) ->+        let f = Int4.fromInt32 . (* 2) . Int4.toInt32+            g = Int4.fromInt32 . (+ 1) . Int4.toInt32+         in fmap (f . g) multirange === fmap f (fmap g multirange)++  describe "Property Tests" do+    it "arbitrary generates valid multiranges" do+      property \(multirange :: Multirange.Multirange Int4.Int4) ->+        -- Multirange instances should be well-formed+        multirange === multirange++    it "equality is reflexive" do+      property \(multirange :: Multirange.Multirange Int4.Int4) ->+        multirange === multirange
+ src/unit-tests/PostgresqlTypes/NumericSpec.hs view
@@ -0,0 +1,152 @@+module PostgresqlTypes.NumericSpec (spec) where++import Control.Monad+import Data.Proxy (Proxy (..))+import qualified Data.Scientific as Scientific+import Data.Typeable (Typeable, typeRep)+import qualified GHC.TypeLits as TypeLits+import qualified PostgresqlTypes.Numeric as Numeric+import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Numeric.Numeric 0 0))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Numeric.Numeric 0 0))++  describe "By precision and scale" do+    byPrecisionAndScale (Proxy @0) (Proxy @0)+    byPrecisionAndScale (Proxy @10) (Proxy @4)+    byPrecisionAndScale (Proxy @5) (Proxy @2)+    byPrecisionAndScale (Proxy @5) (Proxy @0)++  describe "clamping and validation" do+    it "clamps to scale and precision for Numeric(5,2)" do+      let input = Scientific.scientific 999999 (-3) -- 999.999+          normalized = Numeric.normalizeFromScientific @5 @2 input+      Numeric.normalizeToScientific normalized `shouldBe` Scientific.scientific 99999 (-2)++    it "rejects values exceeding precision for Numeric(5,2)" do+      let invalid = Scientific.scientific 1234567 (-2) -- 12345.67 -> 7 total digits > precision 5+      Numeric.refineFromScientific @5 @2 invalid `shouldBe` Nothing++    it "accepts valid values for Numeric(5,2)" do+      let valid = Scientific.scientific 12345 (-2) -- 123.45 fits precision and scale+      Numeric.refineFromScientific @5 @2 valid `shouldBe` Just (Numeric.normalizeFromScientific valid)++    it "rejects scientifics outside PostgreSQL limits for Numeric(0,0)" do+      let tooManyIntegerDigits = Scientific.scientific 1 131074 -- digits before decimal exceed 131072+          tooManyFractionDigits = Scientific.scientific 1 (-20000) -- digits after decimal exceed 16383+      Numeric.refineFromScientific @0 @0 tooManyIntegerDigits `shouldBe` Nothing+      Numeric.refineFromScientific @0 @0 tooManyFractionDigits `shouldBe` Nothing++  describe "special values" do+    it "normalizeToScientific renders special values as 0" do+      Numeric.normalizeToScientific (Numeric.nan :: Numeric.Numeric 0 0) `shouldBe` 0+      Numeric.normalizeToScientific (Numeric.posInfinity :: Numeric.Numeric 0 0) `shouldBe` 0+      Numeric.normalizeToScientific (Numeric.negInfinity :: Numeric.Numeric 0 0) `shouldBe` 0++    it "predicates detect special values" do+      Numeric.isNaN (Numeric.nan :: Numeric.Numeric 0 0) `shouldBe` True+      Numeric.isPosInfinity (Numeric.posInfinity :: Numeric.Numeric 0 0) `shouldBe` True+      Numeric.isNegInfinity (Numeric.negInfinity :: Numeric.Numeric 0 0) `shouldBe` True+      Numeric.isNaN (Numeric.normalizeFromScientific 0 :: Numeric.Numeric 0 0) `shouldBe` False+      Numeric.isPosInfinity (Numeric.normalizeFromScientific 0 :: Numeric.Numeric 0 0) `shouldBe` False+      Numeric.isNegInfinity (Numeric.normalizeFromScientific 0 :: Numeric.Numeric 0 0) `shouldBe` False++    it "refineToScientific rejects special values" do+      Numeric.refineToScientific (Numeric.nan :: Numeric.Numeric 0 0) `shouldBe` Nothing+      Numeric.refineToScientific (Numeric.posInfinity :: Numeric.Numeric 0 0) `shouldBe` Nothing+      Numeric.refineToScientific (Numeric.negInfinity :: Numeric.Numeric 0 0) `shouldBe` Nothing++  describe "Invalid type params" do+    describe "refineFromScientific" do+      it "Fails on any scientific" do+        QuickCheck.property \(sci :: Scientific.Scientific) ->+          Numeric.refineFromScientific @2 @5 sci === Nothing++    describe "normalizeFromScientific" do+      it "Always returns NaN" do+        QuickCheck.property \(sci :: Scientific.Scientific) ->+          let normalized = Numeric.normalizeFromScientific @2 @5 sci+           in Numeric.isNaN normalized++  describe "Valid type params" do+    describe "refineFromScientific" do+      it "Rejects values exceeding scale" do+        let sci = Scientific.scientific 12345 (-3) -- 12.345 has scale 3 > 2+        Numeric.refineFromScientific @5 @2 sci `shouldBe` Nothing++      it "Rejects values exceeding precision" do+        let sci = Scientific.scientific 123456 (-2) -- 12345.6 has precision 6 > 5+        Numeric.refineFromScientific @5 @2 sci `shouldBe` Nothing++      it "Accepts values within precision and scale" do+        let sci = Scientific.scientific 12345 (-2) -- 123.45 fits precision and scale+        Numeric.refineFromScientific @5 @2 sci `shouldBe` Just (Numeric.normalizeFromScientific sci)++    describe "normalizeFromScientific" do+      it "Clamps scale to 2" do+        let sci = Scientific.scientific 12345 (-4) -- 1.2345 has scale 4 > 2+            normalized = Numeric.normalizeFromScientific @5 @2 sci+        Numeric.normalizeToScientific normalized `shouldBe` Scientific.scientific 123 (-2)++      it "Clamps when input is larger than max" do+        let sci = Scientific.scientific 1234567 (-2) -- 12345.67 has precision 7 > 5+            normalized = Numeric.normalizeFromScientific @5 @2 sci+        Numeric.normalizeToScientific normalized `shouldBe` read "999.99"++      it "Clamps when input is smaller than min" do+        let sci = read "-10000"+            normalized = Numeric.normalizeFromScientific @5 @2 sci+        Numeric.normalizeToScientific normalized `shouldBe` read "-999.99"++-- | Property suites shared across several numeric precisions/scales.+byPrecisionAndScale ::+  forall precision scale.+  ( TypeLits.KnownNat precision,+    TypeLits.KnownNat scale,+    QuickCheck.Arbitrary (Numeric.Numeric precision scale),+    Show (Numeric.Numeric precision scale),+    Eq (Numeric.Numeric precision scale),+    Typeable (Numeric.Numeric precision scale)+  ) =>+  Proxy precision ->+  Proxy scale ->+  Spec+byPrecisionAndScale _ _ = do+  let precision = fromIntegral (TypeLits.natVal (Proxy @precision)) :: Int+      scale = fromIntegral (TypeLits.natVal (Proxy @scale)) :: Int++  describe (show (typeRep (Proxy @(Numeric.Numeric precision scale)))) do+    it "project -> normalize restores finite values" do+      QuickCheck.property \(value :: Numeric.Numeric precision scale) ->+        case Numeric.refineToScientific value of+          Nothing -> QuickCheck.property True+          Just sci -> Numeric.normalizeFromScientific @precision @scale sci === value++    it "refineFromScientific . refineToScientific is identity on finite values" do+      QuickCheck.property \(value :: Numeric.Numeric precision scale) ->+        case Numeric.refineToScientific value of+          Nothing -> QuickCheck.property True+          Just sci -> Numeric.refineFromScientific @precision @scale sci === Just value++    it "normalizeFromScientific produces projectable values" do+      QuickCheck.property \(sci :: Scientific.Scientific) ->+        let value = Numeric.normalizeFromScientific @precision @scale sci+            normalizedSci = Numeric.normalizeToScientific value+         in Numeric.refineFromScientific @precision @scale normalizedSci === Just value++    when (precision > 0) do+      it "rounds the input scientific to the correct scale" do+        QuickCheck.property \(sci :: Scientific.Scientific) ->+          let value = Numeric.normalizeFromScientific @precision @scale sci+              normalizedSci = Numeric.normalizeToScientific value+              actualScale = negate (Scientific.base10Exponent normalizedSci)+           in actualScale <= scale
+ src/unit-tests/PostgresqlTypes/OidSpec.hs view
@@ -0,0 +1,48 @@+module PostgresqlTypes.OidSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Word+import qualified PostgresqlTypes.Oid as Oid+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Oid.Oid)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Oid.Oid)++  describe "Constructors" do+    describe "fromWord32" do+      it "creates Oid from Word32" do+        let pgOid = Oid.fromWord32 42+        Oid.toWord32 pgOid `shouldBe` 42++      it "creates Oid from zero" do+        let pgOid = Oid.fromWord32 0+        Oid.toWord32 pgOid `shouldBe` 0++      it "creates Oid from maximum Word32" do+        let pgOid = Oid.fromWord32 4294967295+        Oid.toWord32 pgOid `shouldBe` 4294967295++  describe "Accessors" do+    describe "toWord32" do+      it "extracts Word32 value" do+        let pgOid = Oid.fromWord32 12345+        Oid.toWord32 pgOid `shouldBe` 12345++  describe "Property Tests" do+    it "roundtrips through toWord32 and fromWord32" do+      property \(w :: Word32) ->+        let pgOid = Oid.fromWord32 w+         in Oid.toWord32 pgOid === w++    it "roundtrips through fromWord32 and toWord32" do+      property \(pgOid :: Oid.Oid) ->+        let w = Oid.toWord32 pgOid+            pgOid' = Oid.fromWord32 w+         in pgOid' === pgOid
+ src/unit-tests/PostgresqlTypes/PathSpec.hs view
@@ -0,0 +1,52 @@+module PostgresqlTypes.PathSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified PostgresqlTypes.Path as Path+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Path.Path)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Path.Path)++  describe "Constructors" do+    describe "refineFromPointList (open path)" do+      it "creates open Path from list of points" do+        let points = [(0.0, 0.0), (1.0, 1.0), (2.0, 2.0)]+            result = Path.refineFromPointList False points+        result `shouldSatisfy` isJust+        fmap Path.toClosed result `shouldBe` Just False+        fmap Path.toPointList result `shouldBe` Just points++    describe "refineFromPointList (closed path)" do+      it "creates closed Path from list of points" do+        let points = [(0.0, 0.0), (1.0, 0.0), (1.0, 1.0)]+            result = Path.refineFromPointList True points+        result `shouldSatisfy` isJust+        fmap Path.toClosed result `shouldBe` Just True+        fmap Path.toPointList result `shouldBe` Just points++  describe "Accessors" do+    describe "toClosed and toPointList" do+      it "extracts closed flag and points" do+        let points = [(1.0, 2.0), (3.0, 4.0), (5.0, 6.0)]+        path <- case Path.refineFromPointList False points of+          Just p -> return p+          Nothing -> error "Failed to create Path"+        Path.toClosed path `shouldBe` False+        Path.toPointList path `shouldBe` points++  describe "Property Tests" do+    it "roundtrips through accessors and refineFromPointList" do+      property \(path :: Path.Path) ->+        let closed = Path.toClosed path+            points = Path.toPointList path+            result = Path.refineFromPointList closed points+         in result === Just path
+ src/unit-tests/PostgresqlTypes/PointSpec.hs view
@@ -0,0 +1,62 @@+module PostgresqlTypes.PointSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Point as Point+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Point.Point)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Point.Point)++  describe "Constructors" do+    describe "fromCoordinates" do+      it "creates Point from coordinates" do+        let point = Point.fromCoordinates 3.5 4.2+            x = Point.toX point+            y = Point.toY point+        x `shouldBe` 3.5+        y `shouldBe` 4.2++      it "creates Point at origin" do+        let point = Point.fromCoordinates 0 0+            x = Point.toX point+            y = Point.toY point+        x `shouldBe` 0+        y `shouldBe` 0++      it "creates Point with negative coordinates" do+        let point = Point.fromCoordinates (-1.5) (-2.3)+            x = Point.toX point+            y = Point.toY point+        x `shouldBe` (-1.5)+        y `shouldBe` (-2.3)++  describe "Accessors" do+    describe "toX and toY" do+      it "extract individual coordinates" do+        let point = Point.fromCoordinates 10.5 20.7+            x = Point.toX point+            y = Point.toY point+        (x, y) `shouldBe` (10.5, 20.7)++  describe "Property Tests" do+    it "roundtrips through toX/toY and fromCoordinates" do+      property \(x :: Double, y :: Double) ->+        let point = Point.fromCoordinates x y+            x' = Point.toX point+            y' = Point.toY point+         in (x', y') === (x, y)++    it "roundtrips through fromCoordinates and toX/toY" do+      property \(point :: Point.Point) ->+        let x = Point.toX point+            y = Point.toY point+            point' = Point.fromCoordinates x y+         in point' === point
+ src/unit-tests/PostgresqlTypes/PolygonSpec.hs view
@@ -0,0 +1,43 @@+module PostgresqlTypes.PolygonSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified PostgresqlTypes.Polygon as Polygon+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Polygon.Polygon)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Polygon.Polygon)++  describe "Constructors" do+    describe "refineFromPointList" do+      it "creates Polygon from list of points" do+        let points = [(0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0)]+            result = Polygon.refineFromPointList points+        result `shouldSatisfy` isJust+        fmap Polygon.toPointList result `shouldBe` Just points++      it "creates triangle from 3 points" do+        let points = [(0.0, 0.0), (1.0, 0.0), (0.5, 1.0)]+            result = Polygon.refineFromPointList points+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toPointList" do+      it "extracts list of points" do+        let points = [(1.0, 2.0), (3.0, 4.0), (5.0, 6.0), (7.0, 8.0)]+        Polygon.toPointList <$> Polygon.refineFromPointList points `shouldBe` Just points++  describe "Property Tests" do+    it "roundtrips through toPointList and refineFromPointList" do+      property \(polygon :: Polygon.Polygon) ->+        let points = Polygon.toPointList polygon+            result = Polygon.refineFromPointList points+         in result === Just polygon
+ src/unit-tests/PostgresqlTypes/RangeSpec.hs view
@@ -0,0 +1,38 @@+module PostgresqlTypes.RangeSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified PostgresqlTypes.Int4 as Int4+import qualified PostgresqlTypes.Range as Range+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Range.Range Int4.Int4))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Range.Range Int4.Int4))++  describe "Range Int4" do+    it "has Eq instance" do+      property \(r1 :: Range.Range Int4.Int4) ->+        (r1 == r1) `shouldBe` True++    it "has Functor instance - fmap id = id" do+      property \(range :: Range.Range Int4.Int4) ->+        fmap id range === range++    it "has Functor instance - composition law" do+      property \(range :: Range.Range Int4.Int4) ->+        let f = Int4.fromInt32 . (* 2) . Int4.toInt32+            g = Int4.fromInt32 . (+ 1) . Int4.toInt32+         in fmap (f . g) range === fmap f (fmap g range)++  describe "Property Tests" do+    it "arbitrary generates valid ranges" do+      property \(range :: Range.Range Int4.Int4) ->+        -- Range instances should be well-formed+        range === range
+ src/unit-tests/PostgresqlTypes/TextSpec.hs view
@@ -0,0 +1,74 @@+module PostgresqlTypes.TextSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Text as Text+import qualified PostgresqlTypes.Text as PgText+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @PgText.Text)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @PgText.Text)++  describe "Constructors" do+    describe "normalizeFromText" do+      it "strips null characters" do+        let pgText = PgText.normalizeFromText "hello\NULworld"+        PgText.toText pgText `shouldBe` "helloworld"++      it "preserves text without null characters" do+        let pgText = PgText.normalizeFromText "hello world"+        PgText.toText pgText `shouldBe` "hello world"++      it "handles multiple null characters" do+        let pgText = PgText.normalizeFromText "\NULa\NULb\NULc\NUL"+        PgText.toText pgText `shouldBe` "abc"++      it "handles empty text" do+        let pgText = PgText.normalizeFromText ""+        PgText.toText pgText `shouldBe` ""++    describe "refineFromText" do+      it "rejects text with null characters" do+        PgText.refineFromText "hello\NULworld" `shouldBe` Nothing++      it "accepts text without null characters" do+        let result = PgText.refineFromText "hello world"+        result `shouldSatisfy` isJust+        fmap PgText.toText result `shouldBe` Just "hello world"++      it "accepts empty text" do+        let result = PgText.refineFromText ""+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toText" do+      it "extracts text value" do+        let pgText = PgText.normalizeFromText "test"+        PgText.toText pgText `shouldBe` "test"++  describe "Property Tests" do+    it "normalizeFromText is idempotent" do+      property \(t :: Text.Text) ->+        let normalized1 = PgText.normalizeFromText t+            normalized2 = PgText.normalizeFromText (PgText.toText normalized1)+         in normalized1 === normalized2++    describe "refineFromText" do+      it "succeeds for text without nulls" do+        property \(pgText :: PgText.Text) ->+          let t = PgText.toText pgText+              refined = PgText.refineFromText t+           in refined === Just pgText++      it "rejects text with nulls" do+        property \(NonEmpty prefix, NonEmpty suffix) ->+          let textWithNull = Text.pack prefix <> "\NUL" <> Text.pack suffix+           in PgText.refineFromText textWithNull === Nothing
+ src/unit-tests/PostgresqlTypes/TimeSpec.hs view
@@ -0,0 +1,76 @@+module PostgresqlTypes.TimeSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Time as Time+import qualified PostgresqlTypes.Time as PgTime+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @PgTime.Time)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @PgTime.Time)++  describe "Constructors" do+    describe "normalizeFromMicroseconds" do+      it "creates Time from microseconds" do+        let pgTime = PgTime.normalizeFromMicroseconds 43_200_000_000 -- noon+        PgTime.toMicroseconds pgTime `shouldBe` 43_200_000_000++      it "creates Time from zero (midnight)" do+        let pgTime = PgTime.normalizeFromMicroseconds 0+        PgTime.toMicroseconds pgTime `shouldBe` 0++    describe "normalizeFromTimeOfDay" do+      it "converts TimeOfDay to Time" do+        let tod = Time.TimeOfDay 12 30 45+            pgTime = PgTime.normalizeFromTimeOfDay tod+        PgTime.toTimeOfDay pgTime `shouldBe` tod++      it "handles midnight" do+        let tod = Time.TimeOfDay 0 0 0+            pgTime = PgTime.normalizeFromTimeOfDay tod+        PgTime.toTimeOfDay pgTime `shouldBe` tod++    describe "refineFromTimeOfDay" do+      it "accepts valid TimeOfDay" do+        let tod = Time.TimeOfDay 12 30 45+            result = PgTime.refineFromTimeOfDay tod+        result `shouldSatisfy` isJust+        fmap PgTime.toTimeOfDay result `shouldBe` Just tod++      it "accepts midnight" do+        let tod = Time.TimeOfDay 0 0 0+            result = PgTime.refineFromTimeOfDay tod+        result `shouldSatisfy` isJust++  describe "Accessors" do+    describe "toMicroseconds" do+      it "extracts microseconds value" do+        let pgTime = PgTime.normalizeFromMicroseconds 3661_000_000 -- 1 hour, 1 minute, 1 second+        PgTime.toMicroseconds pgTime `shouldBe` 3661_000_000++    describe "toTimeOfDay" do+      it "converts to TimeOfDay" do+        let pgTime = PgTime.normalizeFromMicroseconds 43_200_000_000 -- noon+            tod = PgTime.toTimeOfDay pgTime+        tod `shouldBe` Time.TimeOfDay 12 0 0++  describe "Property Tests" do+    it "roundtrips through toMicroseconds and normalizeFromMicroseconds" do+      property \(pgTime :: PgTime.Time) ->+        let micros = PgTime.toMicroseconds pgTime+            pgTime' = PgTime.normalizeFromMicroseconds micros+         in pgTime' === pgTime++    it "normalizeFromTimeOfDay is idempotent" do+      property \(tod :: Time.TimeOfDay) ->+        let normalized1 = PgTime.normalizeFromTimeOfDay tod+            normalized2 = PgTime.normalizeFromTimeOfDay (PgTime.toTimeOfDay normalized1)+         in normalized1 === normalized2
+ src/unit-tests/PostgresqlTypes/TimestampSpec.hs view
@@ -0,0 +1,54 @@+module PostgresqlTypes.TimestampSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified Data.Time as Time+import qualified PostgresqlTypes.Timestamp as Timestamp+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Timestamp.Timestamp)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Timestamp.Timestamp)++  describe "Constructors" do+    describe "normalizeFromLocalTime" do+      it "creates Timestamp from LocalTime" do+        let day = Time.fromGregorian 2023 6 15+            tod = Time.TimeOfDay 12 30 45+            localTime = Time.LocalTime day tod+            pgTimestamp = Timestamp.normalizeFromLocalTime localTime+        Timestamp.toLocalTime pgTimestamp `shouldBe` localTime++      it "handles epoch" do+        let day = Time.fromGregorian 2000 1 1+            tod = Time.TimeOfDay 0 0 0+            localTime = Time.LocalTime day tod+            pgTimestamp = Timestamp.normalizeFromLocalTime localTime+        Timestamp.toLocalTime pgTimestamp `shouldBe` localTime++  describe "Accessors" do+    describe "toLocalTime" do+      it "extracts LocalTime value" do+        let day = Time.fromGregorian 2023 6 15+            tod = Time.TimeOfDay 12 30 45+            localTime = Time.LocalTime day tod+            pgTimestamp = Timestamp.normalizeFromLocalTime localTime+        Timestamp.toLocalTime pgTimestamp `shouldBe` localTime++  describe "Property Tests" do+    it "roundtrips through toLocalTime and normalizeFromLocalTime" do+      property \(pgTimestamp :: Timestamp.Timestamp) ->+        let localTime = Timestamp.toLocalTime pgTimestamp+            pgTimestamp' = Timestamp.normalizeFromLocalTime localTime+         in pgTimestamp' === pgTimestamp++    it "roundtrips through normalizeFromLocalTime and toLocalTime for valid LocalTimes" do+      property \(pgTimestamp :: Timestamp.Timestamp) ->+        let localTime = Timestamp.toLocalTime pgTimestamp+            restored = Timestamp.normalizeFromLocalTime localTime+         in Timestamp.toLocalTime restored === localTime
+ src/unit-tests/PostgresqlTypes/TimestamptzSpec.hs view
@@ -0,0 +1,54 @@+module PostgresqlTypes.TimestamptzSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified Data.Time as Time+import qualified PostgresqlTypes.Timestamptz as Timestamptz+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Timestamptz.Timestamptz)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Timestamptz.Timestamptz)++  describe "Constructors" do+    describe "normalizeFromUtcTime" do+      it "creates Timestamptz from UTCTime" do+        let day = Time.fromGregorian 2023 6 15+            diffTime = Time.secondsToDiffTime 45045 -- 12:30:45+            utcTime = Time.UTCTime day diffTime+            pgTimestamptz = Timestamptz.normalizeFromUtcTime utcTime+        Timestamptz.toUtcTime pgTimestamptz `shouldBe` utcTime++      it "handles epoch" do+        let day = Time.fromGregorian 2000 1 1+            diffTime = Time.secondsToDiffTime 0+            utcTime = Time.UTCTime day diffTime+            pgTimestamptz = Timestamptz.normalizeFromUtcTime utcTime+        Timestamptz.toUtcTime pgTimestamptz `shouldBe` utcTime++  describe "Accessors" do+    describe "toUtcTime" do+      it "extracts UTCTime value" do+        let day = Time.fromGregorian 2023 6 15+            diffTime = Time.secondsToDiffTime 45045+            utcTime = Time.UTCTime day diffTime+            pgTimestamptz = Timestamptz.normalizeFromUtcTime utcTime+        Timestamptz.toUtcTime pgTimestamptz `shouldBe` utcTime++  describe "Property Tests" do+    it "roundtrips through toUtcTime and normalizeFromUtcTime" do+      property \(pgTimestamptz :: Timestamptz.Timestamptz) ->+        let utcTime = Timestamptz.toUtcTime pgTimestamptz+            pgTimestamptz' = Timestamptz.normalizeFromUtcTime utcTime+         in pgTimestamptz' === pgTimestamptz++    it "roundtrips through normalizeFromUtcTime and toUtcTime" do+      property \(pgTimestamptz :: Timestamptz.Timestamptz) ->+        let utcTime = Timestamptz.toUtcTime pgTimestamptz+            restored = Timestamptz.normalizeFromUtcTime utcTime+         in Timestamptz.toUtcTime restored === utcTime
+ src/unit-tests/PostgresqlTypes/TimetzSpec.hs view
@@ -0,0 +1,287 @@+module PostgresqlTypes.TimetzSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Int+import Data.Maybe+import qualified Data.Time as Time+import qualified PostgresqlTypes.Timetz as Timetz+import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck as QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Timetz.Timetz)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Timetz.Timetz)++  describe "Constructors" do+    describe "normalizeFromTimeInMicrosecondsAndOffsetInSeconds" do+      it "clamps time values below minimum" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds (-100) 0+        Timetz.toTimeInMicroseconds timetz `shouldBe` 0++      it "clamps time values above maximum" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 90_000_000_000 0+        Timetz.toTimeInMicroseconds timetz `shouldBe` 86_400_000_000++      it "clamps offset values below minimum" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 (-60_000)+        Timetz.toTimeZoneInSeconds timetz `shouldBe` (-57_599)++      it "clamps offset values above maximum" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 60_000+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 57_599++      it "accepts valid values within range" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 43_200_000_000 3600+        Timetz.toTimeInMicroseconds timetz `shouldBe` 43_200_000_000+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 3600++    describe "refineFromTimeInMicrosecondsAndOffsetInSeconds" do+      it "rejects time values below minimum" do+        Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds (-1) 0 `shouldBe` Nothing++      it "rejects time values above maximum" do+        Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 86_400_000_001 0 `shouldBe` Nothing++      it "rejects offset values below minimum" do+        Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 0 (-57_600) `shouldBe` Nothing++      it "rejects offset values above maximum" do+        Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 0 57_600 `shouldBe` Nothing++      it "accepts minimum time and offset" do+        let result = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 0 (-57_599)+        result `shouldSatisfy` isJust++      it "accepts maximum time and offset" do+        let result = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 86_400_000_000 57_599+        result `shouldSatisfy` isJust++      it "accepts valid values within range" do+        let result = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 43_200_000_000 3600+        result `shouldSatisfy` isJust++      describe "normalizeFromTimeOfDayAndTimeZone" do+        it "clamps invalid TimeOfDay to valid range" do+          let invalidTimeOfDay = Time.TimeOfDay 25 0 0 -- Invalid hour+          -- This will be normalized internally by TimeOfDay+              timetz = Timetz.normalizeFromTimeOfDayAndTimeZone invalidTimeOfDay (Time.TimeZone 0 False "UTC")+          -- The time should be normalized (wrapped around)+          Timetz.toTimeInMicroseconds timetz `shouldSatisfy` (<= 86_400_000_000)++        it "clamps extreme time zone offsets" do+          let timeOfDay = Time.TimeOfDay 12 0 0+              extremeOffset = Time.TimeZone 10000 False "EXTREME" -- Very large offset+              timetz = Timetz.normalizeFromTimeOfDayAndTimeZone timeOfDay extremeOffset+          -- Offset should be clamped to valid range+          abs (Timetz.toTimeZoneInSeconds timetz) `shouldSatisfy` (<= 57_599)++        it "handles valid time and time zone" do+          let timeOfDay = Time.TimeOfDay 15 30 45+              timeZone = Time.TimeZone 60 False "UTC+1" -- +1 hour+              timetz = Timetz.normalizeFromTimeOfDayAndTimeZone timeOfDay timeZone+          Timetz.toTimeInMicroseconds timetz `shouldBe` (15 * 3600 + 30 * 60 + 45) * 1_000_000+          Timetz.toTimeZoneInSeconds timetz `shouldBe` 3600++      describe "refineFromTimeOfDayAndTimeZone" do+        it "rejects TimeOfDay that doesn't fit in valid range" do+          -- TimeOfDay with 24:00:00.000001 would exceed maximum+          let result = Timetz.refineFromTimeOfDayAndTimeZone (Time.TimeOfDay 24 0 0.000001) (Time.TimeZone 0 False "UTC")+          result `shouldBe` Nothing++        it "accepts midnight (00:00:00)" do+          let result = Timetz.refineFromTimeOfDayAndTimeZone (Time.TimeOfDay 0 0 0) (Time.TimeZone 0 False "UTC")+          result `shouldSatisfy` isJust++        it "accepts exactly 24:00:00" do+          let result = Timetz.refineFromTimeOfDayAndTimeZone (Time.TimeOfDay 24 0 0) (Time.TimeZone 0 False "UTC")+          result `shouldSatisfy` isJust++        it "accepts valid time and time zone" do+          let result = Timetz.refineFromTimeOfDayAndTimeZone (Time.TimeOfDay 15 30 45) (Time.TimeZone 60 False "UTC+1")+          result `shouldSatisfy` isJust++    describe "Accessors" do+      describe "toTimeInMicroseconds" do+        it "extracts time in microseconds" do+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 43_200_000_000 0+          Timetz.toTimeInMicroseconds timetz `shouldBe` 43_200_000_000++      describe "toTimeZoneInSeconds" do+        it "extracts time zone offset in seconds" do+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 3600+          Timetz.toTimeZoneInSeconds timetz `shouldBe` 3600++      describe "toTimeOfDay" do+        it "converts to TimeOfDay correctly" do+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds ((15 * 3600 + 30 * 60 + 45) * 1_000_000) 0+              timeOfDay = Timetz.toTimeOfDay timetz+          timeOfDay `shouldBe` Time.TimeOfDay 15 30 45++      describe "normalizeToTimeZone" do+        it "normalizes offset to TimeZone with minute precision" do+          -- Test with offset that is a multiple of 60+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 3600+              timeZone = Timetz.normalizeToTimeZone timetz+          Time.timeZoneMinutes timeZone `shouldBe` 60++        it "rounds offset that is not a multiple of 60" do+          -- Test with offset that includes seconds+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 3630 -- 60:30+              timeZone = Timetz.normalizeToTimeZone timetz+          -- Should be rounded to nearest minute+          Time.timeZoneMinutes timeZone `shouldSatisfy` (\m -> abs (m - 60) <= 1)++      describe "refineToTimeZone" do+        it "returns Just for offset that is a multiple of 60" do+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 3600+          Timetz.refineToTimeZone timetz `shouldSatisfy` isJust++        it "returns Nothing for offset that is not a multiple of 60" do+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 3630+          Timetz.refineToTimeZone timetz `shouldBe` Nothing++    describe "Edge cases" do+      it "handles minimum bound time (00:00:00)" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 0+        Timetz.toTimeOfDay timetz `shouldBe` Time.TimeOfDay 0 0 0++      it "handles maximum bound time (24:00:00)" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 86_400_000_000 0+        Timetz.toTimeOfDay timetz `shouldBe` Time.TimeOfDay 24 0 0++      it "handles minimum time zone offset (-15:59:59)" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 (-57_599)+        Timetz.toTimeZoneInSeconds timetz `shouldBe` (-57_599)++      it "handles maximum time zone offset (+15:59:59)" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 57_599+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 57_599++      it "handles midnight UTC" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 0+        Timetz.toTimeInMicroseconds timetz `shouldBe` 0+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 0++      it "handles noon with positive offset" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds (12 * 3600 * 1_000_000) 3600+        Timetz.toTimeOfDay timetz `shouldBe` Time.TimeOfDay 12 0 0+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 3600++      it "handles noon with negative offset" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds (12 * 3600 * 1_000_000) (-3600)+        Timetz.toTimeOfDay timetz `shouldBe` Time.TimeOfDay 12 0 0+        Timetz.toTimeZoneInSeconds timetz `shouldBe` (-3600)++    describe "Conversion instances" do+      describe "IsSome (Int64, Int32) Timetz" do+        it "converts valid values" do+          let result = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 43_200_000_000 3600+          result `shouldSatisfy` isJust++        it "rejects invalid time values" do+          let result = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 90_000_000_000 0+          result `shouldBe` Nothing++        it "rejects invalid offset values" do+          let result = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds 0 60_000+          result `shouldBe` Nothing++        it "roundtrips valid values" do+          QuickCheck.property \(timetz :: Timetz.Timetz) ->+            let microseconds = Timetz.toTimeInMicroseconds timetz+                seconds = Timetz.toTimeZoneInSeconds timetz+                restored = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds microseconds seconds+             in restored === Just timetz++      describe "IsMany (Int64, Int32) Timetz" do+        it "normalizes out-of-range values" do+          let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 90_000_000_000 60_000+          -- Values should be clamped+          Timetz.toTimeInMicroseconds timetz `shouldBe` 86_400_000_000+          Timetz.toTimeZoneInSeconds timetz `shouldBe` 57_599++    describe "Property-based tests" do+      it "toTimeInMicroseconds returns value in valid range" do+        QuickCheck.property \(timetz :: Timetz.Timetz) ->+          let microseconds = Timetz.toTimeInMicroseconds timetz+           in microseconds >= 0 .&&. microseconds <= 86_400_000_000++      it "toTimeZoneInSeconds returns value in valid range" do+        QuickCheck.property \(timetz :: Timetz.Timetz) ->+          let seconds = Timetz.toTimeZoneInSeconds timetz+           in seconds >= (-57_599) .&&. seconds <= 57_599++      it "normalizeFrom* followed by refineFrom* is identity" do+        QuickCheck.property \(microseconds :: Int64, seconds :: Int32) ->+          let normalized = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds microseconds seconds+              microseconds' = Timetz.toTimeInMicroseconds normalized+              seconds' = Timetz.toTimeZoneInSeconds normalized+              projected = Timetz.refineFromTimeInMicrosecondsAndOffsetInSeconds microseconds' seconds'+           in projected === Just normalized++      it "toTimeOfDay followed by normalizeFromTimeOfDay preserves value" do+        QuickCheck.property \(timetz :: Timetz.Timetz) ->+          let timeOfDay = Timetz.toTimeOfDay timetz+              timeZone = Timetz.normalizeToTimeZone timetz+              restored = Timetz.normalizeFromTimeOfDayAndTimeZone timeOfDay timeZone+           in Timetz.toTimeInMicroseconds restored === Timetz.toTimeInMicroseconds timetz++      it "Eq is reflexive" do+        QuickCheck.property \(timetz :: Timetz.Timetz) ->+          timetz === timetz++      it "Eq is symmetric" do+        QuickCheck.property \(t1 :: Timetz.Timetz, t2 :: Timetz.Timetz) ->+          (t1 == t2) === (t2 == t1)++      it "Eq is transitive" do+        QuickCheck.property \(t1 :: Timetz.Timetz, t2 :: Timetz.Timetz, t3 :: Timetz.Timetz) ->+          if (t1 == t2) && (t2 == t3)+            then t1 === t3+            else property True++      it "Ord is consistent with Eq" do+        QuickCheck.property \(t1 :: Timetz.Timetz, t2 :: Timetz.Timetz) ->+          (t1 == t2) === (compare t1 t2 == EQ)++      it "Ord is transitive" do+        QuickCheck.property \(t1 :: Timetz.Timetz, t2 :: Timetz.Timetz, t3 :: Timetz.Timetz) ->+          ((t1 <= t2) && (t2 <= t3)) ==> (t1 <= t3)++      it "Ord is antisymmetric" do+        QuickCheck.property \(t1 :: Timetz.Timetz, t2 :: Timetz.Timetz) ->+          if (t1 <= t2) && (t2 <= t1)+            then t1 === t2+            else property True++      it "Ord is total" do+        QuickCheck.property \(t1 :: Timetz.Timetz, t2 :: Timetz.Timetz) ->+          (t1 <= t2) .||. (t2 <= t1)++    describe "Boundary value tests" do+      it "handles microsecond precision" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 1 0+        Timetz.toTimeInMicroseconds timetz `shouldBe` 1++      it "handles maximum microseconds (one microsecond before 24:00:00)" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds (86_400_000_000 - 1) 0+        Timetz.toTimeInMicroseconds timetz `shouldBe` (86_400_000_000 - 1)++      it "handles one second offset" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 1+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 1++      it "handles one second before minimum offset" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 (-57_598)+        Timetz.toTimeZoneInSeconds timetz `shouldBe` (-57_598)++      it "handles one second before maximum offset" do+        let timetz = Timetz.normalizeFromTimeInMicrosecondsAndOffsetInSeconds 0 57_598+        Timetz.toTimeZoneInSeconds timetz `shouldBe` 57_598
+ src/unit-tests/PostgresqlTypes/UuidSpec.hs view
@@ -0,0 +1,42 @@+module PostgresqlTypes.UuidSpec (spec) where++import Data.Data (Proxy (Proxy))+import qualified Data.UUID as UUID+import qualified PostgresqlTypes.Uuid as Uuid+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @Uuid.Uuid)++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @Uuid.Uuid)++  describe "Constructors" do+    describe "fromUUID" do+      it "creates Uuid from UUID" do+        let uuid = UUID.nil+            pgUuid = Uuid.fromUUID uuid+        Uuid.toUUID pgUuid `shouldBe` uuid++  describe "Accessors" do+    describe "toUUID" do+      it "extracts UUID value" do+        let uuid = UUID.nil+            pgUuid = Uuid.fromUUID uuid+        Uuid.toUUID pgUuid `shouldBe` uuid++  describe "Property Tests" do+    it "roundtrips through toUUID and fromUUID" do+      property \(uuid :: UUID.UUID) ->+        let pgUuid = Uuid.fromUUID uuid+         in Uuid.toUUID pgUuid === uuid++    it "roundtrips through fromUUID and toUUID" do+      property \(pgUuid :: Uuid.Uuid) ->+        let uuid = Uuid.toUUID pgUuid+            pgUuid' = Uuid.fromUUID uuid+         in pgUuid' === pgUuid
+ src/unit-tests/PostgresqlTypes/VarbitSpec.hs view
@@ -0,0 +1,76 @@+module PostgresqlTypes.VarbitSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Vector.Unboxed as VU+import qualified PostgresqlTypes.Varbit as Varbit+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Varbit.Varbit 16))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Varbit.Varbit 16))++  describe "Varbit 16" do+    describe "Constructors" do+      describe "normalizeFromBoolList" do+        it "creates Varbit from list within max length" do+          let varbit = Varbit.normalizeFromBoolList @16 [True, False, True, False, True]+          Varbit.toBoolList varbit `shouldBe` [True, False, True, False, True]++        it "truncates list exceeding max length" do+          let varbit = Varbit.normalizeFromBoolList @16 (replicate 20 True)+          length (Varbit.toBoolList varbit) `shouldBe` 16++        it "accepts empty list" do+          let varbit = Varbit.normalizeFromBoolList @16 []+          Varbit.toBoolList varbit `shouldBe` []++      describe "refineFromBoolList" do+        it "rejects list exceeding max length" do+          Varbit.refineFromBoolList @16 (replicate 20 True) `shouldBe` Nothing++        it "accepts list within max length" do+          let result = Varbit.refineFromBoolList @16 [True, False, True]+          result `shouldSatisfy` isJust++        it "accepts empty list" do+          let result = Varbit.refineFromBoolList @16 []+          result `shouldSatisfy` isJust++      describe "normalizeFromBoolVector" do+        it "creates Varbit from vector" do+          let vec = VU.fromList [True, False, True, False]+              varbit = Varbit.normalizeFromBoolVector @16 vec+          Varbit.toBoolVector varbit `shouldBe` vec++    describe "Accessors" do+      describe "toBoolList" do+        it "extracts Bool list" do+          let varbit = Varbit.normalizeFromBoolList @16 [True, True, False]+          Varbit.toBoolList varbit `shouldBe` [True, True, False]++      describe "toBoolList" do+        it "extracts Bool list" do+          let bools = [True, False, True, False]+              varbit = Varbit.normalizeFromBoolList @16 bools+          Varbit.toBoolList varbit `shouldBe` bools++    describe "Property Tests" do+      it "roundtrips through toBoolList and normalizeFromBoolList" do+        property \(varbit :: Varbit.Varbit 16) ->+          let bools = Varbit.toBoolList varbit+              varbit' = Varbit.normalizeFromBoolList @16 bools+           in varbit' === varbit++      it "roundtrips through toBoolList and normalizeFromBoolVector" do+        property \(varbit :: Varbit.Varbit 16) ->+          let vec = Varbit.toBoolVector @_ @VU.Vector varbit+              varbit' = Varbit.normalizeFromBoolVector @16 vec+           in varbit' === varbit
+ src/unit-tests/PostgresqlTypes/VarcharSpec.hs view
@@ -0,0 +1,64 @@+module PostgresqlTypes.VarcharSpec (spec) where++import Data.Data (Proxy (Proxy))+import Data.Maybe+import qualified Data.Text as Text+import qualified PostgresqlTypes.Varchar as Varchar+import Test.Hspec+import Test.QuickCheck+import qualified UnitTests.Scripts as Scripts+import Prelude++spec :: Spec+spec = do+  describe "Show/Read laws" do+    Scripts.testShowRead (Proxy @(Varchar.Varchar 10))++  describe "IsScalar laws" do+    Scripts.testIsScalar (Proxy @(Varchar.Varchar 10))++  describe "Varchar 10" do+    describe "Constructors" do+      describe "normalizeFromText" do+        it "truncates text exceeding max length" do+          let varchar = Varchar.normalizeFromText @10 "Hello World!"+          Text.length (Varchar.toText varchar) `shouldBe` 10++        it "preserves text within max length" do+          let varchar = Varchar.normalizeFromText @10 "Hello"+          Varchar.toText varchar `shouldBe` "Hello"++        it "strips null characters" do+          let varchar = Varchar.normalizeFromText @10 "hel\NULlo"+          Varchar.toText varchar `shouldBe` "hello"++      describe "refineFromText" do+        it "rejects text exceeding max length" do+          Varchar.refineFromText @10 "Hello World!" `shouldBe` Nothing++        it "rejects text with null characters" do+          Varchar.refineFromText @10 "hel\NULlo" `shouldBe` Nothing++        it "accepts valid text" do+          let result = Varchar.refineFromText @10 "Hello"+          result `shouldSatisfy` isJust+          fmap Varchar.toText result `shouldBe` Just "Hello"++    describe "Accessors" do+      describe "toText" do+        it "extracts text value" do+          let varchar = Varchar.normalizeFromText @10 "test"+          Varchar.toText varchar `shouldBe` "test"++    describe "Property Tests" do+      it "normalizeFromText is idempotent" do+        property \(t :: Text.Text) ->+          let normalized1 = Varchar.normalizeFromText @10 t+              normalized2 = Varchar.normalizeFromText @10 (Varchar.toText normalized1)+           in normalized1 === normalized2++      it "refineFromText succeeds for valid varchars" do+        property \(varchar :: Varchar.Varchar 10) ->+          let t = Varchar.toText varchar+              refined = Varchar.refineFromText @10 t+           in refined === Just varchar
+ src/unit-tests/SpecHook.hs view
@@ -0,0 +1,6 @@+module SpecHook where++import Test.Hspec++hook :: Spec -> Spec+hook = parallel
+ src/unit-tests/UnitTests/Scripts.hs view
@@ -0,0 +1,55 @@+module UnitTests.Scripts where++import Control.Monad+import qualified Data.Attoparsec.Text+import Data.Proxy+import Data.Tagged+import qualified Data.Text as Text+import qualified PostgresqlTypes.Algebra+import qualified PtrPeeker+import qualified PtrPoker.Write+import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck.Classes as Laws+import qualified TextBuilder+import Prelude++-- | Test textual encoder/decoder roundtrip+testIsScalar ::+  forall a.+  ( Arbitrary a,+    Show a,+    Read a,+    Eq a,+    PostgresqlTypes.Algebra.IsScalar a+  ) =>+  Proxy a ->+  Spec+testIsScalar _ =+  let name = Text.unpack (untag (PostgresqlTypes.Algebra.typeSignature @a))+      binEnc = PostgresqlTypes.Algebra.binaryEncoder @a+      binDec = PostgresqlTypes.Algebra.binaryDecoder @a+      txtEnc = PostgresqlTypes.Algebra.textualEncoder @a+      txtDec = PostgresqlTypes.Algebra.textualDecoder @a+   in describe name do+        describe "Encoding via textualEncoder" do+          describe "And decoding via textualDecoder" do+            it "Should produce the original value" $+              property \(value :: a) ->+                let encoded = TextBuilder.toText (txtEnc value)+                    decoding = Data.Attoparsec.Text.parseOnly txtDec encoded+                 in counterexample ("Encoded: " ++ show encoded) $+                      decoding === Right value++        describe "Encoding via binaryEncoder" do+          describe "And decoding via binaryDecoder" do+            it "Should produce the original value" $+              property \(value :: a) ->+                let encoded = PtrPoker.Write.toByteString (binEnc value)+                    decoding = PtrPeeker.runVariableOnByteString binDec encoded+                 in decoding === Right (Right value)++testShowRead :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> SpecWith ()+testShowRead proxy =+  forM_ (Laws.lawsProperties (Laws.showReadLaws proxy)) \(name, property) ->+    it name property