diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Changelog + +1.0.0: Hello, world! The README is probably a better source for what this is diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/hasql-generate.cabal b/hasql-generate.cabal new file mode 100644 --- /dev/null +++ b/hasql-generate.cabal @@ -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 diff --git a/src/Hasql/Generate.hs b/src/Hasql/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate.hs @@ -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 + ) diff --git a/src/Hasql/Generate/Class.hs b/src/Hasql/Generate/Class.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/Class.hs @@ -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 diff --git a/src/Hasql/Generate/Codec.hs b/src/Hasql/Generate/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/Codec.hs @@ -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 diff --git a/src/Hasql/Generate/Column.hs b/src/Hasql/Generate/Column.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/Column.hs @@ -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 diff --git a/src/Hasql/Generate/Config.hs b/src/Hasql/Generate/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/Config.hs @@ -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 = [] + } diff --git a/src/Hasql/Generate/Connection.hs b/src/Hasql/Generate/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/Connection.hs @@ -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] diff --git a/src/Hasql/Generate/Internal/Introspect.hs b/src/Hasql/Generate/Internal/Introspect.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/Internal/Introspect.hs @@ -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) diff --git a/src/Hasql/Generate/TH.hs b/src/Hasql/Generate/TH.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Generate/TH.hs @@ -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\ :: 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\ :: 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\ :: 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\ :: 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 :: 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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