hasql-generate (empty) → 1.0.0

raw patch · 13 files changed

+3655/−0 lines, 13 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, data-default-class, hasql, hasql-generate, postgresql-libpq, scientific, template-haskell, text, time, uuid, vector

Files

• CHANGELOG.md +3/−0
• LICENSE +21/−0
• README.md +298/−0
• hasql-generate.cabal +93/−0
• src/Hasql/Generate.hs +49/−0
• src/Hasql/Generate/Class.hs +97/−0
• src/Hasql/Generate/Codec.hs +158/−0
• src/Hasql/Generate/Column.hs +68/−0
• src/Hasql/Generate/Config.hs +53/−0
• src/Hasql/Generate/Connection.hs +134/−0
• src/Hasql/Generate/Internal/Introspect.hs +189/−0
• src/Hasql/Generate/TH.hs +1710/−0
• test/Main.hs +782/−0

@@ -0,0 +1,3 @@+# Changelog++1.0.0: Hello, world! The README is probably a better source for what this is

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

@@ -0,0 +1,298 @@+# Hasql.Generate+A library for compile-time generation of datatypes from Postgres introspection. Inspired by the relational-query-HDBC library's defineTableFromDB functions, but expanded to use Hasql, support more than just tables, and using the features of Postgres.+Aims to eliminate most of the boilerplate with using Hasql, the duplicate-definitions and need to ensure database-definitions match code-definitions, and be simple enough to use and understand. ++---++## Developing Hasql.Generate++All the tools I use are available in the `nix-shell`.+That will give you `just`, and `justfile` (run with `just help`) will have all the commands you would need.+To run the tests, you will need to have postgres running, which again there's a `just` recipe for (`just pg-start`), since the tests revolve around the generation of types and functions. The `just test` command will setup the database, run the tests, and clean itself up afterwards. When done, just stop the database (`just pg-stop`).+Please format and lint your work (`just format`/`just lint`).++## Using Hasql.Generate++### BYOD (Bring Your Own Data/Database)+To start with this library, you'll need a pre-existing PostgreSQL database with tables, views, or types.++### Config+From there, you should make a `Config` that all the TH splices will generate with. This config should be made in a file that you will _import_ into files that generate types (this is a TemplateHaskell requirement, not mine).+```haskell+data Config+    = Config+      { connection                 :: ConnectionInfo+      , allowDuplicateRecordFields :: Bool+      , newtypePrimaryKeys         :: Bool+      , globalOverrides            :: [(String, Name)]+      }+```+You will need to make a `ConnectionInfo`, with either the `PgSimpleInfo` for "simple" info that's then formed into the connection string, or you can make the libpq connection string yourself (with all the advanced options) with `PgConnectionString` for full control, but you should know what you're doing for this case.+```haskell+data ConnectionInfo+    = PgSimpleInfo+      { pgHost     :: Maybe String+      , pgPort     :: Maybe String+      , pgUser     :: Maybe String+      , pgPassword :: Maybe String+      , pgDatabase :: Maybe String+      }+    | PgConnectionString String+```+If you set any `PgSimpleInfo` field as `Nothing` it will use the libpq defaults. If you will be using the default libpq connection details for all of it, you can use `Data.Default.def` for the `ConnectionInfo`. If you will not be using DuplicateRecordFields, are fine with the primary keys being "regular" types (ex.: `Int` instead of a wrapped-newtype `TypeNamePk {getTypeNamePk :: Int}`), and have no global type-overrides, you can use `Data.Default.def` for the entire `Config`.++### Generate Haskell Datatypes+Once that's setup, we can use that to generate our data. In a file where you want this type to be generated:+```haskell+module MyApp.MySqlDatatypes where++import Hasql.Generate (generate, fromTable, fromView, fromType)+-- You made this in the last step!+import MyApp.MyHasqlGenerateConfig (config)++$(generate config $ fromType "public" "user_type")++$(generate config $ fromTable "public" "users")++$(generate config $ fromView "public" "users_view")+```+If you need to override types on a per-table level:+```haskell+import Data.Function ((&))+import Hasql.Generate (generate, fromTable, withOverrides)+import MyApp.MyHasqlGenerateConfig (config)++$( generate config+    ( fromTable "public" "users"+      & withOverrides [ ("text", ''String) ]+    )+ )+```+Or if you want to generically-derive types:+```haskell+import Data.Aeson ( FromJSON, ToJSON)+import Data.Function ((&))+import GHC.Generics (Generic)+import Hasql.Generate (generate, fromTable, withDerivations)+import MyApp.MyHasqlGenerateConfig (config)++$( generate config+    ( fromTable "public" "users"+      & withDerivations [''Show, ''Eq, ''Generic, ''ToJSON, ''FromJSON] +    )+ )+```+(or you can do both, just chain them)++### Use Generated Tables+Given the following SQL:+```sql+CREATE TYPE public.user_role AS ENUM ('admin', 'important', 'regular');++CREATE TABLE public.users+  ( id     UUID      NOT NULL PRIMARY KEY DEFAULT uuidv7()+  , name   TEXT      NOT NULL+  , "role" user_role NOT NULL DEFAULT 'regular'+  , email  TEXT+  , age    INT4+  );+```+`$( generate def $ fromTable "public" "users")` will generate the following Haskell datatype:+```haskell+data Users+  = Users+    { usersId    :: !UUID+    , usersName  :: !Text+    , usersRole  :: !UserRole+    , usersEmail :: !(Maybe Text)+    , usersAge   :: !(Maybe Int32)+    }+```+\*you are responsible for adding an unqualified import for all types for your database. In the above example, you will need+```haskell+import Data.Int (Int32)+import Data.Text (Text)+import Data.UUID (UUID)+-- See important note on Postgres types below, in "Use Generated Types"+import MyApp.MyUserRoleLocation (UserRole)+```++It will also generate:+- `usersDecoder`+- `usersEncoder`+- `insertUsers`+- `insertManyUsers`+- a `HasInsert` instance++And when it has a Primary Key defined, it will also generate:+- `selectUsers`+- `selectManyUsers`+- `updateUsers`+- `updateManyUsers`+- `deleteUsers`+- `deleteManyUsers`+- a `HasPrimaryKey` instance+- a `HasSelect` instance+- a `HasUpdate` instance+- a `HasDelete` instance++If your Primary Key has a DEFAULT and you want to defer to the database to generate PK values on INSERT, add `withholdPk` to the `fromTable` generator. Without `withholdPk`, the primary key you supply in Haskell will be included in the INSERT, and the Postgres DEFAULT will not be used. You still need to create the record with a primary key value, but it can be a dummy value, like `0` for any Int-based type, or `UUID.nil` for a `UUID`:+```haskell+import Data.Function ((&))+import Hasql.Generate (generate, fromTable, withholdPk)+import MyApp.MyHasqlGenerateConfig (config)++$(generate config (fromTable "public" "users" & withholdPk))+```++### Use Generated Views+Given the following SQL:+```sql+CREATE VIEW public.users_view AS+  SELECT (name, "role", email, age)+  FROM public.users+  WHERE "role" = 'regular'+;+```+`$( generate def $ fromView "public" "users_view")` will generate the following Haskell datatype:+```haskell+data UsersView+  = UsersView+    { usersViewName  :: !(Maybe Text)+    , usersViewRole  :: !(Maybe UserRole)+    , usersViewEmail :: !(Maybe Text)+    , usersViewAge   :: !(Maybe Int32)+    }+```+\*All field types are Maybes in views because that's how Postgres reports the types on-introspection, even if the underlying table's column is `NOT NULL`.++It will also generate:+- `usersViewDecoder`+- `selectUsersView`+- a `HasView` instance++### Use Generated Types+Given the following SQL:+```sql+CREATE TYPE public.user_role+  AS ENUM ('admin', 'important', 'regular');+```+`$( generate def $ fromType "public" "user_role")` will generate the following Haskell datatype:+```haskell+data UserRole+  = Admin+  | Important+  | Regular+```+It will also generate:+- a `PgCodec` instance+- a `PgColumn` instance+- a `HasEnum` instance++IMPORTANT: If you define a type in Postgres, then use that type in a table you generate with `fromTable`, you must supply a matching type to the file containing the table's generator splice. You can either generate it with the `fromType` function as outlined above, or you can make it yourself. If you choose to write your own, you _must_ define `PgCodec` and `PgColumn` instances for the type written yourself, and the file generating the table mentioned previously _must_ have those instances in-scope.++The generated `PgColumn` instance triggers `-Worphans` because the functional+dependency's determining types are `Symbol` literals. Suppress with:+```haskell+{-# OPTIONS_GHC -Wno-orphans #-}+```++### Config Options++#### allowDuplicateRecordFields+Pairs with the DuplicateRecordFields Haskell pragma/language-extension. When active, we drop the camelCase table-name from the front of fields of generated table and view datatypes.++So this:+```haskell+data Users+  = Users+    { usersId    :: !UUID+    , usersName  :: !Text+    , usersRole  :: !UserRole+    , usersEmail :: !(Maybe Text)+    , usersAge   :: !(Maybe Int32)+    }+```+...would instead be this (with `allowDuplicateRecordFields = True`):+```haskell+data Users+  = Users+    { id    :: !UUID+    , name  :: !Text+    , role' :: !UserRole+    , email :: !(Maybe Text)+    , age   :: !(Maybe Int32)+    }+```+If you noticed, in this second example, there is an `id` field. This may conflict with the `id` function in Prelude, so you may wish to hide the `id` from Prelude, or name your columns accordingly. The `role` column is also named `role'` in Haskell, since `role` is a reserved keyword (`role` is also a reserved word in Postgres, hence why we've been double-quoting it in this README). Any Haskell-keywords will append an apostrophe as such.++#### newtypePrimaryKeys+When active, we generate newtype-wrappers for primary keys of tables.++So this:+```haskell+data Users+  = Users+    { usersId    :: !UUID+    , usersName  :: !Text+    , usersRole  :: !UserRole+    , usersEmail :: !(Maybe Text)+    , usersAge   :: !(Maybe Int32)+    }+```+...would instead be this (with `newtypePrimaryKeys = True`):+```haskell+newtype UsersPk = UsersPk { getUsersPk :: UUID }++data Users+  = Users+    { usersId    :: !UsersPk+    , usersName  :: !Text+    , usersRole  :: !UserRole+    , usersEmail :: !(Maybe Text)+    , usersAge   :: !(Maybe Int32)+    }+```++We also support composite primary keys:+```sql+CREATE TABLE public.user_items (+    user_id     UUID     NOT NULL,+    item_id     INT4     NOT NULL,+    json_data   JSONB    NOT NULL,+    PRIMARY KEY (user_id, item_id)+);+```+```haskell+import Data.Aeson (Value)++data UserItemsPk+  = UserItemsPk+    { userItemsPkUserId :: !UUID+    , userItemsPkItemId :: !Int32+    }+  deriving stock (Show, Eq)++data UserItems+  = UserItems+    { userItemsUserId   :: !UUID+    , userItemsItemId   :: !Int32+    , userItemsJsonData :: !Value+    }+```+but note we don't replace a field's type with a newtype wrapper, since it's multiple fields and it gets a little weird.++#### globalOverrides+This allows overrides for all generators using the config. For example, with the Postgres `TEXT` type, we generate `Data.Text.Text` by default. If you wanted to use `String` instead, you would add to the globalOverrides:+```haskell+import Data.Default (Default(def))+import Hasql.Generate (Config(..))++{- In `("text", ''String)`: `"text"` is the PG type (must be lowercase),+   and `''String` is obviously the type you want it to map to+-}+myConfig :: Config+myConfig = def { globalOverrides = [("text", ''String)] }+```++If you only want to override a type just for for a table/view generator, see `withOverrides`, as these take precedence over the global ones.

@@ -0,0 +1,93 @@+cabal-version: 3.4+name:          hasql-generate+version:       1.0.0+synopsis:      Compile-time PostgreSQL data generation for hasql+description:+  Connects to a live PostgreSQL database at compile time via TemplateHaskell,+  introspects table schemas from pg_catalog, and generates types, hasql+  decoders\/encoders, and CRUD statements targeting hasql's binary protocol.++author:           dneaves+maintainer:       dneavesdev@pm.me+homepage:         https://code.dneaves.com/dneaves/hasql-generate+bug-reports:      https://code.dneaves.com/dneaves/hasql-generate/issues/1+license:          MIT+license-file:     LICENSE+copyright:        © 2025 dneaves+category:         Database+build-type:       Simple+tested-with:      GHC ==9.8.4 || ==9.10.3 || ==9.12.2+extra-doc-files:  CHANGELOG.md, README.md++source-repository head+    type: git+    location: https://code.dneaves.com/dneaves/hasql-generate++common warnings+  ghc-options: -Wall++common extensions+  default-extensions:+    NoImplicitPrelude+    AllowAmbiguousTypes+    DataKinds+    DeriveAnyClass+    DerivingStrategies+    DuplicateRecordFields+    FlexibleInstances+    FunctionalDependencies+    InstanceSigs+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    OverloadedStrings+    OverloadedRecordDot+    ScopedTypeVariables+    TemplateHaskell+    TypeFamilies++library+  import:           warnings, extensions+  default-language: GHC2021+  hs-source-dirs:   src+  exposed-modules:+    Hasql.Generate+    Hasql.Generate.Codec+    Hasql.Generate.Column+    Hasql.Generate.Config+    Hasql.Generate.Class+    Hasql.Generate.Connection+    Hasql.Generate.TH+  other-modules:+    Hasql.Generate.Internal.Introspect+  build-depends:+    , aeson              >=2.1     && <2.3+    , base               >=4.19    && <4.22+    , bytestring         >=0.11.5  && <0.13+    , data-default-class >=0.1     && <0.2+    , hasql              >=1.6     && <1.9+    , postgresql-libpq   >=0.10    && <0.12+    , scientific         >=0.3.7   && <0.4+    , template-haskell   >=2.21    && <2.24+    , text               >=2.0.2   && <2.2+    , time               >=1.12    && <1.15+    , uuid               >=1.3     && <1.4+    , vector             >=0.13    && <0.14++test-suite hasql-generate-test+  import:           warnings, extensions+  default-language: GHC2021+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Main.hs+  build-depends:+    , aeson              >=2.1     && <2.3+    , base               >=4.19    && <4.22+    , bytestring         >=0.11.5  && <0.13+    , data-default-class >=0.1     && <0.2+    , hasql              >=1.6     && <1.9+    , hasql-generate+    , scientific         >=0.3.7   && <0.4+    , text               >=2.0.2   && <2.2+    , time               >=1.12    && <1.15+    , uuid               >=1.3     && <1.4

@@ -0,0 +1,49 @@+module Hasql.Generate+    ( Config (..)+    , ConnectionInfo (..)+    , GenerateConfig+    , HasDelete (..)+    , HasEnum (..)+    , HasInsert (..)+    , HasPrimaryKey (..)+    , HasSelect (..)+    , HasUpdate (..)+    , HasView (..)+    , PgCodec (..)+    , PgColumn+    , fromTable+    , fromType+    , fromView+    , generate+    , libpqDefaults+    , withDerivations+    , withOverrides+    , withholdPk+    ) where++import           Hasql.Generate.Class+    ( HasDelete (..)+    , HasEnum (..)+    , HasInsert (..)+    , HasPrimaryKey (..)+    , HasSelect (..)+    , HasUpdate (..)+    , HasView (..)+    )+import           Hasql.Generate.Codec      ( PgCodec (..) )+import           Hasql.Generate.Column     ( PgColumn )+import           Hasql.Generate.Config     ( Config (..) )+import           Hasql.Generate.Connection+    ( ConnectionInfo (..)+    , libpqDefaults+    )+import           Hasql.Generate.TH+    ( GenerateConfig+    , fromTable+    , fromType+    , fromView+    , generate+    , withDerivations+    , withOverrides+    , withholdPk+    )

