rel8 1.6.0.0 → 1.7.0.0

raw patch · 32 files changed

+2200/−428 lines, 32 filesdep −attoparsec-aesondep −binary-parserdep −data-dworddep ~basedep ~base-compatdep ~hasqlPVP ok

version bump matches the API change (PVP)

Dependencies removed: attoparsec-aeson, binary-parser, data-dword, data-textual, network-ip

Dependency ranges changed: base, base-compat, hasql, hedgehog, tmp-postgres

API changes (from Hackage documentation)

Files

• Changelog.md +38/−0
• rel8.cabal +22/−13
• src/Rel8.hs +4/−6
• src/Rel8/Aggregate.hs +1/−1
• src/Rel8/Array.hs +30/−1
• src/Rel8/Decoder.hs +6/−0
• src/Rel8/Encoder.hs +4/−0
• src/Rel8/Expr/Aggregate.hs +3/−3
• src/Rel8/Expr/Order.hs +1/−1
• src/Rel8/Expr/Serialize.hs +5/−3
• src/Rel8/Generic/Construction/ADT.hs +4/−4
• src/Rel8/Generic/Construction/Record.hs +2/−2
• src/Rel8/Statement/Prepared.hs +87/−0
• src/Rel8/Statement/Run.hs +27/−4
• src/Rel8/Statement/SQL.hs +12/−0
• src/Rel8/Table/Verify.hs +644/−0
• src/Rel8/Type.hs +233/−186
• src/Rel8/Type/Array.hs +99/−35
• src/Rel8/Type/Builder/ByteString.hs +16/−0
• src/Rel8/Type/Builder/Fold.hs +16/−0
• src/Rel8/Type/Builder/Time.hs +151/−0
• src/Rel8/Type/Composite.hs +79/−19
• src/Rel8/Type/Decimal.hs +1/−1
• src/Rel8/Type/Decoder.hs +4/−14
• src/Rel8/Type/Encoder.hs +43/−0
• src/Rel8/Type/Enum.hs +35/−15
• src/Rel8/Type/Information.hs +20/−20
• src/Rel8/Type/JSONBEncoded.hs +31/−9
• src/Rel8/Type/JSONEncoded.hs +30/−17
• src/Rel8/Type/Nullable.hs +16/−0
• tests/Main.hs +189/−72
• tests/Rel8/Generic/Rel8able/Test.hs +347/−2

@@ -1,4 +1,42 @@ +<a id='changelog-1.7.0.0'></a>+# 1.7.0.0 — 2025-07-31++## Removed++- Removed support for `network-ip`. We still support `iproute`.++## Added++- Add support for prepared statements. To use prepared statements, simply use `prepare run` instead of `run` with a function that passes the parameters to your statement.++- Added new `Encoder` type with three members: `binary`, which is the Hasql binary encoder, `text` which encodes a type in PostgreSQL's text format (needed for nested arrays) and `quote`, which is the does the thing that the function we previously called `encode` does (i.e., `a -> Opaleye.PrimExpr`).++- Support hasql-1.9++- Add `elem` and `elem1` to `Rel8.Array` for testing if an element is contained in `[]` and `NonEmpty` `Expr`s.++## Changed++- Several changes to `TypeInformation`:++  * Changed the `encode` field of `TypeInformation` to be `Encoder a` instead of `a -> Opaleye.PrimExpr`.++  * Moved the `delimiter` field of `Decoder` into the top level of `TypeInformation`, as it's not "decoding" specific, it's also used when "encoding".++  * Renamed the `parser` field of `Decoder` to `text`, to mirror the `text` field of the new `Encoder` type.++  All of this will break any downstream code that uses a completely custom `DBType` implementation, but anything that uses `ReadShow`, `Enum`, `Composite`, `JSONBEncoded` or `parseTypeInformation` will continue working as before (which should cover all common cases).++- Stop exporting `Decoder` and `Encoder` from the `Rel8` module. These can now be found in `Rel8.Decoder` and `Rel8.Encoder`.++- Some changes were made to the `DBEnum` type class:++  * `Enumable` was removed as a superclass constraint. It is still used to provide the default implementation of the `DBEnum` class.+  * A new method, `enumerate`, was added to the `DBEnum` class (with the default implementation provided by `Enumable`).++  This is unlikely to break any existing `DBEnum` instances, it just allows some instances that weren't possible before (e.g., for types that are not `Generic`).+ <a id='changelog-1.6.0.0'></a> # 1.6.0.0 — 2024-12-13 

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.6.0.0+version:             1.7.0.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -21,20 +21,16 @@   build-depends:       aeson     , attoparsec-    , attoparsec-aeson-    , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20+    , base >= 4.16 && < 4.22     , base16 >= 1.0-    , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13 || ^>= 0.14+    , base-compat >= 0.11 && < 0.15     , bifunctors-    , binary-parser ^>= 0.5-    , data-dword ^>= 0.3     , bytestring     , case-insensitive     , comonad+    , containers     , contravariant-    , data-textual-    , hasql >= 1.6.1.2 && < 1.9-    , network-ip ^>= 0.3+    , hasql >= 1.8 && < 1.10     , iproute ^>= 1.7     , opaleye ^>= 0.10.2.1     , pretty@@ -60,14 +56,21 @@     -Wno-monomorphism-restriction     -Wno-missing-local-signatures     -Wno-missing-kind-signatures+    -Wno-missing-role-annotations+    -Wno-missing-deriving-strategies+    -Wno-term-variable-capture+   hs-source-dirs:     src   exposed-modules:     Rel8     Rel8.Array+    Rel8.Decoder+    Rel8.Encoder     Rel8.Expr.Num     Rel8.Expr.Text     Rel8.Expr.Time+    Rel8.Table.Verify     Rel8.Tabulate    other-modules:@@ -175,6 +178,7 @@     Rel8.Statement.Delete     Rel8.Statement.Insert     Rel8.Statement.OnConflict+    Rel8.Statement.Prepared     Rel8.Statement.Returning     Rel8.Statement.Rows     Rel8.Statement.Run@@ -215,16 +219,21 @@      Rel8.Type     Rel8.Type.Array+    Rel8.Type.Builder.ByteString+    Rel8.Type.Builder.Fold+    Rel8.Type.Builder.Time     Rel8.Type.Composite     Rel8.Type.Decimal     Rel8.Type.Decoder     Rel8.Type.Eq+    Rel8.Type.Encoder     Rel8.Type.Enum     Rel8.Type.Information     Rel8.Type.JSONEncoded     Rel8.Type.JSONBEncoded     Rel8.Type.Monoid     Rel8.Type.Name+    Rel8.Type.Nullable     Rel8.Type.Num     Rel8.Type.Ord     Rel8.Type.Parser@@ -247,20 +256,19 @@     , bytestring     , case-insensitive     , containers-    , data-dword     , hasql     , hasql-transaction-    , hedgehog          ^>= 1.0 || ^>= 1.1 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 || ^>= 1.5+    , hedgehog          >= 1.0 && < 1.6     , mmorph-    , network-ip     , iproute     , rel8     , scientific     , tasty     , tasty-hedgehog     , text+    , these     , time-    , tmp-postgres      ^>=1.34.1.0+    , tmp-postgres >=1.34 && <1.36     , transformers     , uuid     , vector@@ -277,3 +285,4 @@     -Wno-deprecations -Wno-monomorphism-restriction     -Wno-missing-local-signatures -Wno-implicit-prelude     -Wno-missing-kind-signatures+    -Wno-missing-role-annotations

@@ -23,9 +23,6 @@   , mapTypeInformation   , parseTypeInformation -    -- *** @Decoder@-  , Decoder(..)-     -- ** The @DBType@ hierarchy   , DBSemigroup(..)   , DBMonoid(..)@@ -355,6 +352,7 @@   , run1   , runMaybe   , runVector+  , prepared      -- ** @SELECT@   , select@@ -383,6 +381,7 @@     -- ** @WITH@   , Statement   , showStatement+  , showPreparedStatement      -- ** @CREATE VIEW@   , createView@@ -460,6 +459,7 @@ import Rel8.Statement.Delete import Rel8.Statement.Insert import Rel8.Statement.OnConflict+import Rel8.Statement.Prepared import Rel8.Statement.Returning import Rel8.Statement.Run import Rel8.Statement.Select@@ -491,7 +491,6 @@ import Rel8.Table.Window import Rel8.Type import Rel8.Type.Composite-import Rel8.Type.Decoder import Rel8.Type.Eq import Rel8.Type.Enum import Rel8.Type.Information@@ -552,8 +551,7 @@ -- thingSchema :: TableSchema (ADT Thing Name) -- thingSchema = --   TableSchema---     { schema = Nothing,---       name = \"thing\",+--     { name = \"thing\", --       columns = --         nameADT @Thing --           \"tag\"

@@ -76,7 +76,7 @@ --   { customerId :: Column f CustomerId --   , totalOrders :: Column f Int64 --   , productsOrdered :: Column f Int64---   , totalPrice :: Column Scientific+--   , totalPrice :: Column f Scientific --   } --   deriving (Generic, Rel8able) --

@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+ module Rel8.Array   (     -- ** @ListTable@@@ -6,6 +10,7 @@   , index, indexExpr   , last, lastExpr   , length, lengthExpr+  , elem      -- ** @NonEmptyTable@   , NonEmptyTable@@ -13,6 +18,7 @@   , index1, index1Expr   , last1, last1Expr   , length1, length1Expr+  , elem1      -- ** Unsafe   , unsafeSubscript@@ -21,11 +27,34 @@ where  -- base-import Prelude hiding (head, last, length)+import Data.List.NonEmpty (NonEmpty)+import Prelude hiding (elem, head, last, length)  -- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Array (listOf, nonEmptyOf)+import Rel8.Expr.Function (rawBinaryOperator) import Rel8.Expr.List import Rel8.Expr.NonEmpty import Rel8.Expr.Subscript+import Rel8.Schema.Null (Sql) import Rel8.Table.List import Rel8.Table.NonEmpty+import Rel8.Type.Eq (DBEq)+++-- | @'elem' a as@ tests whether @a@ is an element of the list @as@.+elem :: Sql DBEq a => Expr a -> Expr [a] -> Expr Bool+elem = (<@) . listOf . pure+  where+    (<@) = rawBinaryOperator "<@"+infix 4 `elem`+++-- | @'elem1' a as@ tests whether @a@ is an element of the non-empty list+-- @as@.+elem1 :: Sql DBEq a => Expr a -> Expr (NonEmpty a) -> Expr Bool+elem1 = (<@) . nonEmptyOf . pure+  where+    (<@) = rawBinaryOperator "<@"+infix 4 `elem1`

@@ -0,0 +1,6 @@+module Rel8.Decoder (+  Decoder (..),+  Parser,+  parseDecoder,+) where+import Rel8.Type.Decoder

@@ -0,0 +1,4 @@+module Rel8.Encoder (+  Encoder (..),+) where+import Rel8.Type.Encoder

@@ -80,7 +80,7 @@ import Rel8.Table.Opaleye (fromOrder, unpackspec) import Rel8.Table.Order (ascTable) import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Array (arrayTypeName, encodeArrayElement)+import Rel8.Type.Array (arrayTypeName, quoteArrayElement) import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information (TypeInformation) import Rel8.Type.Num (DBFractional, DBNum)@@ -451,7 +451,7 @@   => TypeInformation (Unnullify a) -> Aggregator' fold (Expr a) (Expr [a]) slistAggExpr info =   unsafeMakeAggregator-    (toColumn . encodeArrayElement info . toPrimExpr)+    (toColumn . quoteArrayElement info . toPrimExpr)     (fromPrimExpr . fromColumn)     (Fallback (sempty info))     Opaleye.arrayAgg@@ -461,7 +461,7 @@   => TypeInformation (Unnullify a) -> Aggregator1 (Expr a) (Expr (NonEmpty a)) snonEmptyAggExpr info =   unsafeMakeAggregator-    (toColumn . encodeArrayElement info . toPrimExpr)+    (toColumn . quoteArrayElement info . toPrimExpr)     (fromPrimExpr . fromColumn)     Empty     Opaleye.arrayAgg

@@ -59,7 +59,7 @@     g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }  --- | Transform an ordering so that @null@ values appear first. This corresponds+-- | Transform an ordering so that @null@ values appear last. This corresponds -- to @NULLS LAST@ in SQL. nullsLast :: Order (Expr a) -> Order (Expr (Maybe a)) nullsLast (Order (Opaleye.Order f)) =

@@ -1,3 +1,4 @@+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} {-# language TypeFamilies #-}@@ -24,6 +25,7 @@ import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable ) import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) )  @@ -36,12 +38,12 @@   slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a-slitExpr nullity info@TypeInformation {encode} =+slitExpr nullity info@TypeInformation {encode = Encoder {quote}} =   scastExpr info . Expr . encoder   where     encoder = case nullity of-      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode-      NotNull -> encode+      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) quote+      NotNull -> quote   sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a

@@ -77,10 +77,10 @@  type NoConstructor :: Symbol -> Symbol -> ErrorMessage type NoConstructor datatype constructor =-  ( 'Text "The type `" ':<>:-    'Text datatype ':<>:-    'Text "` has no constructor `" ':<>:-    'Text constructor ':<>:+  ( 'Text "The type `" ' :<>:+    'Text datatype ' :<>:+    'Text "` has no constructor `" ' :<>:+    'Text constructor ' :<>:     'Text "`."   ) 

@@ -63,8 +63,8 @@ type family GConstructor rep where   GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name   GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (-    'Text "`" ':<>:-    'Text name ':<>:+    'Text "`" ' :<>:+    'Text name ' :<>:     'Text "` does not appear to have exactly 1 constructor"    ) 

@@ -0,0 +1,87 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++module Rel8.Statement.Prepared (+  input,+  prepared,+) where++-- base+import Data.Functor.Const (Const (Const), getConst)+import Data.Functor.Contravariant (contramap, (>$<))+import Data.Functor.Identity (runIdentity)+import Prelude++-- hasql+import qualified Hasql.Encoders as Hasql+import qualified Hasql.Statement as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (fromPrimExpr, scastExpr)+import Rel8.Schema.HTable (hfield, hspecs, htabulateA)+import Rel8.Schema.Null (Nullity (Null, NotNull))+import Rel8.Schema.Spec (Spec (..))+import Rel8.Statement (Statement)+import Rel8.Table (Table, fromColumns, toResult)+import Rel8.Table.Serialize (Serializable)+import Rel8.Type.Encoder (binary)+import Rel8.Type.Information (encode)++-- transformers+import Control.Monad.Trans.State.Strict (evalState, state)+++{-| Given a 'Rel8.run' function that converts a 'Statement' to a+'Hasql.Statement', return a 'Rel8.run'-like function which instead takes a+/parameterized/ 'Statement' and converts it to a /preparable/+'Hasql.Statement'.++The parameters @i@ are sent to the database directly via PostgreSQL's binary+format. For large amounts of data this can be significantly more efficient+than embedding the values in the statement with 'Rel8.lit'.+-}+prepared :: forall a b i o.+  Serializable a i =>+  (Statement b -> Hasql.Statement () o) ->+  (a -> Statement b) ->+  Hasql.Statement i o+prepared run mkStatement = Hasql.Statement sql (encoder @a) decode True+  where+    Hasql.Statement sql _ decode _ = run $ mkStatement input+++encoder :: forall a i. Serializable a i => Hasql.Params i+encoder =+  contramap (toResult @_ @a) $+    getConst $+      htabulateA \field ->+        case hfield hspecs field of+          Spec {nullity, info} -> Const $+            runIdentity . (`hfield` field) >$<+              case nullity of+                Null -> Hasql.param $ Hasql.nullable build+                NotNull -> Hasql.param $ Hasql.nonNullable build+              where+                build = binary (encode info)+++input :: Table Expr a => a+input =+  fromColumns $+    flip (evalState @Word) 1 do+      htabulateA \field -> do+        n <- state (\n -> (n, n + 1))+        pure+          case hfield hspecs field of+            Spec {info} ->+              scastExpr info $ fromPrimExpr $+                Opaleye.ConstExpr $ Opaleye.OtherLit $ '$' : show n

@@ -43,6 +43,10 @@  -- | Convert a 'Statement' to a runnable 'Hasql.Statement', disregarding the -- results of that statement (if any).+--+-- @+-- run_ :: Rel8.'Statement' exprs -> Hasql.'Hasql.Statement' () ()+-- @ run_ :: Statement exprs -> Hasql.Statement () () run_ = makeRun Void @@ -50,6 +54,10 @@ -- | Convert a 'Statement' to a runnable 'Hasql.Statement', returning the -- number of rows affected by that statement (for 'Rel8.insert's, -- 'Rel8.update's or Rel8.delete's with 'Rel8.NoReturning').+--+-- @+-- runN :: Rel8.'Statement' () -> Hasql.'Hasql.Statement' () 'Int64'+-- @ runN :: Statement () -> Hasql.Statement () Int64 runN = makeRun RowsAffected @@ -57,21 +65,32 @@ -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as a single row. If the statement returns a number -- of rows other than 1, a runtime exception is thrown.-run1 :: Serializable exprs -  a=> Statement (Query exprs) -> Hasql.Statement () a+--+-- @+-- run1 :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () a+-- @+run1 :: Serializable exprs a => Statement (Query exprs) -> Hasql.Statement () a run1 = makeRun Single   -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as 'Maybe' a single row. If the statement returns -- a number of rows other than 0 or 1, a runtime exception is thrown.-runMaybe :: Serializable exprs -  a=> Statement (Query exprs) -> Hasql.Statement () (Maybe a)+--+-- @+-- runMaybe :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () ('Maybe' a)+-- @+runMaybe :: Serializable exprs a+  => Statement (Query exprs) -> Hasql.Statement () (Maybe a) runMaybe = makeRun Maybe   -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as a list of rows.+--+-- @+-- run :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () [a]+-- @ run :: Serializable exprs a   => Statement (Query exprs) -> Hasql.Statement () [a] run = makeRun List@@ -79,6 +98,10 @@  -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as a 'Vector' of rows.+--+-- @+-- runVector :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () ('Vector' a)+-- @ runVector :: Serializable exprs a   => Statement (Query exprs) -> Hasql.Statement () (Vector a) runVector = makeRun Vector

@@ -1,8 +1,11 @@+{-# language FlexibleContexts #-}+ module Rel8.Statement.SQL   ( showDelete   , showInsert   , showUpdate   , showStatement+  , showPreparedStatement   ) where @@ -13,12 +16,15 @@ import qualified Opaleye.Internal.Tag as Opaleye  -- rel8+import Rel8.Expr (Expr) import Rel8.Statement (Statement, ppDecodeStatement) import Rel8.Statement.Delete ( Delete, ppDelete ) import Rel8.Statement.Insert ( Insert, ppInsert )+import Rel8.Statement.Prepared (input) import Rel8.Statement.Rows (Rows (Void)) import Rel8.Statement.Select (ppSelect) import Rel8.Statement.Update ( Update, ppUpdate )+import Rel8.Table (Table)  -- transformers import Control.Monad.Trans.State.Strict (evalState)@@ -42,3 +48,9 @@ -- | Convert a 'Statement' to a 'String' containing an SQL statement. showStatement :: Statement a -> String showStatement = show . fst . ppDecodeStatement ppSelect Void+++-- | Convert a parameterized 'Statement' to a 'String' containing an SQL+-- statement.+showPreparedStatement :: Table Expr i => (i -> Statement a) -> String+showPreparedStatement = showStatement . ($ input)

@@ -0,0 +1,644 @@++{-# language BlockArguments #-}+{-# language LambdaCase #-}+{-# language RecordWildCards #-}+{-# language RankNTypes #-}+{-# language DuplicateRecordFields #-}+{-# language DerivingStrategies #-}+{-# language OverloadedRecordDot #-}+{-# language TypeApplications #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneDeriving #-}+{-# language DeriveAnyClass #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language DeriveGeneric #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language OverloadedStrings #-}+{-# language GADTs #-}++module Rel8.Table.Verify+    ( getSchemaErrors+    , SomeTableSchema(..)+    , showCreateTable+    , checkedShowCreateTable+    ) where++-- base+import Control.Monad+import Data.Bits (shiftR, (.&.))+import Data.Either (lefts)+import Data.Function+import Data.Functor ((<&>))+import Data.Functor.Const+import Data.Functor.Contravariant ( (>$<) )+import Data.Int ( Int16, Int64 )+import qualified Data.List as L+import Data.List.NonEmpty ( NonEmpty((:|)) )+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (isJust, mapMaybe)+import Data.Text ( Text )+import qualified Data.Text as T+import GHC.Generics+import Prelude hiding ( filter )+import qualified Prelude as P++-- containers+import qualified Data.Map as M++-- hasql+import Hasql.Connection+import qualified Hasql.Statement as HS++-- rel8+import Rel8 -- not importing this seems to cause a type error???+import Rel8.Column ( Column )+import Rel8.Column.List ( HList )+import Rel8.Expr ( Expr )+import Rel8.Generic.Rel8able (GFromExprs, Rel8able)+import Rel8.Query ( Query )+import Rel8.Schema.HTable+import Rel8.Schema.Name ( Name(Name) )+import Rel8.Schema.Null hiding (nullable)+import qualified Rel8.Schema.Null as Null+import qualified Rel8.Statement.Run as RSR+import Rel8.Schema.Table ( TableSchema(..) )+import Rel8.Schema.Spec+import Rel8.Schema.Result ( Result )+import Rel8.Schema.QualifiedName ( QualifiedName(..) )+import Rel8.Table ( Columns )+import Rel8.Table.List ( ListTable )+import Rel8.Table.Serialize ( ToExprs )+import Rel8.Type ( DBType(..) )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Name ( TypeName(..) )++-- these+import Data.These+++data Relkind+    = OrdinaryTable+    | Index+    | Sequence+    | ToastTable+    | View+    | MaterializedView+    | CompositeType+    | ForeignTable+    | PartitionedTable+    | PartitionedIndex+  deriving stock (Show)+  deriving anyclass (DBEq)++instance DBType Relkind where+  typeInformation = parseTypeInformation parser printer typeInformation+    where+      parser = \case+        "r"         -> pure OrdinaryTable+        "i"         -> pure Index+        "S"         -> pure Sequence+        "t"         -> pure ToastTable+        "v"         -> pure View+        "m"         -> pure MaterializedView+        "c"         -> pure CompositeType+        "f"         -> pure ForeignTable+        "p"         -> pure PartitionedTable+        "I"         -> pure PartitionedIndex+        (x :: Text) -> Left $ "Unknown relkind: " ++ show x++      printer = \case+        OrdinaryTable -> "r"+        Index -> "i"+        Sequence -> "S"+        ToastTable -> "t"+        View -> "v"+        MaterializedView -> "m"+        CompositeType -> "c"+        ForeignTable -> "f"+        PartitionedTable -> "p"+        PartitionedIndex -> "I"++newtype Oid = Oid Int64+  deriving newtype (DBType, DBEq, Show)++data PGClass f = PGClass+  { oid :: Column f Oid+  , relname :: Column f Text+  , relkind :: Column f Relkind+  , relnamespace :: Column f Oid+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGClass Result)++pgclass :: TableSchema (PGClass Name)+pgclass = TableSchema+  { name = QualifiedName "pg_class" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGAttribute f = PGAttribute+  { attrelid :: Column f Oid+  , attname :: Column f Text+  , atttypid :: Column f Oid+  , attnum :: Column f Int64+  , atttypmod :: Column f Int64+  , attnotnull :: Column f Bool+  , attndims :: Column f Int16+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGAttribute Result)++pgattribute :: TableSchema (PGAttribute Name)+pgattribute = TableSchema+  { name = QualifiedName "pg_attribute" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGType f = PGType+  { oid :: Column f Oid+  , typname :: Column f Text+  , typnamespace :: Column f Oid+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGType Result)++pgtype :: TableSchema (PGType Name)+pgtype = TableSchema+  { name = QualifiedName "pg_type" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGNamespace f = PGNamespace+  { oid :: Column f Oid+  , nspname :: Column f Text+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGNamespace Result)++pgnamespace :: TableSchema (PGNamespace Name)+pgnamespace = TableSchema+  { name = QualifiedName "pg_namespace" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGCast f = PGCast+  { oid :: Column f Oid+  , castsource :: Column f Oid+  , casttarget :: Column f Oid+  , castfunc :: Column f Oid+  , castcontext :: Column f Text -- Char+  , castmethod :: Column f Char+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGCast Result)++pgcast :: TableSchema (PGCast Name)+pgcast = TableSchema+  { name = QualifiedName "pg_cast" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGTable f = PGTable+  { name :: Column f Text+  , columns :: HList f (Attribute f)+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGTable Result)++data Attribute f = Attribute+  { attribute :: PGAttribute f+  , typ :: PGType f+  , namespace :: PGNamespace f+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (Attribute Result)++data Cast f = Cast+  { source :: PGType f+  , target :: PGType f+  , context :: Column f Text -- Char +  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (Cast Result)++fetchTables :: Query (ListTable Expr (PGTable Expr))+fetchTables = many do+    PGClass{ oid = tableOid, relname } <- orderBy (relname >$< asc) do+      each pgclass+        >>= filter ((lit OrdinaryTable ==.) . relkind)++    columns <- many do+      attribute@PGAttribute{ atttypid } <-+        each pgattribute+          >>= filter ((tableOid ==.) . attrelid)+          >>= filter ((>. 0) . attnum)++      typ <-+        each pgtype+          >>= filter (\PGType{ oid = typoid } -> atttypid ==. typoid)++      namespace <-+        each pgnamespace+          >>= filter (\PGNamespace{ oid = nsoid } -> nsoid ==. typ.typnamespace)++++      return Attribute{ attribute, typ, namespace }++    return PGTable+      { name = relname+      , ..+      }++fetchCasts :: Query (ListTable Expr (Cast Expr))+fetchCasts = many do+    PGCast {castsource, casttarget, castcontext} <- each pgcast+    src <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. castsource)+    tgt <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. casttarget)+    return Cast { source = src, target = tgt, context = castcontext }+++data CheckEnv = CheckEnv+  { schemaMap :: M.Map String [Attribute Result] -- map of schemas to attributes+  , casts :: [(String, String)] -- list of implicit casts+  } deriving (Show)+++nullableToBool :: Nullity a -> Bool+nullableToBool Null = True+nullableToBool NotNull = False+++attrsToMap :: [Attribute Result] -> M.Map String (Attribute Result)+attrsToMap = M.fromList . map (\attr -> (T.unpack attr.attribute.attname, attr))+++data TypeInfo = TypeInfo+  { label :: [String]+  , isNull :: Bool+  , typeName :: TypeName+  }+instance Show TypeInfo where+  show = showTypeInfo+++-- @'schemaToTypeMap'@ takes a schema and returns a map of database column names+-- to the type information associated with the column. It is possible (though+-- undesirable) to write a schema which has multiple columns with the same name,+-- so a list of results are returned for each key.+schemaToTypeMap :: forall k. Rel8able k => k Name -> M.Map String (NonEmpty.NonEmpty TypeInfo)+schemaToTypeMap cols = go . uncurry zip . getConst $+  htabulateA @(Columns (k Name)) $ \field -> +    case (hfield hspecs field, hfield (toColumns cols) field) of +      (Spec {..}, Name name) -> Const ([name], [+        TypeInfo { label = labels+                 , isNull = nullableToBool nullity+                 , typeName = info.typeName}])+  where+    go :: [(String, TypeInfo)] -> M.Map String (NonEmpty.NonEmpty TypeInfo)+    go = M.fromListWith (<>) . map (\(name, typeInfo) -> (name, NonEmpty.singleton typeInfo))++-- A checked version of @schemaToTypeMap@, which returns a list of columns with+-- duplicate names if any such columns are present. Otherwise it returns the+-- type map with no duplicates.+checkedSchemaToTypeMap :: Rel8able k+  => k Name+  -> Either (M.Map String (NonEmpty.NonEmpty TypeInfo)) (M.Map String TypeInfo)+checkedSchemaToTypeMap cols =+  let typeMap = schemaToTypeMap cols+      duplicates = M.filter (\col -> length col > 1) typeMap+  in if length duplicates > 0+  then Left duplicates+  else Right (typeMap & M.mapMaybe \case+    a :| [] -> Just a+    _ -> Nothing)+++showCreateTable_helper :: String -> M.Map String TypeInfo -> String+showCreateTable_helper name typeMap = "CREATE TABLE " <> show name <> " ("+    ++ L.intercalate "," (fmap go $ M.assocs typeMap)+    ++ "\n);"+  where+    go :: (String, TypeInfo) -> String+    go (name, typeInfo) = "\n    " ++ show name ++ " " ++ showTypeInfo typeInfo+++-- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table.+-- This does not show relationships like primary or foreign keys, but can still+-- be useful to see what types @rel8@ will expect of the underlying database.+--+-- In the event that multiple columns have the same name, this will fail silently. To+-- handle that case, see 'checkedShowCreateTable'+showCreateTable :: Rel8able k => TableSchema (k Name) -> String+showCreateTable schema = showCreateTable_helper schema.name.name $ fmap NonEmpty.head $ schemaToTypeMap schema.columns++-- |@'checkedShowCreateTable'@ shows an example CREATE TABLE statement for the+-- table. This does not show relationships like primary or foreign keys, but can+-- still be useful to see what types rel8 will expect of the underlying database.+--+-- In the event that multiple columns have the same name, this will return a map of+-- names to the labels identifying the column.+checkedShowCreateTable :: Rel8able k => TableSchema (k Name) -> Either (M.Map String (NonEmpty [String])) String+checkedShowCreateTable schema = case checkedSchemaToTypeMap schema.columns of+    Left e -> Left $ (fmap . fmap) (\typ -> typ.label)  e+    Right a -> Right $ showCreateTable_helper schema.name.name a++-- implicit casts are ok as long as they're bidirectional+checkTypeEquality :: CheckEnv -> TypeInfo -> TypeInfo -> Maybe ColumnError+checkTypeEquality env db hs+  | Prelude.and [sameDims, sameMods, toName db == toName hs || castExists]+    = Nothing+  | otherwise+    = Just BidirectionalCastDoesNotExist+  where+    castExists = Prelude.and+      [ (toName db, toName hs) `elem` env.casts+      , (toName hs, toName db) `elem` env.casts+      ]++    sameMods, sameDims :: Bool+    sameMods = db.typeName.modifiers == hs.typeName.modifiers+    sameDims = db.typeName.arrayDepth == hs.typeName.arrayDepth++    sameName = equalName db.typeName.name hs.typeName.name++    toName :: TypeInfo -> String+    toName typeInfo = case typeInfo.typeName.name of+        QualifiedName name _ -> L.dropWhile (=='_') name++equalName :: QualifiedName -> QualifiedName -> Bool+equalName (QualifiedName a (Just b)) (QualifiedName a' (Just b'))+  = L.dropWhile (=='_') a == L.dropWhile (=='_') a' && b == b'+equalName (QualifiedName a _) (QualifiedName a' _)+  = dropWhile (=='_') a == dropWhile (=='_') a'++-- check types for a single table+compareTypes+    :: CheckEnv+    -> M.Map String (Attribute Result)+    -> M.Map String TypeInfo+    -> [ColumnInfo]+compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion attrMap typeMap)+  where+    go :: String -> These (Attribute Result) TypeInfo -> ColumnInfo+    go name (These a b) = ColumnInfo+        { name = name+        , dbType = Just $ fromAttribute a+        , hsType = Just $ b+        , error = checkTypeEquality env (fromAttribute a) b+        }+    go name (This a) = ColumnInfo+        { name = name+        , dbType = Just $ fromAttribute a+        , hsType = Nothing+        , error =+            if a.attribute.attnotnull+            then Just DbTypeIsNotNullButNotPresentInHsType+            else Nothing+        }+    go name (That b) = ColumnInfo+        { name = name+        , dbType = Nothing+        , hsType = Just $ b+        , error = Just HsTypeIsPresentButNotPresentInDbType+        }++    fromAttribute :: Attribute Result -> TypeInfo+    fromAttribute attr = TypeInfo+        { label = [T.unpack attr.attribute.attname]+        , isNull = not attr.attribute.attnotnull+        , typeName = TypeName+            { name = QualifiedName+                (T.unpack attr.typ.typname)+                (Just $ T.unpack attr.namespace.nspname)+            , modifiers = toModifier+                (T.dropWhile (=='_') attr.typ.typname)+                attr.attribute.atttypmod+            , arrayDepth = fromIntegral attr.attribute.attndims+            }+        }++    toModifier :: Text -> Int64 -> [String]+    toModifier "bpchar" (-1) = []+    toModifier "bpchar" n = [show (n - 4)]+    toModifier "numeric" (-1) = []+    toModifier "numeric" n = [show $ (n - 4) `shiftR` 16, show $ (n - 4) .&. 65535]+    toModifier _ _ = []++    disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b)+    disjointUnion a b = M.unionWith go (fmap This a) (fmap That b)+      where+        go :: These a b -> These a b -> These a b+        go (This a) (That b) = These a b+        go _ _ = undefined+++-- |@pShowTable@ is a helper function which takes a grid of text and prints it+-- as a table, with padding so that cells are lined in columns, and a bordered+-- header for the first row+pShowTable :: [[Text]] -> Text+pShowTable xs+    = T.intercalate "\n"+    $ addHeaderBorder+    $ fmap (T.intercalate " | ")+    $ L.transpose+    $ zip lengths xs' <&> \(n, column) -> column <&> \cell -> T.justifyLeft n ' ' cell+  where+    addHeaderBorder :: [Text] -> [Text]+    addHeaderBorder [] = []+    addHeaderBorder (x : xs) = x : T.replicate (T.length x) "-" : xs++    xs' :: [[Text]]+    xs' = L.transpose xs++    lengths :: [Int]+    lengths = fmap (maximum . fmap T.length) $ xs'+++pShowErrors :: [TableInfo] -> Text+pShowErrors = T.intercalate "\n\n" . fmap go+  where+    go :: TableInfo -> Text+    go (TableInfo {tableExists, name, columns}) = "Table: " <> T.pack name+        <> if not tableExists then " does not exist\n" else "\n"+        <> pShowTable (["Column Name", "Implied DB type", "Current DB type", "Error"] : (columns <&> \column ->+            [ T.pack $ column.name+            , T.pack $ maybe "" showTypeInfo column.hsType+            , T.pack $ maybe "" showTypeInfo column.dbType+            , T.pack $ maybe "" show column.error+            ]))+    go (DuplicateNames {name, duplicates}) = mconcat+        [ "Table "+        , T.pack (show name)+        , " has multiple columns with the same name. This is an error with the Haskell code generating an impossible schema, rather than an error in your current setup of the database itself. Using 'namesFromLabels' can ensure each column has unique names, which is the easiest way to prevent this, but may require changing names in your database to match the new generated names."+        , pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name, typs) ->+            [ T.pack name+            , T.intercalate " " $ fmap (\typ -> T.intercalate "/" $ fmap T.pack typ.label) $ NonEmpty.toList typs+            ]))+        ]+++data TableInfo+  = TableInfo+    { tableExists :: Bool+    , name :: String+    , columns :: [ColumnInfo]+    }+  | DuplicateNames+    { name :: String+    , duplicates :: M.Map String (NonEmpty.NonEmpty TypeInfo)+    }+  deriving (Show)++data ColumnInfo = ColumnInfo+    { name   :: String+    , hsType :: Maybe TypeInfo+    , dbType :: Maybe TypeInfo+    , error :: Maybe ColumnError+    } deriving (Show)++data ColumnError+    = DbTypeIsNotNullButNotPresentInHsType+    | HsTypeIsPresentButNotPresentInDbType+    | BidirectionalCastDoesNotExist+    deriving (Show)+++showTypeInfo :: TypeInfo -> String+showTypeInfo typeInfo = concat+    [ name+    , if Prelude.null modifiers then "" else "(" <> L.intercalate "," modifiers <> ")"+    , concat (replicate (fromIntegral typeInfo.typeName.arrayDepth) "[]")+    , if typeInfo.isNull then "" else " NOT NULL"+    ]+  where+    name = case typeInfo.typeName.name of+        QualifiedName a Nothing -> show (dropWhile (=='_') a)+        QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (=='_') a)++    modifiers :: [String]+    modifiers = typeInfo.typeName.modifiers+++verifySchema :: Rel8able k => CheckEnv -> TableSchema (k Name) -> TableInfo+verifySchema env schema = case checkedSchemaToTypeMap schema.columns of+    Left dups -> DuplicateNames schema.name.name dups+    Right typeMap -> go typeMap maybeTable+  where+    maybeTable = M.lookup schema.name.name env.schemaMap+    go typeMap Nothing = TableInfo+        { tableExists = False+        , name = schema.name.name+        , columns = compareTypes env mempty typeMap+        }+    go typeMap (Just attrs) = TableInfo+        { tableExists = True+        , name = schema.name.name+        , columns = compareTypes env (attrsToMap attrs) typeMap+        }+++fetchCheckEnv :: HS.Statement () CheckEnv+fetchCheckEnv = fetchSchema <&> \(tbls, casts) -> +  let tblMap = foldMap (\PGTable {..} -> M.singleton (T.unpack name) columns) tbls+      castMap = map (\Cast {..} -> (T.unpack source.typname, T.unpack target.typname)) $ L.filter (\Cast {context} -> context == "i") casts+  in CheckEnv tblMap castMap+ where+  fetchSchema :: HS.Statement () ([PGTable Result], [Cast Result])+  fetchSchema = run1 $ select $ liftA2 (,) fetchTables fetchCasts+++-- |@'SomeTableSchema'@ is used to allow the collection of a variety of different+-- @TableSchema@s under a single type, like:+--+-- @+-- userTable :: TableSchema (User Name)+-- orderTable :: TableSchema (Order Name)+--+-- tables :: [SomeTableSchema]+-- tables = [SomeTableSchema userTable, SomeTable orderTable]+-- @+--+-- This is used by @'schemaErrors'@ to conveniently group every table an+-- application relies on for typechecking the postgresql schemas+-- together in a single batch.+data SomeTableSchema where+    -- The ToExpr constraint isn't used here, but can be used to read from the+    -- SomeTableSchema, which can be useful to combine the type checking with more+    -- thorough value-level checking of the validity of existing rows in the+    -- table.+    SomeTableSchema+        :: (ToExprs (k Expr) (GFromExprs k), Rel8able k)+        => TableSchema (k Name) -> SomeTableSchema++-- |@'getSchemaErrors'@ checks whether the provided schemas have the correct PostgreSQL+-- column names and types to allow reading and writing from their equivalent Haskell+-- types, returning a list of errors if that is not the case. The function does not+-- crash on encountering a bug, instead leaving it to the caller to decide how+-- to respond. A schema is valid if:+--+-- 1. for every existing field, the types match+-- 2. all non-nullable columns are present in the hs type+-- 3. no nonexistent columns are present in the hs type+-- 4. no two columns in the same schema share the same name+--+-- It's still possible for a valid schema to allow invalid data, for instance,+-- if using an ADT, which can introduce restrictions on which values are allowed+-- for the column representing the tag, and introduce restrictions on which+-- columns are non-null depending on the value of the tag. However, if the+-- schema is valid rel8 shouldn't be able to write invalid data to the table.+--+-- However, it is possible for migrations to cause valid data to become invalid+-- in ways not detectable by this function, if the migration code changes the+-- schema correctly but doesn't handle the value-level constraints correctly. So+-- it is a good idea to both read from the tables and check the schema for errors+-- in a transaction during the migration. The former will catch value-level+-- bugs, while the latter will help ensure the schema is set up correctly to+-- be able to insert new data.+--+-- This function does nothing to check that the conflict target of an @Upsert@+-- are valid for the schema, nor can it prevent invalid uses of @unsafeDefault@.+-- However, it should be enough to catch the most likely errors.+getSchemaErrors :: [SomeTableSchema] -> HS.Statement () (Maybe Text)+getSchemaErrors someTables = fmap collectErrors fetchCheckEnv+  where+    collectErrors :: CheckEnv -> Maybe Text+    collectErrors env+        = fmap pShowErrors+        . filterErrors+        . fmap \case+            SomeTableSchema t -> verifySchema env t+        $ someTables++    -- removes each column which is valid for use by rel8, as well as each table+    -- which contains only valid columns+    filterErrors :: [TableInfo] -> Maybe [TableInfo]+    filterErrors tables = case mapMaybe go tables of+        [] -> Nothing+        xs -> Just xs+      where+        go :: TableInfo -> Maybe TableInfo+        go TableInfo {..} = case P.filter (\cd -> isJust cd.error) columns of+            [] -> if tableExists then Nothing else Just $ TableInfo { name , tableExists , columns = [] }+            xs -> Just $ TableInfo { name , tableExists , columns = xs }+        go DuplicateNames {..} = Just (DuplicateNames {..})++

@@ -1,6 +1,7 @@-{-# language LambdaCase #-}+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-}+{-# language LambdaCase #-} {-# language MonoLocalBinds #-} {-# language MultiWayIf #-} {-# language OverloadedStrings #-}@@ -17,23 +18,19 @@ -- aeson import Data.Aeson ( Value ) import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson  -- attoparsec import qualified Data.Attoparsec.ByteString.Char8 as A --- attoparsec-aeson-import qualified Data.Aeson.Parser as Aeson- -- base import Control.Applicative ((<|>)) import Data.Fixed (Fixed)-import Data.Int ( Int8, Int16, Int32, Int64 )-import Data.Word (Word8, Word32)+import Data.Functor.Contravariant ((>$<))+import Data.Int (Int16, Int32, Int64) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) import Prelude-import Data.Bits (Bits (..))-import Data.DoubleWord (fromHiAndLo) import Text.Read (readMaybe)  -- bytestring@@ -42,22 +39,19 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict )+import qualified Data.ByteString.Builder as B+import Data.ByteString.Builder.Prim (primBounded)  -- case-insensitive import Data.CaseInsensitive ( CI ) import qualified Data.CaseInsensitive as CI --- data-textual-import Data.Textual (textual)- -- hasql-import qualified Hasql.Decoders as Hasql---- network-ip-import qualified Network.IP.Addr as IP+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders -import qualified Data.IP-import qualified BinaryParser+-- iproute+import Data.IP (IPRange)  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye@@ -67,27 +61,30 @@ import Rel8.Schema.Null ( NotNull, Sql, nullable ) import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) import Rel8.Type.Decimal (PowerOf10, resolution)-import Rel8.Type.Decoder ( Decoder(..) )+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation ) import Rel8.Type.Name (TypeName (..)) import Rel8.Type.Parser (parse)-import Rel8.Type.Parser.ByteString (bytestring)-import qualified Rel8.Type.Parser.Time as Time+import qualified Rel8.Type.Builder.ByteString as Builder+import qualified Rel8.Type.Parser.ByteString as Parser+import qualified Rel8.Type.Builder.Time as Builder+import qualified Rel8.Type.Parser.Time as Parser  -- scientific-import Data.Scientific ( Scientific )+import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.Scientific (Scientific)  -- text import Data.Text ( Text ) import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text (decodeUtf8)-import qualified Data.Text.Lazy as Lazy ( Text, unpack )-import qualified Data.Text.Lazy as Text ( fromStrict, toStrict )-import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )+import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8Builder)+import qualified Data.Text.Lazy as Lazy (Text, unpack)+import qualified Data.Text.Lazy as Text (fromStrict, toStrict)  -- time import Data.Time.Calendar (Day)-import Data.Time.Clock (UTCTime)+import Data.Time.Clock (DiffTime, UTCTime) import Data.Time.LocalTime   ( CalendarDiffTime (CalendarDiffTime)   , LocalTime@@ -119,16 +116,23 @@ -- | Corresponds to @bool@ instance DBType Bool where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.BoolLit+    { encode =+        Encoder+          { binary = Encoders.bool+          , text = \case+              False -> "f"+              True -> "t"+          , quote = Opaleye.ConstExpr . Opaleye.BoolLit+          }     , decode =         Decoder-          { binary = Hasql.bool-          , parser = \case+          { binary = Decoders.bool+          , text = \case               "t" -> pure True               "f" -> pure False               input -> Left $ "bool: bad bool " <> show input-          , delimiter = ','           }+    , delimiter = ','     , typeName = "bool"     } @@ -136,34 +140,44 @@ -- | Corresponds to @char@ instance DBType Char where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure-    , typeName =-        TypeName-          { name = "bpchar"-          , modifiers = ["1"]-          , arrayDepth = 0+    { encode =+        Encoder+          { binary = Encoders.char+          , text = B.charUtf8+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . pure           }     , decode =          Decoder-          { binary = Hasql.char-          , parser = \input -> case UTF8.uncons input of+          { binary = Decoders.char+          , text = \input -> case UTF8.uncons input of               Just (char, rest) | BS.null rest -> pure char               _ -> Left $ "char: bad char " <> show input-          , delimiter = ','           }+    , delimiter = ','+    , typeName =+        TypeName+          { name = "bpchar"+          , modifiers = ["1"]+          , arrayDepth = 0+          }     }   -- | Corresponds to @int2@ instance DBType Int16 where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+    { encode =+        Encoder+          { binary = Encoders.int2+          , text = B.int16Dec+          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+          }     , decode =         Decoder-          { binary = Hasql.int2-          , parser = parse (A.signed A.decimal)-          , delimiter = ','+          { binary = Decoders.int2+          , text = parse (A.signed A.decimal)           }+    , delimiter = ','     , typeName = "int2"     } @@ -171,13 +185,18 @@ -- | Corresponds to @int4@ instance DBType Int32 where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+    { encode =+        Encoder+          { binary = Encoders.int4+          , text = B.int32Dec+          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+          }     , decode =         Decoder-          { binary = Hasql.int4-          , parser = parse (A.signed A.decimal)-          , delimiter = ','+          { binary = Decoders.int4+          , text = parse (A.signed A.decimal)           }+    , delimiter = ','     , typeName = "int4"     } @@ -185,49 +204,76 @@ -- | Corresponds to @int8@ instance DBType Int64 where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+    { encode =+        Encoder+          { binary = Encoders.int8+          , text = B.int64Dec+          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+          }     , decode =         Decoder-          { binary = Hasql.int8-          , parser = parse (A.signed A.decimal)-          , delimiter = ','+          { binary = Decoders.int8+          , text = parse (A.signed A.decimal)           }+    , delimiter = ','     , typeName = "int8"     }  --- | Corresponds to @float4@+-- | Corresponds to @float4@ and @real@ instance DBType Float where   typeInformation = TypeInformation-    { encode = \x -> Opaleye.ConstExpr-        if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"-           | isNaN x       -> Opaleye.OtherLit "'NaN'"-           | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"-           | otherwise     -> Opaleye.DoubleLit $ realToFrac x+    { encode =+        Encoder+          { binary = Encoders.float4+          , text =+              \x ->+                if | x == (1 / 0)  -> "Infinity"+                   | isNaN x       -> "NaN"+                   | x == (-1 / 0) -> "-Infinity"+                   | otherwise     -> B.floatDec x+          , quote =+              \x -> Opaleye.ConstExpr+                if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"+                   | isNaN x       -> Opaleye.OtherLit "'NaN'"+                   | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"+                   | otherwise     -> Opaleye.DoubleLit $ realToFrac x+          }     , decode =         Decoder-          { binary = Hasql.float4-          , parser = parse (floating (realToFrac <$> A.double))-          , delimiter = ','+          { binary = Decoders.float4+          , text = parse (floating (realToFrac <$> A.double))           }+    , delimiter = ','     , typeName = "float4"     }  --- | Corresponds to @float8@+-- | Corresponds to @float8@ and @double precision@ instance DBType Double where   typeInformation = TypeInformation-    { encode = \x -> Opaleye.ConstExpr-        if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"-           | isNaN x       -> Opaleye.OtherLit "'NaN'"-           | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"-           | otherwise     -> Opaleye.DoubleLit x+    { encode =+        Encoder+          { binary = Encoders.float8+          , text =+              \x ->+                if | x == (1 / 0)  -> "Infinity"+                   | isNaN x       -> "NaN"+                   | x == (-1 / 0) -> "-Infinity"+                   | otherwise     -> B.doubleDec x+          , quote =+              \x -> Opaleye.ConstExpr+                if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"+                   | isNaN x       -> Opaleye.OtherLit "'NaN'"+                   | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"+                   | otherwise     -> Opaleye.DoubleLit x+          }     , decode =         Decoder-          { binary = Hasql.float8-          , parser = parse (floating A.double)-          , delimiter = ','+          { binary = Decoders.float8+          , text = parse (floating A.double)           }+    , delimiter = ','     , typeName = "float8"     } @@ -235,49 +281,52 @@ -- | Corresponds to @numeric@ instance DBType Scientific where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.NumericLit+    { encode =+        Encoder+          { binary = Encoders.numeric+          , text = scientificBuilder+          , quote = Opaleye.ConstExpr . Opaleye.NumericLit+          }     , decode =         Decoder-          { binary = Hasql.numeric-          , parser = parse A.scientific-          , delimiter = ','+          { binary = Decoders.numeric+          , text = parse A.scientific           }+    , delimiter = ','     , typeName = "numeric"     }   -- | Corresponds to @numeric(1000, log₁₀ n)@ instance PowerOf10 n => DBType (Fixed n) where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac-    , decode =-        realToFrac <$>-        Decoder-          { binary = Hasql.numeric-          , parser = parse A.scientific-          , delimiter = ','-          }-    , typeName =-        TypeName-          { name = "numeric"-          , modifiers = ["1000", show (resolution @n)]-          , arrayDepth = 0-          }-    }+  typeInformation =+    mapTypeInformation realToFrac realToFrac (typeInformation @Scientific)+      { typeName =+          TypeName+            { name = "numeric"+            , modifiers = ["1000", show (resolution @n)]+            , arrayDepth = 0+            }+      }   -- | Corresponds to @timestamptz@ instance DBType UTCTime where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%FT%T%QZ'"+        Encoder+          { binary = Encoders.timestamptz+          , text = primBounded Builder.utcTime+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%FT%T%QZ'"+          }     , decode =         Decoder-          { binary = Hasql.timestamptz-          , parser = parse Time.utcTime-          , delimiter = ','+          { binary = Decoders.timestamptz+          , text = parse Parser.utcTime           }+    , delimiter = ','     , typeName = "timestamptz"     } @@ -286,14 +335,19 @@ instance DBType Day where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%F'"+        Encoder+          { binary = Encoders.date+          , text = primBounded Builder.day+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%F'"+          }     , decode =         Decoder-          { binary = Hasql.date-          , parser = parse Time.day-          , delimiter = ','+          { binary = Decoders.date+          , text = parse Parser.day           }+    , delimiter = ','     , typeName = "date"     } @@ -302,14 +356,19 @@ instance DBType LocalTime where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%FT%T%Q'"+        Encoder+          { binary = Encoders.timestamp+          , text = primBounded Builder.localTime+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%FT%T%Q'"+          }     , decode =         Decoder-          { binary = Hasql.timestamp-          , parser = parse Time.localTime-          , delimiter = ','+          { binary = Decoders.timestamp+          , text = parse Parser.localTime           }+    , delimiter = ','     , typeName = "timestamp"     } @@ -318,14 +377,19 @@ instance DBType TimeOfDay where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%T%Q'"+        Encoder+          { binary = Encoders.time+          , text = primBounded Builder.timeOfDay+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%T%Q'"+          }     , decode =         Decoder-          { binary = Hasql.time-          , parser = parse Time.timeOfDay-          , delimiter = ','+          { binary = Decoders.time+          , text = parse Parser.timeOfDay           }+    , delimiter = ','     , typeName = "time"     } @@ -334,14 +398,19 @@ instance DBType CalendarDiffTime where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%bmon %0Es'"+        Encoder+          { binary = toDiffTime >$< Encoders.interval+          , text = Builder.calendarDiffTime+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%bmon %0Es'"+          }     , decode =         Decoder-          { binary = CalendarDiffTime 0 . realToFrac <$> Hasql.interval-          , parser = parse Time.calendarDiffTime-          , delimiter = ','+          { binary = CalendarDiffTime 0 . realToFrac <$> Decoders.interval+          , text = parse Parser.calendarDiffTime           }+    , delimiter = ','     , typeName = "interval"     } @@ -349,13 +418,18 @@ -- | Corresponds to @text@ instance DBType Text where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack+    { encode =+        Encoder+          { binary = Encoders.text+          , text = Text.encodeUtf8Builder+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack+          }     , decode =         Decoder-          { binary = Hasql.text-          , parser = pure . Text.decodeUtf8-          , delimiter = ','+          { binary = Decoders.text+          , text = pure . Text.decodeUtf8           }+    , delimiter = ','     , typeName = "text"     } @@ -383,13 +457,18 @@ -- | Corresponds to @bytea@ instance DBType ByteString where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit+    { encode =+        Encoder+          { binary = Encoders.bytea+          , text = Builder.bytestring+          , quote = Opaleye.ConstExpr . Opaleye.ByteStringLit+          }     , decode =         Decoder-          { binary = Hasql.bytea-          , parser = parse bytestring-          , delimiter = ','+          { binary = Decoders.bytea+          , text = parse Parser.bytestring           }+    , delimiter = ','     , typeName = "bytea"     } @@ -404,15 +483,20 @@ -- | Corresponds to @uuid@ instance DBType UUID where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString+    { encode =+        Encoder+          { binary = Encoders.uuid+          , text = B.byteString . UUID.toASCIIBytes+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString+          }     , decode =         Decoder-          { binary = Hasql.uuid-          , parser = \input -> case UUID.fromASCIIBytes input of+          { binary = Decoders.uuid+          , text = \input -> case UUID.fromASCIIBytes input of               Just a -> pure a               Nothing -> Left $ "uuid: bad UUID " <> show input-          , delimiter = ','           }+    , delimiter = ','     , typeName = "uuid"     } @@ -421,86 +505,44 @@ instance DBType Value where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        Opaleye.quote .-        Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode+        Encoder+          { binary = Encoders.jsonb+          , text = Aeson.fromEncoding . Aeson.toEncoding+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .+              Lazy.unpack . Aeson.encodeToLazyText+          }     , decode =         Decoder-          { binary = Hasql.jsonb-          , parser = parse Aeson.value-          , delimiter = ','+          { binary = Decoders.jsonb+          , text = Aeson.eitherDecodeStrict           }+    , delimiter = ','     , typeName = "jsonb"     }   -- | Corresponds to @inet@-instance DBType (IP.NetAddr IP.IP) where+instance DBType IPRange where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.StringLit . IP.printNetAddr-    , decode =-        Decoder-          { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser-                      (\netmask x -> IP.netAddr (IP.IPv4 $ IP.IP4 x) netmask)-                      (\netmask x1 x2 x3 x4 -> IP.netAddr (IP.IPv6 $ IP.IP6 $ fromHiAndLo (fromHiAndLo x1 x2) (fromHiAndLo x3 x4)) netmask) :: Hasql.Value (IP.NetAddr IP.IP))-          , parser = parse $-              textual-                <|> (`IP.netAddr` 32) . IP.IPv4 <$> textual-                <|> (`IP.netAddr` 128) . IP.IPv6 <$> textual-          , delimiter = ','+        Encoder+          { binary = Encoders.inet+          , text = B.string7 . show+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . show           }-    , typeName = "inet"-    }---- | Corresponds to @inet@-instance DBType Data.IP.IPRange where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.StringLit . show     , decode =         Decoder-          { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser-                      (\netmask x -> Data.IP.IPv4Range $ Data.IP.makeAddrRange (Data.IP.toIPv4w x) $ fromIntegral netmask)-                      (\netmask x1 x2 x3 x4 -> Data.IP.IPv6Range $ Data.IP.makeAddrRange (Data.IP.toIPv6w (x1, x2, x3, x4)) $ fromIntegral netmask))-          , parser = \str -> case readMaybe $ BS8.unpack str of+          { binary = Decoders.inet+          , text = \str -> case readMaybe $ BS8.unpack str of               Just x -> Right x               Nothing -> Left "Failed to parse inet"-          , delimiter = ','           }+    , delimiter = ','     , typeName = "inet"     } --- | Address family AF_INET-inetAddressFamily :: Word8-inetAddressFamily =-  2 --- | Address family AF_INET6-inet6AddressFamily :: Word8-inet6AddressFamily =-  3---- | This is vendored from `postgresql-binary`.-netaddrParser :: (Word8 -> Word32 -> ip) -> (Word8 -> Word32 -> Word32 -> Word32 ->  Word32 -> ip) -> BinaryParser.BinaryParser ip-netaddrParser mkIpv4 mkIpv6 = do-  af <- intOfSize 1-  netmask <- intOfSize 1-  isCidr <- intOfSize @Int8 1-  ipSize <- intOfSize @Int8 1-  if | af == inetAddressFamily ->-         mkIpv4 netmask <$> intOfSize 4-     | af == inet6AddressFamily ->-         mkIpv6 netmask <$> intOfSize 4 <*> intOfSize 4  <*> intOfSize 4 <*> intOfSize 4-     | otherwise -> BinaryParser.failure ("Unknown address family: " <> Text.pack (show af))--intOfSize :: (Integral a, Bits a) => Int -> BinaryParser.BinaryParser a-intOfSize x =-  fmap integralPack (BinaryParser.bytesOfSize x)-  where-    integralPack = BS.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0-- instance Sql DBType a => DBType [a] where   typeInformation = listTypeInformation nullable typeInformation @@ -511,3 +553,8 @@  floating :: Floating a => A.Parser a -> A.Parser a floating p = p <|> A.signed (1.0 / 0 <$ "Infinity") <|> 0.0 / 0 <$ "NaN"+++toDiffTime :: CalendarDiffTime -> DiffTime+toDiffTime (CalendarDiffTime months seconds) =+  realToFrac (months * 30 * 24 * 60 * 60) + realToFrac seconds

@@ -1,3 +1,4 @@+{-# language DisambiguateRecordFields #-} {-# language GADTs #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-}@@ -6,7 +7,7 @@ {-# language ViewPatterns #-}  module Rel8.Type.Array-  ( array, encodeArrayElement, extractArrayElement+  ( array, quoteArrayElement, extractArrayElement   , arrayTypeName   , listTypeInformation   , nonEmptyTypeInformation@@ -21,35 +22,48 @@ import Control.Applicative ((<|>), many) import Data.Bifunctor (first) import Data.Foldable (fold, toList)-import Data.List.NonEmpty ( NonEmpty, nonEmpty )-import Prelude hiding ( head, last, length, null, repeat, zipWith )+import Data.Functor.Contravariant ((>$<))+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Prelude hiding (head, last, length, null, repeat, zipWith)  -- bytestring import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as L +-- case-insensitive+import qualified Data.CaseInsensitive as CI+ -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8-import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )-import Rel8.Type.Decoder (Decoder (..), NullableOrNot (..), Parser)-import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )+import Rel8.Schema.Null (Unnullify, Nullity (Null, NotNull))+import Rel8.Type.Builder.Fold (interfoldMap)+import Rel8.Type.Decoder (Decoder (..), Parser)+import Rel8.Type.Encoder (Encoder (..))+import Rel8.Type.Information (TypeInformation(..), parseTypeInformation) import Rel8.Type.Name (TypeName (..), showTypeName)+import Rel8.Type.Nullable (NullableOrNot (..)) import Rel8.Type.Parser (parse)  -- text import qualified Data.Text as Text+import qualified Data.Text.Lazy as Text (toStrict)+import qualified Data.Text.Lazy.Encoding as Lazy (decodeUtf8)   array :: Foldable f   => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr array info =   Opaleye.CastExpr (showTypeName (arrayType info) <> "[]") .-  Opaleye.ArrayExpr . map (encodeArrayElement info) . toList+  Opaleye.ArrayExpr . map (quoteArrayElement info) . toList {-# INLINABLE array #-}  @@ -57,25 +71,34 @@   => Nullity a   -> TypeInformation (Unnullify a)   -> TypeInformation [a]-listTypeInformation nullity info@TypeInformation {encode, decode} =+listTypeInformation nullity info@TypeInformation {decode, encode, delimiter} =   TypeInformation     { decode =         Decoder-          { binary = Hasql.listArray $ case nullity of-              Null -> Hasql.nullable (decodeArrayElement info decode)-              NotNull -> Hasql.nonNullable (decodeArrayElement info decode)-          , parser = case nullity of-              Null -> arrayParser (Nullable decode)-              NotNull -> arrayParser (NonNullable decode)-          , delimiter = ','+          { binary = Decoders.listArray $ case nullity of+              Null -> Decoders.nullable (decodeArrayElement info decode)+              NotNull -> Decoders.nonNullable (decodeArrayElement info decode)+          , text = case nullity of+              Null -> arrayParser delimiter (Nullable decode)+              NotNull -> arrayParser delimiter (NonNullable decode)           }-    , encode = case nullity of-        Null ->-          Opaleye.ArrayExpr .-          fmap (encodeArrayElement info . maybe null encode)-        NotNull ->-          Opaleye.ArrayExpr .-          fmap (encodeArrayElement info . encode)+    , encode =+        Encoder+          { binary = Encoders.foldableArray $ case nullity of+              Null -> Encoders.nullable (encodeArrayElement info encode)+              NotNull -> Encoders.nonNullable (encodeArrayElement info encode)+          , text = case nullity of+              Null -> arrayBuild delimiter (Nullable encode)+              NotNull -> arrayBuild delimiter (NonNullable encode)+          , quote = case nullity of+              Null ->+                Opaleye.ArrayExpr .+                fmap (quoteArrayElement info . maybe null (quote encode))+              NotNull ->+                Opaleye.ArrayExpr .+                fmap (quoteArrayElement info . quote encode)+          }+    , delimiter = ','     , typeName = arrayTypeName info     }   where@@ -107,15 +130,21 @@   | otherwise = typeName info  -decodeArrayElement :: TypeInformation a -> Decoder x -> Hasql.Value x-decodeArrayElement info-  | isArray info = \decoder ->-      Hasql.refine (first Text.pack . parser decoder) Hasql.bytea+decodeArrayElement :: TypeInformation a -> Decoder x -> Decoders.Value x+decodeArrayElement info Decoder {binary, text}+  | isArray info =+      Decoders.refine (first Text.pack . text) Decoders.bytea   | otherwise = binary  -encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr-encodeArrayElement info+encodeArrayElement :: TypeInformation a -> Encoder x -> Encoders.Value x+encodeArrayElement info Encoder {binary, text}+  | isArray info = Text.toStrict . Lazy.decodeUtf8 . toLazyByteString . text >$< Encoders.text+  | otherwise = binary+++quoteArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr+quoteArrayElement info   | isArray info = Opaleye.CastExpr "text" . Opaleye.CastExpr (showTypeName (typeName info))   | otherwise = id @@ -146,14 +175,49 @@                         A.char '\\' <|> A.char '"'  -arrayParser :: NullableOrNot Decoder a -> Parser [a]-arrayParser = \case-  Nullable Decoder {parser, delimiter} -> \input -> do+arrayParser :: Char -> NullableOrNot Decoder a -> Parser [a]+arrayParser delimiter = \case+  Nullable Decoder {text} -> \input -> do     elements <- parseArray delimiter input-    traverse (traverse parser) elements-  NonNullable Decoder {parser, delimiter} -> \input -> do+    traverse (traverse text) elements+  NonNullable Decoder {text} -> \input -> do     elements <- parseArray delimiter input-    traverse (maybe (Left "array: unexpected null") parser) elements+    traverse (maybe (Left "array: unexpected null") text) elements+++buildArray :: Char -> [Maybe ByteString] -> Builder+buildArray delimiter elements =+  B.char8 '{' <>+  interfoldMap (B.char8 delimiter) element elements <>+  B.char8 '}'+  where+    element = \case+      Nothing -> B.string7 "NULL"+      Just a+        | BS.null a -> "\"\""+        | CI.mk a == "null" -> escaped+        | BS.any (A.inClass escapeClass) a -> escaped+        | otherwise -> unescaped+        where+          escapeClass = delimiter : "\\\"{}\t\n"+          unescaped = B.byteString a+          escaped =+            B.char8 '"' <> BS.foldr ((<>) . escape) mempty a <> B.char8 '"'+            where+              escape = \case+                '"' -> B.string7 "\\\""+                '\\' -> B.string7 "\\\\"+                c -> B.char8 c+++arrayBuild :: Char -> NullableOrNot Encoder a -> [a] -> Builder+arrayBuild delimiter = \case+  Nullable Encoder {text} ->+    buildArray delimiter .+    map (fmap (L.toStrict . toLazyByteString . text))+  NonNullable Encoder {text} ->+    buildArray delimiter .+    map (Just . L.toStrict . toLazyByteString . text)   head :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr

@@ -0,0 +1,16 @@+{-# language OverloadedStrings #-}++module Rel8.Type.Builder.ByteString (+  bytestring,+) where++-- base+import Prelude++-- bytestring+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, byteStringHex, string7)+++bytestring :: ByteString -> Builder+bytestring bytes = string7 "\\x" <> byteStringHex bytes

@@ -0,0 +1,16 @@+{-# language LambdaCase #-}++module Rel8.Type.Builder.Fold (+  interfoldMap+) where++-- base+import Prelude+++interfoldMap :: (Foldable t, Monoid m) => m -> (a -> m) -> t a -> m+interfoldMap sep f = maybe mempty id . foldr go Nothing+  where+    go x = \case+      Nothing -> Just (f x)+      Just acc -> Just (f x <> sep <> acc)

@@ -0,0 +1,151 @@+{-# language BangPatterns #-}+{-# language NumericUnderscores #-}+{-# language OverloadedStrings #-}+{-# language PatternSynonyms #-}+{-# language PartialTypeSignatures #-}+{-# language TypeApplications #-}+{-# language ViewPatterns #-}++{-# options_ghc -Wno-partial-type-signatures #-}+-- bytestring does not export Monoidal so we can't write a complete type+-- signature for 'divide'++{-# options_ghc -Wno-unused-top-binds #-}+-- GHC considers the YMD pattern unused but we use its selectors++module Rel8.Type.Builder.Time (+  calendarDiffTime,+  day,+  localTime,+  timeOfDay,+  utcTime,+) where++-- base+import Data.Char (chr)+import Data.Fixed (Fixed (MkFixed), Pico)+import Data.Int (Int32, Int64)+import Prelude hiding ((<>))++-- bytestring+import Data.ByteString.Builder (Builder, string7)+import Data.ByteString.Builder.Prim (+  BoundedPrim, condB, emptyB, liftFixedToBounded,+  FixedPrim, char8, int32Dec,+  (>$<), (>*<),+ )++-- time+import Data.Time.Calendar (Day, toGregorian)+import Data.Time.Clock (UTCTime (utctDay, utctDayTime))+import Data.Time.Format.ISO8601 (iso8601Show)+import Data.Time.LocalTime (+  CalendarDiffTime,+  LocalTime (localDay, localTimeOfDay),+  TimeOfDay (todHour, todMin, todSec),+  timeToTimeOfDay+ )+++digit :: FixedPrim Int+digit = (\x -> chr (x + 48)) >$< char8+++digits2 :: FixedPrim Int+digits2 = divide (`quotRem` 10) digit digit+++digits3 :: FixedPrim Int+digits3 = divide (`quotRem` 10) digits2 digit+++digits4 :: FixedPrim Int+digits4 = divide (`quotRem` 10) digits3 digit+++frac :: BoundedPrim Int64+frac = condB (== 0) emptyB $ liftFixedToBounded (char '.') <> trunc12+  where+    trunc12 =+      divide+        (`quotRem` 1_000_000)+        (fromIntegral >$< ifZero trunc6 (liftFixedToBounded digits6))+        (fromIntegral >$< nonZero trunc6)++    digitB = liftFixedToBounded digit++    digits6 = divide (`quotRem` 10) digits5 digit+    digits5 = divide (`quotRem` 10) digits4 digit++    trunc6 = divide (`quotRem` 100_000) digitB trunc5+    trunc5 = nonZero $ divide (`quotRem` 10_000) digitB trunc4+    trunc4 = nonZero $ divide (`quotRem` 1_000) digitB trunc3+    trunc3 = nonZero $ divide (`quotRem` 100) digitB trunc2+    trunc2 = nonZero $ divide (`quotRem` 10) digitB trunc1+    trunc1 = nonZero digitB++    nonZero = ifZero emptyB+    ifZero = condB (== 0)+++seconds :: BoundedPrim Pico+seconds =+  (\(MkFixed s) -> fromIntegral s `quotRem` 1_000_000_000_000) >$<+  (liftFixedToBounded (fromIntegral >$< digits2) >*< frac)+++year :: BoundedPrim Int32+year = condB (>= 10000) int32Dec (liftFixedToBounded (fromIntegral >$< digits4))+++day :: BoundedPrim Day+day =+  (fromIntegral . ymdYear >$< year) <>+  liftFixedToBounded+    ( char '-' <> (ymdMonth >$< digits2) <> char '-' <> (ymdDay >$< digits2)+    )+++pattern YMD :: Integer -> Int -> Int -> Day+pattern YMD {ymdYear, ymdMonth, ymdDay} <-+  (toGregorian -> (ymdYear, ymdMonth, ymdDay))+++timeOfDay :: BoundedPrim TimeOfDay+timeOfDay =+  liftFixedToBounded+    ( (todHour >$< digits2) <> char ':' <> (todMin >$< digits2) <> char ':'+    ) <>+  (todSec >$< seconds)+++utcTime :: BoundedPrim UTCTime+utcTime =+  (utctDay >$< day) <>+  liftFixedToBounded (char ' ') <>+  (timeToTimeOfDay . utctDayTime >$< timeOfDay) <>+  liftFixedToBounded (char 'Z')+++localTime :: BoundedPrim LocalTime+localTime =+  (localDay >$< day) <>+  liftFixedToBounded (char ' ') <>+  (localTimeOfDay >$< timeOfDay)+++calendarDiffTime :: CalendarDiffTime -> Builder+calendarDiffTime = string7 . iso8601Show+++char :: Char -> FixedPrim a+char c = (\_ -> c) >$< char8+++(<>) :: _ => f a -> f a -> f a+(<>) = divide (\a -> (a, a))+infixr 6 <>+++divide :: _ => (a -> (b, c)) -> f b -> f c -> f a+divide f a b = f >$< (a >*< b)

@@ -4,6 +4,7 @@ {-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language GADTs #-}+{-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-}@@ -27,7 +28,8 @@ import Control.Applicative ((<|>), many, optional) import Data.Foldable (fold) import Data.Functor.Const (Const (Const), getConst)-import Data.Functor.Identity (Identity (Identity))+import Data.Functor.Contravariant ((>$<))+import Data.Functor.Identity (Identity (Identity), runIdentity) import Data.Kind ( Constraint, Type ) import Data.List (uncons) import Prelude@@ -35,9 +37,14 @@ -- bytestring import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Builder as B+import Data.ByteString.Lazy (toStrict)  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye@@ -58,8 +65,11 @@ import Rel8.Table.Rel8able () import Rel8.Table.Serialize ( litHTable ) import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Builder.Fold (interfoldMap) import Rel8.Type.Decoder (Decoder (Decoder), Parser) import qualified Rel8.Type.Decoder as Decoder+import Rel8.Type.Encoder (Encoder (Encoder))+import qualified Rel8.Type.Encoder as Encoder import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information ( TypeInformation(..) ) import Rel8.Type.Name (TypeName (..))@@ -91,11 +101,16 @@   typeInformation = TypeInformation     { decode =         Decoder-          { binary = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)-          , parser = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser-          , delimiter = ','+          { binary = Decoders.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)+          , text = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser           }-    , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite+    , encode =+        Encoder+          { binary = Encoders.composite (toResult @_ @(HKD a Expr) . unComposite >$< encoder)+          , text = builder . toResult @_ @(HKD a Expr) . unComposite+          , quote = quoter . litHTable . toResult @_ @(HKD a Expr) . unComposite+          }+    , delimiter = ','     , typeName =         TypeName           { name = compositeTypeName @a@@ -135,7 +150,7 @@ -- single column expression, by combining them into a PostgreSQL composite -- type. compose :: DBComposite a => HKD a Expr -> Expr a-compose = castExpr . fromPrimExpr . encoder . toColumns+compose = castExpr . fromPrimExpr . quoter . toColumns   -- | Expand a composite type into a 'HKD'.@@ -150,20 +165,13 @@     names = toColumns (compositeFields @a)  -decoder :: HTable t => Hasql.Composite (t Result)+decoder :: HTable t => Decoders.Composite (t Result) decoder = unwrapApplicative $ htabulateA \field ->   case hfield hspecs field of     Spec {nullity, info} -> WrapApplicative $ Identity <$>       case nullity of-        Null -> Hasql.field $ Hasql.nullable $ Decoder.binary $ decode info-        NotNull -> Hasql.field $ Hasql.nonNullable $ Decoder.binary $ decode info---encoder :: HTable t => t Expr -> Opaleye.PrimExpr-encoder a = Opaleye.FunExpr "ROW" exprs-  where-    exprs = getConst $ htabulateA \field -> case hfield a field of-      expr -> Const [toPrimExpr expr]+        Null -> Decoders.field $ Decoders.nullable $ Decoder.binary $ decode info+        NotNull -> Decoders.field $ Decoders.nonNullable $ Decoder.binary $ decode info   parser :: HTable t => Parser (t Result)@@ -178,10 +186,10 @@       mbytes <- StateT $ maybe missing pure . uncons       lift $ Identity <$> case hfield hspecs field of         Spec {nullity, info} -> case nullity of-          Null -> traverse (Decoder.parser (decode info)) mbytes+          Null -> traverse (Decoder.text (decode info)) mbytes           NotNull -> case mbytes of             Nothing -> Left "composite: unexpected null"-            Just bytes -> Decoder.parser (decode info) bytes+            Just bytes -> Decoder.text (decode info) bytes     missing = Left "composite: missing fields"  @@ -201,3 +209,55 @@                   BS.singleton <$> do                     A.char '\\' <|> A.char '"'                 quote = "\"" <$ A.string "\"\""+++encoder :: forall t. HTable t => Encoders.Composite (t Result)+encoder = getConst $ htabulateA @t \field ->+  case hfield hspecs field of+    Spec {nullity, info} -> Const $+      runIdentity . (`hfield` field) >$<+        case nullity of+          Null -> Encoders.field $ Encoders.nullable build+          NotNull -> Encoders.field $ Encoders.nonNullable build+        where+          build = Encoder.binary (encode info)+++builder :: HTable t => t Result -> Builder+builder input = buildRow $ getConst $ htabulateA \field ->+  Const $ pure $+    case hfield input field of+      Identity a ->+        case hfield hspecs field of+          Spec {nullity, info} -> case nullity of+            Null -> build <$> a+            NotNull -> Just $ build a+            where+              build =+                toStrict . toLazyByteString . Encoder.text (encode info)+++buildRow :: [Maybe ByteString] -> Builder+buildRow elements =+  B.char8 '(' <>+  interfoldMap (B.char8 ',') (foldMap element) elements <>+  B.char8 ')'+  where+    element a+        | BS.null a = "\"\""+        | BS.all (A.notInClass escapeClass) a = B.byteString a+        | otherwise =+            B.char8 '"' <> BS.foldr ((<>) . escape) mempty a <> B.char8 '"'+        where+          escapeClass = ",\\\"()\t\n"+          escape = \case+            '"' -> B.string7 "\"\""+            '\\' -> B.string7 "\\\\"+            c -> B.char8 c+++quoter :: HTable t => t Expr -> Opaleye.PrimExpr+quoter a = Opaleye.FunExpr "ROW" exprs+  where+    exprs = getConst $ htabulateA \field -> case hfield a field of+      expr -> Const [toPrimExpr expr]

@@ -100,4 +100,4 @@ type family IsPowerOf10' bool n where   IsPowerOf10' 'True _n = ()   IsPowerOf10' 'False n =-    TypeError ('ShowType n ':<>: 'Text " is not a power of 10")+    TypeError ('ShowType n ' :<>: 'Text " is not a power of 10")

@@ -1,12 +1,11 @@ {-# language DerivingStrategies #-} {-# language DeriveFunctor #-}-{-# language GADTs #-} {-# language NamedFieldPuns #-} {-# language StandaloneKindSignatures #-}+{-# language DuplicateRecordFields #-}  module Rel8.Type.Decoder (   Decoder (..),-  NullableOrNot (..),   Parser,   parseDecoder, ) where@@ -35,11 +34,8 @@ data Decoder a = Decoder   { binary :: Hasql.Value a     -- ^ How to deserialize from PostgreSQL's binary format.-  , parser :: Parser a+  , text :: Parser a     -- ^ How to deserialize from PostgreSQL's text format.-  , delimiter :: Char-    -- ^ The delimiter that is used in PostgreSQL's text format in arrays of-    -- this type (this is almost always ',').   }   deriving stock (Functor) @@ -50,15 +46,9 @@ -- a given 'Decoder'. The parser is applied when deserializing rows -- returned. parseDecoder :: (a -> Either String b) -> Decoder a -> Decoder b-parseDecoder f Decoder {binary, parser, delimiter} =+parseDecoder f Decoder {binary, text} =   Decoder     { binary = Hasql.refine (first Text.pack . f) binary-    , parser = parser >=> f-    , delimiter+    , text = text >=> f     } --type NullableOrNot :: (Type -> Type) -> Type -> Type-data NullableOrNot decoder a where-  NonNullable :: decoder a -> NullableOrNot decoder a-  Nullable :: decoder a -> NullableOrNot decoder (Maybe a)

@@ -0,0 +1,43 @@+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language RecordWildCards #-}+{-# language StandaloneKindSignatures #-}+{-# language StrictData #-}+{-# language DuplicateRecordFields #-}++module Rel8.Type.Encoder (+  Encoder (..),+) where++-- base+import Data.Functor.Contravariant (Contravariant, (>$<), contramap)+import Data.Kind (Type)+import Prelude++-- bytestring+import Data.ByteString.Builder (Builder)++-- hasql+import qualified Hasql.Encoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+++type Encoder :: Type -> Type+data Encoder a = Encoder+  { binary :: Hasql.Value a+    -- ^ How to serialize to PostgreSQL's binary format.+  , text :: a -> Builder+    -- ^ How to serialize to PostgreSQL's text format.+  , quote :: a -> Opaleye.PrimExpr+    -- ^ How to encode a single Haskell value as an SQL expression.+  }+++instance Contravariant Encoder where+  contramap f Encoder {..} = Encoder+    { binary = f >$< binary+    , text = text . f+    , quote = quote . f+    }

@@ -1,5 +1,7 @@ {-# language AllowAmbiguousTypes #-} {-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language LambdaCase #-}@@ -13,7 +15,7 @@  module Rel8.Type.Enum   ( Enum( Enum )-  , DBEnum( enumValue, enumTypeName )+  , DBEnum( enumValue, enumTypeName, enumerate )   , Enumable   ) where@@ -32,7 +34,8 @@ import Prelude hiding ( Enum )  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye@@ -41,6 +44,7 @@ import Rel8.Schema.QualifiedName (QualifiedName) import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information ( TypeInformation(..) ) import Rel8.Type.Name (TypeName (..))@@ -48,7 +52,7 @@  -- text import Data.Text (pack)-import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding (decodeUtf8, encodeUtf8Builder)   -- | A deriving-via helper type for column types that store an \"enum\" type@@ -69,21 +73,29 @@  instance DBEnum a => DBType (Enum a) where   typeInformation = TypeInformation-    { decode =+    { encode =         let-          mapping = (pack . enumValue &&& Enum) . to <$> genumerate @(Rep a)+          toText (Enum a) = pack $ enumValue a+        in+        Encoder+          { binary = Encoders.enum toText+          , text = encodeUtf8Builder . toText+          , quote =+              Opaleye.ConstExpr .+              Opaleye.StringLit .+              enumValue @a .+              unEnum+          }+    , decode =+        let+          mapping = (pack . enumValue &&& Enum) <$> enumerate           unrecognised = Left "enum: unrecognised value"         in           Decoder-            { binary = Hasql.enum (`lookup` mapping)-            , parser = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8-            , delimiter = ','+            { binary = Decoders.enum (`lookup` mapping)+            , text = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8             }-    , encode =-        Opaleye.ConstExpr .-        Opaleye.StringLit .-        enumValue @a .-        unEnum+    , delimiter = ','     , typeName =         TypeName           { name = enumTypeName @a@@ -107,15 +119,23 @@  -- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type. type DBEnum :: Type -> Constraint-class (DBType a, Enumable a) => DBEnum a where+class DBType a => DBEnum a where   -- | Map Haskell values to the corresponding element of the @enum@ type. The   -- default implementation of this method will use the exact name of the   -- Haskell constructors.   enumValue :: a -> String-  enumValue = gshow @(Rep a) . from    -- | The name of the PostgreSQL @enum@ type that @a@ maps to.   enumTypeName :: QualifiedName++  -- | List of all possible values of the enum type.+  enumerate :: [a]++  default enumValue :: Enumable a => a -> String+  enumValue = gshow @(Rep a) . from++  default enumerate :: Enumable a => [a]+  enumerate = to <$> genumerate @(Rep a)   -- | Types that are sum types, where each constructor is unary (that is, has no

@@ -3,25 +3,21 @@ {-# language StandaloneKindSignatures #-} {-# language StrictData #-} -module Rel8.Type.Information-  ( TypeInformation(..)-  , mapTypeInformation-  , parseTypeInformation-  )-where+module Rel8.Type.Information (+  TypeInformation(..),+  mapTypeInformation,+  parseTypeInformation,+) where  -- base-import Data.Kind ( Type )+import Data.Functor.Contravariant ((>$<))+import Data.Kind (Type) import Prelude --- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye- -- rel8-import Rel8.Type.Name (TypeName)---- text import Rel8.Type.Decoder (Decoder, parseDecoder)+import Rel8.Type.Encoder (Encoder)+import Rel8.Type.Name (TypeName)   -- | @TypeInformation@ describes how to encode and decode a Haskell type to and@@ -29,14 +25,17 @@ -- database, which is used to accurately type literals.  type TypeInformation :: Type -> Type data TypeInformation a = TypeInformation-  { encode :: a -> Opaleye.PrimExpr-    -- ^ How to encode a single Haskell value as a SQL expression.+  { encode :: Encoder a+    -- ^ How to serialize a Haskell value to PostgreSQL.   , decode :: Decoder a-    -- ^ How to deserialize a single result back to Haskell.+    -- ^ How to deserialize a PostgreSQL result back to Haskell.+  , delimiter :: Char+    -- ^ The delimiter that is used in PostgreSQL's text format in arrays of+    -- this type (this is almost always ',').   , typeName :: TypeName     -- ^ The name of the SQL type.   }-+   -- | Simultaneously map over how a type is both encoded and decoded, while -- retaining the name of the type. This operation is useful if you want to@@ -59,9 +58,10 @@ parseTypeInformation :: ()   => (a -> Either String b) -> (b -> a)   -> TypeInformation a -> TypeInformation b-parseTypeInformation to from TypeInformation {encode, decode, typeName} =+parseTypeInformation to from TypeInformation {encode, decode, delimiter, typeName} =   TypeInformation-    { encode = encode . from-    , decode = parseDecoder to decode+    { decode = parseDecoder to decode+    , encode = from >$< encode+    , delimiter     , typeName     }

@@ -1,30 +1,40 @@+{-# language DisambiguateRecordFields #-} {-# language OverloadedStrings #-} {-# language StandaloneKindSignatures #-} -module Rel8.Type.JSONBEncoded-  ( JSONBEncoded(..)-  )-where+module Rel8.Type.JSONBEncoded (+  JSONBEncoded(..),+) where  -- aeson import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, parseJSON, toJSON)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson import Data.Aeson.Types (parseEither)  -- base import Data.Bifunctor ( first )+import Data.Functor.Contravariant ((>$<)) import Data.Kind ( Type ) import Prelude  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders +-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye (quote)+ -- rel8 import Rel8.Type ( DBType(..) ) import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) )  -- text import Data.Text ( pack )+import Data.Text.Lazy (unpack)   -- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.@@ -32,14 +42,26 @@ newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }   deriving (Show, Eq, Ord) + instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where   typeInformation = TypeInformation-    { encode = encode typeInformation . toJSON . fromJSONBEncoded+    { encode =+        Encoder+          { binary = toJSON . fromJSONBEncoded >$< Encoders.jsonb+          , text = Aeson.fromEncoding . Aeson.toEncoding . fromJSONBEncoded+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              Opaleye.quote .+              unpack . Aeson.encodeToLazyText . fromJSONBEncoded+          }     , decode =         Decoder-          { binary = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb-          , parser = fmap JSONBEncoded . eitherDecodeStrict-          , delimiter = ','+          { binary =+              Decoders.refine+                (first pack . fmap JSONBEncoded . parseEither parseJSON)+                Decoders.jsonb+          , text = fmap JSONBEncoded . eitherDecodeStrict           }+    , delimiter = ','     , typeName = "jsonb"     }

@@ -1,35 +1,41 @@+{-# language DisambiguateRecordFields #-} {-# language StandaloneKindSignatures #-}-{-# language OverloadedStrings        #-}-{-# language TypeApplications         #-}+{-# language OverloadedStrings #-}+{-# language TypeApplications #-} -module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where+module Rel8.Type.JSONEncoded (+  JSONEncoded(..),+) where  -- aeson-import Data.Aeson ( FromJSON, ToJSON, parseJSON )-import Data.Aeson.Types ( parseEither )+import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, parseJSON, toJSON) import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson+import Data.Aeson.Types (parseEither)  -- base-import Data.Kind ( Type ) import Data.Bifunctor (first)+import Data.Functor.Contravariant ((>$<))+import Data.Kind ( Type ) import Prelude  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- rel8 import Rel8.Type ( DBType(..) )+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) )-import Rel8.Type.Decoder ( Decoder(..) )  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )  -- text-import qualified Data.Text as Text-import qualified Data.Text.Lazy as Lazy-import qualified Data.Text.Lazy.Encoding as Lazy+import Data.Text (pack)+import Data.Text.Lazy (unpack)   -- | A deriving-via helper type for column types that store a Haskell value@@ -43,14 +49,21 @@ instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .-        Lazy.unpack . Lazy.decodeUtf8 .-        Aeson.encode . fromJSONEncoded+        Encoder+          { binary = toJSON . fromJSONEncoded >$< Encoders.json+          , text = Aeson.fromEncoding . Aeson.toEncoding . fromJSONEncoded+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .+              unpack . Aeson.encodeToLazyText . fromJSONEncoded+          }     , decode =         Decoder-          { binary = Hasql.refine (first Text.pack . fmap JSONEncoded . parseEither parseJSON) Hasql.json-          , parser = fmap JSONEncoded . Aeson.eitherDecodeStrict-          , delimiter = ','+          { binary =+              Decoders.refine+                (first pack . fmap JSONEncoded . parseEither parseJSON)+                Decoders.json+          , text = fmap JSONEncoded . eitherDecodeStrict           }+    , delimiter = ','     , typeName = "json"     }

@@ -0,0 +1,16 @@+{-# language GADTs #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Type.Nullable (+  NullableOrNot (..),+) where++-- base+import Data.Kind (Type)+import Prelude+++type NullableOrNot :: (Type -> Type) -> Type -> Type+data NullableOrNot decoder a where+  NonNullable :: decoder a -> NullableOrNot decoder a+  Nullable :: decoder a -> NullableOrNot decoder (Maybe a)

@@ -1,5 +1,6 @@ {-# language BangPatterns #-} {-# language BlockArguments #-}+{-# language CPP #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} {-# language DerivingVia #-}@@ -13,6 +14,8 @@ {-# language StandaloneDeriving #-} {-# language TypeApplications #-} +{-# language PartialTypeSignatures #-}+ module Main   ( main   )@@ -36,13 +39,14 @@ import Data.List ( nub, sort ) import Data.Maybe ( catMaybes ) import Data.Ratio ((%))-import Data.String ( fromString )-import Data.Word (Word32, Word8)+import Data.Word (Word32) import GHC.Generics ( Generic ) import Prelude hiding (truncate)  -- bytestring+import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy+import Data.ByteString ( ByteString )  -- case-insensitive import Data.CaseInsensitive ( mk )@@ -52,30 +56,34 @@ import qualified Data.Map.Strict as Map  -- hasql-import Hasql.Connection ( Connection, acquire, release )+import Hasql.Connection ( Connection, ConnectionError, acquire, release )+#if MIN_VERSION_hasql(1,9,0)+import qualified Hasql.Connection.Setting+import qualified Hasql.Connection.Setting.Connection+#endif import Hasql.Session ( sql, run )  -- hasql-transaction import Hasql.Transaction ( Transaction, condemn, statement )+import qualified Hasql.Transaction as Hasql import qualified Hasql.Transaction.Sessions as Hasql  -- hedgehog-import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )+import Hedgehog ( annotate, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +-- iproute+import qualified Data.IP+ -- mmorph import Control.Monad.Morph ( hoist ) --- network-ip-import Network.IP.Addr (NetAddr, IP, IP4(..), IP6(..), IP46(..), net4Addr, net6Addr, fromNetAddr46, Net4Addr, Net6Addr)-import Data.DoubleWord (Word128(..))--import qualified Data.IP- -- rel8 import Rel8 ( Result ) import qualified Rel8+import qualified Rel8.Generic.Rel8able.Test as Rel8able+import qualified Rel8.Table.Verify as Verify  -- scientific import Data.Scientific ( Scientific )@@ -87,7 +95,7 @@ import Test.Tasty.Hedgehog ( testProperty )  -- text-import Data.Text ( Text, pack, unpack )+import Data.Text ( Text, unpack ) import qualified Data.Text as T import qualified Data.Text.Lazy import Data.Text.Encoding ( decodeUtf8 )@@ -134,7 +142,6 @@     , testDBEq getTestDatabase     , testTableEquality getTestDatabase     , testFromRational getTestDatabase-    , testFromString getTestDatabase     , testCatMaybeTable getTestDatabase     , testCatMaybe getTestDatabase     , testMaybeTable getTestDatabase@@ -149,20 +156,19 @@     , testSelectArray getTestDatabase     , testNestedMaybeTable getTestDatabase     , testEvaluate getTestDatabase+    , testShowCreateTable getTestDatabase     ]-   where-     startTestDatabase = do       db <- TmpPostgres.start >>= either throwIO return -      bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do+      bracket (either (error . show) return =<< acquireFromConnectionString (TmpPostgres.toConnectionString db)) release \conn -> void do         flip run conn do           sql "CREATE EXTENSION citext"           sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"           sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"           sql "CREATE SEQUENCE test_seq"-          sql "CREATE TYPE composite AS (\"bool\" bool, \"char\" char, \"array\" int4[])"+          sql "CREATE TYPE composite AS (\"bool\" bool, \"char\" text, \"array\" int4[])"        return db @@ -170,9 +176,119 @@   connect :: TmpPostgres.DB -> IO Connection-connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure+connect = acquireFromConnectionString . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure +acquireFromConnectionString :: ByteString -> IO (Either ConnectionError Connection)+acquireFromConnectionString connectionString =+#if MIN_VERSION_hasql(1,9,0)+  acquire +    [ Hasql.Connection.Setting.connection . Hasql.Connection.Setting.Connection.string . decodeUtf8 $ connectionString+    ]+#else+  acquire connectionString+#endif +testShowCreateTable :: IO TmpPostgres.DB -> TestTree+testShowCreateTable getTestDatabase = testGroup "CREATE TABLE"+  [ testTypeChecker "tableTest" Rel8able.tableTest Rel8able.genTableTest getTestDatabase+  , testTypeChecker "tablePair" Rel8able.tablePair Rel8able.genTablePair getTestDatabase+  , testTypeChecker "tableMaybe" Rel8able.tableMaybe Rel8able.genTableMaybe getTestDatabase+  , testTypeChecker "tableEither" Rel8able.tableEither Rel8able.genTableEither getTestDatabase+  , testTypeChecker "tableThese" Rel8able.tableThese Rel8able.genTableThese getTestDatabase+  , testTypeChecker "tableList" Rel8able.tableList Rel8able.genTableList getTestDatabase+  , testTypeChecker "tableNest" Rel8able.tableNest Rel8able.genTableNest getTestDatabase+  , testTypeChecker "nonRecord" Rel8able.nonRecord Rel8able.genNonRecord getTestDatabase+  , testTypeChecker "tableProduct" Rel8able.tableProduct Rel8able.genTableProduct getTestDatabase+  , testTypeChecker "tableType" Rel8able.tableType Rel8able.genTableType getTestDatabase+  , testWrongTable getTestDatabase+  , testDuplicateTable getTestDatabase+  , testCharMismatch getTestDatabase+  , testNumericMismatch getTestDatabase+  ]+  where+    -- confirms that the type checker works correctly for numeric modifiers+    testNumericMismatch = databasePropertyTest "numeric mismatch" \transaction -> transaction do+      lift $ Hasql.sql $ "create table \"tableNumeric\" ( foo numeric(1000, 4) not null );"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableNumeric]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()+      lift $ Hasql.sql $ "alter table \"tableNumeric\" alter column foo set data type numeric(1000, 2);"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableNumeric]+      case typeErrors of+        Nothing -> pure ()+        Just _ -> failure++    -- tests that the type checker works correctly for bpchar modifiers+    testCharMismatch = databasePropertyTest "bpchar mismatch" \transaction -> transaction do+      lift $ Hasql.sql $ "create table \"tableChar\" ( foo bpchar(2) not null );"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableChar]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()+      lift $ Hasql.sql $ "alter table \"tableChar\" alter column foo set data type bpchar(1);"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableChar]+      case typeErrors of+        Nothing -> pure ()+        Just a -> do+            annotate (unpack a)+            failure++    -- confirms that the type checker fails when no type errors are present in a+    -- table with duplicate column names+    testDuplicateTable = databasePropertyTest "duplicate columns" \transaction -> transaction do+      lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableDuplicate+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableDuplicate]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()++    -- confirms that the type checker fails if the types mismatch+    testWrongTable = databasePropertyTest "type mismatch" \transaction -> transaction do+      lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableType+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.badTableType]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()++    testTypeChecker ::+      ( Show (k Result), Rel8.Rel8able k, Rel8.Selects (k Rel8.Name) (k Rel8.Expr)+      , Rel8.Serializable (k Rel8.Expr) (k Rel8.Result))+      => TestName -> Rel8.TableSchema (k Rel8.Name) -> Gen (k Result) -> IO TmpPostgres.DB -> TestTree+    testTypeChecker testName tableSchema genRows = databasePropertyTest testName \transaction -> do+      rows <- forAll $ Gen.list (Range.linear 0 10) genRows++      transaction do+        lift $ Hasql.sql $ B.pack $ Verify.showCreateTable tableSchema+        typeErrors <- lift $ statement () $ Verify.getSchemaErrors [Verify.SomeTableSchema tableSchema]+        case typeErrors of+          Nothing -> pure ()+          Just typ -> do+            annotate (unpack typ)+            failure++        selected <- lift do+          statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert+            { into = tableSchema+            , rows = Rel8.values $ map Rel8.lit rows+            , onConflict = Rel8.DoNothing+            , returning = Rel8.NoReturning+            }+          statement () $ Rel8.run $ Rel8.select do+            Rel8.each tableSchema++        -- not every type we use this with has an ord instance, and we're+        -- primarily checking the type checker here, not the parser/printer,+        -- so we this is only here as one additional check+        length selected === length rows++ databasePropertyTest   :: TestName   -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())@@ -430,7 +546,7 @@  data Composite = Composite   { bool :: !Bool-  , char :: !Char+  , char :: !Text   , array :: ![Int32]   }   deriving stock (Eq, Show, Generic)@@ -441,18 +557,15 @@   compositeTypeName = "composite"   compositeFields = Rel8.namesFromLabels --- | Postgres doesn't support the NULL character (not to be confused with a NULL value) inside strings.-removeNull :: Text -> Text-removeNull = T.filter (/='\0') - testDBType :: IO TmpPostgres.DB -> TestTree testDBType getTestDatabase = testGroup "DBType instances"   [ dbTypeTest "Bool" Gen.bool   , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)   , dbTypeTest "CalendarDiffTime" genCalendarDiffTime-  , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict . removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode-  , dbTypeTest "CI Text" $ mk .removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "Char" Gen.unicode+  , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> genText+  , dbTypeTest "CI Text" $ mk <$> genText   , dbTypeTest "Composite" genComposite   , dbTypeTest "Day" genDay   , dbTypeTest "Double" $ (/ 10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)@@ -461,14 +574,13 @@   , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded   , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded   , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)-  , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict . removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> genText   , dbTypeTest "LocalTime" genLocalTime   , dbTypeTest "Scientific" $ genScientific-  , dbTypeTest "Text" $ removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "Text" genText   , dbTypeTest "TimeOfDay" genTimeOfDay   , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime   , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32-  , dbTypeTest "INet" genNetAddrIP   , dbTypeTest "INet" genIPRange   , dbTypeTest "Value" genValue   , dbTypeTest "JSONEncoded" genJSONEncoded@@ -482,10 +594,10 @@       , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase       ] -    t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a)+    t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a)       => Gen a-      -> (TestT Transaction () -> PropertyT IO b)-      -> PropertyT IO b+      -> (TestT Transaction () -> PropertyT IO ())+      -> PropertyT IO ()     t generator transaction = do       x <- forAll generator       y <- forAll generator@@ -526,15 +638,39 @@             Rel8.aggregate Rel8.listCatExpr $               Rel8.values $ map Rel8.litExpr xsss         diff res''''' (==) (concat xsss)-       +      transaction do+        res <- lift do+          statement x $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.Expr _) .+            pure+        diff res (==) x++        res' <- lift do+          statement [x, y] $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.Expr _)) .+            Rel8.many . Rel8.catListTable+        diff res' (==) [x, y]++        res'' <- lift do+          statement [[x, y]] $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.Expr _))) .+            Rel8.many . Rel8.many . (Rel8.catListTable >=> Rel8.catListTable)+        diff res'' (==) [[x, y]]++        res''' <- lift do+          statement [[[x, y]]] $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.Expr _)))) .+            Rel8.many . Rel8.many . Rel8.many . (Rel8.catListTable >=> Rel8.catListTable >=> Rel8.catListTable)+        diff res''' (==) [[[x, y]]]+     genScientific :: Gen Scientific     genScientific = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)      genComposite :: Gen Composite     genComposite = do       bool <- Gen.bool-      char <- Gen.unicode+      char <- genText       array <- Gen.list (Range.linear 0 10) (Gen.int32 (Range.linear (-10000) 10000))       pure Composite {..} @@ -568,29 +704,13 @@     genWord32 :: Gen Word32     genWord32 = Gen.integral Range.linearBounded -    genWord128 :: Gen Word128-    genWord128 = Gen.integral Range.linearBounded--    genNetAddrIP  :: Gen (NetAddr IP)-    genNetAddrIP =-      let-        genIP4Mask :: Gen Word8-        genIP4Mask = Gen.integral (Range.linearFrom 0 0 32)--        genIPv4 :: Gen (IP46 Net4Addr Net6Addr)-        genIPv4 = IPv4 <$> (liftA2 net4Addr (IP4 <$> genWord32) genIP4Mask)--        genIP6Mask :: Gen Word8-        genIP6Mask = Gen.integral (Range.linearFrom 0 0 128)--        genIPv6 :: Gen (IP46 Net4Addr Net6Addr)-        genIPv6 = IPv6 <$> (liftA2 net6Addr (IP6 <$> genWord128) genIP6Mask)--       in fromNetAddr46 <$> Gen.choice [ genIPv4, genIPv6 ]-     genIPRange :: Gen (Data.IP.IPRange)     genIPRange =-      let+      Gen.choice+        [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask)+        , Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)+        ]+      where         genIP4Mask :: Gen Int         genIP4Mask = Gen.integral (Range.linearFrom 0 0 32) @@ -603,17 +723,16 @@         genIPv6 :: Gen (Data.IP.IPv6)         genIPv6 = Data.IP.toIPv6w <$> ((,,,) <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32) -       in Gen.choice [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask), Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)]-     genKey :: Gen Aeson.Key-    genKey = Aeson.Key.fromText <$> Gen.text (Range.linear 0 10) Gen.unicode+    genKey = Aeson.Key.fromText <$> genText      genValue :: Gen Aeson.Value     genValue = Gen.recursive Gen.choice      [ pure Aeson.Null      , Aeson.Bool <$> Gen.bool      , Aeson.Number <$> genScientific-     , Aeson.String <$> Gen.text (Range.linear 0 10) Gen.unicode]+     , Aeson.String <$> genText+     ]      [ Aeson.Object . Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue)      , Aeson.Array . Vector.fromList <$> Gen.list (Range.linear 0 10) genValue      ]@@ -627,7 +746,7 @@   [ dbEqTest "Bool" Gen.bool   , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded   , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded-  , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode+  , dbEqTest "Text" $ genText   ]    where@@ -651,6 +770,15 @@         res === (x == y)  +genText :: Gen Text+genText = removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode+  where+    -- | Postgres doesn't support the NULL character (not to be confused with a NULL value) inside strings.+    removeNull :: Text -> Text+    removeNull = T.filter (/= '\0')+++ testTableEquality :: IO TmpPostgres.DB -> TestTree testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do    (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable@@ -678,28 +806,17 @@         pure $ fromRational rational     diff result (~=) double   where-    wholeDigits x = fromIntegral $ length $ show $ round x+    wholeDigits x = fromIntegral $ length $ show $ round @_ @Integer x     -- A Double gives us between 15-17 decimal digits of precision.     -- It's tempting to say that two numbers are equal if they differ by less than 1e15.     -- But this doesn't hold.     -- The precision is split between the whole numer part and the decimal part of the number.     -- For instance, a number between 10 and 99 only has around 13 digits of precision in its decimal part.     -- Postgres and Haskell show differing amounts of digits in these cases,-    a ~= b = abs (a - b) < 10**(-15 + wholeDigits a)+    a ~= b = abs (a - b) < 10 ** (-15 + wholeDigits a)     infix 4 ~=  -testFromString :: IO TmpPostgres.DB -> TestTree-testFromString = databasePropertyTest "fromString" \transaction -> do-  str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode--  transaction do-    result <- lift do-      statement () $ Rel8.run1 $ Rel8.select do-        pure $ fromString str-    result === pack str-- testCatMaybeTable :: IO TmpPostgres.DB -> TestTree testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do   rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable@@ -809,7 +926,7 @@   where     genRows :: PropertyT IO [TestTable Result]     genRows = forAll do-      Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)+      Gen.list (Range.linear 0 10) $ liftA2 TestTable genText (pure True)   genTestTable :: Gen (TestTable Result)

@@ -1,3 +1,4 @@+{-# language ScopedTypeVariables #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-}@@ -5,9 +6,13 @@ {-# language DuplicateRecordFields #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-}+{-# language StandaloneDeriving #-} {-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-}+{-# language RecordWildCards #-} {-# language UndecidableInstances #-}  {-# options_ghc -O0 #-}@@ -17,97 +22,264 @@   ) where +-- aeson+import Data.Aeson ( Value(..) )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as Aeson+ -- base+import Data.Fixed ( Fixed ( MkFixed ), E2 )+import Data.Int ( Int16, Int32, Int64 )+import Data.Functor.Identity ( Identity(..) )+import qualified Data.List.NonEmpty as NonEmpty import GHC.Generics ( Generic ) import Prelude+import Control.Applicative ( liftA3 ) +-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as LB++-- case-insensitive+import Data.CaseInsensitive ( CI )+import qualified Data.CaseInsensitive as CI++-- containers+import qualified Data.Map as Map++-- hedgehog+import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+ -- rel8 import Rel8 +-- scientific+import Data.Scientific ( Scientific, fromFloatDigits )++-- time+import Data.Time.Calendar (Day)+import Data.Time.Clock (UTCTime(..), secondsToDiffTime, secondsToNominalDiffTime)+import Data.Time.LocalTime+  ( CalendarDiffTime (CalendarDiffTime)+  , LocalTime(..)+  , TimeOfDay(..)+  )+ -- text import Data.Text ( Text )+import qualified Data.Text.Lazy as LT +-- these+import Data.These +-- uuid+import Data.UUID ( UUID )+import qualified Data.UUID as UUID++-- vector+import Data.Vector ( Vector )+import qualified Data.Vector as Vector+++makeSchema :: forall f. Rel8able f => QualifiedName -> TableSchema (f Name)+makeSchema name = TableSchema+  { name = name+  , columns = namesFromLabels @(f Name)+  }+++data TableDuplicate f = TableDuplicate+  { foo :: TablePair f+  , bar :: TablePair f+  }+  deriving stock Generic+  deriving anyclass Rel8able++tableDuplicate :: TableSchema (TableDuplicate Name)+tableDuplicate = TableSchema+  { name = "tableDuplicate"+  , columns = namesFromLabelsWith NonEmpty.last+  }++ data TableTest f = TableTest   { foo :: Column f Bool   , bar :: Column f (Maybe Bool)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableTest f)+deriving stock instance f ~ Result => Eq (TableTest f)+deriving stock instance f ~ Result => Ord (TableTest f) +tableTest :: TableSchema (TableTest Name)+tableTest = makeSchema "tableTest" +genTableTest :: Hedgehog.MonadGen m => m (TableTest Result)+genTableTest = TableTest <$> Gen.bool <*> Gen.maybe Gen.bool++ data TablePair f = TablePair   { foo :: Column f Bool   , bars :: (Column f Text, Column f Text)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TablePair f)+deriving stock instance f ~ Result => Eq (TablePair f)+deriving stock instance f ~ Result => Ord (TablePair f) +tablePair :: TableSchema (TablePair Name)+tablePair = makeSchema "tablePair" +genTablePair :: Hedgehog.MonadGen m => m (TablePair Result)+genTablePair = TablePair+  <$> Gen.bool+  <*> liftA2 (,) (Gen.text (Range.linear 0 10) Gen.alphaNum) (Gen.text (Range.linear 0 10) Gen.alphaNum)++ data TableMaybe f = TableMaybe   { foo :: Column f [Maybe Bool]   , bars :: HMaybe f (TablePair f, TablePair f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableMaybe f)+deriving stock instance f ~ Result => Eq (TableMaybe f)+deriving stock instance f ~ Result => Ord (TableMaybe f) +tableMaybe :: TableSchema (TableMaybe Name)+tableMaybe = makeSchema "tableMaybe" +genTableMaybe :: Hedgehog.MonadGen m => m (TableMaybe Result)+genTableMaybe = TableMaybe+  <$> Gen.list (Range.linear 0 10) (Gen.maybe Gen.bool)+  <*> Gen.maybe (liftA2 (,) genTablePair genTablePair)++ data TableEither f = TableEither   { foo :: Column f Bool   , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableEither f)+deriving stock instance f ~ Result => Eq (TableEither f)+deriving stock instance f ~ Result => Ord (TableEither f) +tableEither :: TableSchema (TableEither Name)+tableEither = makeSchema "tableEither" +genTableEither :: Hedgehog.MonadGen m => m (TableEither Result)+genTableEither = TableEither+  <$> Gen.bool+  <*> Gen.either (Gen.maybe $ liftA2 (,) genTablePair genTablePair) Gen.alphaNum++ data TableThese f = TableThese   { foo :: Column f Bool   , bars :: HThese f (TableMaybe f) (TableEither f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableThese f)+deriving stock instance f ~ Result => Eq (TableThese f)+deriving stock instance f ~ Result => Ord (TableThese f) +tableThese :: TableSchema (TableThese Name)+tableThese = makeSchema "tableThese" +genTableThese :: Hedgehog.MonadGen m => m (TableThese Result)+genTableThese = TableThese+  <$> Gen.bool+  <*> Gen.choice+    [ This <$> genTableMaybe+    , That <$> genTableEither+    , These <$> genTableMaybe <*> genTableEither+    ]++ data TableList f = TableList   { foo :: Column f Bool   , bars :: HList f (TableThese f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableList f)+deriving stock instance f ~ Result => Eq (TableList f)+deriving stock instance f ~ Result => Ord (TableList f) +tableList :: TableSchema (TableList Name)+tableList = makeSchema "tableList" +genTableList :: Hedgehog.MonadGen m => m (TableList Result)+genTableList = TableList+  <$> Gen.bool+  <*> Gen.list (Range.linear 0 10) genTableThese++ data TableNonEmpty f = TableNonEmpty   { foo :: Column f Bool   , bars :: HNonEmpty f (TableList f, TableMaybe f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableNonEmpty f)+deriving stock instance f ~ Result => Eq (TableNonEmpty f)+deriving stock instance f ~ Result => Ord (TableNonEmpty f) +tableNonEmpty :: TableSchema (TableNonEmpty Name)+tableNonEmpty = makeSchema "tableNonEmpty" +genTableNonEmpty :: Hedgehog.MonadGen m => m (TableNonEmpty Result)+genTableNonEmpty = TableNonEmpty+  <$> Gen.bool+  <*> Gen.nonEmpty (Range.linear 0 10) (liftA2 (,) genTableList genTableMaybe)++ data TableNest f = TableNest   { foo :: Column f Bool   , bars :: HList f (HMaybe f (TablePair f))   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableNest f)+deriving stock instance f ~ Result => Eq (TableNest f)+deriving stock instance f ~ Result => Ord (TableNest f) +tableNest :: TableSchema (TableNest Name)+tableNest = makeSchema "tableNest" +genTableNest :: Hedgehog.MonadGen m => m (TableNest Result)+genTableNest = TableNest+  <$> Gen.bool+  <*> Gen.list (Range.linear 0 10) (Gen.maybe genTablePair)++ data S3Object = S3Object   { bucketName :: Text   , objectKey :: Text   }-  deriving stock Generic+  deriving stock (Generic, Show, Eq, Ord)   instance x ~ HKD S3Object Expr => ToExprs x S3Object   data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC-  deriving stock Generic+  deriving stock (Generic, Show, Eq, Ord)   instance x ~ HKD HKDSum Expr => ToExprs x HKDSum +genHKDSum :: Hedgehog.MonadGen m => m HKDSum+genHKDSum = Gen.choice+  [ HKDSumA <$> Gen.text (Range.linear 0 10) Gen.alpha+  , HKDSumB <$> Gen.bool <*> Gen.alpha+  , pure HKDSumC+  ]  data HKDTest f = HKDTest   { s3Object :: Lift f S3Object@@ -115,7 +287,14 @@   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (HKDTest f)+deriving stock instance f ~ Result => Eq (HKDTest f)+deriving stock instance f ~ Result => Ord (HKDTest f) +genHKDTest :: Hedgehog.MonadGen m => m (HKDTest Result)+genHKDTest = HKDTest+  <$> liftA2 S3Object (Gen.text (Range.linear 0 10) Gen.alpha) (Gen.text (Range.linear 0 10) Gen.alpha)+  <*> genHKDSum  data NonRecord f = NonRecord   (Column f Bool)@@ -130,22 +309,63 @@   (Column f Char)   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (NonRecord f)+deriving stock instance f ~ Result => Eq (NonRecord f)+deriving stock instance f ~ Result => Ord (NonRecord f) +nonRecord :: TableSchema (NonRecord Name)+nonRecord = makeSchema "nonRecord" +genNonRecord :: Hedgehog.MonadGen m => m (NonRecord Result)+genNonRecord = NonRecord+  <$> Gen.bool+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha++ data TableSum f   = TableSumA (Column f Bool) (Column f Text)   | TableSumB   | TableSumC (Column f Text)   deriving stock Generic+deriving stock instance f ~ Result => Show (TableSum f)+deriving stock instance f ~ Result => Eq (TableSum f)+deriving stock instance f ~ Result => Ord (TableSum f)  +genTableSum :: Hedgehog.MonadGen m => m (HADT Result TableSum)+genTableSum = Gen.choice+  [ TableSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha+  , pure TableSumB+  , TableSumC <$> Gen.text (Range.linear 0 10) Gen.alpha+  ]++ data BarbieSum f   = BarbieSumA (f Bool) (f Text)   | BarbieSumB   | BarbieSumC (f Text)   deriving stock Generic+deriving stock instance f ~ Result => Show (BarbieSum f)+deriving stock instance f ~ Result => Eq (BarbieSum f)+deriving stock instance f ~ Result => Ord (BarbieSum f)  +genBarbieSum :: Hedgehog.MonadGen m => m (BarbieSum Result)+genBarbieSum = Gen.choice+  [ BarbieSumA <$> fmap Identity Gen.bool <*> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha)+  , pure BarbieSumB+  , BarbieSumC <$> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha)+  ]++ data TableProduct f = TableProduct   { sum :: HADT f BarbieSum   , list :: TableList f@@ -153,8 +373,32 @@   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableProduct f)+deriving stock instance f ~ Result => Eq (TableProduct f)+deriving stock instance f ~ Result => Ord (TableProduct f) +tableProduct :: TableSchema (TableProduct Name)+tableProduct = makeSchema "tableProduct" +genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result)+genTableProduct = TableProduct+  <$> genBarbieSum+  <*> genTableList+  <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum genHKDSum genHKDTest)++-- tableProduct :: TableProduct Name+-- tableProduct = makeSchema "tableProduct"++-- genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result)+-- genTableProduct = TableProduct+--   <$> Gen.choice+--     [ BarbieSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha+--     , BarbieSumB+--     , BarbieSumC <$> Gen.text (Range.linear 0 10) Gen.alpha+--     ]+--   <*> genTableList+--   <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum)+ data TableTestB f = TableTestB   { foo :: f Bool   , bar :: f (Maybe Bool)@@ -187,3 +431,104 @@   }   deriving stock Generic   deriving anyclass Rel8able+++data TableType f = TableType+  { bool                :: Column f Bool+  , char                :: Column f Char+  , int16               :: Column f Int16+  , int32               :: Column f Int32+  , int64               :: Column f Int64+  , float               :: Column f Float+  , double              :: Column f Double+  , scientific          :: Column f Scientific+  , fixed               :: Column f (Fixed E2)+  , utctime             :: Column f UTCTime+  , day                 :: Column f Day+  , localtime           :: Column f LocalTime+  , timeofday           :: Column f TimeOfDay+  , calendardifftime    :: Column f CalendarDiffTime+  , text                :: Column f Text+  , lazytext            :: Column f LT.Text+  , citext              :: Column f (CI Text)+  , cilazytext          :: Column f (CI LT.Text)+  , bytestring          :: Column f ByteString+  , lazybytestring      :: Column f LB.ByteString+  , uuid                :: Column f UUID+  , value               :: Column f Value+  } deriving stock (Generic)+deriving anyclass instance Rel8able TableType+deriving stock instance f ~ Result => Show (TableType f)+deriving stock instance f ~ Result => Eq (TableType f)+-- deriving stock instance f ~ Result => Ord (TableType f)++tableType :: TableSchema (TableType Name)+tableType = makeSchema "tableType"++badTableType :: TableSchema (TableProduct Name)+badTableType = makeSchema "tableType"++genTableType :: Hedgehog.MonadGen m => m (TableType Result)+genTableType = do+  bool <- Gen.bool+  char <- Gen.alpha+  int16 <- Gen.int16 range+  int32 <- Gen.int32 range+  int64 <- Gen.int64 range+  float <- Gen.float linearFrac+  double <- Gen.double linearFrac+  scientific <- fromFloatDigits <$> Gen.realFloat linearFrac+  utctime <- UTCTime <$> (toEnum <$> Gen.integral range) <*> fmap secondsToDiffTime (Gen.integral range)+  day <- toEnum <$> Gen.integral range+  localtime <- LocalTime <$> (toEnum <$> Gen.integral range) <*> timeOfDay+  timeofday <- timeOfDay+  text <- Gen.text range Gen.alpha+  lazytext <- LT.fromStrict <$> Gen.text range Gen.alpha+  citext <- CI.mk <$> Gen.text range Gen.alpha+  cilazytext <- CI.mk <$> LT.fromStrict <$> Gen.text range Gen.alpha+  bytestring <- Gen.bytes range+  lazybytestring <- LB.fromStrict <$> Gen.bytes range+  uuid <- UUID.fromWords <$> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range+  fixed <- MkFixed <$> Gen.integral range+  value <- Gen.choice+    [ Object <$> Aeson.fromMapText <$> Map.fromList <$> Gen.list range (liftA2 (,) (Gen.text range Gen.alpha) (pure Null))+    , Array <$> Vector.fromList <$> Gen.list range (pure Null)+    , String <$> Gen.text range Gen.alpha+    , Number <$> fromFloatDigits <$> Gen.realFloat linearFrac+    , Bool <$> Gen.bool+    , pure Null+    ]+  calendardifftime <- CalendarDiffTime <$> Gen.integral range <*> (secondsToNominalDiffTime <$> Gen.realFrac_ linearFrac)+  pure TableType {..}+  where+    timeOfDay :: Hedgehog.MonadGen m => m TimeOfDay+    timeOfDay = TimeOfDay <$> Gen.integral range <*> Gen.integral range <*> Gen.realFrac_ linearFrac++    range :: Integral a => Range.Range a+    range = Range.linear 0 10++    linearFrac :: (Fractional a, Ord a) => Range.Range a+    linearFrac = Range.linearFrac 0 10++data TableNumeric f = TableNumeric+  { foo :: Column f (Fixed E2)+  } deriving stock (Generic)+deriving anyclass instance Rel8able TableNumeric+deriving stock instance f ~ Result => Show (TableNumeric f)+deriving stock instance f ~ Result => Eq (TableNumeric f)++tableNumeric :: TableSchema (TableNumeric Name)+tableNumeric = makeSchema "tableNumeric"+++data TableChar f = TableChar+  { foo :: Column f Char+  } deriving stock (Generic)+deriving anyclass instance Rel8able TableChar+deriving stock instance f ~ Result => Show (TableChar f)+deriving stock instance f ~ Result => Eq (TableChar f)++tableChar :: TableSchema (TableChar Name)+tableChar = makeSchema "tableChar"++