@@ -0,0 +1,97 @@+module Hasql.Generate.Class+    ( HasDelete (..)+    , HasEnum (..)+    , HasInsert (..)+    , HasPrimaryKey (..)+    , HasSelect (..)+    , HasUpdate (..)+    , HasView (..)+    ) where++----------------------------------------------------------------------------------------------------++import           Data.Maybe    ( Maybe )+import           Data.Text     ( Text )++import qualified Hasql.Session++----------------------------------------------------------------------------------------------------++{-  Typeclass providing utility functions for PostgreSQL enum types generated+    by @fromType@.++    * @allValues@ — all constructors in declaration order (matching PostgreSQL+      sort order).+    * @toText@ — convert a constructor to its PostgreSQL label as 'Text'.+    * @fromText@ — parse a PostgreSQL label back to a constructor, returning+      'Nothing' on unrecognised input.+-}+class HasEnum a where+  allValues :: [a]+  toText :: a -> Text+  fromText :: Text -> Maybe a++----------------------------------------------------------------------------------------------------++{-  Typeclass for tables with a primary key that support SELECT-by-PK queries.+    The associated type @SelectKey@ is the PK type (single value or tuple for+    composite keys). Returns @Nothing@ when the key is not found.++    @selectMany@ takes a list of keys and returns all matching rows. Unmatched+    keys are silently omitted. An empty input list returns an empty result.+-}+class HasSelect a where+  type SelectKey a+  select :: SelectKey a -> Hasql.Session.Session (Maybe a)+  selectMany :: [SelectKey a] -> Hasql.Session.Session [a]++{-  Typeclass for tables that support INSERT with RETURNING. All tables get an+    instance; the insert returns the full record (including any server-generated+    columns like serial PKs).++    @insertMany@ inserts multiple rows in a single round-trip using @unnest@-based+    array parameters and returns all inserted rows via @RETURNING@.+-}+class HasInsert a where+  insert :: a -> Hasql.Session.Session a+  insertMany :: [a] -> Hasql.Session.Session [a]++{-  Typeclass for tables with a primary key that support UPDATE-by-PK with+    RETURNING. Returns @Nothing@ if the PK was not found.++    @updateMany@ updates multiple rows in a single round-trip using an @unnest@+    subquery join. Returns only the rows that were actually updated; unmatched+    PKs are silently omitted.+-}+class HasUpdate a where+  update :: a -> Hasql.Session.Session (Maybe a)+  updateMany :: [a] -> Hasql.Session.Session [a]++{-  Typeclass for tables with a primary key that support DELETE-by-PK.+    The associated type @DeleteKey@ is the PK type.++    @deleteMany@ deletes multiple rows in a single round-trip. Unmatched+    keys are silently ignored.+-}+class HasDelete a where+  type DeleteKey a+  delete :: DeleteKey a -> Hasql.Session.Session ()+  deleteMany :: [DeleteKey a] -> Hasql.Session.Session ()++-- | Typeclass for views — read-only relations with no primary key.+class HasView a where+  selectView :: Hasql.Session.Session [a]++{-  Typeclass for tables with a primary key, providing generic PK operations.+    Generated for all tables with PKs regardless of 'newtypePrimaryKeys'.++    @PkOf@ is the PK type (newtype wrapper when enabled, raw type otherwise).+    @RawPkOf@ is always the unwrapped PK type (e.g. @UUID@ or @(UUID, Int32)@).+-}+class HasPrimaryKey a where+  type PkOf a+  type RawPkOf a+  toPk :: a -> PkOf a+  wrapPk :: RawPkOf a -> PkOf a+  unwrapPk :: PkOf a -> RawPkOf a+  rawPk :: a -> RawPkOf a

@@ -0,0 +1,158 @@+module Hasql.Generate.Codec+    ( PgCodec (..)+    ) where++----------------------------------------------------------------------------------------------------++import qualified Data.Aeson                 as Aeson+import           Data.Bool                  ( Bool )+import           Data.ByteString            ( ByteString )+import           Data.Char                  ( Char )+import           Data.Functor               ( fmap )+import qualified Data.Functor.Contravariant as Contravariant+import           Data.Int                   ( Int16, Int32, Int64 )+import           Data.Scientific            ( Scientific )+import           Data.String                ( String )+import           Data.Text                  ( Text )+import qualified Data.Text+import           Data.Time+    ( Day+    , DiffTime+    , LocalTime+    , TimeOfDay+    , TimeZone+    , UTCTime+    )+import           Data.UUID                  ( UUID )++import qualified Hasql.Decoders             as Decoders+import qualified Hasql.Encoders             as Encoders++import           Prelude                    ( Double, Float )++----------------------------------------------------------------------------------------------------++{-  Typeclass mapping a Haskell type to its hasql binary-protocol encoder and+    decoder. Each instance pairs a type with the corresponding hasql 'Value'+    encoder and decoder, enabling the TH code generator to resolve codecs by+    type inference alone.+-}+class PgCodec a where+  pgDecode :: Decoders.Value a+  pgEncode :: Encoders.Value a++----------------------------------------------------------------------------------------------------++instance PgCodec Bool where+  pgDecode :: Decoders.Value Bool+  pgDecode = Decoders.bool+  pgEncode :: Encoders.Value Bool+  pgEncode = Encoders.bool++instance PgCodec Int16 where+  pgDecode :: Decoders.Value Int16+  pgDecode = Decoders.int2+  pgEncode :: Encoders.Value Int16+  pgEncode = Encoders.int2++instance PgCodec Int32 where+  pgDecode :: Decoders.Value Int32+  pgDecode = Decoders.int4+  pgEncode :: Encoders.Value Int32+  pgEncode = Encoders.int4++instance PgCodec Int64 where+  pgDecode :: Decoders.Value Int64+  pgDecode = Decoders.int8+  pgEncode :: Encoders.Value Int64+  pgEncode = Encoders.int8++instance PgCodec Float where+  pgDecode :: Decoders.Value Float+  pgDecode = Decoders.float4+  pgEncode :: Encoders.Value Float+  pgEncode = Encoders.float4++instance PgCodec Double where+  pgDecode :: Decoders.Value Double+  pgDecode = Decoders.float8+  pgEncode :: Encoders.Value Double+  pgEncode = Encoders.float8++instance PgCodec Scientific where+  pgDecode :: Decoders.Value Scientific+  pgDecode = Decoders.numeric+  pgEncode :: Encoders.Value Scientific+  pgEncode = Encoders.numeric++instance PgCodec Char where+  pgDecode :: Decoders.Value Char+  pgDecode = Decoders.char+  pgEncode :: Encoders.Value Char+  pgEncode = Encoders.char++instance PgCodec Text where+  pgDecode :: Decoders.Value Text+  pgDecode = Decoders.text+  pgEncode :: Encoders.Value Text+  pgEncode = Encoders.text++instance PgCodec String where+  pgDecode :: Decoders.Value String+  pgDecode = fmap Data.Text.unpack Decoders.text+  pgEncode :: Encoders.Value String+  pgEncode = Contravariant.contramap Data.Text.pack Encoders.text++instance PgCodec ByteString where+  pgDecode :: Decoders.Value ByteString+  pgDecode = Decoders.bytea+  pgEncode :: Encoders.Value ByteString+  pgEncode = Encoders.bytea++instance PgCodec Day where+  pgDecode :: Decoders.Value Day+  pgDecode = Decoders.date+  pgEncode :: Encoders.Value Day+  pgEncode = Encoders.date++instance PgCodec LocalTime where+  pgDecode :: Decoders.Value LocalTime+  pgDecode = Decoders.timestamp+  pgEncode :: Encoders.Value LocalTime+  pgEncode = Encoders.timestamp++instance PgCodec UTCTime where+  pgDecode :: Decoders.Value UTCTime+  pgDecode = Decoders.timestamptz+  pgEncode :: Encoders.Value UTCTime+  pgEncode = Encoders.timestamptz++instance PgCodec TimeOfDay where+  pgDecode :: Decoders.Value TimeOfDay+  pgDecode = Decoders.time+  pgEncode :: Encoders.Value TimeOfDay+  pgEncode = Encoders.time++instance PgCodec (TimeOfDay, TimeZone) where+  pgDecode :: Decoders.Value (TimeOfDay, TimeZone)+  pgDecode = Decoders.timetz+  pgEncode :: Encoders.Value (TimeOfDay, TimeZone)+  pgEncode = Encoders.timetz++instance PgCodec DiffTime where+  pgDecode :: Decoders.Value DiffTime+  pgDecode = Decoders.interval+  pgEncode :: Encoders.Value DiffTime+  pgEncode = Encoders.interval++instance PgCodec UUID where+  pgDecode :: Decoders.Value UUID+  pgDecode = Decoders.uuid+  pgEncode :: Encoders.Value UUID+  pgEncode = Encoders.uuid++instance PgCodec Aeson.Value where+  pgDecode :: Decoders.Value Aeson.Value+  pgDecode = Decoders.jsonb+  pgEncode :: Encoders.Value Aeson.Value+  pgEncode = Encoders.jsonb

@@ -0,0 +1,68 @@+module Hasql.Generate.Column+    ( PgColumn+    ) where++----------------------------------------------------------------------------------------------------++import qualified Data.Aeson           as Aeson+import           Data.Bool            ( Bool )+import           Data.ByteString      ( ByteString )+import           Data.Char            ( Char )+import           Data.Int             ( Int16, Int32, Int64 )+import           Data.Scientific      ( Scientific )+import           Data.Text            ( Text )+import           Data.Time+    ( Day+    , DiffTime+    , LocalTime+    , TimeOfDay+    , TimeZone+    , UTCTime+    )+import           Data.UUID            ( UUID )++import           GHC.TypeLits         ( Symbol )++import           Hasql.Generate.Codec ( PgCodec )++import           Prelude              ( Double, Float )++----------------------------------------------------------------------------------------------------++{-  Typeclass mapping a schema-qualified PostgreSQL type name to a Haskell type.+    The functional dependency @pgSchema pgName -> a@ ensures each+    (schema, type name) pair resolves to exactly one Haskell type.++    Built-in types use @\"pg_catalog\"@ as their schema. User-defined types+    (e.g. enums created with @fromType@) use their actual schema name.++    The TH code generator uses @reifyInstances@ on this class to discover the+    correct Haskell type for each column at compile time. Users can define+    additional instances for custom PostgreSQL types (e.g. enums).+-}+class (PgCodec a) => PgColumn (pgSchema :: Symbol) (pgName :: Symbol) a | pgSchema pgName -> a++----------------------------------------------------------------------------------------------------++instance PgColumn "pg_catalog" "bool" Bool+instance PgColumn "pg_catalog" "int2" Int16+instance PgColumn "pg_catalog" "int4" Int32+instance PgColumn "pg_catalog" "int8" Int64+instance PgColumn "pg_catalog" "float4" Float+instance PgColumn "pg_catalog" "float8" Double+instance PgColumn "pg_catalog" "numeric" Scientific+instance PgColumn "pg_catalog" "char" Char+instance PgColumn "pg_catalog" "text" Text+instance PgColumn "pg_catalog" "varchar" Text+instance PgColumn "pg_catalog" "bpchar" Text+instance PgColumn "pg_catalog" "name" Text+instance PgColumn "pg_catalog" "bytea" ByteString+instance PgColumn "pg_catalog" "date" Day+instance PgColumn "pg_catalog" "timestamp" LocalTime+instance PgColumn "pg_catalog" "timestamptz" UTCTime+instance PgColumn "pg_catalog" "time" TimeOfDay+instance PgColumn "pg_catalog" "timetz" (TimeOfDay, TimeZone)+instance PgColumn "pg_catalog" "interval" DiffTime+instance PgColumn "pg_catalog" "uuid" UUID+instance PgColumn "pg_catalog" "json" Aeson.Value+instance PgColumn "pg_catalog" "jsonb" Aeson.Value

@@ -0,0 +1,53 @@+module Hasql.Generate.Config+    ( Config (..)+    ) where++----------------------------------------------------------------------------------------------------++import           Data.Bool                 ( Bool (..) )+import           Data.Default.Class        ( Default (..) )+import           Data.String               ( String )++import           Hasql.Generate.Connection ( ConnectionInfo, libpqDefaults )++import           Language.Haskell.TH       ( Name )++----------------------------------------------------------------------------------------------------++{-  Top-level configuration for compile-time code generation.++    Embeds the database connection parameters ('ConnectionInfo') together with+    behavioral flags that control the shape of the generated code.++    Use @def@ for the default configuration, which reads connection details+    from standard PostgreSQL environment variables, sets False to allowDuplicateRecordFields+    and newtypePrimaryKeys, and has an emply override list.+-}+data Config+    = Config+      { connection                 :: ConnectionInfo+      , allowDuplicateRecordFields :: Bool+      , newtypePrimaryKeys         :: Bool+      , globalOverrides            :: [(String, Name)]+      }++{-  Default configuration:++    * Connection via libpq environment variables (@PGHOST@, @PGPORT@, etc.)+    * @allowDuplicateRecordFields = False@ — field names are prefixed with the+      type name so the generated code compiles without @DuplicateRecordFields@+    * @newtypePrimaryKeys = False@ — when @True@, generates newtype (single PK)+      or data record (composite PK) wrappers for primary keys, plus @HasPrimaryKey@+      instances for all tables with PKs+    * @globalOverrides = []@ — PG type overrides applied to all tables. Per-table+      'withOverrides' take precedence over global ones.+-}+instance Default Config where+  def :: Config+  def =+    Config+      { connection = libpqDefaults+      , allowDuplicateRecordFields = False+      , newtypePrimaryKeys = False+      , globalOverrides = []+      }

@@ -0,0 +1,134 @@+module Hasql.Generate.Connection+    ( ConnectionInfo (..)+    , libpqDefaults+    , toConnString+    , withCompileTimeConnection+    ) where++----------------------------------------------------------------------------------------------------++import           Control.Exception         ( bracket, throwIO )++import           Data.Bool                 ( Bool (..), otherwise, (||) )+import qualified Data.ByteString           as BS+import qualified Data.ByteString.Char8     as BS8+import           Data.Char                 ( Char )+import           Data.Default.Class        ( Default (..) )+import           Data.Eq                   ( (/=), (==) )+import           Data.Functor              ( (<$>) )+import           Data.List+    ( any+    , concatMap+    , null+    , unwords+    , (++)+    )+import           Data.Maybe                ( Maybe (..), catMaybes, maybe )+import           Data.Semigroup            ( (<>) )+import           Data.String               ( String )++import qualified Database.PostgreSQL.LibPQ as PQ++import           Prelude                   ( Applicative (pure), userError )++import           System.IO                 ( IO )++----------------------------------------------------------------------------------------------------++{-  Acquire a libpq connection for compile-time schema introspection, run the+    provided action, and ensure the connection is closed afterward.++    The 'Data.ByteString.ByteString' argument is passed directly to+    @PQ.connectdb@. An empty string causes libpq to read connection+    parameters from standard PostgreSQL environment variables (@PGHOST@,+    @PGPORT@, @PGUSER@, @PGPASSWORD@, @PGDATABASE@, etc.).++    Throws an 'IOError' if the connection cannot be established.+-}+withCompileTimeConnection :: BS8.ByteString -> (PQ.Connection -> IO a) -> IO a+withCompileTimeConnection connStr =+  bracket acquire release+  where+    acquire :: IO PQ.Connection+    acquire = do+      conn <- PQ.connectdb connStr+      status <- PQ.status conn+      if status /= PQ.ConnectionOk+        then do+          msg <- maybe "unknown error" BS8.unpack <$> PQ.errorMessage conn+          PQ.finish conn+          throwIO (userError ("hasql-generate: compile-time DB connection failed: " <> msg))+        else+          pure conn++    release :: PQ.Connection -> IO ()+    release = PQ.finish++----------------------------------------------------------------------------------------------------++{-  Connection configuration for compile-time PostgreSQL introspection.++    @PgSimpleInfo@ lets you specify individual connection fields. Any field+    left as @Nothing@ is omitted from the connection string, so libpq falls+    back to its standard environment variables (@PGHOST@, @PGPORT@, etc.).++    @PgConnectionString@ passes a raw libpq connection string through as-is,+    useful for advanced options like @sslmode=verify-full@.+-}+data ConnectionInfo+    = PgSimpleInfo+      { pgHost     :: Maybe String+      , pgPort     :: Maybe String+      , pgUser     :: Maybe String+      , pgPassword :: Maybe String+      , pgDatabase :: Maybe String+      }+    | PgConnectionString String++{-  All @Nothing@ — produces an empty connection string so libpq reads+    standard environment variables.+-}+instance Default ConnectionInfo where+  def :: ConnectionInfo+  def = libpqDefaults++libpqDefaults :: ConnectionInfo+libpqDefaults = PgSimpleInfo Nothing Nothing Nothing Nothing Nothing++{-  Assemble a 'ConnectionInfo' into a libpq connection 'BS.ByteString'.++    For @PgSimpleInfo@, builds a @key=value@ string from the fields that+    are @Just@, omitting @Nothing@ fields. For @PgConnectionString@, passes+    the raw string through.+-}+toConnString :: ConnectionInfo -> BS.ByteString+toConnString (PgConnectionString s) = BS8.pack s+toConnString (PgSimpleInfo host port user pass db) =+  let pairs =+        catMaybes+          [ kvPair "host" host+          , kvPair "port" port+          , kvPair "user" user+          , kvPair "password" pass+          , kvPair "dbname" db+          ]+   in if null pairs+        then BS.empty+        else BS8.pack (unwords pairs)+  where+    kvPair :: String -> Maybe String -> Maybe String+    kvPair _key Nothing   = Nothing+    kvPair key (Just val) = Just (key <> "=" <> escapeValue val)++    escapeValue :: String -> String+    escapeValue v+      | needsQuoting v = "'" ++ concatMap escapeChar v ++ "'"+      | otherwise = v++    needsQuoting :: String -> Bool+    needsQuoting = any (\c -> c == ' ' || c == '\'' || c == '\\')++    escapeChar :: Char -> String+    escapeChar '\'' = "\\'"+    escapeChar '\\' = "\\\\"+    escapeChar c    = [c]

@@ -0,0 +1,189 @@+module Hasql.Generate.Internal.Introspect+    ( ColumnInfo (..)+    , introspectColumns+    , introspectEnumLabels+    , introspectPrimaryKey+    ) where++----------------------------------------------------------------------------------------------------++import           Control.Exception         ( throwIO )+import           Control.Monad             ( return )++import           Data.Bool                 ( Bool (..), otherwise )+import qualified Data.ByteString           as BS+import qualified Data.ByteString.Char8     as BS8+import           Data.Eq                   ( (==) )+import           Data.Function             ( ($) )+import           Data.Functor              ( (<$>) )+import           Data.Maybe                ( Maybe (..), maybe )+import           Data.Semigroup            ( (<>) )+import           Data.String               ( String )++import qualified Database.PostgreSQL.LibPQ as PQ++import           Prelude+    ( Applicative (pure)+    , userError+    , (+)+    )++import           System.IO                 ( IO )++----------------------------------------------------------------------------------------------------++data ColumnInfo+    = ColumnInfo+      { colName       :: String+      , colPgSchema   :: String+      , colPgType     :: String+      , colIsEnum     :: Bool+      , colNotNull    :: Bool+      , colHasDefault :: Bool+      }++----------------------------------------------------------------------------------------------------++{-  Query @pg_catalog@ for all visible user columns of the given table, including+    both base types (@typtype = 'b'@) and enum types (@typtype = 'e'@), excluding+    composite, pseudo, and range types. Results are ordered by column position.+-}+introspectColumns :: PQ.Connection -> String -> String -> IO [ColumnInfo]+introspectColumns conn schema table = do+  result <- PQ.execParams conn columnSQL [textParam schema, textParam table] PQ.Text+  withQueryResult "column" result parseColumnRows++----------------------------------------------------------------------------------------------------++{-  Query @pg_catalog@ for the primary key column names of the given table,+    ordered by their position within the index.+-}+introspectPrimaryKey :: PQ.Connection -> String -> String -> IO [String]+introspectPrimaryKey conn schema table = do+  result <- PQ.execParams conn primaryKeySQL [textParam schema, textParam table] PQ.Text+  withQueryResult "primary key" result parsePkRows++----------------------------------------------------------------------------------------------------++{-  Query @pg_catalog@ for the labels of a PostgreSQL enum type in the given+    schema, ordered by their sort position (@enumsortorder@).+-}+introspectEnumLabels :: PQ.Connection -> String -> String -> IO [String]+introspectEnumLabels conn schema typeName = do+  result <- PQ.execParams conn enumLabelSQL [textParam schema, textParam typeName] PQ.Text+  withQueryResult "enum label" result parseEnumRows++----------------------------------------------------------------------------------------------------++columnSQL :: BS.ByteString+columnSQL =+  "SELECT tn.nspname, a.attname, t.typname, t.typtype, a.attnotnull, a.atthasdef \+  \FROM pg_catalog.pg_attribute a \+  \JOIN pg_catalog.pg_class c ON c.oid = a.attrelid \+  \JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace \+  \JOIN pg_catalog.pg_type t ON t.oid = a.atttypid \+  \JOIN pg_catalog.pg_namespace tn ON tn.oid = t.typnamespace \+  \WHERE n.nspname = $1 \+  \  AND c.relname = $2 \+  \  AND a.attnum > 0 \+  \  AND NOT a.attisdropped \+  \  AND t.typtype IN ('b', 'e') \+  \  AND t.typcategory NOT IN ('C', 'P', 'X') \+  \ORDER BY a.attnum"++primaryKeySQL :: BS.ByteString+primaryKeySQL =+  "SELECT a.attname \+  \FROM pg_catalog.pg_index i \+  \JOIN pg_catalog.pg_class c ON c.oid = i.indrelid \+  \JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace \+  \JOIN pg_catalog.pg_attribute a ON a.attrelid = i.indrelid \+  \  AND a.attnum = ANY(i.indkey) \+  \WHERE n.nspname = $1 \+  \  AND c.relname = $2 \+  \  AND i.indisprimary \+  \ORDER BY array_position(i.indkey, a.attnum)"++enumLabelSQL :: BS.ByteString+enumLabelSQL =+  "SELECT e.enumlabel \+  \FROM pg_catalog.pg_enum e \+  \JOIN pg_catalog.pg_type t ON t.oid = e.enumtypid \+  \JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace \+  \WHERE n.nspname = $1 \+  \  AND t.typname = $2 \+  \ORDER BY e.enumsortorder"++----------------------------------------------------------------------------------------------------++parseColumnRows :: PQ.Result -> IO [ColumnInfo]+parseColumnRows res = do+  nRows <- PQ.ntuples res+  mapRows nRows $ \row -> do+    schemaVal <- PQ.getvalue res row 0+    nameVal <- PQ.getvalue res row 1+    typeVal <- PQ.getvalue res row 2+    typtypeVal <- PQ.getvalue res row 3+    notNullVal <- PQ.getvalue res row 4+    defVal <- PQ.getvalue res row 5+    let schema = maybe "" BS8.unpack schemaVal+        name = maybe "" BS8.unpack nameVal+        typ = maybe "" BS8.unpack typeVal+        isEnum = Just "e" == typtypeVal+        notNull = maybe False parseBool notNullVal+        hasDef = maybe False parseBool defVal+    return (ColumnInfo name schema typ isEnum notNull hasDef)++parsePkRows :: PQ.Result -> IO [String]+parsePkRows res = do+  nRows <- PQ.ntuples res+  mapRows nRows $ \row -> do+    nameVal <- PQ.getvalue res row 0+    return (maybe "" BS8.unpack nameVal)++parseEnumRows :: PQ.Result -> IO [String]+parseEnumRows res = do+  nRows <- PQ.ntuples res+  mapRows nRows $ \row -> do+    labelVal <- PQ.getvalue res row 0+    return (maybe "" BS8.unpack labelVal)++parseBool :: BS.ByteString -> Bool+parseBool bs+  | bs == "t" = True+  | otherwise = False++----------------------------------------------------------------------------------------------------++-- | Wrap a 'String' as a libpq text parameter (oid 25 = @text@).+textParam :: String -> Maybe (PQ.Oid, BS.ByteString, PQ.Format)+textParam str = Just (PQ.Oid 25, BS8.pack str, PQ.Text)++{-  Unwrap and validate a libpq query result, passing it to a row-parser on+    success. The @label@ argument names the introspection step for error+    messages.+-}+withQueryResult :: String -> Maybe PQ.Result -> (PQ.Result -> IO a) -> IO a+withQueryResult label result parse = case result of+  Nothing -> throwIO (userError ("hasql-generate: " <> label <> " introspection query returned no result"))+  Just res -> do+    status <- PQ.resultStatus res+    if status == PQ.TuplesOk+      then parse res+      else do+        msg <- maybe "unknown error" BS8.unpack <$> PQ.resultErrorMessage res+        throwIO (userError ("hasql-generate: " <> label <> " introspection failed: " <> msg))++-- |  Iterate over row indices [0 .. nRows-1] collecting results.+mapRows :: PQ.Row -> (PQ.Row -> IO a) -> IO [a]+mapRows nRows fn = go (PQ.Row 0)+  where+    go i+      | i == nRows = pure []+      | otherwise = do+          x <- fn i+          xs <- go (nextRow i)+          pure (x : xs)++    nextRow :: PQ.Row -> PQ.Row+    nextRow (PQ.Row n) = PQ.Row (n + 1)

@@ -0,0 +1,1710 @@+module Hasql.Generate.TH+    ( GenerateConfig+    , fromTable+    , fromType+    , fromView+    , generate+    , withDerivations+    , withOverrides+    , withholdPk+    ) where++----------------------------------------------------------------------------------------------------++import           Control.Applicative                ( (<*>) )+import           Control.Monad                      ( mapM, return )+import           Control.Monad.Fail                 ( MonadFail (fail) )++import           Data.Bool+    ( Bool (..)+    , not+    , otherwise+    , (&&)+    )+import           Data.Char                          ( toLower, toUpper )+import           Data.Eq                            ( (==) )+import           Data.Foldable                      ( foldl )+import           Data.Function                      ( flip, ($), (.) )+import           Data.Functor                       ( (<$>) )+import qualified Data.Functor.Contravariant         as Contravariant+import           Data.Int                           ( Int )+import           Data.List+    ( all+    , break+    , concatMap+    , elem+    , filter+    , intercalate+    , length+    , lookup+    , map+    , notElem+    , null+    , partition+    , zip+    , zipWith+    , (!!)+    )+import           Data.Maybe                         ( Maybe (..) )+import           Data.Semigroup                     ( (<>) )+import           Data.String                        ( String )+import qualified Data.String+import qualified Data.Text+import qualified Data.Tuple++import qualified Hasql.Decoders+import qualified Hasql.Encoders+import qualified Hasql.Generate.Class+import qualified Hasql.Generate.Codec+import qualified Hasql.Generate.Column+import           Hasql.Generate.Config              ( Config (..) )+import           Hasql.Generate.Connection+    ( toConnString+    , withCompileTimeConnection+    )+import           Hasql.Generate.Internal.Introspect+    ( ColumnInfo (..)+    , introspectColumns+    , introspectEnumLabels+    , introspectPrimaryKey+    )+import qualified Hasql.Session+import qualified Hasql.Statement++import           Language.Haskell.TH++import           Prelude+    ( enumFromTo+    , mconcat+    , show+    , (+)+    , (-)+    )++----------------------------------------------------------------------------------------------------++-- | Whether the target relation is a table (full CRUD), a view (read-only), or a type (enum).+data RelationKind = Table | View | Type++{-  Configuration for a table, view, or type code-generation request.++    Use 'fromTable', 'fromView', or 'fromType' to create a default config,+    then chain modifier functions with @(&)@ to customise it:++    @+    fromTable \"public\" \"users\"+        & withDerivations [''Show, ''Eq, ''Generic]+        & withOverrides [(\"timestamptz\", ''UTCTime)]+        & withholdPk+    @+-}+data GenerateConfig+    = GenerateConfig+      { tcSchema      :: String+      , tcTable       :: String+      , tcKind        :: RelationKind+      , tcDerivations :: [Name]+      , tcOverrides   :: [(String, Name)]+      , tcWithholdPk  :: Bool+      }++{-  Create a 'GenerateConfig' for the given schema and table with no derivations+    and no type overrides. Generates full CRUD code.+-}+fromTable :: String -> String -> GenerateConfig+fromTable schema table =+  GenerateConfig+    { tcSchema = schema+    , tcTable = table+    , tcKind = Table+    , tcDerivations = []+    , tcOverrides = []+    , tcWithholdPk = False+    }++{-  Create a 'GenerateConfig' for the given schema and view with no derivations+    and no type overrides. Generates read-only code: a record type, a decoder,+    a SELECT statement, and a 'HasView' instance.+-}+fromView :: String -> String -> GenerateConfig+fromView schema view =+  GenerateConfig+    { tcSchema = schema+    , tcTable = view+    , tcKind = View+    , tcDerivations = []+    , tcOverrides = []+    , tcWithholdPk = False+    }++{-  Create a 'GenerateConfig' for the given schema and enum type with no+    derivations. Generates a Haskell sum type, a 'PgCodec' instance,+    and a 'PgColumn' instance. Overrides are ignored for types.++    The splice must appear before any @fromTable@ whose table has a column of+    this enum type, since TH processes splices top to bottom.++    __Orphan instance warning:__ The generated @PgColumn@ instance will trigger+    GHC's @-Worphans@ warning because the functional dependency's determining+    types are @Symbol@ literals, which GHC never considers local to any user+    module. This is expected and harmless. Add the following pragma to any+    module that uses @fromType@:++    @+    \{\-\# OPTIONS_GHC -Wno-orphans \#\-\}+    @+-}+fromType :: String -> String -> GenerateConfig+fromType schema typeName =+  GenerateConfig+    { tcSchema = schema+    , tcTable = typeName+    , tcKind = Type+    , tcDerivations = []+    , tcOverrides = []+    , tcWithholdPk = False+    }++-- | Append derivation class 'Name's to the config.+withDerivations :: [Name] -> GenerateConfig -> GenerateConfig+withDerivations names cfg = cfg {tcDerivations = tcDerivations cfg <> names}++{-  Append per-table PG type overrides. Each pair maps a PostgreSQL type name+    (e.g. @\"timestamptz\"@) to a Haskell type 'Name' (e.g. @''UTCTime@).+    The override type must still have a 'PgCodec' instance.+-}+withOverrides :: [(String, Name)] -> GenerateConfig -> GenerateConfig+withOverrides ovs cfg = cfg {tcOverrides = tcOverrides cfg <> ovs}++{-  Opt in to excluding PK columns from INSERT when all PK columns have+    database defaults. Without this, INSERT always includes all columns.++    @+    fromTable \"public\" \"users\" & withholdPk+    @+-}+withholdPk :: GenerateConfig -> GenerateConfig+withholdPk cfg = cfg {tcWithholdPk = True}++{-  Terminal step that introspects a PostgreSQL database at compile time and+    generates the provided data construct:++    Usage:+    @+    \$(generate def (fromTable \"public\" \"users\" & withDerivations [''Show, ''Eq]))+    @+-}+generate :: Config -> GenerateConfig -> Q [Dec]+generate config genConfig =+  case kind of+    Type -> do+      labels <- runIO $ withCompileTimeConnection connStr $ \conn ->+        introspectEnumLabels conn schema table+      if null labels+        then fail ("hasql-generate: no enum labels found for " <> schema <> "." <> table)+        else generateTypeDecs schema table (pascalCase table) derivNames labels+    Table -> do+      (typeName, resolvedCols, pkCols) <- getPgData+      let pkInfo = buildPkInfo resolvedCols pkCols+      generateAllDecs config withhold schema table typeName derivNames resolvedCols pkInfo+    View -> do+      (typeName, resolvedCols, _) <- getPgData+      generateViewDecs schema table typeName derivNames resolvedCols+  where+    connStr = toConnString (connection config)+    schema = tcSchema genConfig+    table = tcTable genConfig+    kind = tcKind genConfig+    derivNames = tcDerivations genConfig+    withhold = tcWithholdPk genConfig+    mergedOverrides = tcOverrides genConfig <> globalOverrides config+    getPgData = do+      (columns, pkCols') <- runIO $ withCompileTimeConnection connStr $ \conn -> do+        cols <- introspectColumns conn schema table+        pks <- case kind of+          Table -> introspectPrimaryKey conn schema table+          _     -> return []+        return (cols, pks)+      if null columns+        then fail ("hasql-generate: no columns found for " <> schema <> "." <> table)+        else do+          resolvedCols <- mapM (resolveColumnWithOverrides mergedOverrides) columns+          let typName = pascalCase table+              resolvedCols' =+                if allowDuplicateRecordFields config+                  then resolvedCols+                  else map (prefixFieldName typName) resolvedCols+          return (typName, resolvedCols', pkCols')++----------------------------------------------------------------------------------------------------++data ResolvedColumn+    = ResolvedColumn+      { rcColName    :: String+      , rcFieldName  :: String+      , rcType       :: Type+      , rcNotNull    :: Bool+      , rcHasDefault :: Bool+      , rcPgCast     :: Maybe String+      }++data PkInfo+    = NoPrimaryKey+    | SinglePk ResolvedColumn+    | CompositePk [ResolvedColumn]++----------------------------------------------------------------------------------------------------++{-  Resolve a column's Haskell type. If the column's PG type name appears in+    the overrides list, use the override 'Name' directly (as @ConT@). Otherwise+    fall back to 'PgColumn' instance resolution via 'reifyInstances'.+-}+resolveColumnWithOverrides :: [(String, Name)] -> ColumnInfo -> Q ResolvedColumn+resolveColumnWithOverrides overrides col = do+  hsType <- case lookup (colPgType col) overrides of+    Just overrideName -> return (ConT overrideName)+    Nothing -> do+      a <- newName "a"+      insts <-+        reifyInstances+          ''Hasql.Generate.Column.PgColumn+          [ LitT (StrTyLit (colPgSchema col))+          , LitT (StrTyLit (colPgType col))+          , VarT a+          ]+      case insts of+        [InstanceD _ _ (AppT (AppT (AppT _ _) _) ty) _] -> return ty+        [] ->+          fail+            ( "hasql-generate: no PgColumn instance for pg type '"+                <> colPgSchema col+                <> "."+                <> colPgType col+                <> "' (column '"+                <> colName col+                <> "')"+            )+        _ ->+          fail+            ( "hasql-generate: multiple PgColumn instances for pg type '"+                <> colPgSchema col+                <> "."+                <> colPgType col+                <> "' (column '"+                <> colName col+                <> "') — expected exactly one"+            )+  let pgCast =+        if colIsEnum col+          then Just (quoteIdent (colPgSchema col) <> "." <> quoteIdent (colPgType col))+          else Nothing+  return+    ResolvedColumn+      { rcColName = colName col+      , rcFieldName = sanitizeField (camelCase (colName col))+      , rcType = hsType+      , rcNotNull = colNotNull col+      , rcHasDefault = colHasDefault col+      , rcPgCast = pgCast+      }++----------------------------------------------------------------------------------------------------++buildPkInfo :: [ResolvedColumn] -> [String] -> PkInfo+buildPkInfo _ [] = NoPrimaryKey+buildPkInfo resolvedCols [pkName] =+  case filter (\rc -> rcColName rc == pkName) resolvedCols of+    [rc] -> SinglePk rc+    _    -> NoPrimaryKey+buildPkInfo resolvedCols pkNames =+  let lookupPk pkn = filter (\rc -> rcColName rc == pkn) resolvedCols+      pkCols = concatMap lookupPk pkNames+   in if length pkCols == length pkNames+        then CompositePk pkCols+        else NoPrimaryKey++----------------------------------------------------------------------------------------------------++generateAllDecs+  :: Config -> Bool -> String -> String -> String -> [Name] -> [ResolvedColumn] -> PkInfo -> Q [Dec]+generateAllDecs config withhold schema table typName derivNames resolvedCols pkInfo = do+  let useNtPk = newtypePrimaryKeys config+      pkTypName = typName <> "Pk"+      allowDupFields = allowDuplicateRecordFields config++  -- Generate PK wrapper type declarations (before main record so newtype is in scope)+  pkTypeDecs <-+    if useNtPk+      then case pkInfo of+        SinglePk rc -> do+          ntDec <- genPkNewtype pkTypName derivNames rc+          codecDec <- genPkNewtypeCodec pkTypName+          return (ntDec <> codecDec)+        CompositePk rcs -> do+          let pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs+          recDec <- genPkRecord pkTypName derivNames pkRcs+          encDec <- genPkRecordEncoder pkTypName pkRcs+          return (recDec <> encDec)+        NoPrimaryKey -> return []+      else return []++  -- For single PK with newtypes, rewrite the PK column's type to the newtype+  let (resolvedCols', pkInfo') =+        if useNtPk+          then case pkInfo of+            SinglePk rc ->+              let rc' = rc {rcType = ConT (mkName pkTypName)}+                  cols' = map (\c -> if rcColName c == rcColName rc then rc' else c) resolvedCols+               in (cols', SinglePk rc')+            _ -> (resolvedCols, pkInfo)+          else (resolvedCols, pkInfo)++  -- Compute pkTypOverride for composite PK with newtypes+  let pkTypOverride = case (useNtPk, pkInfo) of+        (True, CompositePk _) -> Just pkTypName+        _                     -> Nothing++  -- Generate main record, decoder, encoder, insert (single + batch)+  dataDec <- genDataType typName derivNames resolvedCols'+  decoderDec <- genDecoder typName resolvedCols'+  encoderDec <- genEncoder typName resolvedCols'+  let insertCols = computeInsertCols withhold resolvedCols' pkInfo'+  insDec <- genInsert schema table typName resolvedCols' insertCols+  insMany <- genInsertMany schema table typName resolvedCols' insertCols+  hasInsInst <- genHasInsertInstance typName++  -- Generate PK-dependent statements and instances (single + batch)+  pkDecs <- case pkInfo' of+    NoPrimaryKey -> return []+    _ -> do+      sel <- genSelectByPk schema table typName resolvedCols' pkInfo' pkTypOverride+      selMany <- genSelectMany schema table typName resolvedCols' pkInfo' pkTypOverride+      upd <- genUpdate schema table typName resolvedCols' pkInfo'+      updMany <- genUpdateMany schema table typName resolvedCols' pkInfo'+      del <- genDeleteByPk schema table typName pkInfo' pkTypOverride+      delMany <- genDeleteMany schema table typName pkInfo' pkTypOverride+      hasSelInst <- genHasSelectInstance typName pkInfo' pkTypOverride+      hasUpdInst <- genHasUpdateInstance typName+      hasDelInst <- genHasDeleteInstance typName pkInfo' pkTypOverride+      return (sel <> selMany <> upd <> updMany <> del <> delMany <> hasSelInst <> hasUpdInst <> hasDelInst)++  -- Generate HasPrimaryKey instance (for ALL tables with PKs)+  hasPkInst <- case pkInfo of+    NoPrimaryKey -> return []+    _ -> genHasPrimaryKeyInstance typName pkInfo pkInfo' useNtPk pkTypOverride allowDupFields++  return (pkTypeDecs <> dataDec <> decoderDec <> encoderDec <> insDec <> insMany <> hasInsInst <> pkDecs <> hasPkInst)++{-  Generate read-only declarations for a view: data type, decoder, SELECT+    statement, and 'HasView' instance.+-}+generateViewDecs+  :: String -> String -> String -> [Name] -> [ResolvedColumn] -> Q [Dec]+generateViewDecs schema table typName derivNames resolvedCols = do+  dataDec <- genDataType typName derivNames resolvedCols+  decoderDec <- genDecoder typName resolvedCols+  selectDec <- genSelectView schema table typName resolvedCols+  hasViewInst <- genHasViewInstance typName+  return (dataDec <> decoderDec <> selectDec <> hasViewInst)++{-  Generate declarations for a PostgreSQL enum type: a Haskell sum type,+    a 'PgCodec' instance (using @Decoders.enum@ / @Encoders.enum@), and+    a 'PgColumn' instance mapping the schema-qualified PG type name to the+    generated Haskell type.+-}+generateTypeDecs+  :: String -> String -> String -> [Name] -> [String] -> Q [Dec]+generateTypeDecs schema pgTypeName hsTypeName derivNames labels = do+  sumType <- genSumType hsTypeName derivNames labels+  codecInst <- genPgCodecInstance hsTypeName labels+  columnInst <- genPgColumnInstance schema pgTypeName hsTypeName+  enumInst <- genHasEnumInstance hsTypeName labels+  return (sumType <> codecInst <> columnInst <> enumInst)++genSumType :: String -> [Name] -> [String] -> Q [Dec]+genSumType hsTypeName derivNames labels = do+  let tName = mkName hsTypeName+      cons = map (\lbl -> NormalC (mkName (pascalCase lbl)) []) labels+      derivClauses = mkDerivClauses derivNames+  return [DataD [] tName [] Nothing cons derivClauses]++genPgCodecInstance :: String -> [String] -> Q [Dec]+genPgCodecInstance hsTypeName labels = do+  let tName = mkName hsTypeName+      -- pgDecode: Decoders.enum (\t -> case Data.Text.unpack t of "lbl" -> Just Con; ... _ -> Nothing)+      t = mkName "t"+      decoderMatches =+        map+          ( \lbl ->+              Match+                (LitP (StringL lbl))+                (NormalB (AppE (ConE 'Just) (ConE (mkName (pascalCase lbl)))))+                []+          )+          labels+          <> [Match WildP (NormalB (ConE 'Nothing)) []]+      decoderLam =+        LamE+          [VarP t]+          (CaseE (AppE (VarE 'Data.Text.unpack) (VarE t)) decoderMatches)+      decoderBody = AppE (VarE 'Hasql.Decoders.enum) decoderLam+      decoderDec = FunD 'Hasql.Generate.Codec.pgDecode [Clause [] (NormalB decoderBody) []]+      -- pgEncode: Encoders.enum (\x -> case x of Con -> "lbl"; ...)+      x = mkName "x"+      encoderMatches =+        map+          ( \lbl ->+              Match+                (ConP (mkName (pascalCase lbl)) [] [])+                (NormalB (textLit lbl))+                []+          )+          labels+      encoderLam = LamE [VarP x] (CaseE (VarE x) encoderMatches)+      encoderBody = AppE (VarE 'Hasql.Encoders.enum) encoderLam+      encoderDec = FunD 'Hasql.Generate.Codec.pgEncode [Clause [] (NormalB encoderBody) []]+      instanceType = AppT (ConT ''Hasql.Generate.Codec.PgCodec) (ConT tName)+  return [InstanceD Nothing [] instanceType [decoderDec, encoderDec]]++genPgColumnInstance :: String -> String -> String -> Q [Dec]+genPgColumnInstance schema pgTypeName hsTypeName = do+  let tName = mkName hsTypeName+      instanceType =+        AppT+          ( AppT+              (AppT (ConT ''Hasql.Generate.Column.PgColumn) (LitT (StrTyLit schema)))+              (LitT (StrTyLit pgTypeName))+          )+          (ConT tName)+  return [InstanceD Nothing [] instanceType []]++{-  Generate a @HasEnum@ instance for the given sum type.++    @allValues@ is a list of all constructors. @toText@ is a multi-clause+    function mapping each constructor to its PostgreSQL label. @fromText@+    unpacks the 'Text' to a 'String' and matches on string literals.+-}+genHasEnumInstance :: String -> [String] -> Q [Dec]+genHasEnumInstance hsTypeName labels = do+  let tName = mkName hsTypeName+      -- allValues = [Con1, Con2, ...]+      allValuesDec =+        FunD+          'Hasql.Generate.Class.allValues+          [Clause [] (NormalB (ListE (map (ConE . mkName . pascalCase) labels))) []]+      -- toText Con1 = "label1"; toText Con2 = "label2"; ...+      toTextClauses =+        map+          ( \lbl ->+              Clause+                [ConP (mkName (pascalCase lbl)) [] []]+                (NormalB (textLit lbl))+                []+          )+          labels+      toTextDec = FunD 'Hasql.Generate.Class.toText toTextClauses+      -- fromText t = case Data.Text.unpack t of "label1" -> Just Con1; ... _ -> Nothing+      t = mkName "t"+      fromTextMatches =+        map+          ( \lbl ->+              Match+                (LitP (StringL lbl))+                (NormalB (AppE (ConE 'Just) (ConE (mkName (pascalCase lbl)))))+                []+          )+          labels+          <> [Match WildP (NormalB (ConE 'Nothing)) []]+      fromTextBody =+        LamE+          [VarP t]+          (CaseE (AppE (VarE 'Data.Text.unpack) (VarE t)) fromTextMatches)+      fromTextDec =+        FunD+          'Hasql.Generate.Class.fromText+          [Clause [] (NormalB fromTextBody) []]+      instanceType = AppT (ConT ''Hasql.Generate.Class.HasEnum) (ConT tName)+  return [InstanceD Nothing [] instanceType [allValuesDec, toTextDec, fromTextDec]]++----------------------------------------------------------------------------------------------------+-- Data type generation+----------------------------------------------------------------------------------------------------++genDataType :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]+genDataType typName derivNames cols = do+  let tName = mkName typName+      fields = map mkField cols+      con = RecC tName fields+      derivClauses = mkDerivClauses derivNames+  return [DataD [] tName [] Nothing [con] derivClauses]+  where+    mkField :: ResolvedColumn -> VarBangType+    mkField resCol =+      let fName = mkName (rcFieldName resCol)+          fieldBang = Bang NoSourceUnpackedness SourceStrict+          typ = fieldType resCol+       in (fName, fieldBang, typ)++fieldType :: ResolvedColumn -> Type+fieldType resCol+  | rcNotNull resCol = rcType resCol+  | otherwise = AppT (ConT ''Maybe) (rcType resCol)++{-  Partition deriving class 'Name's into stock and anyclass 'DerivClause's.+    Known stock-derivable classes get @deriving stock@; everything else gets+    @deriving anyclass@. Empty groups are omitted.+-}+mkDerivClauses :: [Name] -> [DerivClause]+mkDerivClauses names =+  let (stock, anyclass) = partition isStockDerivable names+   in clauseFor StockStrategy stock <> clauseFor AnyclassStrategy anyclass+  where+    clauseFor _ []      = []+    clauseFor strat nms = [DerivClause (Just strat) (map ConT nms)]++isStockDerivable :: Name -> Bool+isStockDerivable nm =+  nameBase nm+    `elem` [ "Show"+           , "Read"+           , "Eq"+           , "Ord"+           , "Bounded"+           , "Enum"+           , "Ix"+           , "Generic"+           , "Generic1"+           , "Data"+           , "Typeable"+           , "Lift"+           , "Functor"+           , "Foldable"+           , "Traversable"+           ]++----------------------------------------------------------------------------------------------------+-- Decoder generation+----------------------------------------------------------------------------------------------------++genDecoder :: String -> [ResolvedColumn] -> Q [Dec]+genDecoder typName cols = do+  let decName = mkName (camelCase typName <> "Decoder")+      tName = mkName typName+      sigTy = AppT (ConT ''Hasql.Decoders.Row) (ConT tName)+  sig <- sigD decName (return sigTy)+  body <- genDecoderBody tName cols+  let dec = ValD (VarP decName) (NormalB body) []+  return [sig, dec]++genDecoderBody :: Name -> [ResolvedColumn] -> Q Exp+genDecoderBody tName cols =+  case cols of+    [] -> fail "hasql-generate: cannot generate decoder for table with no columns"+    (x : xs) -> do+      let first = applyFmap (ConE tName) (columnDecodeExp x)+      foldl applyAp (return first) (map (return . columnDecodeExp) xs)++columnDecodeExp :: ResolvedColumn -> Exp+columnDecodeExp resCol =+  let nullability =+        if rcNotNull resCol+          then VarE 'Hasql.Decoders.nonNullable+          else VarE 'Hasql.Decoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgDecode+   in AppE (VarE 'Hasql.Decoders.column) (AppE nullability codec)++applyFmap :: Exp -> Exp -> Exp+applyFmap f x = InfixE (Just f) (VarE '(<$>)) (Just x)++applyAp :: Q Exp -> Q Exp -> Q Exp+applyAp qf qx = do+  f <- qf+  InfixE (Just f) (VarE '(<*>)) . Just <$> qx++----------------------------------------------------------------------------------------------------+-- Encoder generation+----------------------------------------------------------------------------------------------------++genEncoder :: String -> [ResolvedColumn] -> Q [Dec]+genEncoder typName cols = do+  let encName = mkName (camelCase typName <> "Encoder")+      tName = mkName typName+      sigTy = AppT (ConT ''Hasql.Encoders.Params) (ConT tName)+  sig <- sigD encName (return sigTy)+  let body = AppE (VarE 'mconcat) (ListE (map (columnEncodeExp tName) cols))+      dec = ValD (VarP encName) (NormalB body) []+  return [sig, dec]++{-  Generate a single encoder term:+    @contramap fieldSelector (Hasql.Encoders.param (Hasql.Encoders.nonNullable pgEncode))@++    Uses a record pattern match lambda to extract the field, which works+    regardless of @DuplicateRecordFields@ or @NoFieldSelectors@ settings.+-}+columnEncodeExp :: Name -> ResolvedColumn -> Exp+columnEncodeExp tName rc =+  let nullability =+        if rcNotNull rc+          then VarE 'Hasql.Encoders.nonNullable+          else VarE 'Hasql.Encoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgEncode+      paramEnc = AppE (VarE 'Hasql.Encoders.param) (AppE nullability codec)+      x = mkName "x"+      selector =+        LamE+          [RecP tName [(mkName (rcFieldName rc), VarP x)]]+          (VarE x)+   in AppE (AppE (VarE 'Contravariant.contramap) selector) paramEnc++{-  Generate a single array encoder term for batch operations:++    @contramap (map (\\TypeName{field = x} -> x))+      (Encoders.param (Encoders.nonNullable+        (Encoders.foldableArray (nonNullable\/nullable pgEncode))))@++    The outer @param@ is always @nonNullable@ (the array itself is always present).+    The inner @foldableArray@ element nullability follows 'rcNotNull'.+    The selector uses @map@ over a @RecP@ lambda pattern.+-}+columnArrayEncodeExp :: Name -> ResolvedColumn -> Exp+columnArrayEncodeExp tName rc =+  let elementNullability =+        if rcNotNull rc+          then VarE 'Hasql.Encoders.nonNullable+          else VarE 'Hasql.Encoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgEncode+      arrayEnc =+        AppE+          (VarE 'Hasql.Encoders.foldableArray)+          (AppE elementNullability codec)+      paramEnc =+        AppE+          (VarE 'Hasql.Encoders.param)+          (AppE (VarE 'Hasql.Encoders.nonNullable) arrayEnc)+      x = mkName "x"+      fieldExtractor =+        LamE+          [RecP tName [(mkName (rcFieldName rc), VarP x)]]+          (VarE x)+      mapSelector = AppE (VarE 'map) fieldExtractor+   in AppE (AppE (VarE 'Contravariant.contramap) mapSelector) paramEnc++{-  Generate an array encoder for a single PK value list:++    @Encoders.param (Encoders.nonNullable+      (Encoders.foldableArray (nonNullable\/nullable pgEncode)))@+-}+singlePkArrayEncoder :: ResolvedColumn -> Exp+singlePkArrayEncoder resCol =+  let elementNullability =+        if rcNotNull resCol+          then VarE 'Hasql.Encoders.nonNullable+          else VarE 'Hasql.Encoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgEncode+      arrayEnc =+        AppE+          (VarE 'Hasql.Encoders.foldableArray)+          (AppE elementNullability codec)+   in AppE+        (VarE 'Hasql.Encoders.param)+        (AppE (VarE 'Hasql.Encoders.nonNullable) arrayEnc)++{-  Generate an array encoder for batch PK operations over @[PkType]@ input.++    * @NoPrimaryKey@: @noParams@+    * @SinglePk@: 'singlePkArrayEncoder'+    * @CompositePk@ without newtypes: @mconcat@ of tuple-field array encoders+    * @CompositePk@ with newtypes: @mconcat@ of RecP-based array encoders+      over the PK record type+-}+pkArrayEncoder :: Maybe String -> PkInfo -> Q Exp+pkArrayEncoder (Just pkTypName) (CompositePk rcs) = do+  let tName = mkName pkTypName+  return (AppE (VarE 'mconcat) (ListE (map (columnArrayEncodeExp tName) rcs)))+pkArrayEncoder _ NoPrimaryKey = return (VarE 'Hasql.Encoders.noParams)+pkArrayEncoder _ (SinglePk rc) = return (singlePkArrayEncoder rc)+pkArrayEncoder _ (CompositePk rcs) = do+  let n = length rcs+      encoders =+        zipWith+          (flip (tupleFieldArrayEncoder n))+          rcs+          (enumFromTo 0 (n - 1))+  return (AppE (VarE 'mconcat) (ListE encoders))++{-  Generate an array encoder for one field of a tuple PK:++    @contramap (map (\\(_, x, _) -> x))+      (Encoders.param (Encoders.nonNullable (Encoders.foldableArray ...)))@+-}+tupleFieldArrayEncoder :: Int -> Int -> ResolvedColumn -> Exp+tupleFieldArrayEncoder tupleSize idx resCol =+  let elementNullability =+        if rcNotNull resCol+          then VarE 'Hasql.Encoders.nonNullable+          else VarE 'Hasql.Encoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgEncode+      arrayEnc =+        AppE+          (VarE 'Hasql.Encoders.foldableArray)+          (AppE elementNullability codec)+      paramEnc =+        AppE+          (VarE 'Hasql.Encoders.param)+          (AppE (VarE 'Hasql.Encoders.nonNullable) arrayEnc)+      accessor = tupleAccessor tupleSize idx+      mapSelector = AppE (VarE 'map) accessor+   in AppE (AppE (VarE 'Contravariant.contramap) mapSelector) paramEnc++----------------------------------------------------------------------------------------------------+-- CRUD statement generation+----------------------------------------------------------------------------------------------------++{-  Assemble a typed top-level @Statement@ binding from its parts: name, type+    signature, SQL literal, encoder expression, and decoder expression.+    Every statement generator delegates to this for the final assembly.+-}+genStatement :: Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]+genStatement stmtName sigTy sql enc dec = do+  sig <- sigD stmtName (return sigTy)+  let body = applyStatement sql enc dec+      valDec = ValD (VarP stmtName) (NormalB body) []+  return [sig, valDec]++genSelectByPk+  :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Maybe String -> Q [Dec]+genSelectByPk schema table typName cols pkInfo pkTypOverride = do+  let stmtName = mkName ("select" <> typName)+      decName = mkName (camelCase typName <> "Decoder")+      pkType = pkParamType pkTypOverride pkInfo+      sql = selectByPkSql schema table cols pkInfo+      sigTy =+        AppT+          (AppT (ConT ''Hasql.Statement.Statement) pkType)+          (AppT (ConT ''Maybe) (ConT (mkName typName)))+  pkEnc <- pkEncoder pkTypOverride pkInfo+  genStatement stmtName sigTy sql pkEnc (AppE (VarE 'Hasql.Decoders.rowMaybe) (VarE decName))++{-  Compute the columns to include in INSERT. When 'withholdPk' is active+    and all PK columns have database defaults, the PK columns are excluded+    from the insert column list (the DB generates them). Without 'withholdPk',+    all columns are always included.+-}+computeInsertCols :: Bool -> [ResolvedColumn] -> PkInfo -> [ResolvedColumn]+computeInsertCols withhold allCols pkInfo =+  let pkNames = pkColumnNames pkInfo+      pkCols = filter (\rc -> rcColName rc `elem` pkNames) allCols+      allPkDefaulted = not (null pkCols) && all rcHasDefault pkCols+   in if withhold && allPkDefaulted+        then filter (\rc -> rcColName rc `notElem` pkNames) allCols+        else allCols++{-  Generate the INSERT statement. @allCols@ is the full record column list+    (used for RETURNING and the decoder), @insertCols@ is the subset actually+    included in the INSERT column list and VALUES params. When PK columns have+    defaults, @insertCols@ excludes them.+-}+genInsert+  :: String -> String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Q [Dec]+genInsert schema table typName allCols insertCols =+  let stmtName = mkName ("insert" <> typName)+      tName = mkName typName+      decName = mkName (camelCase typName <> "Decoder")+      sql = insertSql schema table allCols insertCols+      sigTy = AppT (AppT (ConT ''Hasql.Statement.Statement) (ConT tName)) (ConT tName)+      enc = insertEncoder tName insertCols+   in genStatement stmtName sigTy sql enc (AppE (VarE 'Hasql.Decoders.singleRow) (VarE decName))++{-  Generate an inline encoder for the INSERT that only encodes the insert+    columns (which may be a subset of all columns when PK columns are excluded).+-}+insertEncoder :: Name -> [ResolvedColumn] -> Exp+insertEncoder tName cols =+  AppE (VarE 'mconcat) (ListE (map (columnEncodeExp tName) cols))++{-  The UPDATE uses the full record encoder, so SQL parameter positions match+    the record field order. SET covers non-PK columns and WHERE covers PK+    columns, each referencing the correct @$N@ from the encoder.+-}+genUpdate+  :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Q [Dec]+genUpdate schema table typName cols pkInfo =+  let stmtName = mkName ("update" <> typName)+      tName = mkName typName+      encName = mkName (camelCase typName <> "Encoder")+      decName = mkName (camelCase typName <> "Decoder")+      sql = updateSql schema table cols pkInfo+      sigTy =+        AppT+          (AppT (ConT ''Hasql.Statement.Statement) (ConT tName))+          (AppT (ConT ''Maybe) (ConT tName))+   in genStatement stmtName sigTy sql (VarE encName) (AppE (VarE 'Hasql.Decoders.rowMaybe) (VarE decName))++genDeleteByPk :: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]+genDeleteByPk schema table _typName pkInfo pkTypOverride = do+  let stmtName = mkName ("delete" <> pascalCase table)+      pkType = pkParamType pkTypOverride pkInfo+      sql = deleteSql schema table pkInfo+      sigTy = AppT (AppT (ConT ''Hasql.Statement.Statement) pkType) (TupleT 0)+  pkEnc <- pkEncoder pkTypOverride pkInfo+  genStatement stmtName sigTy sql pkEnc (VarE 'Hasql.Decoders.noResult)++{-  Generate @selectMany\<TypeName\> :: Statement [PkType] [TypeName]@.++    Uses 'selectManySql' and 'pkArrayEncoder' for the input encoding.+-}+genSelectMany+  :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Maybe String -> Q [Dec]+genSelectMany schema table typName cols pkInfo pkTypOverride = do+  let stmtName = mkName ("selectMany" <> typName)+      tName = mkName typName+      decName = mkName (camelCase typName <> "Decoder")+      pkType = pkParamType pkTypOverride pkInfo+      sql = selectManySql schema table cols pkInfo+      sigTy =+        AppT+          (AppT (ConT ''Hasql.Statement.Statement) (AppT ListT pkType))+          (AppT ListT (ConT tName))+  pkEnc <- pkArrayEncoder pkTypOverride pkInfo+  genStatement stmtName sigTy sql pkEnc (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))++{-  Generate @deleteMany\<TypeName\> :: Statement [PkType] ()@.++    Uses 'deleteManySql' and 'pkArrayEncoder'.+-}+genDeleteMany+  :: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]+genDeleteMany schema table _typName pkInfo pkTypOverride = do+  let stmtName = mkName ("deleteMany" <> pascalCase table)+      pkType = pkParamType pkTypOverride pkInfo+      sql = deleteManySql schema table pkInfo+      sigTy = AppT (AppT (ConT ''Hasql.Statement.Statement) (AppT ListT pkType)) (TupleT 0)+  pkEnc <- pkArrayEncoder pkTypOverride pkInfo+  genStatement stmtName sigTy sql pkEnc (VarE 'Hasql.Decoders.noResult)++{-  Generate @insertMany\<TypeName\> :: Statement [TypeName] [TypeName]@.++    Uses 'insertManySql' and @mconcat@ of 'columnArrayEncodeExp' for+    each insert column. Respects 'computeInsertCols' (excludes defaulted+    PK columns).+-}+genInsertMany+  :: String -> String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Q [Dec]+genInsertMany schema table typName allCols insertCols =+  let stmtName = mkName ("insertMany" <> typName)+      tName = mkName typName+      decName = mkName (camelCase typName <> "Decoder")+      sql = insertManySql schema table allCols insertCols+      sigTy =+        AppT+          (AppT (ConT ''Hasql.Statement.Statement) (AppT ListT (ConT tName)))+          (AppT ListT (ConT tName))+      enc = AppE (VarE 'mconcat) (ListE (map (columnArrayEncodeExp tName) insertCols))+   in genStatement stmtName sigTy sql enc (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))++{-  Generate @updateMany\<TypeName\> :: Statement [TypeName] [TypeName]@.++    Uses 'updateManySql' and @mconcat@ of 'columnArrayEncodeExp' for ALL+    columns (both PK and non-PK appear in the unnest subquery). Only generated+    when the table has a primary key.+-}+genUpdateMany+  :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Q [Dec]+genUpdateMany schema table typName cols pkInfo =+  let stmtName = mkName ("updateMany" <> typName)+      tName = mkName typName+      decName = mkName (camelCase typName <> "Decoder")+      sql = updateManySql schema table cols pkInfo+      sigTy =+        AppT+          (AppT (ConT ''Hasql.Statement.Statement) (AppT ListT (ConT tName)))+          (AppT ListT (ConT tName))+      enc = AppE (VarE 'mconcat) (ListE (map (columnArrayEncodeExp tName) cols))+   in genStatement stmtName sigTy sql enc (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))++----------------------------------------------------------------------------------------------------+-- Typeclass instance generation+----------------------------------------------------------------------------------------------------++-- | Build @\\param -> Hasql.Session.statement param stmtName@.+sessionLambda :: String -> Name -> Exp+sessionLambda paramName stmtName =+  LamE+    [VarP (mkName paramName)]+    ( AppE+        (AppE (VarE 'Hasql.Session.statement) (VarE (mkName paramName)))+        (VarE stmtName)+    )++{-  Generate an instance with two session-wrapper methods (single + batch) and+    no associated types. Used for 'HasInsert' and 'HasUpdate'.+-}+genSimpleCrudInstance :: Name -> Name -> Name -> String -> String -> Q [Dec]+genSimpleCrudInstance className singleMethod batchMethod prefix typName = do+  let tName = mkName typName+      singleDec = FunD singleMethod [Clause [] (NormalB (sessionLambda "x" (mkName (prefix <> typName)))) []]+      batchDec = FunD batchMethod [Clause [] (NormalB (sessionLambda "xs" (mkName (prefix <> "Many" <> typName)))) []]+  return [InstanceD Nothing [] (AppT (ConT className) (ConT tName)) [singleDec, batchDec]]++{-  Generate an instance with two session-wrapper methods (single + batch) and+    one associated type for the key. Used for 'HasSelect' and 'HasDelete'.+-}+genKeyCrudInstance :: Name -> Name -> Name -> Name -> String -> String -> PkInfo -> Maybe String -> Q [Dec]+genKeyCrudInstance className singleMethod batchMethod assocType prefix typName pkInfo pkTypOverride = do+  let tName = mkName typName+      keyType = pkParamType pkTypOverride pkInfo+      singleDec = FunD singleMethod [Clause [] (NormalB (sessionLambda "k" (mkName (prefix <> typName)))) []]+      batchDec = FunD batchMethod [Clause [] (NormalB (sessionLambda "ks" (mkName (prefix <> "Many" <> typName)))) []]+      keyTySynInst = TySynInstD (TySynEqn Nothing (AppT (ConT assocType) (ConT tName)) keyType)+  return [InstanceD Nothing [] (AppT (ConT className) (ConT tName)) [keyTySynInst, singleDec, batchDec]]++genHasInsertInstance :: String -> Q [Dec]+genHasInsertInstance =+  genSimpleCrudInstance ''Hasql.Generate.Class.HasInsert 'Hasql.Generate.Class.insert 'Hasql.Generate.Class.insertMany "insert"++genHasSelectInstance :: String -> PkInfo -> Maybe String -> Q [Dec]+genHasSelectInstance =+  genKeyCrudInstance ''Hasql.Generate.Class.HasSelect 'Hasql.Generate.Class.select 'Hasql.Generate.Class.selectMany ''Hasql.Generate.Class.SelectKey "select"++genHasUpdateInstance :: String -> Q [Dec]+genHasUpdateInstance =+  genSimpleCrudInstance ''Hasql.Generate.Class.HasUpdate 'Hasql.Generate.Class.update 'Hasql.Generate.Class.updateMany "update"++genHasDeleteInstance :: String -> PkInfo -> Maybe String -> Q [Dec]+genHasDeleteInstance =+  genKeyCrudInstance ''Hasql.Generate.Class.HasDelete 'Hasql.Generate.Class.delete 'Hasql.Generate.Class.deleteMany ''Hasql.Generate.Class.DeleteKey "delete"++----------------------------------------------------------------------------------------------------+-- View-specific generators+----------------------------------------------------------------------------------------------------++{-  Generate a @select<TypeName> :: Statement () [TypeName]@ that selects+    all rows from the view with no parameters.+-}+genSelectView+  :: String -> String -> String -> [ResolvedColumn] -> Q [Dec]+genSelectView schema table typName cols =+  let stmtName = mkName ("select" <> typName)+      tName = mkName typName+      decName = mkName (camelCase typName <> "Decoder")+      sql = selectViewSql schema table cols+      sigTy =+        AppT+          (AppT (ConT ''Hasql.Statement.Statement) (TupleT 0))+          (AppT ListT (ConT tName))+   in genStatement stmtName sigTy sql (VarE 'Hasql.Encoders.noParams) (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))++selectViewSql :: String -> String -> [ResolvedColumn] -> Exp+selectViewSql schema table cols =+  sqlLit+    ( "SELECT "+        <> columnList cols+        <> " FROM "+        <> qualifiedName schema table+    )++-- | Generate a @HasView@ instance for a view.+genHasViewInstance :: String -> Q [Dec]+genHasViewInstance typName = do+  let tName = mkName typName+      stmtName = mkName ("select" <> typName)+      body =+        AppE+          (AppE (VarE 'Hasql.Session.statement) (TupE []))+          (VarE stmtName)+      selectViewMethod = FunD 'Hasql.Generate.Class.selectView [Clause [] (NormalB body) []]+  return [InstanceD Nothing [] (AppT (ConT ''Hasql.Generate.Class.HasView) (ConT tName)) [selectViewMethod]]++----------------------------------------------------------------------------------------------------+-- SQL generation helpers+----------------------------------------------------------------------------------------------------++selectByPkSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp+selectByPkSql schema table cols pkInfo =+  let pkWhere = pkWhereClause pkInfo 1+   in sqlLit+        ( "SELECT "+            <> columnList cols+            <> " FROM "+            <> qualifiedName schema table+            <> " WHERE "+            <> pkWhere+        )++insertSql :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp+insertSql schema table allCols insertCols =+  let insertColNames = columnList insertCols+      returnColNames = columnList allCols+      params = typedParamList 1 insertCols+   in sqlLit+        ( "INSERT INTO "+            <> qualifiedName schema table+            <> " ("+            <> insertColNames+            <> ")"+            <> " VALUES ("+            <> params+            <> ")"+            <> " RETURNING "+            <> returnColNames+        )++updateSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp+updateSql schema table cols pkInfo =+  let pkNames = pkColumnNames pkInfo+      indexed = zip cols (enumFromTo 1 (length cols))+      nonPkSet = filter (\(rc, _) -> rcColName rc `notElem` pkNames) indexed+      pkWhere = filter (\(rc, _) -> rcColName rc `elem` pkNames) indexed+      setClauses =+        intercalate+          ", "+          (map (\(rc, i) -> quoteIdent (rcColName rc) <> " = " <> paramRef i rc) nonPkSet)+      whereClauses =+        intercalate+          " AND "+          (map (\(rc, i) -> quoteIdent (rcColName rc) <> " = " <> paramRef i rc) pkWhere)+   in sqlLit+        ( "UPDATE "+            <> qualifiedName schema table+            <> " SET "+            <> setClauses+            <> " WHERE "+            <> whereClauses+            <> " RETURNING "+            <> columnList cols+        )++deleteSql :: String -> String -> PkInfo -> Exp+deleteSql schema table pkInfo =+  let pkWhere = pkWhereClause pkInfo 1+   in sqlLit+        ( "DELETE FROM "+            <> qualifiedName schema table+            <> " WHERE "+            <> pkWhere+        )++----------------------------------------------------------------------------------------------------+-- Batch SQL generation helpers+----------------------------------------------------------------------------------------------------++{-  Generate SQL for batch select: @SELECT cols FROM s.t WHERE pk = ANY($1)@+    for single PK, or @WHERE (c1, c2) IN (SELECT unnest($1), unnest($2))@+    for composite PK.+-}+selectManySql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp+selectManySql schema table cols pkInfo =+  sqlLit+    ( "SELECT "+        <> columnList cols+        <> " FROM "+        <> qualifiedName schema table+        <> " WHERE "+        <> batchPkWhereClause pkInfo+    )++{-  Generate SQL for batch delete: same WHERE clause logic as 'selectManySql'.+-}+deleteManySql :: String -> String -> PkInfo -> Exp+deleteManySql schema table pkInfo =+  sqlLit+    ( "DELETE FROM "+        <> qualifiedName schema table+        <> " WHERE "+        <> batchPkWhereClause pkInfo+    )++{-  Generate SQL for batch insert using @unnest@-based array parameters:++    @INSERT INTO s.t (cols) SELECT * FROM unnest($1, $2, ...) RETURNING allCols@+-}+insertManySql :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp+insertManySql schema table allCols insertCols =+  let insertColNames = columnList insertCols+      returnColNames = columnList allCols+      params = typedArrayParamList 1 insertCols+   in sqlLit+        ( "INSERT INTO "+            <> qualifiedName schema table+            <> " ("+            <> insertColNames+            <> ") SELECT * FROM unnest("+            <> params+            <> ") RETURNING "+            <> returnColNames+        )++{-  Generate SQL for batch update using an @unnest@ subquery join:++    @UPDATE s.t SET c1 = d.c1, c2 = d.c2+    FROM (SELECT unnest($1) AS pk, unnest($2) AS c1, unnest($3) AS c2) d+    WHERE s.t.pk = d.pk+    RETURNING s.t.*@++    All columns (PK and non-PK) appear in the unnest subquery. SET covers+    non-PK columns. WHERE joins on PK columns.+-}+updateManySql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp+updateManySql schema table cols pkInfo =+  let pkNames = pkColumnNames pkInfo+      nonPkCols = filter (\rc -> rcColName rc `notElem` pkNames) cols+      setClauses =+        intercalate+          ", "+          (map (\rc -> quoteIdent (rcColName rc) <> " = d." <> quoteIdent (rcColName rc)) nonPkCols)+      -- All columns in the unnest subquery+      unnestParams =+        intercalate+          ", "+          ( zipWith+              (\rc i -> "unnest(" <> arrayParamRef i rc <> ") AS " <> quoteIdent (rcColName rc))+              cols+              (enumFromTo 1 (length cols))+          )+      -- WHERE join on PK columns+      pkJoin =+        intercalate+          " AND "+          ( map+              (\pkn -> qualifiedName schema table <> "." <> quoteIdent pkn <> " = d." <> quoteIdent pkn)+              pkNames+          )+   in sqlLit+        ( "UPDATE "+            <> qualifiedName schema table+            <> " SET "+            <> setClauses+            <> " FROM (SELECT "+            <> unnestParams+            <> ") d WHERE "+            <> pkJoin+            <> " RETURNING "+            <> qualifiedName schema table+            <> ".*"+        )++{-  Generate the WHERE clause for batch PK operations.++    Single PK: @pk = ANY($1)@ — uses @arrayParamRef@ for enum cast support.+    Composite PK: @(c1, c2) IN (SELECT unnest($1), unnest($2))@.+-}+batchPkWhereClause :: PkInfo -> String+batchPkWhereClause NoPrimaryKey = "true"+batchPkWhereClause (SinglePk rc) =+  quoteIdent (rcColName rc) <> " = ANY(" <> arrayParamRef 1 rc <> ")"+batchPkWhereClause (CompositePk rcs) =+  let pkTuple = "(" <> intercalate ", " (map (quoteIdent . rcColName) rcs) <> ")"+      unnests =+        intercalate+          ", "+          ( zipWith+              (\rc i -> "unnest(" <> arrayParamRef i rc <> ")")+              rcs+              (enumFromTo 1 (length rcs))+          )+   in pkTuple <> " IN (SELECT " <> unnests <> ")"++{-  Generate a comma-separated array parameter list with per-column type casts,+    using 'arrayParamRef' so enum types get @[]@ appended.+-}+typedArrayParamList :: Int -> [ResolvedColumn] -> String+typedArrayParamList start cols =+  intercalate ", " (zipWith arrayParamRef (enumFromTo start (start + length cols - 1)) cols)++textLit :: String -> Exp+textLit s = AppE (VarE 'Data.String.fromString) (LitE (StringL s))++sqlLit :: String -> Exp+sqlLit = textLit++applyStatement :: Exp -> Exp -> Exp -> Exp+applyStatement sql enc dec =+  foldl AppE (ConE 'Hasql.Statement.Statement) [sql, enc, dec, ConE 'True]++columnList :: [ResolvedColumn] -> String+columnList cols = intercalate ", " (map (quoteIdent . rcColName) cols)++{-  Format a single parameter reference, appending a @::type@ cast when the+    column has 'rcPgCast' set (e.g. for enum types).++    @paramRef 3 rc@  →  @\"$3\"@ or @\"$3::hg_test.user_role\"@+-}+paramRef :: Int -> ResolvedColumn -> String+paramRef i rc = case rcPgCast rc of+  Nothing   -> "$" <> show i+  Just cast -> "$" <> show i <> "::" <> cast++{-  Format an array parameter reference for batch operations. Appends @[]@ to+    the cast suffix for enum types so that PostgreSQL receives the correct+    array type annotation.++    @arrayParamRef 1 rcEnum@  produces @\"$1::hg_test.user_role[]\"@+    @arrayParamRef 2 rcPlain@ produces @\"$2\"@+-}+arrayParamRef :: Int -> ResolvedColumn -> String+arrayParamRef i rc = case rcPgCast rc of+  Nothing   -> "$" <> show i+  Just cast -> "$" <> show i <> "::" <> cast <> "[]"++{-  Generate a comma-separated parameter list with per-column type casts.++    @typedParamList 1 [rcPlain, rcEnum]@  →  @\"$1, $2::hg_test.user_role\"@+-}+typedParamList :: Int -> [ResolvedColumn] -> String+typedParamList start cols =+  intercalate ", " (zipWith paramRef (enumFromTo start (start + length cols - 1)) cols)++pkWhereClause :: PkInfo -> Int -> String+pkWhereClause NoPrimaryKey _ = "true"+pkWhereClause (SinglePk rc) startIdx =+  quoteIdent (rcColName rc) <> " = " <> paramRef startIdx rc+pkWhereClause (CompositePk rcs) startIdx =+  intercalate+    " AND "+    ( zipWith+        (\rc i -> quoteIdent (rcColName rc) <> " = " <> paramRef i rc)+        rcs+        (enumFromTo startIdx (startIdx + length rcs - 1))+    )++pkColumnNames :: PkInfo -> [String]+pkColumnNames NoPrimaryKey      = []+pkColumnNames (SinglePk rc)     = [rcColName rc]+pkColumnNames (CompositePk rcs) = map rcColName rcs++----------------------------------------------------------------------------------------------------+-- PK type and encoder helpers+----------------------------------------------------------------------------------------------------++pkParamType :: Maybe String -> PkInfo -> Type+pkParamType (Just pkTypName) (CompositePk _) = ConT (mkName pkTypName)+pkParamType _ NoPrimaryKey = TupleT 0+pkParamType _ (SinglePk rc) = fieldType rc+pkParamType _ (CompositePk rcs) =+  foldl AppT (TupleT (length rcs)) (map fieldType rcs)++pkEncoder :: Maybe String -> PkInfo -> Q Exp+pkEncoder (Just pkTypName) (CompositePk _) =+  return (VarE (mkName (camelCase pkTypName <> "Encoder")))+pkEncoder _ NoPrimaryKey = return (VarE 'Hasql.Encoders.noParams)+pkEncoder _ (SinglePk rc) = return (singleParamEncoder rc)+pkEncoder _ (CompositePk rcs) = return (compositeEncoder rcs)++singleParamEncoder :: ResolvedColumn -> Exp+singleParamEncoder rc =+  let nullability =+        if rcNotNull rc+          then VarE 'Hasql.Encoders.nonNullable+          else VarE 'Hasql.Encoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgEncode+   in AppE (VarE 'Hasql.Encoders.param) (AppE nullability codec)++compositeEncoder :: [ResolvedColumn] -> Exp+compositeEncoder rcs =+  let n = length rcs+      encoders =+        zipWith+          (flip (tupleFieldEncoder n))+          rcs+          (enumFromTo 0 (n - 1))+   in AppE (VarE 'mconcat) (ListE encoders)++tupleFieldEncoder :: Int -> Int -> ResolvedColumn -> Exp+tupleFieldEncoder tupleSize idx rc =+  let nullability =+        if rcNotNull rc+          then VarE 'Hasql.Encoders.nonNullable+          else VarE 'Hasql.Encoders.nullable+      codec = VarE 'Hasql.Generate.Codec.pgEncode+      paramEnc = AppE (VarE 'Hasql.Encoders.param) (AppE nullability codec)+      accessor = tupleAccessor tupleSize idx+   in AppE (AppE (VarE 'Contravariant.contramap) accessor) paramEnc++{-  Build a lambda extracting the Nth element from a tuple of known size.+    For pairs, uses @fst@ and @snd@. For larger tuples, generates a pattern match:+    @\\(_, _, x, _) -> x@+-}+tupleAccessor :: Int -> Int -> Exp+tupleAccessor 2 0 = VarE 'Data.Tuple.fst+tupleAccessor 2 1 = VarE 'Data.Tuple.snd+tupleAccessor size idx =+  let names = map (\i -> mkName ("t" <> show i)) (enumFromTo 0 (size - 1))+      pats = map VarP names+      target = names !! idx+   in LamE [TupP pats] (VarE target)++----------------------------------------------------------------------------------------------------+-- Newtype PK generation+----------------------------------------------------------------------------------------------------++{-  Generate a newtype wrapper for a single-column primary key.++    @genPkNewtype \"UsersPk\" [''Show, ''Eq] rc@  where @rc@ has type @UUID@++    produces:++    @newtype UsersPk = UsersPk { getUsersPk :: !UUID } deriving stock (Show, Eq)@+-}+genPkNewtype :: String -> [Name] -> ResolvedColumn -> Q [Dec]+genPkNewtype pkTypName derivNames rc = do+  let tName = mkName pkTypName+      unwrapperName = mkName ("get" <> pkTypName)+      fieldBang = Bang NoSourceUnpackedness NoSourceStrictness+      field = (unwrapperName, fieldBang, rcType rc)+      con = RecC tName [field]+      derivClauses = mkDerivClauses derivNames+  return [NewtypeD [] tName [] Nothing con derivClauses]++{-  Generate a @PgCodec@ instance for a single-column PK newtype.++    @genPkNewtypeCodec \"UsersPk\"@  produces:++    @+    instance PgCodec UsersPk where+      pgDecode = UsersPk \<$\> pgDecode+      pgEncode = contramap getUsersPk pgEncode+    @+-}+genPkNewtypeCodec :: String -> Q [Dec]+genPkNewtypeCodec pkTypName = do+  let tName = mkName pkTypName+      conName = mkName pkTypName+      unwrapperName = mkName ("get" <> pkTypName)+      -- pgDecode = Con <$> pgDecode+      decoderBody =+        InfixE+          (Just (ConE conName))+          (VarE '(<$>))+          (Just (VarE 'Hasql.Generate.Codec.pgDecode))+      decoderDec = FunD 'Hasql.Generate.Codec.pgDecode [Clause [] (NormalB decoderBody) []]+      -- pgEncode = contramap unwrapper pgEncode+      encoderBody =+        AppE+          (AppE (VarE 'Contravariant.contramap) (VarE unwrapperName))+          (VarE 'Hasql.Generate.Codec.pgEncode)+      encoderDec = FunD 'Hasql.Generate.Codec.pgEncode [Clause [] (NormalB encoderBody) []]+      instanceType = AppT (ConT ''Hasql.Generate.Codec.PgCodec) (ConT tName)+  return [InstanceD Nothing [] instanceType [decoderDec, encoderDec]]++{-  Generate a data record for a composite primary key.++    @genPkRecord \"CompositePkPk\" [''Show, ''Eq] pkRcs@  produces a record with+    fields matching the PK columns.+-}+genPkRecord :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]+genPkRecord pkTypName derivNames pkRcs = do+  let tName = mkName pkTypName+      fields = map mkPkField pkRcs+      con = RecC tName fields+      derivClauses = mkDerivClauses derivNames+  return [DataD [] tName [] Nothing [con] derivClauses]+  where+    mkPkField :: ResolvedColumn -> VarBangType+    mkPkField rc =+      let fName = mkName (rcFieldName rc)+          fieldBang = Bang NoSourceUnpackedness SourceStrict+       in (fName, fieldBang, fieldType rc)++{-  Generate an encoder for a composite PK record type.++    @genPkRecordEncoder \"CompositePkPk\" pkRcs@  produces:++    @+    compositePkPkEncoder :: Encoders.Params CompositePkPk+    compositePkPkEncoder = mconcat [...]+    @+-}+genPkRecordEncoder :: String -> [ResolvedColumn] -> Q [Dec]+genPkRecordEncoder pkTypName pkRcs = do+  let encName = mkName (camelCase pkTypName <> "Encoder")+      tName = mkName pkTypName+      sigTy = AppT (ConT ''Hasql.Encoders.Params) (ConT tName)+  sig <- sigD encName (return sigTy)+  let body = AppE (VarE 'mconcat) (ListE (map (columnEncodeExp tName) pkRcs))+      dec = ValD (VarP encName) (NormalB body) []+  return [sig, dec]++{-  Compute the field name for a PK record column. Uses @rcColName@ (the raw PG+    column name) rather than the main record's potentially-prefixed @rcFieldName@.+-}+pkRecordFieldName :: String -> Bool -> ResolvedColumn -> ResolvedColumn+pkRecordFieldName pkTypName allowDupFields rc =+  if allowDupFields+    then rc {rcFieldName = sanitizeField (camelCase (rcColName rc))}+    else rc {rcFieldName = sanitizeField (camelCase pkTypName <> pascalCase (rcColName rc))}++----------------------------------------------------------------------------------------------------+-- HasPrimaryKey instance generation+----------------------------------------------------------------------------------------------------++{-  Generate a @HasPrimaryKey@ instance for a table.++    Handles all four cases: single/composite × newtypes/no-newtypes.+    @rawPk@ is generated explicitly since the type families are non-injective+    and GHC cannot resolve a default @unwrapPk . toPk@ composition.+-}+genHasPrimaryKeyInstance+  :: String -> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q [Dec]+genHasPrimaryKeyInstance typName origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields = do+  let tName = mkName typName+      pkOfType = pkParamType pkTypOverride pkInfo'+      rawPkOfType = pkParamType Nothing origPkInfo+      pkOfTySynInst =+        TySynInstD+          (TySynEqn Nothing (AppT (ConT ''Hasql.Generate.Class.PkOf) (ConT tName)) pkOfType)+      rawPkOfTySynInst =+        TySynInstD+          (TySynEqn Nothing (AppT (ConT ''Hasql.Generate.Class.RawPkOf) (ConT tName)) rawPkOfType)+  toPkBody <- genToPk typName pkInfo' pkTypOverride allowDupFields+  wrapPkBody <- genWrapPk origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields+  unwrapPkBody <- genUnwrapPk origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields+  rawPkBody <- genRawPk typName origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields+  let toPkDec = FunD 'Hasql.Generate.Class.toPk [Clause [] (NormalB toPkBody) []]+      wrapPkDec = FunD 'Hasql.Generate.Class.wrapPk [Clause [] (NormalB wrapPkBody) []]+      unwrapPkDec = FunD 'Hasql.Generate.Class.unwrapPk [Clause [] (NormalB unwrapPkBody) []]+      rawPkDec = FunD 'Hasql.Generate.Class.rawPk [Clause [] (NormalB rawPkBody) []]+      instanceType = AppT (ConT ''Hasql.Generate.Class.HasPrimaryKey) (ConT tName)+  return+    [ InstanceD+        Nothing+        []+        instanceType+        [pkOfTySynInst, rawPkOfTySynInst, toPkDec, wrapPkDec, unwrapPkDec, rawPkDec]+    ]++{-  Generate the @toPk@ method body: extracts PK field(s) from the main record.++    Single PK: @\\Rec{field = x} -> x@+    Composite, no newtypes: @\\Rec{f1 = x0, f2 = x1} -> (x0, x1)@+    Composite, with newtypes: @\\Rec{f1 = x0, f2 = x1} -> PkRec{pf1 = x0, pf2 = x1}@+-}+genToPk :: String -> PkInfo -> Maybe String -> Bool -> Q Exp+genToPk typName pkInfo' pkTypOverride allowDupFields = do+  let tName = mkName typName+  case pkInfo' of+    NoPrimaryKey -> fail "hasql-generate: genToPk called with NoPrimaryKey"+    SinglePk rc -> do+      let x = mkName "x"+      return (LamE [RecP tName [(mkName (rcFieldName rc), VarP x)]] (VarE x))+    CompositePk rcs -> do+      let xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (length rcs - 1))+          pat = RecP tName (zipWith (\rc x -> (mkName (rcFieldName rc), VarP x)) rcs xs)+      case pkTypOverride of+        Just pkTypName -> do+          let pkCon = mkName pkTypName+              pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs+              body = RecConE pkCon (zipWith (\prc x -> (mkName (rcFieldName prc), VarE x)) pkRcs xs)+          return (LamE [pat] body)+        Nothing -> do+          let body = TupE (map (Just . VarE) xs)+          return (LamE [pat] body)++{-  Generate the @wrapPk@ method body: converts raw PK value(s) to the PK type.++    No newtypes: @\\x -> x@ (identity)+    Single + newtypes: @ConE pkTypName@ (newtype constructor)+    Composite + newtypes: @\\(x0, x1) -> PkRec{pf1 = x0, pf2 = x1}@+-}+genWrapPk :: PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp+genWrapPk _origPkInfo _pkInfo' useNtPk pkTypOverride allowDupFields+  | not useNtPk = return identityLam+  | otherwise = case (_origPkInfo, pkTypOverride) of+      (SinglePk _, _) -> do+        let pkTypName = case _pkInfo' of+              SinglePk rc -> case rcType rc of+                ConT n -> nameBase n+                _      -> ""+              _ -> ""+        return (ConE (mkName pkTypName))+      (CompositePk rcs, Just pkTypName) -> do+        let n = length rcs+            xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (n - 1))+            pat = TupP (map VarP xs)+            pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs+            body = RecConE (mkName pkTypName) (zipWith (\prc x -> (mkName (rcFieldName prc), VarE x)) pkRcs xs)+        return (LamE [pat] body)+      _ -> return identityLam++{-  Generate the @unwrapPk@ method body: converts PK type to raw value(s).++    No newtypes: @\\x -> x@ (identity)+    Single + newtypes: @VarE getterName@ (newtype field accessor)+    Composite + newtypes: @\\PkRec{pf1 = x0, pf2 = x1} -> (x0, x1)@+-}+genUnwrapPk :: PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp+genUnwrapPk _origPkInfo _pkInfo' useNtPk pkTypOverride allowDupFields+  | not useNtPk = return identityLam+  | otherwise = case (_origPkInfo, pkTypOverride) of+      (SinglePk _, _) -> do+        let pkTypName = case _pkInfo' of+              SinglePk rc -> case rcType rc of+                ConT n -> nameBase n+                _      -> ""+              _ -> ""+        return (VarE (mkName ("get" <> pkTypName)))+      (CompositePk rcs, Just pkTypName) -> do+        let n = length rcs+            xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (n - 1))+            pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs+            pat = RecP (mkName pkTypName) (zipWith (\prc x -> (mkName (rcFieldName prc), VarP x)) pkRcs xs)+            body = TupE (map (Just . VarE) xs)+        return (LamE [pat] body)+      _ -> return identityLam++{-  Generate the @rawPk@ method body: extracts raw PK value(s) directly from the+    main record.++    Without newtypes: same as @toPk@ — the PK type is already the raw type.+    With newtypes, single PK: pattern matches through the newtype to extract+    the raw value (e.g. @\\Rec{id = NtSinglePk x} -> x@).+    With newtypes, composite PK: extracts raw fields into a tuple (the record+    fields are already raw types, only the PK wrapper is a record).+-}+genRawPk :: String -> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp+genRawPk typName origPkInfo pkInfo' useNtPk _pkTypOverride allowDupFields+  | not useNtPk = genToPk typName origPkInfo Nothing allowDupFields+  | otherwise = do+      let tName = mkName typName+      case origPkInfo of+        NoPrimaryKey -> fail "hasql-generate: genRawPk called with NoPrimaryKey"+        SinglePk _rc -> do+          -- The record field is the newtype; pattern match through it+          case pkInfo' of+            SinglePk rc' -> do+              let pkTypName = case rcType rc' of+                    ConT n -> nameBase n+                    _      -> ""+                  x = mkName "x"+                  innerPat = ConP (mkName pkTypName) [] [VarP x]+                  pat = RecP tName [(mkName (rcFieldName rc'), innerPat)]+              return (LamE [pat] (VarE x))+            _ -> fail "hasql-generate: genRawPk single PK mismatch"+        CompositePk rcs -> do+          -- Composite PK fields in the main record are raw types (not rewritten)+          let xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (length rcs - 1))+              -- Use pkInfo' field names since those are what the main record uses+              rcs' = case pkInfo' of+                CompositePk cs -> cs+                _              -> rcs+              pat = RecP tName (zipWith (\rc x -> (mkName (rcFieldName rc), VarP x)) rcs' xs)+              body = TupE (map (Just . VarE) xs)+          return (LamE [pat] body)++identityLam :: Exp+identityLam =+  let x = mkName "x"+   in LamE [VarP x] (VarE x)++----------------------------------------------------------------------------------------------------+-- Utility functions+----------------------------------------------------------------------------------------------------++{-  Wrap a single PostgreSQL identifier in double-quotes, escaping any+    internal double-quote characters per the SQL standard (@\"\"@ → @\"\"\"\"@).+-}+quoteIdent :: String -> String+quoteIdent s = "\"" <> concatMap escDQ s <> "\""+  where+    escDQ '"' = "\"\""+    escDQ c   = [c]++{-  Build a schema-qualified, double-quoted identifier pair.++    @qualifiedName \"public\" \"users\"@  →  @\"\\\"public\\\".\\\"users\\\"\"@+-}+qualifiedName :: String -> String -> String+qualifiedName schema name = quoteIdent schema <> "." <> quoteIdent name++{-  Prefix a resolved column's field name with the type name in camelCase.++    @prefixFieldName \"Users\" rc{rcColName=\"tenant_id\"}@  gives+    @rc{rcFieldName=\"usersTenantId\"}@+-}+prefixFieldName :: String -> ResolvedColumn -> ResolvedColumn+prefixFieldName typName rc =+  rc {rcFieldName = sanitizeField (camelCase typName <> pascalCase (rcColName rc))}++{-  Append an apostrophe to a camelCase identifier if it collides with a+    Haskell reserved keyword. This is idiomatic Haskell (e.g. @type'@, @class'@).+-}+sanitizeField :: String -> String+sanitizeField s+  | s `elem` haskellKeywords = s <> "'"+  | otherwise = s++-- | Haskell reserved keywords that may collide with generated camelCase identifiers.+haskellKeywords :: [String]+haskellKeywords =+  [ "case"+  , "class"+  , "data"+  , "default"+  , "deriving"+  , "do"+  , "else"+  , "forall"+  , "foreign"+  , "hiding"+  , "if"+  , "import"+  , "in"+  , "infix"+  , "infixl"+  , "infixr"+  , "instance"+  , "let"+  , "module"+  , "newtype"+  , "of"+  , "qualified"+  , "then"+  , "type"+  , "where"+  , "mdo"+  , "rec"+  , "proc"+  , "pattern"+  , "role"+  , "family"+  , "stock"+  , "anyclass"+  , "via"+  ]++{-  Convert a snake_case or plain identifier to PascalCase.++    @\"user_emails\"  →  \"UserEmails\"@+    @\"users\"        →  \"Users\"@+-}+pascalCase :: String -> String+pascalCase = concatMap titleWord . splitSnake++{-  Convert a snake_case or PascalCase identifier to camelCase.++    @\"tenant_id\"    →  \"tenantId\"@+    @\"UserEmails\"   →  \"userEmails\"@+    @\"name\"         →  \"name\"@+-}+camelCase :: String -> String+camelCase s = case splitSnake s of+  []       -> []+  (w : ws) -> lowerFirst w <> concatMap titleWord ws++titleWord :: String -> String+titleWord []       = []+titleWord (c : cs) = toUpper c : cs++lowerFirst :: String -> String+lowerFirst []       = []+lowerFirst (c : cs) = toLower c : cs++{-  Split a string on underscores.++    @\"tenant_id\"  →  [\"tenant\", \"id\"]@+    @\"name\"       →  [\"name\"]@+-}+splitSnake :: String -> [String]+splitSnake [] = []+splitSnake s = case break (== '_') s of+  (word, [])       -> [word]+  (word, _ : rest) -> word : splitSnake rest

@@ -0,0 +1,782 @@+module Main+    ( main+    ) where++----------------------------------------------------------------------------------------------------++import           Control.Exception    ( bracket )++import           Data.Aeson           ( FromJSON, ToJSON, eitherDecode, encode )+import           Data.Default.Class   ( Default (def) )+import           Data.Either          ( Either (..) )+import           Data.Eq              ( Eq, (/=), (==) )+import           Data.Function        ( ($), (&) )+import           Data.Int             ( Int32 )+import           Data.List            ( any, length, null )+import           Data.Maybe           ( Maybe (..) )+import           Data.Ord             ( Ord )+import           Data.Semigroup       ( (<>) )+import           Data.String          ( String )+import           Data.Text            ( Text )+import           Data.UUID            ( UUID )+import qualified Data.UUID+import           Data.UUID.V4         ( nextRandom )++import           GHC.Generics         ( Generic )+import           GHC.Show             ( Show, show )++import qualified Hasql.Connection+import qualified Hasql.Decoders+import qualified Hasql.Encoders+import           Hasql.Generate+    ( Config (..)+    , HasEnum (..)+    , HasPrimaryKey (..)+    , fromTable+    , fromType+    , fromView+    , generate+    , withDerivations+    , withholdPk+    )+import qualified Hasql.Generate.Class as Q+import qualified Hasql.Session+import qualified Hasql.Statement++import           Prelude+    ( Bool (..)+    , IO+    , error+    , fmap+    , not+    , otherwise+    , pure+    , putStrLn+    , seq+    , (>>)+    )++import           System.Exit          ( die, exitSuccess )++----------------------------------------------------------------------------------------------------++-- Enum type: generates sum type + PgCodec + PgColumn instances.+-- Must appear before any fromTable whose columns reference this enum.+$(generate (def {allowDuplicateRecordFields = True}) (fromType "hg_test" "user_role" & withDerivations [''Show, ''Eq, ''Ord]))++-- Table with enum column: exercises the PgColumn instance generated by fromType above.+$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "with_role" & withDerivations [''Show, ''Eq]))++-- Functional test table: CRUD + derived instances + global type override exercised at runtime+$( generate+     (def {allowDuplicateRecordFields = True, globalOverrides = [("text", ''String)]})+     ( fromTable "hg_test" "users"+         & withDerivations [''Show, ''Eq, ''Generic, ''ToJSON, ''FromJSON]+         & withholdPk+     )+ )++-- Single UUID PK: generates data type, decoder, encoder, select, insert, update, delete+$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "with_pk"))++-- No PK: generates data type, decoder, encoder only+$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "no_pk"))++-- Composite PK: generates all CRUD with tuple PK type+$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "composite_pk"))++-- View: generates read-only data type, decoder, SELECT, and HasView instance+$(generate (def {allowDuplicateRecordFields = True}) (fromView "hg_test" "user_emails" & withDerivations [''Show, ''Eq]))++-- Newtype PK (single): generates newtype wrapper, PgCodec, HasPrimaryKey+$( generate+     (def {allowDuplicateRecordFields = True, newtypePrimaryKeys = True})+     (fromTable "hg_test" "nt_single" & withDerivations [''Show, ''Eq])+ )++-- Newtype PK (composite): generates data record wrapper, encoder, HasPrimaryKey+$( generate+     (def {allowDuplicateRecordFields = True, newtypePrimaryKeys = True})+     (fromTable "hg_test" "nt_composite" & withDerivations [''Show, ''Eq])+ )++-- Prefixed fields (default config): field names are prefixed with the type name+$(generate def (fromTable "hg_test" "prefix_demo"))++-- Reserved keyword columns: tests that field names colliding with Haskell keywords+-- get an apostrophe suffix (e.g. "type" -> "type'", "class" -> "class'", "data" -> "data'")+$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "keyword_cols" & withDerivations [''Show, ''Eq]))++----------------------------------------------------------------------------------------------------++main :: IO ()+main = do+  testGeneratorsGenerate+  testPrefixedFields+  testKeywordSanitization+  testUsersCrud+  testUsersDerivation+  testEnumUtilities+  testEnumRoundTrip+  testViewSelect+  testNewtypePkCrud+  testHasPrimaryKey+  testBatchCrud+  testBatchTypeclasses+  exitSuccess++----------------------------------------------------------------------------------------------------+-- Compile-time generation test+----------------------------------------------------------------------------------------------------++{-  If this module compiles, the TH splices produced valid, well-typed code.+    We reference every generated binding to ensure nothing was silently omitted.+-}+testGeneratorsGenerate :: IO ()+testGeneratorsGenerate =+  _urAdmin+    .> _urModerator+    .> _urMember+    .> _wrDec+    .> _wrEnc+    .> _wrSel+    .> _wrIns+    .> _wrUpd+    .> _wrDel+    .> _wpDec+    .> _wpEnc+    .> _wpSel+    .> _wpIns+    .> _wpUpd+    .> _wpDel+    .> _npDec+    .> _npEnc+    .> _npIns+    .> _cpDec+    .> _cpEnc+    .> _cpSel+    .> _cpIns+    .> _cpUpd+    .> _cpDel+    .> _ueDec+    .> _ueSel+    .> _nsSel+    .> _nsDel+    .> _nsIns+    .> _ncSel+    .> _ncDel+    .> _ncIns+    .> _urAll+    .> _urToText+    .> _urFromText+    .> _pdDec+    .> _pdEnc+    .> _pdIns+    .> _kwDec+    .> _kwEnc+    .> _kwIns+    .> _smWp+    .> _dmWp+    .> _imWp+    .> _umWp+    .> _smCp+    .> _dmCp+    .> _imNp+    .> _imU+    .> _smNs+    .> _smNc+    .> _imCp+    .> _umCp+    .> _wrSmany+    .> _wrDmany+    .> _wrImany+    .> _wrUmany+    .> pure ()+    >> putStrLn "Generator test passed ✔"+  where+    a .> b = a `seq` b++    _urAdmin :: UserRole+    _urAdmin = Admin++    _urModerator :: UserRole+    _urModerator = Moderator++    _urMember :: UserRole+    _urMember = Member++    _wrDec :: Hasql.Decoders.Row WithRole+    _wrDec = withRoleDecoder++    _wrEnc :: Hasql.Encoders.Params WithRole+    _wrEnc = withRoleEncoder++    _wrSel :: Hasql.Statement.Statement UUID (Maybe WithRole)+    _wrSel = selectWithRole++    _wrIns :: Hasql.Statement.Statement WithRole WithRole+    _wrIns = insertWithRole++    _wrUpd :: Hasql.Statement.Statement WithRole (Maybe WithRole)+    _wrUpd = updateWithRole++    _wrDel :: Hasql.Statement.Statement UUID ()+    _wrDel = deleteWithRole++    _wpDec :: Hasql.Decoders.Row WithPk+    _wpDec = withPkDecoder++    _wpEnc :: Hasql.Encoders.Params WithPk+    _wpEnc = withPkEncoder++    _wpSel :: Hasql.Statement.Statement UUID (Maybe WithPk)+    _wpSel = selectWithPk++    _wpIns :: Hasql.Statement.Statement WithPk WithPk+    _wpIns = insertWithPk++    _wpUpd :: Hasql.Statement.Statement WithPk (Maybe WithPk)+    _wpUpd = updateWithPk++    _wpDel :: Hasql.Statement.Statement UUID ()+    _wpDel = deleteWithPk++    _npDec :: Hasql.Decoders.Row NoPk+    _npDec = noPkDecoder++    _npEnc :: Hasql.Encoders.Params NoPk+    _npEnc = noPkEncoder++    _npIns :: Hasql.Statement.Statement NoPk NoPk+    _npIns = insertNoPk++    _cpDec :: Hasql.Decoders.Row CompositePk+    _cpDec = compositePkDecoder++    _cpEnc :: Hasql.Encoders.Params CompositePk+    _cpEnc = compositePkEncoder++    _cpSel :: Hasql.Statement.Statement (UUID, Int32) (Maybe CompositePk)+    _cpSel = selectCompositePk++    _cpIns :: Hasql.Statement.Statement CompositePk CompositePk+    _cpIns = insertCompositePk++    _cpUpd :: Hasql.Statement.Statement CompositePk (Maybe CompositePk)+    _cpUpd = updateCompositePk++    _cpDel :: Hasql.Statement.Statement (UUID, Int32) ()+    _cpDel = deleteCompositePk++    _ueDec :: Hasql.Decoders.Row UserEmails+    _ueDec = userEmailsDecoder++    _ueSel :: Hasql.Statement.Statement () [UserEmails]+    _ueSel = selectUserEmails++    _urAll :: [UserRole]+    _urAll = allValues++    _urToText :: UserRole -> Text+    _urToText = toText++    _urFromText :: Text -> Maybe UserRole+    _urFromText = fromText++    -- Newtype PK (single) — PK param is NtSinglePk, not raw UUID+    _nsSel :: Hasql.Statement.Statement NtSinglePk (Maybe NtSingle)+    _nsSel = selectNtSingle++    _nsDel :: Hasql.Statement.Statement NtSinglePk ()+    _nsDel = deleteNtSingle++    _nsIns :: Hasql.Statement.Statement NtSingle NtSingle+    _nsIns = insertNtSingle++    -- Newtype PK (composite) — PK param is NtCompositePk record, not raw tuple+    _ncSel :: Hasql.Statement.Statement NtCompositePk (Maybe NtComposite)+    _ncSel = selectNtComposite++    _ncDel :: Hasql.Statement.Statement NtCompositePk ()+    _ncDel = deleteNtComposite++    _ncIns :: Hasql.Statement.Statement NtComposite NtComposite+    _ncIns = insertNtComposite++    _pdDec :: Hasql.Decoders.Row PrefixDemo+    _pdDec = prefixDemoDecoder++    _pdEnc :: Hasql.Encoders.Params PrefixDemo+    _pdEnc = prefixDemoEncoder++    _pdIns :: Hasql.Statement.Statement PrefixDemo PrefixDemo+    _pdIns = insertPrefixDemo++    _kwDec :: Hasql.Decoders.Row KeywordCols+    _kwDec = keywordColsDecoder++    _kwEnc :: Hasql.Encoders.Params KeywordCols+    _kwEnc = keywordColsEncoder++    _kwIns :: Hasql.Statement.Statement KeywordCols KeywordCols+    _kwIns = insertKeywordCols++    -- Batch with single PK+    _smWp :: Hasql.Statement.Statement [UUID] [WithPk]+    _smWp = selectManyWithPk++    _dmWp :: Hasql.Statement.Statement [UUID] ()+    _dmWp = deleteManyWithPk++    _imWp :: Hasql.Statement.Statement [WithPk] [WithPk]+    _imWp = insertManyWithPk++    _umWp :: Hasql.Statement.Statement [WithPk] [WithPk]+    _umWp = updateManyWithPk++    -- Batch with composite PK+    _smCp :: Hasql.Statement.Statement [(UUID, Int32)] [CompositePk]+    _smCp = selectManyCompositePk++    _dmCp :: Hasql.Statement.Statement [(UUID, Int32)] ()+    _dmCp = deleteManyCompositePk++    _imCp :: Hasql.Statement.Statement [CompositePk] [CompositePk]+    _imCp = insertManyCompositePk++    _umCp :: Hasql.Statement.Statement [CompositePk] [CompositePk]+    _umCp = updateManyCompositePk++    -- Batch insert (always generated, even no-PK tables)+    _imNp :: Hasql.Statement.Statement [NoPk] [NoPk]+    _imNp = insertManyNoPk++    -- Batch with defaulted PK (insert excludes PK columns)+    _imU :: Hasql.Statement.Statement [Users] [Users]+    _imU = insertManyUsers++    -- Batch with newtype PKs+    _smNs :: Hasql.Statement.Statement [NtSinglePk] [NtSingle]+    _smNs = selectManyNtSingle++    _smNc :: Hasql.Statement.Statement [NtCompositePk] [NtComposite]+    _smNc = selectManyNtComposite++    -- Batch with enum column+    _wrSmany :: Hasql.Statement.Statement [UUID] [WithRole]+    _wrSmany = selectManyWithRole++    _wrDmany :: Hasql.Statement.Statement [UUID] ()+    _wrDmany = deleteManyWithRole++    _wrImany :: Hasql.Statement.Statement [WithRole] [WithRole]+    _wrImany = insertManyWithRole++    _wrUmany :: Hasql.Statement.Statement [WithRole] [WithRole]+    _wrUmany = updateManyWithRole++----------------------------------------------------------------------------------------------------+-- Prefixed field name test+----------------------------------------------------------------------------------------------------++testPrefixedFields :: IO ()+testPrefixedFields = do+  let pd = PrefixDemo {prefixDemoVal = 42}+  assertEqual "prefixed field named \"val\"" 42 (prefixDemoVal pd)+  putStrLn "Prefixed fields test passed ✔"++----------------------------------------------------------------------------------------------------+-- Keyword sanitization test+----------------------------------------------------------------------------------------------------++{-  Verify that PostgreSQL columns named after Haskell reserved keywords get+    an apostrophe suffix in the generated record fields. If this function+    compiles and the field names are accessible, the sanitization works.+-}+testKeywordSanitization :: IO ()+testKeywordSanitization = withTestConnection $ \conn -> do+  let kw =+        KeywordCols+          { id = Data.UUID.nil+          , type' = "something" :: Text+          , class' = Just ("someclass" :: Text)+          , data' = 42 :: Int32+          }++  -- Insert via typeclass — exercises encoder with sanitized field names+  inserted <- runSession conn (Q.insert kw)+  assertEqual "keyword sanitization > type'" kw.type' inserted.type'+  assertEqual "keyword sanitization > class'" kw.class' inserted.class'+  assertEqual "keyword sanitization > data'" kw.data' inserted.data'++  -- Clean up+  runSession conn (Q.delete @KeywordCols inserted.id)++  putStrLn "Keyword sanitization test passed ✔"++----------------------------------------------------------------------------------------------------+-- CRUD functional test+----------------------------------------------------------------------------------------------------++testUsersCrud :: IO ()+testUsersCrud = withTestConnection $ \conn -> do+  let testUuid = Data.UUID.nil+  let user =+        Users+          { id = testUuid+          , name = "Alice"+          , email = Just "alice@example.com"+          }++  -- Insert via typeclass+  inserted <- runSession conn (Q.insert user)+  assertNotEqual "insert roundtrip > id" user.id inserted.id+  assertEqual "insert roundtrip > name" user.name inserted.name+  assertEqual "insert roundtrip > email" user.email inserted.email++  -- Select by PK via typeclass+  found <- runSession conn (Q.select @Users inserted.id)+  assertEqual "select by PK" (Just inserted) found+  assertEqual "select by PK > id" (Just inserted.id) (fmap (.id) found)++  -- Update via typeclass+  let updatedUser =+        Users+          { id = inserted.id+          , name = "Bob"+          , email = Just "bob@example.com"+          }+  updated <- runSession conn (Q.update updatedUser)+  assertEqual "update roundtrip" (Just updatedUser) updated++  -- Verify update persisted+  found2 <- runSession conn (Q.select @Users inserted.id)+  assertEqual "select after update" (Just updatedUser) found2++  -- Delete via typeclass+  runSession conn (Q.delete @Users inserted.id)++  -- Verify deletion+  gone <- runSession conn (Q.select @Users inserted.id)+  assertEqual "select after delete" (Nothing :: Maybe Users) gone++  putStrLn "CRUD test passed ✔"++----------------------------------------------------------------------------------------------------+-- Derivation tests+----------------------------------------------------------------------------------------------------++testUsersDerivation :: IO ()+testUsersDerivation = do+  testUuid <- nextRandom+  let user =+        Users+          { id = testUuid+          , name = "Alice"+          , email = Just "alice@example.com"+          }+      encoded = encode user+  case eitherDecode encoded of+    Left err      -> error ("JSON roundtrip failed: " <> err)+    Right decoded -> assertEqual "JSON roundtrip" user decoded++  -- Also test with a Nothing field+  let userNoEmail =+        Users+          { id = testUuid+          , name = "Bob"+          , email = Nothing+          }+      encodedNoEmail = encode userNoEmail+  case eitherDecode encodedNoEmail of+    Left err -> error ("JSON roundtrip (null email) failed: " <> err)+    Right decoded -> assertEqual "JSON roundtrip (null email)" userNoEmail decoded++  assertEqual+    "show derivation"+    ("Users {id = " <> show testUuid <> ", name = \"Alice\", email = Just \"alice@example.com\"}")+    (show user)++  putStrLn "Derivation test passed ✔"++----------------------------------------------------------------------------------------------------+-- HasEnum utility test+----------------------------------------------------------------------------------------------------++testEnumUtilities :: IO ()+testEnumUtilities = do+  assertEqual "allValues length" 3 (length (allValues :: [UserRole]))+  assertEqual "allValues order" [Admin, Moderator, Member] (allValues :: [UserRole])+  assertEqual "toText Admin" "admin" (toText Admin)+  assertEqual "toText Moderator" "moderator" (toText Moderator)+  assertEqual "toText Member" "member" (toText Member)+  assertEqual "fromText admin" (Just Admin) (fromText "admin")+  assertEqual "fromText moderator" (Just Moderator) (fromText "moderator")+  assertEqual "fromText member" (Just Member) (fromText "member")+  assertEqual "fromText bogus" (Nothing :: Maybe UserRole) (fromText "bogus")+  putStrLn "Enum utilities test passed ✔"++----------------------------------------------------------------------------------------------------+-- Enum round-trip test+----------------------------------------------------------------------------------------------------++testEnumRoundTrip :: IO ()+testEnumRoundTrip = withTestConnection $ \conn -> do+  let wr =+        WithRole+          { id = Data.UUID.nil+          , name = "EnumUser"+          , role' = Admin+          }++  -- Insert via typeclass+  inserted <- runSession conn (Q.insert wr)+  assertEqual "enum roundtrip > role'" Admin inserted.role'+  assertEqual "enum roundtrip > name" "EnumUser" inserted.name++  -- Select by PK via typeclass+  found <- runSession conn (Q.select @WithRole inserted.id)+  assertEqual "enum select" (Just inserted) found++  -- Update to a different role+  let updated = inserted {role' = Member}+  result <- runSession conn (Q.update updated)+  assertEqual "enum update > role'" (Just Member) (fmap (.role') result)++  -- Clean up+  runSession conn (Q.delete @WithRole inserted.id)++  -- Verify deletion+  gone <- runSession conn (Q.select @WithRole inserted.id)+  assertEqual "enum delete" (Nothing :: Maybe WithRole) gone++  putStrLn "Enum roundtrip test passed ✔"++----------------------------------------------------------------------------------------------------+-- View functional test+----------------------------------------------------------------------------------------------------++testViewSelect :: IO ()+testViewSelect = withTestConnection $ \conn -> do+  -- Insert a user with email (appears in user_emails view)+  let user =+        Users+          { id = Data.UUID.nil+          , name = "ViewUser"+          , email = Just "view@example.com"+          }+  inserted <- runSession conn (Q.insert user)++  -- Select all from the view via typeclass+  rows <- runSession conn (Q.selectView @UserEmails)+  assertTrue "view returns rows" (not (null rows))+  assertTrue "view contains inserted user" (any (\ue -> ue.id == Just inserted.id) rows)++  -- Clean up+  runSession conn (Q.delete @Users inserted.id)++  putStrLn "View test passed ✔"++----------------------------------------------------------------------------------------------------+-- Newtype PK CRUD test+----------------------------------------------------------------------------------------------------++testNewtypePkCrud :: IO ()+testNewtypePkCrud = withTestConnection $ \conn -> do+  testUuid <- nextRandom+  let user =+        NtSingle+          { id = NtSinglePk testUuid+          , name = "NtAlice"+          , email = Just "nt@example.com"+          }++  -- Insert+  inserted <- runSession conn (Hasql.Session.statement user insertNtSingle)+  assertEqual "nt insert > name" "NtAlice" inserted.name+  assertEqual "nt insert > email" (Just "nt@example.com") inserted.email++  -- Select by newtype PK+  found <- runSession conn (Hasql.Session.statement inserted.id selectNtSingle)+  assertEqual "nt select by PK" (Just inserted) found++  -- Update+  let updatedUser =+        NtSingle+          { id = inserted.id+          , name = "NtBob"+          , email = Just "ntbob@example.com"+          }+  updated <- runSession conn (Hasql.Session.statement updatedUser updateNtSingle)+  assertEqual "nt update" (Just updatedUser) updated++  -- Delete by newtype PK+  runSession conn (Hasql.Session.statement inserted.id deleteNtSingle)+  gone <- runSession conn (Hasql.Session.statement inserted.id selectNtSingle)+  assertEqual "nt delete" (Nothing :: Maybe NtSingle) gone++  putStrLn "Newtype PK CRUD test passed ✔"++----------------------------------------------------------------------------------------------------+-- HasPrimaryKey test+----------------------------------------------------------------------------------------------------++testHasPrimaryKey :: IO ()+testHasPrimaryKey = do+  testUuid <- nextRandom++  -- Test HasPrimaryKey on existing table with raw UUID PK (no newtypes)+  let wp = WithPk {pkid = testUuid, name = "Test", email = Nothing, age = Nothing}+  assertEqual "withPk toPk" testUuid (toPk wp)+  assertEqual "withPk wrapPk" testUuid (wrapPk @WithPk testUuid)+  assertEqual "withPk unwrapPk" testUuid (unwrapPk @WithPk testUuid)+  assertEqual "withPk rawPk" testUuid (rawPk wp)++  -- Test HasPrimaryKey on newtype single PK table+  let ns = NtSingle {id = NtSinglePk testUuid, name = "NtTest", email = Nothing}+  assertEqual "ntSingle toPk" (NtSinglePk testUuid) (toPk ns)+  assertEqual "ntSingle wrapPk" (NtSinglePk testUuid) (wrapPk @NtSingle testUuid)+  assertEqual "ntSingle unwrapPk" testUuid (unwrapPk @NtSingle (NtSinglePk testUuid))+  assertEqual "ntSingle rawPk" testUuid (rawPk ns)++  -- Test wrapPk / unwrapPk roundtrip+  let pk = NtSinglePk testUuid+  assertEqual "ntSingle wrap/unwrap roundtrip" pk (wrapPk @NtSingle (unwrapPk @NtSingle pk))++  -- Test HasPrimaryKey on composite PK table (no newtypes)+  let cp = CompositePk {tenantId = testUuid, itemId = 42, payload = "test"}+  assertEqual "compositePk toPk" (testUuid, 42) (toPk cp)+  assertEqual "compositePk rawPk" (testUuid, 42) (rawPk cp)++  -- Test HasPrimaryKey on newtype composite PK table+  let nc = NtComposite {tenantId = testUuid, itemId = 99, payload = "nctest"}+      ncPk = NtCompositePk {tenantId = testUuid, itemId = 99}+  assertEqual "ntComposite toPk" ncPk (toPk nc)+  assertEqual "ntComposite wrapPk" ncPk (wrapPk @NtComposite (testUuid, 99))+  assertEqual "ntComposite unwrapPk" (testUuid, 99) (unwrapPk @NtComposite ncPk)+  assertEqual "ntComposite rawPk" (testUuid, 99) (rawPk nc)++  putStrLn "HasPrimaryKey test passed ✔"++----------------------------------------------------------------------------------------------------+-- Batch CRUD functional test+----------------------------------------------------------------------------------------------------++testBatchCrud :: IO ()+testBatchCrud = withTestConnection $ \conn -> do+  uuid1 <- nextRandom+  uuid2 <- nextRandom+  uuid3 <- nextRandom++  let rec1 = WithPk {pkid = uuid1, name = "Batch1", email = Just "b1@test.com", age = Just 10}+      rec2 = WithPk {pkid = uuid2, name = "Batch2", email = Nothing, age = Just 20}+      rec3 = WithPk {pkid = uuid3, name = "Batch3", email = Just "b3@test.com", age = Nothing}++  -- insertMany+  inserted <- runSession conn (Hasql.Session.statement [rec1, rec2, rec3] insertManyWithPk)+  assertEqual "insertMany count" 3 (length inserted)++  -- selectMany all 3+  found <- runSession conn (Hasql.Session.statement [uuid1, uuid2, uuid3] selectManyWithPk)+  assertEqual "selectMany count" 3 (length found)+  assertTrue "selectMany contains uuid1" (any (\r -> r.pkid == uuid1) found)+  assertTrue "selectMany contains uuid2" (any (\r -> r.pkid == uuid2) found)+  assertTrue "selectMany contains uuid3" (any (\r -> r.pkid == uuid3) found)++  -- updateMany (use full construction to avoid ambiguous record update)+  let upd1 = WithPk {pkid = uuid1, name = "Updated1", email = rec1.email, age = rec1.age}+      upd2 = WithPk {pkid = uuid2, name = "Updated2", email = rec2.email, age = rec2.age}+      upd3 = WithPk {pkid = uuid3, name = "Updated3", email = rec3.email, age = rec3.age}+  updated <- runSession conn (Hasql.Session.statement [upd1, upd2, upd3] updateManyWithPk)+  assertEqual "updateMany count" 3 (length updated)+  assertTrue "updateMany name1" (any (\(r :: WithPk) -> r.name == "Updated1") updated)+  assertTrue "updateMany name2" (any (\(r :: WithPk) -> r.name == "Updated2") updated)+  assertTrue "updateMany name3" (any (\(r :: WithPk) -> r.name == "Updated3") updated)++  -- deleteMany first 2+  runSession conn (Hasql.Session.statement [uuid1, uuid2] deleteManyWithPk)++  -- selectMany all 3 — only the third should remain+  remaining <- runSession conn (Hasql.Session.statement [uuid1, uuid2, uuid3] selectManyWithPk)+  assertEqual "after deleteMany count" 1 (length remaining)+  assertTrue "after deleteMany only uuid3 remains" (any (\r -> r.pkid == uuid3) remaining)++  -- Clean up+  runSession conn (Hasql.Session.statement [uuid3] deleteManyWithPk)++  putStrLn "Batch CRUD test passed ✔"++----------------------------------------------------------------------------------------------------+-- Batch typeclass test+----------------------------------------------------------------------------------------------------++testBatchTypeclasses :: IO ()+testBatchTypeclasses = withTestConnection $ \conn -> do+  uuid1 <- nextRandom+  uuid2 <- nextRandom++  let rec1 = WithPk {pkid = uuid1, name = "TC1", email = Just "tc1@test.com", age = Just 30}+      rec2 = WithPk {pkid = uuid2, name = "TC2", email = Nothing, age = Nothing}++  -- insertMany via typeclass+  inserted <- runSession conn (Q.insertMany [rec1, rec2])+  assertEqual "typeclass insertMany count" 2 (length inserted)++  -- selectMany via typeclass+  found <- runSession conn (Q.selectMany @WithPk [uuid1, uuid2])+  assertEqual "typeclass selectMany count" 2 (length found)++  -- updateMany via typeclass (use full construction to avoid ambiguous record update)+  let upd1 = WithPk {pkid = uuid1, name = "TC1-updated", email = rec1.email, age = rec1.age}+      upd2 = WithPk {pkid = uuid2, name = "TC2-updated", email = rec2.email, age = rec2.age}+  updated <- runSession conn (Q.updateMany [upd1, upd2])+  assertEqual "typeclass updateMany count" 2 (length updated)+  assertTrue "typeclass updateMany name" (any (\(r :: WithPk) -> r.name == "TC1-updated") updated)++  -- deleteMany via typeclass+  runSession conn (Q.deleteMany @WithPk [uuid1, uuid2])++  -- Verify deletion+  gone <- runSession conn (Q.selectMany @WithPk [uuid1, uuid2])+  assertEqual "typeclass deleteMany" 0 (length gone)++  putStrLn "Batch typeclass test passed ✔"++----------------------------------------------------------------------------------------------------+-- Test helpers+----------------------------------------------------------------------------------------------------++withTestConnection :: (Hasql.Connection.Connection -> IO a) -> IO a+withTestConnection =+  bracket acquire Hasql.Connection.release+  where+    acquire :: IO Hasql.Connection.Connection+    acquire = do+      result <- Hasql.Connection.acquire ""+      case result of+        Left err   -> error ("Failed to connect: " <> show err)+        Right conn -> pure conn++runSession :: Hasql.Connection.Connection -> Hasql.Session.Session a -> IO a+runSession conn session = do+  result <- Hasql.Session.run session conn+  case result of+    Left err -> error ("Session failed: " <> show err)+    Right a  -> pure a++assertEqual :: (Eq a, Show a) => String -> a -> a -> IO ()+assertEqual label expected actual+  | expected == actual = pure ()+  | otherwise =+      die $ "Assertion failed (" <> label <> "): expected " <> show expected <> " but got " <> show actual++assertTrue :: String -> Bool -> IO ()+assertTrue label condition+  | condition = pure ()+  | otherwise = die ("Assertion failed (" <> label <> "): expected True but got False")++assertNotEqual :: (Eq a, Show a) => String -> a -> a -> IO ()+assertNotEqual label unexpected actual+  | unexpected /= actual = pure ()+  | otherwise =+      die $ "Assertion failed (" <> label <> "): expected NOT " <> show unexpected <> " but got " <> show actual