hasql-check (empty) → 0.5.0.0

raw patch · 19 files changed

+5450/−0 lines, 19 filesdep +aesondep +arraydep +base

Dependencies added: aeson, array, base, bytestring, containers, directory, filepath, hasql, hasql-check, hasql-th, mtl, postgresql-syntax, pqi, pqi-ffi, process, scientific, sydtest, template-haskell, temporary, text, time, uuid, vector

Files

• ChangeLog.md +39/−0
• LICENSE +28/−0
• README.md +639/−0
• app/Main.hs +342/−0
• hasql-check.cabal +257/−0
• src/Hasql/Check.hs +100/−0
• src/Hasql/Check/Annotate.hs +119/−0
• src/Hasql/Check/Compile.hs +204/−0
• src/Hasql/Check/Finding.hs +252/−0
• src/Hasql/Check/Inferred.hs +643/−0
• src/Hasql/Check/Inferred/Quote.hs +393/−0
• src/Hasql/Check/Inferred/TH.hs +129/−0
• src/Hasql/Check/Lexer.x +276/−0
• src/Hasql/Check/Nullability.hs +530/−0
• src/Hasql/Check/Parser.y +60/−0
• src/Hasql/Check/Quoter.hs +39/−0
• src/Hasql/Check/TH.hs +131/−0
• src/Hasql/Check/Types.hs +276/−0
• test/Main.hs +993/−0

@@ -0,0 +1,39 @@+# Changelog++## 0.5.0.0++Add `Hasql.Check.Inferred.TH`: quoters for statements without annotations,+whose parameter and result types come from the Haskell types they are used+at. Each type names its Postgres type at the type level, so a `newtype`+deriving `Value`, or deriving it via `Domain`, is checked as such, and+`Vector`s and lists are arrays, and an enumeration deriving it via `PgEnum`+is an enum, whose labels the checker compares with the database's. Add+`--inferred`, which checks them, and the `hasql-check-ghc` package, which+gets their types from GHC: `Hasql.Check.Plugin`, a GHC plugin that checks+them while they compile, and `hasql-check-hie`, which reads them from GHC's+`.hie` files.++## 0.4.0.0++Add `--types`, and `HASQL_CHECK_TYPES` for compile-time checks: warn about+annotations that convert a table column, or a parameter assigned to one, to a+narrower type.++Suppress warnings with `hasql-check: allow` directives above a quote, or with+a baseline file (`--baseline`, `--write-baseline`, `HASQL_CHECK_BASELINE`).+Add `--fail-on-warnings`, and `--files0-from` for checking every file in one+run.++## 0.3.0.0++Add `Hasql.Check.TH`: hasql-th's quasiquoters, checking their statements+against a database while they compile.++## 0.2.0.0++Add `--nullability`: warn about result columns annotated non-null that can be+null.++## 0.1.0.0++Initial release.

@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2021-2026, Kronor++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,639 @@+# hasql-check++Check the SQL in your [hasql-th](https://hackage.haskell.org/package/hasql-th)+quasiquotes against a real PostgreSQL database, before it reaches production.++hasql-th checks that a statement parses. `hasql-check` asks Postgres whether it+runs against your schema, and whether the types you annotated it with hold:++```+$ hasql-check src/Shop/Customers.hs+Error in src/Shop/Customers.hs:12:5+ERROR:  column "emial" does not exist+LINE 1: SELECT emial :: text FROM customer WHERE id = $1 :: int8+               ^+HINT:  Perhaps you meant to reference the column "customer.email".+```++It runs as a command for CI, and as a drop-in replacement for `Hasql.TH`+that reports the same errors while GHC compiles. It also comes with quoters+that need no annotations at all, taking the types from how the statement is+used in Haskell.++## Contents++- [Installing](#installing)+- [The example schema](#the-example-schema)+- [Statements that do not match the schema](#statements-that-do-not-match-the-schema)+- [Columns that can be null](#columns-that-can-be-null---nullability)+- [Annotations that narrow a value](#annotations-that-narrow-a-value---types)+- [Allowing a warning on purpose](#allowing-a-warning-on-purpose)+- [Adopting it in an existing codebase](#adopting-it-in-an-existing-codebase)+- [Running it in CI](#running-it-in-ci)+- [Checking while you compile](#checking-while-you-compile)+- [Statements without annotations](#statements-without-annotations)+- [Reference](#reference)+- [Limitations](#limitations)++## Installing++```+git clone https://github.com/kronor-io/hasql-check+cd hasql-check+cabal install exe:hasql-check+```++It links against libpq, so install your platform's PostgreSQL client library+first (`libpq-dev` on Debian and Ubuntu).++## The example schema++The examples below run against this schema:++```sql+create table customer (+  id       int8 primary key,+  email    text not null,+  nickname text+);++create table orders (+  id          int8 primary key,+  customer_id int8 not null references customer,+  total_cents int8 not null,+  quantity    int2 not null+);+```++Point `hasql-check` at the database with `--database`, or set+`DATABASE_URL`:++```+export DATABASE_URL=postgres://localhost/shop+```++## Statements that do not match the schema++`hasql-check` finds every hasql-th quote in the files you give it and+`PREPARE`s its statement. Given this module:++```haskell+customerEmail :: Statement Int64 (Maybe Text)+customerEmail =+    [maybeStatement|+        select emial :: text+        from customer+        where id = $1 :: int8+    |]+```++```+$ hasql-check src/Shop/Customers.hs+Error in src/Shop/Customers.hs:12:5+ERROR:  column "emial" does not exist+LINE 1: SELECT emial :: text FROM customer WHERE id = $1 :: int8+               ^+HINT:  Perhaps you meant to reference the column "customer.email".+```++It exits 1 when any statement fails. A dropped column, a renamed function or a+changed type in a migration shows up here, for every statement that uses it.++To see which quotes it would check, without connecting:++```+$ hasql-check --list src/Shop/*.hs+src/Shop/Customers.hs:12:5: maybeStatement+src/Shop/Orders.hs:11:5: maybeStatement+src/Shop/Orders.hs:19:5: resultlessStatement+src/Shop/Profiles.hs:12:5: maybeStatement+src/Shop/Profiles.hs:20:5: vectorStatement+```++## Columns that can be null: `--nullability`++hasql-th decodes `nickname :: text` as a `Text`. If the column holds a `NULL`,+decoding fails at runtime, and only for that row. `--nullability` asks the+database:++```haskell+profile :: Statement Int64 (Maybe (Text, Text))+profile =+    [maybeStatement|+        select email :: text, nickname :: text+        from customer+        where id = $1 :: int8+    |]++customerTotals :: Statement () (Vector (Text, Int64))+customerTotals =+    [vectorStatement|+        select c.email :: text, o.total_cents :: int8+        from customer c+        left join orders o on o.customer_id = c.id+    |]+```++```+$ hasql-check --nullability src/Shop/Profiles.hs+Warning in src/Shop/Profiles.hs:12:5+  column 2 (nickname) is annotated non-null, but public.customer.nickname is nullable+Warning in src/Shop/Profiles.hs:20:5+  column 2 (total_cents) is annotated non-null, but comes from the nullable side of an outer join+```++`total_cents` is `NOT NULL` in its table, but a customer without orders gets a+`NULL` from the left join. Any of these fixes the warning:++```haskell+select email :: text, nickname :: text?    -- decode it as Maybe Text+...+where id = $1 :: int8 and nickname is not null    -- or only return rows that have one+```++or, if every row really has one, a `NOT NULL` constraint on the column.++Expressions (`count(*)`, `coalesce(...)`) and views are not checked, since+Postgres does not say whether they can be null.++## Annotations that narrow a value: `--types`++An annotation is a cast, and `PREPARE` accepts a cast that loses information.+`--types` warns about them:++```haskell+orderTotal :: Statement Int64 (Maybe Int32)+orderTotal =+    [maybeStatement|+        select total_cents :: int4+        from orders+        where id = $1 :: int8+    |]++placeOrder :: Statement (Int64, Int64, Int64, Int32) ()+placeOrder =+    [resultlessStatement|+        insert into orders (id, customer_id, total_cents, quantity)+        values ($1 :: int8, $2 :: int8, $3 :: int8, $4 :: int4)+    |]+```++```+$ hasql-check --types src/Shop/Orders.hs+Warning in src/Shop/Orders.hs:11:5+  column 1 (total_cents) is annotated integer, but is a bigint: it may overflow+Warning in src/Shop/Orders.hs:19:5+  parameter $4 is annotated integer, but is assigned to a smallint column: it may overflow+```++Both work until a value does not fit. It warns about lossy integer and+floating-point conversions, `numeric` to integers or floats, and+`timestamptz` to `timestamp` or `date`. It checks result columns that read a+table column, and parameters assigned in `INSERT ... VALUES` and+`UPDATE ... SET`. It does not check expressions (`count(*) :: int4` is almost+always deliberate), or parameters that are only compared (`where id = $1 ::+int4` widens the column, it does not narrow the parameter).++## Allowing a warning on purpose++When a warning is wrong for your data, say so in a comment directly above the+quote, naming the rule and the column (or `$n` for a parameter):++```haskell+profile =+    -- Every customer picks a nickname at sign-up; the column is nullable+    -- only for accounts migrated from the old shop.+    -- hasql-check: allow nullable(nickname)+    [maybeStatement|+        select email :: text, nickname :: text+        ...++customerTotals =+    -- hasql-check: allow nullable(total)+    [vectorStatement|+        select c.email :: text, o.total_cents :: int8+        ...+```++The first directive silences the `nickname` warning. The second names a column+the statement does not have, so it allows nothing, and that is reported too,+which keeps typos and stale directives from piling up:++```+$ hasql-check --nullability src/Shop/Profiles.hs+Warning in src/Shop/Profiles.hs:24:5+  column 2 (total_cents) is annotated non-null, but comes from the nullable side of an outer join+  allow nullable(total) suppresses nothing+```++The rules are `nullable` and `narrowing`. Several go on one line,+`-- hasql-check: allow nullable(street, city), narrowing($4)`. Quote column+names that have spaces: `nullable("display name")`. (A directive cannot go+inside the SQL, because hasql-th does not accept SQL comments in a quote.)++## Adopting it in an existing codebase++An existing codebase will have warnings. To fail CI on new ones without+fixing the old ones first, record them in a baseline. (These examples assume+the `emial` typo above is fixed; a statement that does not prepare is always+an error, baseline or not.)++```+$ hasql-check --nullability --types --write-baseline .hasql-check-baseline src/Shop/*.hs+$ cat .hasql-check-baseline+# hasql-check baseline: findings to ignore. Written by --write-baseline.+09d21523a3c4b3f0 narrowing total_cents # src/Shop/Orders.hs:11:5+07d99122eb9eeadd narrowing $4 # src/Shop/Orders.hs:19:5+f44d2176be2dd654 nullable nickname # src/Shop/Profiles.hs:12:5+9bdbaed7ce894852 nullable total_cents # src/Shop/Profiles.hs:20:5+```++Commit it, and check against it with `--fail-on-warnings`. The existing+findings pass:++```+$ hasql-check --nullability --types --baseline .hasql-check-baseline --fail-on-warnings src/Shop/*.hs+$ echo $?+0+```++A new one fails:++```haskell+customerNickname :: Statement Int64 (Vector Text)+customerNickname =+    [vectorStatement|+        select c.nickname :: text+        from orders o join customer c on c.id = o.customer_id+        where o.id = $1 :: int8+    |]+```++```+$ hasql-check --nullability --types --baseline .hasql-check-baseline --fail-on-warnings src/Shop/*.hs+Warning in src/Shop/Orders.hs:26:5+  column 1 (nickname) is annotated non-null, but public.customer.nickname is nullable+$ echo $?+1+```++An entry is keyed by a hash of the statement, not by its line, so moving a+quote or reformatting it keeps the entry, and changing its SQL drops it.+Rewrite the baseline with `--write-baseline` as you fix findings.++## Running it in CI++Run your migrations against a fresh database, then check every module. Give+it the file list with `--files0-from` rather than `xargs`, which can split the+files across several runs:++```yaml+jobs:+  hasql-check:+    runs-on: ubuntu-latest+    services:+      postgres:+        image: postgres:18+        env:+          POSTGRES_PASSWORD: postgres+        ports: ["5432:5432"]+    env:+      DATABASE_URL: postgres://postgres:postgres@localhost:5432/postgres+    steps:+      - uses: actions/checkout@v4+      - run: ./migrate.sh   # however you apply your schema+      - run: cabal install exe:hasql-check   # from a checkout of this repository+      - run: |+          find src -name '*.hs' -print0 \+            | hasql-check --nullability --types \+                --baseline .hasql-check-baseline --fail-on-warnings --files0-from -+```++If your statements read session settings with `current_setting(...)`, give+them placeholder values (`PGOPTIONS="-c app.tenant_id=0"`). Postgres+evaluates those calls while planning, and the nullability check plans every+statement.++## Checking while you compile++`Hasql.Check.TH` exports hasql-th's quasiquoters, and checks each statement+against a database as GHC compiles it. Swap the import:++```haskell+import Hasql.Check.TH    -- instead of: import Hasql.TH+```++and set `HASQL_CHECK_DATABASE_URL`. The error then appears at the quote, in+GHC's output and in your editor:++```+$ HASQL_CHECK_DATABASE_URL=postgres://localhost/shop cabal build+src/Shop/Customers.hs:12:21: error: [GHC-39584]+    • hasql-check: the statement does not prepare against HASQL_CHECK_DATABASE_URL:+ERROR:  column "emial" does not exist+LINE 1: SELECT emial :: text FROM customer WHERE id = $1 :: int8+               ^+HINT:  Perhaps you meant to reference the column "customer.email".++    • In the quasi-quotation:+        [maybeStatement|+        select emial :: text+        from customer+        where id = $1 :: int8+    |]+```++Without the variable nothing is checked, so CI and release builds behave+exactly as with `Hasql.TH`. If the database cannot be reached, the build+prints one warning and carries on. Each check takes about a millisecond, over+one connection shared by every quote.++GHC only runs a quote when it recompiles the module, so a migration does not+recheck modules that have not changed. Set `HASQL_CHECK_SCHEMA_FILE` to a file+that changes with your schema, such as a migration plan, and every module+with a checked quote depends on it. GHCi and ghciwatch notice the change on+their own; for `cabal build`, also list the file in the package's+`extra-source-files`. Keep running the command in CI, which checks everything+regardless.++## Statements without annotations++`Hasql.Check.Inferred.TH` has quoters that take no annotations. The Haskell+type a statement is used at decides its parameter and result types:++```haskell+import Hasql.Check.Inferred.TH++profile :: Statement Int64 (Maybe (Text, Maybe Text))+profile = [maybeStatement| select email, nickname from customer where id = $1 |]+```++The quoter annotates the parameters, and casts the result columns to the+types they are read as, in a projection around the statement:++```sql+WITH hasql_check_result (c1, c2) AS (SELECT email, nickname FROM customer WHERE id = $1 :: int8)+SELECT c1 :: text, c2 :: text FROM hasql_check_result+```++So a `varchar` column can be read as `Text` and an `int4` one as `Int64`, and+without them hasql's decoders need the exact type, and fail at runtime. The+statement itself is left as written, so its `DISTINCT ON`, `ORDER BY` and+`GROUP BY` mean what they did, and a `*` is cast too. A `WITH` list of its own+goes first, where a data-modifying statement in it must be.++The type does not have to be on the binding. GHC infers it from how the rows+are used, as it does for any other value:++```haskell+cancelPayment :: Int64 -> Text -> Session ()++cancelAll :: Int64 -> Session ()+cancelAll merchantId = do+    payments <- Session.statement merchantId [vectorStatement| select id, reference from payment where merchant_id = $1 |]+    for_ payments \(paymentId, reference) -> cancelPayment paymentId reference+```++Here the statement is a `Statement Int64 (Vector (Int64, Text))`, without+saying so anywhere.++Each Haskell type stands for one Postgres type:++| Haskell | Postgres |+|---|---|+| `Bool` | `bool` |+| `Int16`, `Int32`, `Int64` | `int2`, `int4`, `int8` |+| `Float`, `Double` | `float4`, `float8` |+| `Scientific` | `numeric` |+| `Text` | `text` |+| `ByteString` | `bytea` |+| `UUID` | `uuid` |+| `Day`, `TimeOfDay` | `date`, `time` |+| `LocalTime`, `UTCTime` | `timestamp`, `timestamptz` |+| `Aeson.Value` | `jsonb` |+| `Maybe a` | `a`, and may be NULL |+| `Vector a`, `[a]` | `a[]`; `Vector (Maybe a)` for elements that may be NULL |++Parameters and rows are a single value or a tuple of up to eight, and `()`+for no parameters.++### Your own types++A `newtype` is sent and read as the type it wraps:++```haskell+{-# LANGUAGE UndecidableInstances #-}++newtype Email = Email Text+    deriving newtype (Value)+```++For a column of a domain, derive through `Domain` and its name. The statement+then casts to the domain, so Postgres checks its constraints on what you send:++```haskell+newtype Quantity = Quantity Int16+    deriving (Value) via Domain "quantity" Int16+```++Each type's Postgres type is part of its `Value` instance, as the associated+type `PgType`, so a type of your own needs nothing else to be checked.+Deriving the instance needs `UndecidableInstances` in that module.++An enumeration is sent and read as a Postgres enum, each constructor as the+label of the same name:++```haskell+-- create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED');++data PaymentState = PENDING | PAID+    deriving stock (Generic)+    deriving (Value) via PgEnum "payment_state" PaymentState+```++The labels are part of the type too, so the checker compares them with the+enum's, for the way each statement uses it: a label the Haskell type cannot+read fails when the statement reads it, and one the database does not have+fails when it is sent.++```+Error in src/Shop/Enums.hs:20:11+column 1 (state) is read as Shop.Enums.PaymentState, which cannot read labels payment_state has: REFUNDED+```++### Checking them while you compile++The types are only known once GHC has type-checked the module, after the+quoter ran. A GHC plugin, `Hasql.Check.Plugin` from the `hasql-check-ghc`+package, checks each statement then, as `Hasql.Check.TH` does for hasql-th's+quoters. Add it to the package:++```+build-depends: hasql-check-ghc+ghc-options:   -fplugin=Hasql.Check.Plugin+```++and set `HASQL_CHECK_DATABASE_URL`, and the same environment variables as+for [`Hasql.Check.TH`](#environment-variables-for-hasqlcheckth-and-the-plugin). A statement+that does not fit the schema is a compile error at its quote, in GHC's output+and in your editor:++```+src/Shop/Newtypes.hs:35:34: error:+    hasql-check: the statement does not fit HASQL_CHECK_DATABASE_URL's schema:+      column 1 (nickname) is text, but is read as Shop.Newtypes.Nickname (bigint), which Postgres converts it to only when told to, and can fail to at runtime+   |+35 | nicknameOf = [singletonStatement| select nickname from customer where id = $1 |]+   |                                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+```++Without the variable it checks nothing, and if the database cannot be reached+it says so once and lets the build carry on.++### Checking them in CI++In CI, as for annotated statements, check everything with the command+instead. Have GHC write `.hie` files, and read the types from them with+`hasql-check-hie`, also from `hasql-check-ghc`:++```+$ cabal build --ghc-options='-fwrite-ide-info -hiedir=.hie'+$ hasql-check-hie $(find .hie -name '*.hie') > statements.jsonl+$ hasql-check --inferred statements.jsonl --nullability --types+```++Given this module:++```haskell+profile :: Statement Int64 (Maybe (Text, Maybe Text))+profile = [maybeStatement| select email, nickname from customer where id = $1 |]++orderTotal :: Statement Int64 (Maybe Int32)+orderTotal = [maybeStatement| select total_cents from orders where id = $1 |]++totals :: Statement () (Vector (Text, Int64))+totals = [vectorStatement| select c.email, o.total_cents from customer c left join orders o on o.customer_id = c.id |]++setQuantity :: Statement (Int64, Int64) ()+setQuantity = [resultlessStatement| update orders set quantity = $1 where id = $2 |]+```++it reports, in terms of the Haskell types:++```+Warning in src/Shop/Orders.hs:15:14+  column 1 (total_cents) is read as integer, but is a bigint: it may overflow+Warning in src/Shop/Orders.hs:18:10+  column 2 (total_cents) is not a Maybe in Haskell, but comes from the nullable side of an outer join+Warning in src/Shop/Orders.hs:21:15+  parameter $1 is sent as bigint, but is assigned to a smallint column: it may overflow+```++Each statement is checked as the annotated hasql-th statement it is sent as,+so everything above applies: errors, directives, baselines and+`--fail-on-warnings`. The statement is prepared as it is sent, with the+parameter types hasql sends. It also fails when the Haskell type reads a+different number of columns than the statement returns, and when it sends a+parameter the statement does not use: the statement runs, but whatever the+parameter was for, a filter say, does not happen.++A quote that is both in a source file you pass and in `--inferred` is checked+once, as inferred.++It also fails when a column must be converted in a way that can fail.+Postgres converts a value to almost any type when told to, even `'abc'` to a+number, so the cast must not be the only thing that makes a column fit:++```haskell+newtype Nickname = Nickname Int64+    deriving newtype (Value)++nicknameOf :: Statement CustomerId Nickname+nicknameOf = [singletonStatement| select nickname from customer where id = $1 |]+```++```+Error in src/Shop/Newtypes.hs:35:14+column 1 (nickname) is text, but is read as Shop.Newtypes.Nickname (bigint), which Postgres converts it to only when told to, and can fail to at runtime+```++A column whose type Postgres converts on its own, `varchar` to `text` or+`int4` to `int8`, is fine, and one that narrows is a `--types` warning.++A statement must have concrete types where it is written: a binding of type+`(Params p, Row r) => Statement p r` does not compile, since its Postgres+types cannot be known there. Give it a concrete type.++`hasql-check-hie` needs no database, so it can run inside a sandboxed build,+such as a Nix derivation, with only the `--inferred` step outside it.++The plugin and `hasql-check-hie` use GHC's own library, and GHC's+internals change with each release: build `hasql-check-ghc` with the GHC+your project uses. It supports GHC 9.12 and 9.14.++## Reference++### Options++| Option | |+|---|---|+| `-d`, `--database CONNINFO` | libpq connection string or URI. Default: `DATABASE_URL`, then `psql_conn_string`, then libpq's `PG*` variables. |+| `-n`, `--nullability` | Warn about non-null annotations on columns that can be null. |+| `-t`, `--types` | Warn about annotations that narrow a value. |+| `-b`, `--baseline FILE` | Ignore the findings listed in `FILE`. |+| `--write-baseline FILE` | Write the current findings to `FILE`. |+| `--fail-on-warnings` | Exit 1 if anything is warned about. |+| `--files0-from FILE` | Also check the NUL-separated file names in `FILE`, or on stdin with `-`. |+| `--inferred FILE` | Also check the statements of `Hasql.Check.Inferred.TH` in `FILE`, as `hasql-check-hie` writes them, or on stdin with `-`. Repeatable. |+| `-q`, `--quoter NAME` | Also check quotes using this quoter, for your own quoters built on hasql-th. Repeatable. |+| `-l`, `--list` | List the quotes that would be checked, without connecting. |++It checks `singletonStatement`, `maybeStatement`, `vectorStatement`,+`foldStatement`, `resultlessStatement` and `rowsAffectedStatement`, qualified+or not. It skips quotes inside comments and string literals, and+`uncheckedSql`, which is meant for scripts `PREPARE` cannot take.++Exit codes: 0 when everything prepares (and, with `--fail-on-warnings`,+nothing is warned about), 1 otherwise, 2 for bad arguments.++### Environment variables for `Hasql.Check.TH` and the plugin++| Variable | |+|---|---|+| `HASQL_CHECK_DATABASE_URL` | The database to check against. Unset: nothing is checked. |+| `HASQL_CHECK_NULLABILITY` | Set: also print the `--nullability` warnings. |+| `HASQL_CHECK_TYPES` | Set: also print the `--types` warnings. |+| `HASQL_CHECK_BASELINE` | A baseline file, as written by `--write-baseline`. |+| `HASQL_CHECK_SCHEMA_FILE` | A file that changes with the schema, for recompilation. |++The warnings go to stderr in GHC's format, rather than through GHC, so+`-Werror` does not turn them into errors.++## Limitations++- The nullability and narrowing checks skip statements they cannot take+  apart: `UNION`s, and `SELECT *`.+- They need the plan, so a statement that reads a session setting the+  connection lacks is only partly checked; see [Running it in CI](#running-it-in-ci).+- The quoters without annotations do not take composite types yet, nor+  arrays of more than one dimension. An enum's labels are its constructors'+  names; for others, write the `Value` instance, with its `PgLabels`. A `String` is not an array:+  use `Text`. A `CALL` cannot be+  wrapped, so its result columns must have exactly the types they are read+  as.+- The default build parses statements as upstream hasql-th does. Building with+  the `kronor-syntax` flag instead accepts the Haskell targets+  (`$f (a :: int8)`) and parameter fields (`$1.$field`) of Kronor's hasql-th+  fork, and needs Kronor's fork of `postgresql-syntax`.++## Development++`cabal test` starts a throwaway PostgreSQL server, so `initdb`, `pg_ctl` and+`psql` must be on `PATH`. The plugin's tests compile fixtures with GHC+itself, which finds the plugin through the package environment cabal writes+(`write-ghc-environment-files: always`, in `cabal.project`).++The nullability check follows [sqlx](https://github.com/launchbadge/sqlx)'s:+the statement is prepared again without its annotations so that Postgres+reports what each column reads, and its `EXPLAIN` plan shows the outer joins+and `IS NOT NULL` filters.

@@ -0,0 +1,342 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2022 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+module Main where++import Control.Applicative ((<|>))+import Control.Monad (forM, forM_, when)+import Data.ByteString qualified+import Data.Either (isLeft, rights)+import Data.List (isSuffixOf)+import Data.Text (Text)+import Data.Text qualified+import Data.Text.Encoding qualified+import Hasql.Check+import Hasql.Check.Finding+import Hasql.Check.Inferred.Quote (Inferred (..), annotated, checkInferred, readInferred)+import Hasql.Check.Lexer+import Hasql.Check.Nullability qualified as Nullability+import Hasql.Check.Parser+import Hasql.Check.Quoter+import Hasql.Check.Types qualified as Types+import Hasql.Connection qualified+import Hasql.Connection.Settings qualified+import Hasql.Session qualified+import Pqi qualified+import Pqi.Ffi qualified+import System.Console.GetOpt+import System.Directory (doesFileExist)+import System.Environment (getArgs, getProgName)+import System.Environment qualified+import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith)+import System.FilePath (splitDirectories)+import System.IO (hPutStr, hPutStrLn, stderr)+import Prelude hiding (lex)+++data Options = Options+    { database :: Maybe Text+    , extraQuoters :: [Text]+    , listOnly :: Bool+    , nullability :: Bool+    , types :: Bool+    , baselineFile :: Maybe FilePath+    , writeBaseline :: Maybe FilePath+    , failOnWarnings :: Bool+    , filesFrom :: Maybe FilePath+    , inferred :: [FilePath]+    , showHelp :: Bool+    }+++defaultOptions :: Options+defaultOptions =+    Options+        { database = Nothing+        , extraQuoters = []+        , listOnly = False+        , nullability = False+        , types = False+        , baselineFile = Nothing+        , writeBaseline = Nothing+        , failOnWarnings = False+        , filesFrom = Nothing+        , inferred = []+        , showHelp = False+        }+++options :: [OptDescr (Options -> Options)]+options =+    [ Option+        ['d']+        ["database"]+        (ReqArg (\s o -> o{database = Just (Data.Text.pack s)}) "CONNINFO")+        "libpq connection string or URI to prepare against"+    , Option+        ['q']+        ["quoter"]+        (ReqArg (\s o -> o{extraQuoters = Data.Text.pack s : o.extraQuoters}) "NAME")+        "also check quasiquotes with this quoter name (repeatable)"+    , Option+        ['l']+        ["list"]+        (NoArg (\o -> o{listOnly = True}))+        "list the quasiquotes that would be checked, without connecting"+    , Option+        ['n']+        ["nullability"]+        (NoArg (\o -> o{nullability = True}))+        "warn about result columns annotated non-null that can be null"+    , Option+        ['t']+        ["types"]+        (NoArg (\o -> o{types = True}))+        "warn about annotations that convert a value to a narrower type"+    , Option+        ['b']+        ["baseline"]+        (ReqArg (\s o -> o{baselineFile = Just s}) "FILE")+        "ignore the findings listed in FILE"+    , Option+        []+        ["write-baseline"]+        (ReqArg (\s o -> o{writeBaseline = Just s}) "FILE")+        "write the findings, after directives, to FILE as a baseline"+    , Option+        []+        ["fail-on-warnings"]+        (NoArg (\o -> o{failOnWarnings = True}))+        "exit 1 if anything is warned about"+    , Option+        []+        ["files0-from"]+        (ReqArg (\s o -> o{filesFrom = Just s}) "FILE")+        "also check the NUL-separated file names in FILE, or stdin if FILE is -"+    , Option+        []+        ["inferred"]+        (ReqArg (\s o -> o{inferred = s : o.inferred}) "FILE")+        "also check the quotes of Hasql.Check.Inferred.TH in FILE, as hasql-check-hie writes them, or stdin if FILE is - (repeatable)"+    , Option+        ['h']+        ["help"]+        (NoArg (\o -> o{showHelp = True}))+        "show this help"+    ]+++usage :: IO String+usage = do+    progName <- getProgName+    let header =+            unlines+                [ "Usage: " ++ progName ++ " [options...] FILES..."+                , ""+                , "Prepares the SQL in every hasql-th quasiquote in FILES against a live database,"+                , "so statements that do not match the schema fail here instead of at runtime."+                , ""+                , "The database is the first of: --database, $DATABASE_URL, $psql_conn_string, and"+                , "otherwise libpq's own defaults (PGHOST, PGPORT, PGDATABASE, PGUSER, ...)."+                , ""+                , "Quoters checked by default: " ++ Data.Text.unpack (Data.Text.intercalate ", " quotersSupported)+                ]+    pure (usageInfo header options)+++execOpts :: IO (Options, [FilePath])+execOpts = do+    argv <- getArgs+    case getOpt Permute options argv of+        (fs, files, []) -> do+            let opts = foldl (flip ($)) defaultOptions fs+            when opts.showHelp do+                usage >>= putStr+                exitSuccess+            -- One invocation for every file, rather than xargs splitting them+            -- between several, so that --write-baseline sees all the findings.+            listed <- case opts.filesFrom of+                Nothing -> pure []+                Just path -> do+                    contents <- if path == "-" then Data.ByteString.getContents else Data.ByteString.readFile path+                    pure+                        [ Data.Text.unpack (Data.Text.Encoding.decodeUtf8Lenient name)+                        | name <- Data.ByteString.split 0 contents+                        , not (Data.ByteString.null name)+                        ]+            let allFiles = files <> listed+            when (null allFiles && null opts.filesFrom && null opts.inferred) do+                usage >>= hPutStr stderr+                exitWith (ExitFailure 2)+            pure (opts, allFiles)+        (_, _, errs) -> do+            usage >>= hPutStr stderr . (concat errs ++)+            exitWith (ExitFailure 2)+++-- | The connection string. An empty one leaves every setting to libpq's+-- environment variables and defaults.+connectionString :: Options -> IO Text+connectionString opts = case opts.database of+    Just conn -> pure conn+    Nothing -> do+        databaseUrl <- nonEmpty <$> System.Environment.lookupEnv "DATABASE_URL"+        legacy <- nonEmpty <$> System.Environment.lookupEnv "psql_conn_string"+        pure (maybe "" Data.Text.pack (databaseUrl <|> legacy))+  where+    nonEmpty = \case+        Just "" -> Nothing+        other -> other+++getConnection :: Options -> IO Hasql.Connection.Connection+getConnection opts = do+    sqlConnString <- connectionString opts+    eConn <- Hasql.Connection.acquire Pqi.Ffi.adapter (Hasql.Connection.Settings.connectionString sqlConnString)+    case eConn of+        Left err -> do+            error (show err)+        Right conn -> pure conn+++-- | hasql 2 has no @withLibPQConnection@; the supported escape hatch is a+-- session built with 'Hasql.Session.onLibpqConnection', which hands over the+-- raw pqi connection and takes it back unchanged.+withLibPqConnection :: Hasql.Connection.Connection -> (Pqi.Connection -> IO a) -> IO a+withLibPqConnection conn action = do+    result <-+        Hasql.Connection.use+            conn+            (Hasql.Session.onLibpqConnection (\pq -> (\r -> (Right r, pq)) <$> action pq))+    case result of+        Left err -> error (show err)+        Right a -> pure a+++data PrepareError+    = ParseError FilePath String+    | DbError QuasiQuote String+    deriving stock (Eq, Show)+++-- | The checked quasiquotes in each file, or why the file could not be read.+collect :: [Text] -> [FilePath] -> IO [(FilePath, Either String [(QuasiQuote, Maybe Inferred)])]+collect quoters files =+    forM files \file -> do+        errParse <- parseFile file+        pure (file, map (,Nothing) . filter (\(QuasiQuote (_, quoter) _) -> isQuoterIn quoters quoter) <$> errParse)+++-- | The inferred quotes in each file, each standing for the hasql-th quote+-- its Haskell types annotate it as.+collectInferred :: [FilePath] -> IO [(FilePath, Either String [(QuasiQuote, Maybe Inferred)])]+collectInferred paths =+    concat <$> forM paths \path -> do+        contents <- if path == "-" then Data.ByteString.getContents else Data.ByteString.readFile path+        case readInferred contents of+            Left err -> pure [(path, Left err)]+            Right quotes ->+                pure+                    [ case annotated q of+                        Left err -> (q.file, Left (q.file <> ":" <> show q.line <> ":" <> show q.column <> ": " <> err))+                        Right sql -> (q.file, Right [(QuasiQuote (here, q.quoter) (here, sql), Just q)])+                    | q <- quotes+                    , let here = AlexPn 0 q.line q.column+                    ]+++-- | Whether a quote found in a source file is one --inferred has: its+-- quoter has the same names as hasql-th's. The paths may be relative to+-- different directories, so one need only end with the other; and the quote+-- must be the same, so that one in another package with the same path is+-- still checked.+isInferred :: [(FilePath, Either String [(QuasiQuote, Maybe Inferred)])] -> (FilePath, QuasiQuote) -> Bool+isInferred inferredQuotes (file, QuasiQuote (AlexPn _ line column, _) (_, sql)) =+    or+        [ q.line == line && q.column == column && q.sql == sql && sameFile q.file+        | (_, Right quotes) <- inferredQuotes+        , (_, Just q) <- quotes+        ]+  where+    sameFile other = components other `isSuffixOf` components file || components file `isSuffixOf` components other+    components = filter (`notElem` ["", "."]) . splitDirectories+++location :: FilePath -> QuasiQuote -> String+location file (QuasiQuote (AlexPn _ quoterRow quoterCol, _) _) =+    file <> ":" <> show quoterRow <> ":" <> show quoterCol+++main :: IO ()+main = do+    (opts, fileList) <- execOpts+    fromSources <- collect (opts.extraQuoters <> quotersSupported) fileList+    inferredQuotes <- collectInferred (reverse opts.inferred)+    let parsed = [(file, filter (\(qq, _) -> not (isInferred inferredQuotes (file, qq))) <$> quotes) | (file, quotes) <- fromSources] <> inferredQuotes+    if opts.listOnly+        then do+            forM_ parsed \case+                (file, Left err) -> putStrLn ("Error in " <> file <> "\n" <> err)+                (file, Right qqs) -> forM_ qqs \(qq@(QuasiQuote (_, quoter) _), _) ->+                    putStrLn (location file qq <> ": " <> Data.Text.unpack quoter)+            when (any (isLeft . snd) parsed) (exitWith (ExitFailure 1))+        else do+            baseline <- forM opts.baselineFile \path -> do+                contents <- Data.Text.Encoding.decodeUtf8Lenient <$> Data.ByteString.readFile path+                either (\err -> hPutStrLn stderr err >> exitWith (ExitFailure 2)) pure (readBaseline contents)+            conn <- getConnection opts+            results <- withLibPqConnection conn \libPqConn -> do+                catalogue <-+                    if opts.nullability || opts.types+                        then either (error . ("Cannot read the catalogue: " <>)) Just <$> Nullability.prepareSession libPqConn+                        else pure Nothing+                fmap concat . forM parsed $ \case+                    (file, Left err) -> do+                        putStrLn ("Error in " <> file)+                        putStrLn err+                        pure [Left (ParseError file err)]+                    (file, Right qqs) -> do+                        -- An inferred quote's file may not be where it was+                        -- compiled from; it then has no directives.+                        exists <- doesFileExist file+                        fileLines <- if exists then Data.Text.lines . Data.Text.Encoding.decodeUtf8Lenient <$> Data.ByteString.readFile file else pure []+                        forM qqs \(qq@(QuasiQuote (AlexPn _ line _, quoter) (_, stmt)), inferredQuote) -> do+                            let checkedRules =+                                    [Nullable | opts.nullability && isQuoterIn Nullability.resultQuoters quoter]+                                        <> [Narrowing | opts.types]+                                report h found = do+                                    let (kept, messages) = settle checkedRules (directivesAbove fileLines line) baseline h found+                                    when (not (null messages)) do+                                        putStrLn ("Warning in " <> location file qq)+                                        forM_ messages \m -> putStrLn ("  " <> m)+                                    pure (Right (length messages, [BaselineEntry h f.rule f.subject (Data.Text.pack (location file qq)) | f <- kept]))+                                failed err = do+                                    putStrLn ("Error in " <> location file qq)+                                    putStrLn err+                                    pure (Left (DbError qq err))+                            case inferredQuote of+                                -- Checked as it is sent; its warnings in terms of+                                -- its Haskell types.+                                Just q ->+                                    checkInferred libPqConn catalogue (Nullable `elem` checkedRules) (Narrowing `elem` checkedRules) q >>= \case+                                        Left err -> failed err+                                        Right (found, h) -> report h found+                                Nothing ->+                                    Hasql.Check.prepare libPqConn "" stmt >>= \case+                                        Left err -> failed err+                                        Right _ -> case (catalogue, parseStmt stmt) of+                                            (Just cat, Right ast) -> do+                                                nullable <- if Nullable `elem` checkedRules then Nullability.check libPqConn cat ast else pure []+                                                narrowing <- if opts.types then Types.check libPqConn cat ast else pure []+                                                report (statementHash (renderStmt ast)) (nullable <> narrowing)+                                            _ -> pure (Right (0, []))+            let (warningCounts, entries) = unzip (rights results)+            forM_ opts.writeBaseline \path ->+                Data.ByteString.writeFile path (Data.Text.Encoding.encodeUtf8 (renderBaseline (concat entries)))+            when (any isLeft results) (exitWith (ExitFailure 1))+            when (opts.failOnWarnings && sum warningCounts > 0) (exitWith (ExitFailure 1))

@@ -0,0 +1,257 @@+cabal-version:   3.0+name:            hasql-check+version:         0.5.0.0+synopsis:        Check hasql-th statements against a live PostgreSQL schema+description:+  Finds the hasql-th quasiquotes in Haskell source files and PREPAREs each+  statement against a live PostgreSQL database, so statements that no longer+  match the schema fail in CI rather than at runtime.++category:        Database, Development+homepage:        https://github.com/kronor-io/hasql-check+bug-reports:     https://github.com/kronor-io/hasql-check/issues+license:         BSD-3-Clause+license-file:    LICENSE+author:          Pranay Sashank, Jose Lorenzo Rodriguez+maintainer:      lorenzo@kronor.io, pranay.sashank@kronor.io+copyright:       2021-2026 Kronor+build-type:      Simple+tested-with:     GHC ==9.10.3 || ==9.12.4 || ==9.14.1+extra-doc-files:+  ChangeLog.md+  README.md++source-repository head+  type:     git+  location: https://github.com/kronor-io/hasql-check++flag lint+  description: lint+  manual:      True+  default:     False++flag kronor-syntax+  description:+    Accept the hasql-th extensions of Kronor's forks (Haskell targets and+    Haskell param fields). Needs Kronor's fork of postgresql-syntax.++  manual:      True+  default:     False++library+  exposed-modules:+    Hasql.Check+    Hasql.Check.Annotate+    Hasql.Check.Compile+    Hasql.Check.Finding+    Hasql.Check.Inferred+    Hasql.Check.Inferred.Quote+    Hasql.Check.Inferred.TH+    Hasql.Check.Lexer+    Hasql.Check.Nullability+    Hasql.Check.Parser+    Hasql.Check.Quoter+    Hasql.Check.TH+    Hasql.Check.Types++  hs-source-dirs:     src+  default-language:   GHC2021+  default-extensions:+    ApplicativeDo+    BangPatterns+    BinaryLiterals+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    DoAndIfThenElse+    DuplicateRecordFields+    EmptyDataDecls+    EmptyDataDeriving+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    InstanceSigs+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NoImplicitPrelude+    OverloadedRecordDot+    OverloadedStrings+    PartialTypeSignatures+    PatternGuards+    PatternSynonyms+    PolyKinds+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    StrictData+    TupleSections+    TypeApplications+    TypeFamilies+    TypeSynonymInstances+    ViewPatterns++  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+    -freverse-errors -fhide-source-paths++  if flag(lint)+    ghc-options: -Werror++  build-depends:+    , aeson              >=2.0  && <2.4+    , array              >=0.5  && <0.6+    , base               >=4.20 && <4.23+    , bytestring         >=0.11 && <0.13+    , containers         >=0.6  && <0.9+    , directory          >=1.3  && <1.4+    , hasql              >=2.0  && <2.1+    , hasql-th           >=0.5  && <0.6+    , mtl                >=2.2  && <2.4+    , postgresql-syntax  >=0.5  && <0.6+    , pqi                >=1.1  && <1.2+    , pqi-ffi            >=1.0  && <1.1+    , scientific         >=0.3  && <0.4+    , template-haskell   >=2.18 && <2.25+    , text               >=2.0  && <2.2+    , time               >=1.11 && <1.17+    , uuid               >=1.3  && <1.4+    , vector             >=0.12 && <0.14++  if flag(kronor-syntax)+    cpp-options: -DKRONOR_SYNTAX++  build-tool-depends:+    , alex:alex    >=3.2  && <4+    , happy:happy  >=1.20 && <3++executable hasql-check+  main-is:            Main.hs+  hs-source-dirs:     app+  default-language:   GHC2021+  default-extensions:+    ApplicativeDo+    BangPatterns+    BinaryLiterals+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    DoAndIfThenElse+    DuplicateRecordFields+    EmptyDataDecls+    EmptyDataDeriving+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    InstanceSigs+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NoImplicitPrelude+    OverloadedRecordDot+    OverloadedStrings+    PartialTypeSignatures+    PatternGuards+    PatternSynonyms+    PolyKinds+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    StrictData+    TupleSections+    TypeApplications+    TypeFamilies+    TypeSynonymInstances+    ViewPatterns++  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+    -freverse-errors -fhide-source-paths++  build-depends:+    , base         >=4.20 && <4.23+    , bytestring   >=0.11 && <0.13+    , directory    >=1.3  && <1.4+    , filepath     >=1.4  && <1.6+    , hasql        >=2.0  && <2.1+    , hasql-check+    , pqi          >=1.1  && <1.2+    , pqi-ffi      >=1.0  && <1.1+    , text         >=2.0  && <2.2++  if flag(lint)+    ghc-options: -Werror++-- The executable tests start their own PostgreSQL server, so initdb, pg_ctl+-- and psql must be on PATH.+test-suite hasql-check-test+  type:               exitcode-stdio-1.0+  main-is:            Main.hs+  hs-source-dirs:     test+  default-language:   GHC2021+  default-extensions:+    BlockArguments+    DataKinds+    LambdaCase+    OverloadedStrings++  ghc-options:        -Wall -threaded -rtsopts -with-rtsopts=-N++  if flag(lint)+    ghc-options: -Werror++  build-depends:+    , base              >=4.20 && <4.23+    , bytestring        >=0.11 && <0.13+    , directory         >=1.3  && <1.4+    , filepath          >=1.4  && <1.6+    , hasql             >=2.0  && <2.1+    , hasql-check+    , pqi-ffi           >=1.0  && <1.1+    , process           >=1.6  && <1.7+    , sydtest           >=0.19 && <0.34+    , template-haskell  >=2.18 && <2.25+    , temporary         >=1.3  && <1.4+    , text              >=2.0  && <2.2+    , vector            >=0.12 && <0.14++  build-tool-depends: hasql-check:hasql-check++  if flag(kronor-syntax)+    cpp-options: -DKRONOR_SYNTAX

@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}++-- |+-- Module      : Hasql.Check+-- Copyright   : (c) 2022 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+module Hasql.Check where++import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import PostgresqlSyntax qualified as Ast+import Pqi qualified+import Prelude+++-- | Turn the SQL text inside a quasiquote into the SQL the splice actually+-- sends to Postgres, mirroring @Hasql.TH.expPreparableStmtAstParser@ composed+-- with @Hasql.TH.Extraction.Exp.sql@ line for line. Rendering at 'mempty'+-- drops the nullability markers.+renderSql :: Text -> Either String ByteString+renderSql sql = renderStmt <$> parseStmt sql+++-- | The statement in a quasiquote, as the splice would render it.+parseStmt :: Text -> Either String Ast.PreparableStmt+parseStmt sql = either (Left . Text.unpack) (Right . lowerAst) (Ast.parse quoterSettings sql)+++-- | A statement in plain SQL, as Postgres reads it, whatever syntax this+-- build takes in hasql-th's quotes: for the quoters of+-- "Hasql.Check.Inferred.TH", and the annotated statements that stand for+-- theirs, which hasql-th's nullability markers may annotate.+--+-- Not lowered: Kronor's fork numbers the placeholders afresh as it lowers+-- its parameter fields, which would turn a lone @$2@ into @$1@.+parsePlainStmt :: Bool -> Text -> Either String Ast.PreparableStmt+parsePlainStmt markers sql = either (Left . Text.unpack) Right (Ast.parse (Ast.nullabilityMarkers markers) sql)+++renderStmt :: Ast.PreparableStmt -> ByteString+renderStmt = Text.encodeUtf8 . Ast.toText mempty++#ifdef KRONOR_SYNTAX++-- | The settings Kronor's fork of hasql-th parses with: upstream's nullability+-- markers, plus its Haskell targets and Haskell param fields.+quoterSettings :: Ast.Settings+quoterSettings =+    mconcat+        [ Ast.nullabilityMarkers True+        , Ast.haskellTargets True+        , Ast.haskellParamFields True+        ]+++-- | 'Ast.lower' numbers the placeholders as they fall in the tree that will+-- actually be rendered - the one with the Haskell targets erased - but hands+-- back the tree that still carries them, because the quasiquoter builds its+-- row decoder by walking those targets. We have no decoder to build, so the+-- erasure the quasiquoter defers to 'Hasql.TH.Extraction.Exp' happens right+-- here.+lowerAst :: Ast.PreparableStmt -> Ast.PreparableStmt+lowerAst ast = Ast.eraseHaskellTargets (fst (Ast.lower ast))++#else++-- | The settings upstream hasql-th parses with.+quoterSettings :: Ast.Settings+quoterSettings = Ast.nullabilityMarkers True+++-- | Upstream hasql-th renders the statement as parsed.+lowerAst :: Ast.PreparableStmt -> Ast.PreparableStmt+lowerAst = id++#endif+++prepare :: Pqi.Connection -> Text -> Text -> IO (Either String ())+prepare conn stmtName unParsedStmt =+    either (pure . Left) (prepareStmt conn (Text.encodeUtf8 stmtName)) (parseStmt unParsedStmt)+++-- | Prepare a statement under a name, returning the server's error if it fails.+prepareStmt :: Pqi.Connection -> ByteString -> Ast.PreparableStmt -> IO (Either String ())+prepareStmt conn stmtName stmt = do+    mr <- conn.prepare stmtName (renderStmt stmt) Nothing+    case mr of+        Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage+        Just r -> do+            rs <- r.resultStatus+            if rs `elem` [Pqi.EmptyQuery, Pqi.BadResponse, Pqi.NonfatalError, Pqi.FatalError]+                then maybe (Left "Something went wrong") (Left . Text.unpack . Text.decodeUtf8Lenient) <$> r.resultErrorMessage+                else pure (Right ())

@@ -0,0 +1,119 @@+{-# LANGUAGE CPP #-}++-- |+-- Module      : Hasql.Check.Annotate+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Annotate the parameters of a statement that has no annotations, as+-- hasql-th asks for.+--+-- 'Hasql.Check.Inferred.TH' annotates with the types of the Haskell values a+-- statement is used with, and the checker annotates the same way, so that it+-- checks the statement the quoter sends. Result columns are not annotated+-- here: the quoter casts them around the statement, where they cannot change+-- what it means.+module Hasql.Check.Annotate (+    annotate,+    typename,+    placeholder,+    untypedLiterals,+) where++import Data.Data (Data, cast, gmapT)+import Data.Foldable (toList)+import Data.Text (Text)+import Data.Text qualified as Text+import PostgresqlSyntax qualified as Ast+import Prelude+++-- | A type, as an annotation would name it - @int8@, @public.payment_state@,+-- @text[]@ - nullable or not. An array's nullability is its elements'.+typename :: Text -> Bool -> Either String Ast.Typename+typename name nullable = case Ast.parse mempty name of+    Right (Ast.Typename setof t _ Nothing) -> Right (Ast.Typename setof t nullable Nothing)+    Right (Ast.Typename setof t _ (Just (dimensions, _))) -> Right (Ast.Typename setof t False (Just (dimensions, nullable)))+    Left _ -> Left ("not a Postgres type name: " <> Text.unpack name)+++-- | A made-up type with a plain name, to find in the rendered statement.+placeholder :: Text -> Ast.Typename+placeholder name =+    Ast.Typename False (Ast.GenericTypeSimpleTypename (Ast.GenericType (Ast.UnquotedIdent name) Nothing Nothing)) False Nothing+++-- | The statement with each occurrence of the @n@th parameter, counting from+-- 1, cast to the type given for it, if one is. A parameter that is+-- subscripted or has a field taken, @$1['key']@, is cast before that:+-- @($1 :: jsonb)['key']@.+annotate :: (Int -> Maybe Ast.Typename) -> Ast.PreparableStmt -> Ast.PreparableStmt+annotate param = go+  where+    go :: Data b => b -> b+    go x = case cast x of+        Just (Ast.CExprAExpr p@(Ast.ParamCExpr n Nothing)) | Just t <- param n, Just r <- cast (Ast.TypecastAExpr (Ast.CExprAExpr p) t) -> r+        _ -> case cast x of+            Just (Ast.CExprBExpr p@(Ast.ParamCExpr n Nothing)) | Just t <- param n, Just r <- cast (Ast.TypecastBExpr (Ast.CExprBExpr p) t) -> r+            _ -> case cast x of+                Just (Ast.ParamCExpr n (Just indirection))+                    | Just t <- param n+                    , Just r <- cast (Ast.InParensCExpr (Ast.TypecastAExpr (Ast.CExprAExpr (Ast.ParamCExpr n Nothing)) t) (Just indirection)) ->+                        r+                _ -> gmapT go x+++-- | The result columns, counting from 1, that are a string literal or NULL+-- with no type of its own, and the literal: Postgres reads one as the type+-- it is cast to, so whether the quoter's cast works depends only on the+-- literal. Only a plain SELECT's columns are found.+untypedLiterals :: Ast.PreparableStmt -> [(Int, Text)]+untypedLiterals = \case+    Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens _ (Ast.SimpleSelectSelectClause (Ast.NormalSimpleSelect (Just t) _ _ _ _ _ _)) _ _ _)) ->+        [(n, Ast.toText mempty e) | (n, Just e) <- zip [1 ..] (targeting t), untyped e]+    _ -> []+  where+    targeting = \case+        Ast.NormalTargeting l -> normalTargets l+        Ast.AllTargeting (Just l) -> targets l+        Ast.DistinctTargeting _ l -> targets l+        Ast.AllTargeting Nothing -> []+    untyped = \case+        Ast.CExprAExpr (Ast.AexprConstCExpr (Ast.SAexprConst _)) -> True+        Ast.CExprAExpr (Ast.AexprConstCExpr Ast.NullAexprConst) -> True+        _ -> False+++-- | Each target's expression; nothing for a @*@, which stops the counting.+targets :: Ast.TargetList -> [Maybe Ast.AExpr]+targets (Ast.TargetList els) = takeWhile (/= Nothing) (map expr (toList els))+  where+    expr = \case+        Ast.AliasedExprTargetEl a _ -> Just a+        Ast.ImplicitlyAliasedExprTargetEl a _ -> Just a+        Ast.ExprTargetEl a -> Just a+        Ast.AsteriskTargetEl -> Nothing++#ifdef KRONOR_SYNTAX++normalTargets :: Ast.HsTargetList -> [Maybe Ast.AExpr]+normalTargets (Ast.HsTargetList els) = takeWhile (/= Nothing) (map one (toList els))+  where+    one = \case+        Ast.SqlTargetEl te -> case te of+            Ast.AliasedExprTargetEl a _ -> Just a+            Ast.ImplicitlyAliasedExprTargetEl a _ -> Just a+            Ast.ExprTargetEl a -> Just a+            Ast.AsteriskTargetEl -> Nothing+        _ -> Nothing++#else++normalTargets :: Ast.TargetList -> [Maybe Ast.AExpr]+normalTargets = targets++#endif

@@ -0,0 +1,204 @@+-- |+-- Module      : Hasql.Check.Compile+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Checking statements while GHC compiles them, from "Hasql.Check.TH"'s+-- quoters or from a compiler plugin: the configuration, read from the+-- environment, one connection for the whole compilation, and warnings that+-- GHC's output and an editor pick up.+--+-- * @HASQL_CHECK_DATABASE_URL@: a libpq connection string or URI. Unset,+--   nothing is checked.+-- * @HASQL_CHECK_SCHEMA_FILE@: a file that changes whenever the schema does,+--   such as a migration plan.+-- * @HASQL_CHECK_NULLABILITY@, @HASQL_CHECK_TYPES@: when set, the warnings of+--   @hasql-check --nullability@ and @--types@ too.+-- * @HASQL_CHECK_BASELINE@: a baseline file, as @--write-baseline@ writes it.+module Hasql.Check.Compile (+    -- * Configuration+    Config (..),+    readConfig,++    -- * The connection+    Session (..),+    withSession,+    reportUnavailable,++    -- * Warnings+    warnings,+    warning,+) where++import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)+import Control.Exception (SomeException, try)+import Control.Monad (unless)+import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Either (fromRight)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Hasql.Check.Finding (Baseline, Finding, Rule, directivesAbove, readBaseline, settle)+import Hasql.Check.Nullability qualified as Nullability+import Pqi qualified+import Pqi.Ffi qualified+import System.Environment (lookupEnv)+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO)+import Prelude+++-- * Configuration+++data Config = Config+    { databaseUrl :: Maybe String+    , schemaFile :: Maybe FilePath+    , nullability :: Bool+    , types :: Bool+    , baseline :: Maybe FilePath+    }+++readConfig :: IO Config+readConfig =+    Config+        <$> nonEmpty "HASQL_CHECK_DATABASE_URL"+        <*> nonEmpty "HASQL_CHECK_SCHEMA_FILE"+        <*> (isJust <$> nonEmpty "HASQL_CHECK_NULLABILITY")+        <*> (isJust <$> nonEmpty "HASQL_CHECK_TYPES")+        <*> nonEmpty "HASQL_CHECK_BASELINE"+  where+    nonEmpty name =+        lookupEnv name >>= \case+            Just "" -> pure Nothing+            other -> pure other+++-- * The connection+++data Session = Session+    { url :: String+    -- ^ What the connection was made to. A long GHCi session can outlive a+    -- change of HASQL_CHECK_DATABASE_URL, and must follow it.+    , connection :: Pqi.Connection+    , catalogue :: Maybe (ByteString.ByteString, Nullability.Catalogue)+    -- ^ Loaded for nullability and types, keyed by the schema file's contents.+    }+++-- | One connection for every statement the compiler checks, created on first+-- use. The lock also keeps the statements of one check together, which+-- nullability needs: it prepares, explains and deallocates a named+-- statement.++{- HLINT ignore session "Avoid restricted function" -}+-- A process-wide variable is the point: it outlives every splice.+session :: MVar (Maybe Session)+session = unsafePerformIO (newMVar Nothing)+{-# NOINLINE session #-}+++-- | Run a check on the connection to the given database, with the catalogue+-- if asked for; or why the database cannot be reached. A connection that+-- breaks during a check - a restarted database under a long GHCi session -+-- is replaced, and the check run once more on the new one.+withSession :: Config -> String -> Bool -> (Session -> IO a) -> IO (Either String a)+withSession config url withCatalogue action = modifyMVar session \current -> do+    fingerprint <-+        if withCatalogue+            then maybe (pure ByteString.empty) readFileOrEmpty config.schemaFile+            else pure ByteString.empty+    let attempt existing =+            open fingerprint existing >>= \case+                Left why -> pure (Nothing, Left why)+                Right s -> do+                    result <- action s+                    status <- s.connection.status+                    pure (if status == Pqi.ConnectionOk then Just s else Nothing, Right result)+    attempt current >>= \case+        (Nothing, Right _) | Just _ <- current -> attempt Nothing+        result -> pure result+  where+    open fingerprint = \case+        Just s+            | s.url /= url -> do+                s.connection.finish+                open fingerprint Nothing+            | not withCatalogue || fmap fst s.catalogue == Just fingerprint -> pure (Right s)+            | otherwise -> loadCatalogue fingerprint s.connection+        Nothing -> do+            conn <- Pqi.Ffi.adapter.connectdb (ByteString.Char8.pack url)+            status <- conn.status+            if status /= Pqi.ConnectionOk+                then Left . maybe "cannot connect" ByteString.Char8.unpack <$> conn.errorMessage+                else+                    if withCatalogue+                        then loadCatalogue fingerprint conn+                        else pure (Right (Session url conn Nothing))++    loadCatalogue fingerprint conn =+        Nullability.prepareSession conn >>= \case+            Left err -> pure (Left err)+            Right cat -> pure (Right (Session url conn (Just (fingerprint, cat))))++    readFileOrEmpty path = fromRight ByteString.empty <$> (try (ByteString.readFile path) :: IO (Either SomeException ByteString.ByteString))+++-- | Whether the database being unavailable has already been reported.++{- HLINT ignore reportedUnavailable "Avoid restricted function" -}+reportedUnavailable :: IORef Bool+reportedUnavailable = unsafePerformIO (newIORef False)+{-# NOINLINE reportedUnavailable #-}+++-- | Say, once a compilation, that the database cannot be reached: not about+-- any one statement, so with no location.+reportUnavailable :: String -> IO ()+reportUnavailable why = do+    reported <- atomicModifyIORef' reportedUnavailable (True,)+    unless reported (hPutStrLn stderr ("hasql-check: not checking statements: " <> why))+++-- * Warnings+++-- | The warnings to report for a statement at a line of a file, after its+-- directives and the baseline, if any.+warnings :: Config -> [Rule] -> FilePath -> Int -> Text -> [Finding] -> IO [String]+warnings config rules file line fingerprint found+    | null rules = pure []+    | otherwise = do+        fileLines <- readLines file+        known <- traverse readBaselineFile config.baseline+        let (_, messages) = settle rules (directivesAbove fileLines line) (either (const Nothing) Just =<< known) fingerprint found+        pure (maybe [] (\err -> ["cannot read HASQL_CHECK_BASELINE: " <> err]) (known >>= either Just (const Nothing)) <> messages)+++-- | A warning in GHC's format, so that tools reading GHC's output pick it up,+-- but written to stderr rather than reported to GHC: under -Werror GHC would+-- fail the build on it, and these are advice.+warning :: FilePath -> (Int, Int) -> String -> IO ()+warning file (line, column) message =+    hPutStrLn stderr (file <> ":" <> show line <> ":" <> show column <> ": warning: hasql-check: " <> message)+++-- | A file's lines, or none if it cannot be read.+readLines :: FilePath -> IO [Text]+readLines path = either (const []) (Text.lines . Text.decodeUtf8Lenient) <$> (try (ByteString.readFile path) :: IO (Either SomeException ByteString.ByteString))+++readBaselineFile :: FilePath -> IO (Either String Baseline)+readBaselineFile path =+    (try (ByteString.readFile path) :: IO (Either SomeException ByteString.ByteString)) >>= \case+        Left e -> pure (Left (show e))+        Right bytes -> pure (readBaseline (Text.decodeUtf8Lenient bytes))

@@ -0,0 +1,252 @@+-- |+-- Module      : Hasql.Check.Finding+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Warnings about a statement, and the two ways of suppressing them.+--+-- A directive, in the comment lines directly above the line a quote starts on,+-- suppresses findings about that quote's statement:+--+-- > -- hasql-check: allow nullable(street, city), narrowing($4)+-- > [singletonStatement| ... |]+--+-- A baseline file lists findings to ignore wherever their statement is, so+-- that existing findings can be left while new ones fail CI.+module Hasql.Check.Finding (+    -- * Findings+    Rule (..),+    ruleName,+    Finding (..),++    -- * Directives+    Allowance,+    directivesAbove,+    applyDirectives,++    -- * Baselines+    Baseline,+    BaselineEntry (..),+    statementHash,+    readBaseline,+    renderBaseline,+    inBaseline,++    -- * Both+    settle,+) where++import Data.Bits (xor)+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.Char (isSpace)+import Data.List (partition, sortOn)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Word (Word64)+import Numeric (showHex)+import Prelude+++-- * Findings+++data Rule+    = -- | A result column annotated non-null that can be null.+      Nullable+    | -- | An annotation that converts a value to a narrower type.+      Narrowing+    deriving stock (Eq, Ord, Show, Enum, Bounded)+++ruleName :: Rule -> Text+ruleName = \case+    Nullable -> "nullable"+    Narrowing -> "narrowing"+++data Finding = Finding+    { rule :: Rule+    , subject :: Text+    -- ^ The result column's name, or the parameter as @$n@.+    , message :: String+    }+++-- * Directives+++-- | A rule allowed for a subject.+type Allowance = (Rule, Text)+++-- | The allowances in the block of comment lines directly above a line, given+-- the file's lines and the line, from 1. Malformed directives are reported.+directivesAbove :: [Text] -> Int -> ([Allowance], [String])+directivesAbove fileLines line =+    foldMap parseLine (takeWhile isComment (reverse (take (line - 1) fileLines)))+  where+    isComment = Text.isPrefixOf "--" . Text.stripStart+    parseLine l = case Text.breakOn "hasql-check:" l of+        (_, rest) | not (Text.null rest) -> parseDirective (Text.strip (Text.drop (Text.length "hasql-check:") rest))+        _ -> mempty+++parseDirective :: Text -> ([Allowance], [String])+parseDirective t = case Text.stripPrefix "allow" t of+    Just rest -> foldMap entry (splitTopLevel (Text.strip rest))+    Nothing -> ([], ["directive not understood: " <> Text.unpack t])+  where+    entry e = case Text.breakOn "(" (Text.strip e) of+        (name, args)+            | Just inner <- Text.stripPrefix "(" args >>= Text.stripSuffix ")"+            , Just r <- lookup (Text.strip name) [(ruleName r', r') | r' <- [minBound .. maxBound]] ->+                case subjects inner of+                    Right names -> ([(r, subj) | subj <- names], [])+                    Left err -> ([], ["directive not understood: " <> Text.unpack e <> ": " <> err])+        _ -> ([], ["directive not understood: " <> Text.unpack e])+    -- Split on the commas between entries, not those inside them.+    splitTopLevel = go 0 ""+      where+        go :: Int -> Text -> Text -> [Text]+        go depth acc s = case Text.uncons s of+            Nothing -> [acc | not (Text.all isSpace acc)]+            Just (c, cs)+                | c == ',' && depth == 0 -> acc : go depth "" cs+                | c == '(' -> go (depth + 1) (Text.snoc acc c) cs+                | c == ')' -> go (depth - 1) (Text.snoc acc c) cs+                | otherwise -> go depth (Text.snoc acc c) cs+++-- | The findings the allowances leave, and the allowances that suppressed+-- nothing for the rules that were checked.+applyDirectives :: [Rule] -> [Allowance] -> [Finding] -> ([Finding], [Allowance])+applyDirectives checked allowances findings =+    (kept, [a | a@(r, _) <- allowances, r `elem` checked, a `Set.notMember` used])+  where+    allowed f = (f.rule, f.subject) `elem` allowances+    (suppressed, kept) = partition allowed findings+    used = Set.fromList [(f.rule, f.subject) | f <- suppressed]+++-- * Baselines+++data BaselineEntry = BaselineEntry+    { hash :: Text+    , entryRule :: Rule+    , entrySubject :: Text+    , origin :: Text+    -- ^ Where the statement was when the entry was written, for people.+    }+++-- | Findings to ignore, by statement, rule and subject.+newtype Baseline = Baseline (Set (Text, Rule, Text))+++-- | A stable hash of a statement as rendered, so that layout changes to the+-- quote leave it alone. 64-bit FNV-1a.+statementHash :: ByteString -> Text+statementHash = Text.pack . pad . flip showHex "" . ByteString.foldl' step offset+  where+    offset = 0xcbf29ce484222325 :: Word64+    step h b = (h `xor` fromIntegral b) * 0x100000001b3+    pad s = replicate (16 - length s) '0' <> s+++-- | One entry a line: hash, rule, subject, then optionally @# origin@.+readBaseline :: Text -> Either String Baseline+readBaseline = fmap (Baseline . Set.fromList) . traverse entry . filter (not . blank) . Text.lines+  where+    blank l = Text.null (Text.strip l) || "#" `Text.isPrefixOf` Text.stripStart l+    entry l = either (\err -> Left (concat ["Malformed baseline line: ", Text.unpack l, ": ", err])) Right do+        let (h, afterHash) = Text.break isSpace (Text.stripStart l)+            (r, afterRule) = Text.break isSpace (Text.stripStart afterHash)+        r' <- maybe (Left "unknown rule") Right (lookup r [(ruleName x, x) | x <- [minBound .. maxBound]])+        (subj, rest) <- word (Text.stripStart afterRule)+        if Text.null (Text.strip rest) || "#" `Text.isPrefixOf` Text.stripStart rest+            then Right (h, r', subj)+            else Left "trailing text"+++renderBaseline :: [BaselineEntry] -> Text+renderBaseline entries =+    Text.unlines+        ( "# hasql-check baseline: findings to ignore. Written by --write-baseline."+            : [ Text.unwords [e.hash, ruleName e.entryRule, quote e.entrySubject, "#", e.origin]+              | e <- sortOn (\e -> (e.origin, e.hash, e.entryRule, e.entrySubject)) entries+              ]+        )+++inBaseline :: Baseline -> Text -> Finding -> Bool+inBaseline (Baseline entries) h f = (h, f.rule, f.subject) `Set.member` entries+++-- * Both+++-- | Apply a quote's directives and the baseline to its statement's findings:+-- the findings left after the directives, which are what a baseline written+-- now would hold, and the messages to report - the findings the baseline does+-- not cover either, malformed directives, and allowances that suppress+-- nothing.+settle :: [Rule] -> ([Allowance], [String]) -> Maybe Baseline -> Text -> [Finding] -> ([Finding], [String])+settle checked (allowances, malformed) baseline h findings =+    ( kept+    , [f.message | f <- kept, maybe True (\b -> not (inBaseline b h f)) baseline]+        <> malformed+        <> [ concat ["allow ", Text.unpack (ruleName r), "(", Text.unpack subj, ") suppresses nothing"]+           | (r, subj) <- unused+           ]+    )+  where+    (kept, unused) = applyDirectives checked allowances findings+++-- * Names+++-- | A column name as written in a baseline or a directive: bare, or in double+-- quotes when it has spaces or punctuation, with @\\@ and @\"@ escapes.+quote :: Text -> Text+quote name+    | not (Text.null name) && Text.all plain name = name+    | otherwise = Text.concat ["\"", Text.concatMap escape name, "\""]+  where+    plain c = not (isSpace c) && c `notElem` ("#\"\\,()" :: String)+    escape c = if c == '"' || c == '\\' then Text.pack ['\\', c] else Text.singleton c+++-- | A name, bare or quoted, at the start of the text, and the text after it.+word :: Text -> Either String (Text, Text)+word t = case Text.uncons t of+    Just ('"', rest) -> go "" rest+    _ ->+        let (bare, rest) = Text.break (\c -> isSpace c || c == ',') t+         in if Text.null bare then Left "missing name" else Right (bare, rest)+  where+    go acc s = case Text.uncons s of+        Nothing -> Left "unterminated quote"+        Just ('"', rest) -> Right (acc, rest)+        Just ('\\', rest) | Just (c, rest') <- Text.uncons rest -> go (Text.snoc acc c) rest'+        Just (c, rest) -> go (Text.snoc acc c) rest+++-- | Comma-separated names, bare or quoted.+subjects :: Text -> Either String [Text]+subjects t+    | Text.null (Text.strip t) = Right []+    | otherwise = do+        (name, rest) <- word (Text.stripStart t)+        case Text.uncons (Text.stripStart rest) of+            Nothing -> Right [name]+            Just (',', more) -> (name :) <$> subjects more+            Just _ -> Left "expected a comma"

@@ -0,0 +1,643 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+-- 'statement' and 'resultless' name their Postgres types through equalities+-- they do not need themselves: with them, GHC works the names out where a+-- statement is used, which is what puts them in the .hie files.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- |+-- Module      : Hasql.Check.Inferred+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Statements whose encoders and decoders are chosen by the Haskell types they+-- are used with, for the quoters in "Hasql.Check.Inferred.TH".+--+-- Each Haskell type stands for one Postgres type, named at the type level by+-- 'PgType', and the statement sends the annotations hasql-th would ask for:+-- @select email from customer@ used as a @Statement Int64 Text@ is sent as+-- @select (email)::text from customer@. A @varchar@ column is then read as+-- 'Text', and an @int4@ one as 'Int64', where an exact decoder would fail.+--+-- Because the names are types, GHC works them out where a statement is used,+-- and records them in its @.hie@ files, where @hasql-check-hie@ reads them:+-- a @newtype@ deriving 'Value' is checked as the type it wraps, with no list+-- of types to keep in step.+module Hasql.Check.Inferred (+    -- * Types+    Value (..),+    typeName,+    Domain (..),+    PgEnum (..),+    GEnum (..),+    qualifiedName,+    Column (..),+    Params (..),+    Row (..),++    -- * Postgres types at the type level+    PgColumnType,+    PgColumnLabels,+    PgParamLabels,+    PgColumnLabelLists,+    PostgresParamLabels,+    PostgresColumnLabels,+    PgParamTypes,+    PgColumnTypes,+    KnownSymbols (..),+    PostgresParams,+    PostgresColumns,++    -- * Statements+    Template (..),+    Wrapped (..),+    Piece (..),+    statement,+    resultless,+    render,+) where++import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.Functor.Contravariant ((>$<))+import Data.Int (Int16, Int32, Int64)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (Day, LocalTime, TimeOfDay, UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import GHC.Generics (C1, D1, Generic (..), M1 (..), Meta (..), U1 (..), (:+:) (..))+import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement+import Language.Haskell.TH.Syntax (Lift)+import PostgresqlSyntax qualified as Ast+import Prelude+++-- | A Haskell type, and the Postgres type it is sent and read as.+--+-- A @newtype@ can derive the instance of the type it wraps:+--+-- > newtype Email = Email Text+-- >     deriving newtype (Value)+class Value a where+    -- | The Postgres type's name, as an annotation would give it: @"int8"@,+    -- @"public.payment_state"@.+    type PgType a :: Symbol+++    -- | The labels of the Postgres enum it is, if it is one, for the checker.+    type PgLabels a :: [Symbol]+++    type PgLabels a = '[]+++    encodeValue :: E.Value a+    decodeValue :: D.Value a+++-- | The name of a type's Postgres type.+typeName :: forall a. KnownSymbol (PgType a) => Text+typeName = Text.pack (symbolVal (Proxy @(PgType a)))+++instance Value Bool where+    type PgType Bool = "bool"+    encodeValue = E.bool+    decodeValue = D.bool+++instance Value Int16 where+    type PgType Int16 = "int2"+    encodeValue = E.int2+    decodeValue = D.int2+++instance Value Int32 where+    type PgType Int32 = "int4"+    encodeValue = E.int4+    decodeValue = D.int4+++instance Value Int64 where+    type PgType Int64 = "int8"+    encodeValue = E.int8+    decodeValue = D.int8+++instance Value Float where+    type PgType Float = "float4"+    encodeValue = E.float4+    decodeValue = D.float4+++instance Value Double where+    type PgType Double = "float8"+    encodeValue = E.float8+    decodeValue = D.float8+++instance Value Scientific where+    type PgType Scientific = "numeric"+    encodeValue = E.numeric+    decodeValue = D.numeric+++instance Value Text where+    type PgType Text = "text"+    encodeValue = E.text+    decodeValue = D.text+++instance Value ByteString where+    type PgType ByteString = "bytea"+    encodeValue = E.bytea+    decodeValue = D.bytea+++instance Value UUID where+    type PgType UUID = "uuid"+    encodeValue = E.uuid+    decodeValue = D.uuid+++instance Value Day where+    type PgType Day = "date"+    encodeValue = E.date+    decodeValue = D.date+++instance Value LocalTime where+    type PgType LocalTime = "timestamp"+    encodeValue = E.timestamp+    decodeValue = D.timestamp+++instance Value UTCTime where+    type PgType UTCTime = "timestamptz"+    encodeValue = E.timestamptz+    decodeValue = D.timestamptz+++instance Value TimeOfDay where+    type PgType TimeOfDay = "time"+    encodeValue = E.time+    decodeValue = D.time+++instance Value Aeson.Value where+    type PgType Aeson.Value = "jsonb"+    encodeValue = E.jsonb+    decodeValue = D.jsonb+++-- | A type sent and read as the one it wraps, under the name of a Postgres+-- domain over it, so that Postgres checks the domain's constraints:+--+-- > newtype Cents = Cents Int64+-- >     deriving (Value) via Domain "cents" Int64+newtype Domain (name :: Symbol) a = Domain a+++instance Value a => Value (Domain name a) where+    type PgType (Domain name a) = name+    type PgLabels (Domain name a) = PgLabels a+    encodeValue = (\(Domain a) -> a) >$< encodeValue+    decodeValue = Domain <$> decodeValue+++-- | A Haskell enumeration sent and read as a Postgres enum, by the enum's+-- name: each constructor, which takes no fields, as the label of the same+-- name.+--+-- > data PaymentState = PENDING | PAID+-- >     deriving stock (Generic)+-- >     deriving (Value) via PgEnum "payment_state" PaymentState+--+-- The checker compares the labels with the enum's in the database.+newtype PgEnum (name :: Symbol) a = PgEnum a+++instance (KnownSymbol name, Generic a, GEnum (Rep a)) => Value (PgEnum name a) where+    type PgType (PgEnum name a) = name+    type PgLabels (PgEnum name a) = ConstructorNames (Rep a)+    encodeValue = uncurry E.enum (qualifiedName (Text.pack (symbolVal (Proxy @name)))) (\(PgEnum a) -> glabel (from a))+    decodeValue = uncurry D.enum (qualifiedName (Text.pack (symbolVal (Proxy @name)))) (\t -> PgEnum . to <$> lookup t gvalues)+++-- | A type's schema, if its name has one, and its own name, as the+-- identifiers they are: the name is SQL, as a cast takes it, so a quoted+-- part is taken as it is and an unquoted one in lower case, as Postgres+-- takes them.+qualifiedName :: Text -> (Maybe Text, Text)+qualifiedName n = case Ast.parse mempty n of+    Right (Ast.Typename _ (Ast.GenericTypeSimpleTypename (Ast.GenericType i attrs _)) _ _) ->+        -- The last part is the type, and the one before it its schema; a+        -- part before that is the database, which must be the one connected+        -- to.+        case reverse (i : maybe [] (\(Ast.Attrs as) -> toList as) attrs) of+            own : schema : _ -> (Just (ident schema), ident own)+            own : _ -> (Nothing, ident own)+            [] -> (Nothing, n)+    _ -> (Nothing, n)+  where+    ident = \case+        Ast.QuotedIdent t -> t+        Ast.UnquotedIdent t -> t+++-- | The constructors of an enumeration, by name.+class GEnum f where+    gvalues :: [(Text, f p)]+    glabel :: f p -> Text+++instance GEnum f => GEnum (D1 m f) where+    gvalues = [(l, M1 x) | (l, x) <- gvalues]+    glabel (M1 x) = glabel x+++instance (GEnum f, GEnum g) => GEnum (f :+: g) where+    gvalues = [(l, L1 x) | (l, x) <- gvalues] <> [(l, R1 x) | (l, x) <- gvalues]+    glabel = \case+        L1 x -> glabel x+        R1 x -> glabel x+++instance KnownSymbol label => GEnum (C1 ('MetaCons label fixity strict) U1) where+    gvalues = [(Text.pack (symbolVal (Proxy @label)), M1 U1)]+    glabel _ = Text.pack (symbolVal (Proxy @label))+++-- | An enumeration's constructor names.+type family ConstructorNames (f :: Type -> Type) :: [Symbol] where+    ConstructorNames (D1 m f) = ConstructorNames f+    ConstructorNames (f :+: g) = Append (ConstructorNames f) (ConstructorNames g)+    ConstructorNames (C1 ('MetaCons label fixity strict) U1) = '[label]+++type family Append (xs :: [k]) (ys :: [k]) :: [k] where+    Append '[] ys = ys+    Append (x ': xs) ys = x ': Append xs ys+++-- | A one-dimensional array, whose elements may be NULL when they are+-- 'Maybe's: a @Vector Int64@ is an @int8[]@.+instance Column a => Value (Vector a) where+    type PgType (Vector a) = AppendSymbol (PgColumnType a) "[]"+    type PgLabels (Vector a) = PgColumnLabels a+    encodeValue = E.foldableArray encodeColumn+    decodeValue = D.vectorArray decodeColumn+++-- | A one-dimensional array, as a list. A 'String' is not one: 'Char' has no+-- Postgres type; use 'Text'.+instance Column a => Value [a] where+    type PgType [a] = AppendSymbol (PgColumnType a) "[]"+    type PgLabels [a] = PgColumnLabels a+    encodeValue = E.foldableArray encodeColumn+    decodeValue = D.listArray decodeColumn+++-- | A column or parameter, which may be NULL when it is a 'Maybe'.+class Column a where+    encodeColumn :: E.NullableOrNot E.Value a+    decodeColumn :: D.NullableOrNot D.Value a+++instance {-# OVERLAPPABLE #-} Value a => Column a where+    encodeColumn = E.nonNullable encodeValue+    decodeColumn = D.nonNullable decodeValue+++instance Value a => Column (Maybe a) where+    encodeColumn = E.nullable encodeValue+    decodeColumn = D.nullable decodeValue+++-- | A column's enum labels, if it is one.+type family PgColumnLabels (a :: Type) :: [Symbol] where+    PgColumnLabels (Maybe a) = PgLabels a+    PgColumnLabels a = PgLabels a+++-- | A column's Postgres type.+type family PgColumnType (a :: Type) :: Symbol where+    PgColumnType (Maybe a) = PgType a+    PgColumnType a = PgType a+++-- | A statement's parameters: none, one, or a tuple of them.+class Params a where+    params :: E.Params a+++instance Params () where+    params = E.noParams+++instance {-# OVERLAPPABLE #-} Column a => Params a where+    params = E.param encodeColumn+++instance (Column a, Column b) => Params (a, b) where+    params =+        (fst >$< E.param encodeColumn)+            <> (snd >$< E.param encodeColumn)+++instance (Column a, Column b, Column c) => Params (a, b, c) where+    params =+        ((\(x, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, x, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, x) -> x) >$< E.param encodeColumn)+++instance (Column a, Column b, Column c, Column d) => Params (a, b, c, d) where+    params =+        ((\(x, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, x, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, x, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, x) -> x) >$< E.param encodeColumn)+++instance (Column a, Column b, Column c, Column d, Column e) => Params (a, b, c, d, e) where+    params =+        ((\(x, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, x, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, x, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, x, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, x) -> x) >$< E.param encodeColumn)+++instance (Column a, Column b, Column c, Column d, Column e, Column f) => Params (a, b, c, d, e, f) where+    params =+        ((\(x, _, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, x, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, x, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, x, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, x, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, _, x) -> x) >$< E.param encodeColumn)+++instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g) => Params (a, b, c, d, e, f, g) where+    params =+        ((\(x, _, _, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, x, _, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, x, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, x, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, x, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, _, x, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, _, _, x) -> x) >$< E.param encodeColumn)+++instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h) => Params (a, b, c, d, e, f, g, h) where+    params =+        ((\(x, _, _, _, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, x, _, _, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, x, _, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, x, _, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, x, _, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, _, x, _, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, _, _, x, _) -> x) >$< E.param encodeColumn)+            <> ((\(_, _, _, _, _, _, _, x) -> x) >$< E.param encodeColumn)+++-- | The Postgres types of a statement's parameters.+type family PgParamTypes (p :: Type) :: [Symbol] where+    PgParamTypes () = '[]+    PgParamTypes (a, b) = '[PgColumnType a, PgColumnType b]+    PgParamTypes (a, b, c) = '[PgColumnType a, PgColumnType b, PgColumnType c]+    PgParamTypes (a, b, c, d) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d]+    PgParamTypes (a, b, c, d, e) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e]+    PgParamTypes (a, b, c, d, e, f) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f]+    PgParamTypes (a, b, c, d, e, f, g) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g]+    PgParamTypes (a, b, c, d, e, f, g, h) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g, PgColumnType h]+    PgParamTypes a = '[PgColumnType a]+++-- | The enum labels of a statement's parameters, one list each.+type family PgParamLabels (p :: Type) :: [[Symbol]] where+    PgParamLabels () = '[]+    PgParamLabels (a, b) = '[PgColumnLabels a, PgColumnLabels b]+    PgParamLabels (a, b, c) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c]+    PgParamLabels (a, b, c, d) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d]+    PgParamLabels (a, b, c, d, e) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e]+    PgParamLabels (a, b, c, d, e, f) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f]+    PgParamLabels (a, b, c, d, e, f, g) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g]+    PgParamLabels (a, b, c, d, e, f, g, h) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g, PgColumnLabels h]+    PgParamLabels a = '[PgColumnLabels a]+++-- | A result row: one column, or a tuple of them.+class Row a where+    row :: D.Row a+++instance {-# OVERLAPPABLE #-} Column a => Row a where+    row = D.column decodeColumn+++instance (Column a, Column b) => Row (a, b) where+    row = (,) <$> D.column decodeColumn <*> D.column decodeColumn+++instance (Column a, Column b, Column c) => Row (a, b, c) where+    row = (,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn+++instance (Column a, Column b, Column c, Column d) => Row (a, b, c, d) where+    row = (,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn+++instance (Column a, Column b, Column c, Column d, Column e) => Row (a, b, c, d, e) where+    row = (,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn+++instance (Column a, Column b, Column c, Column d, Column e, Column f) => Row (a, b, c, d, e, f) where+    row = (,,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn+++instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g) => Row (a, b, c, d, e, f, g) where+    row = (,,,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn+++instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h) => Row (a, b, c, d, e, f, g, h) where+    row = (,,,,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn+++-- | The Postgres types of a statement's result columns.+type family PgColumnTypes (r :: Type) :: [Symbol] where+    PgColumnTypes (a, b) = '[PgColumnType a, PgColumnType b]+    PgColumnTypes (a, b, c) = '[PgColumnType a, PgColumnType b, PgColumnType c]+    PgColumnTypes (a, b, c, d) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d]+    PgColumnTypes (a, b, c, d, e) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e]+    PgColumnTypes (a, b, c, d, e, f) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f]+    PgColumnTypes (a, b, c, d, e, f, g) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g]+    PgColumnTypes (a, b, c, d, e, f, g, h) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g, PgColumnType h]+    PgColumnTypes a = '[PgColumnType a]+++-- | The enum labels of a statement's result columns, one list each.+type family PgColumnLabelLists (r :: Type) :: [[Symbol]] where+    PgColumnLabelLists (a, b) = '[PgColumnLabels a, PgColumnLabels b]+    PgColumnLabelLists (a, b, c) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c]+    PgColumnLabelLists (a, b, c, d) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d]+    PgColumnLabelLists (a, b, c, d, e) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e]+    PgColumnLabelLists (a, b, c, d, e, f) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f]+    PgColumnLabelLists (a, b, c, d, e, f, g) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g]+    PgColumnLabelLists (a, b, c, d, e, f, g, h) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g, PgColumnLabels h]+    PgColumnLabelLists a = '[PgColumnLabels a]+++-- | Type-level names, as text.+class KnownSymbols (ss :: [Symbol]) where+    symbolTexts :: [Text]+++instance KnownSymbols '[] where+    symbolTexts = []+++instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where+    symbolTexts = Text.pack (symbolVal (Proxy @s)) : symbolTexts @ss+++-- | The Postgres types of a statement's parameters, as GHC worked them out+-- where it is used. A class of its own, rather than 'KnownSymbols' itself,+-- so that @hasql-check-hie@ finds the whole list in a @.hie@ file, and not+-- only the tails 'KnownSymbols' is built from.+class KnownSymbols ps => PostgresParams ps+++instance KnownSymbols ps => PostgresParams ps+++-- | The Postgres types of a statement's result columns; see 'PostgresParams'.+class KnownSymbols cs => PostgresColumns cs+++instance KnownSymbols cs => PostgresColumns cs+++-- | The enum labels of a statement's parameters, as GHC worked them out where+-- it is used, for @hasql-check-hie@ to find; see 'PostgresParams'.+class PostgresParamLabels (ls :: [[Symbol]])+++instance PostgresParamLabels ls+++-- | The enum labels of a statement's result columns; see 'PostgresParams'.+class PostgresColumnLabels (ls :: [[Symbol]])+++instance PostgresColumnLabels ls+++-- | A statement's text, as the quoter cut it.+--+-- Its result columns are cast in a projection around it,+--+-- > WITH <its own WITH list,> r (c1, c2) AS (<the statement>) SELECT c1 :: int8, c2 :: text FROM r+--+-- rather than where they are selected, so that the statement means what it+-- did: a cast column is another expression to DISTINCT ON, ORDER BY and+-- GROUP BY, and no longer the primary key other columns depend on. The+-- statement's own WITH list goes first, since one with a data-modifying+-- statement must stay at the top.+data Template = Template+    { whole :: [Piece]+    -- ^ The statement, for one returning no rows.+    , wrapped :: Maybe Wrapped+    -- ^ Its parts, unless it cannot be put in a WITH list: a CALL.+    }+    deriving stock (Eq, Show, Lift)+++data Wrapped = Wrapped+    { with :: Maybe [Piece]+    -- ^ Its own WITH list, with the WITH.+    , body :: [Piece]+    -- ^ The rest of it.+    , name :: Text+    -- ^ A name for it that it does not use itself.+    }+    deriving stock (Eq, Show, Lift)+++-- | Some SQL, or the place of a parameter's annotation.+data Piece+    = Sql Text+    | -- | The annotation of the nth parameter, counting from 1.+      ParamType Int+    deriving stock (Eq, Show, Lift)+++-- | The statement's text, given the Postgres types of its parameters and+-- result columns.+render :: [Text] -> [Text] -> Template -> Text+render paramTypes' columnTypes' t = case (columnTypes', t.wrapped) of+    (_ : _, Just w) ->+        mconcat+            [ maybe "WITH " (\with -> fill with <> ", ") w.with+            , w.name+            , " ("+            , Text.intercalate ", " columns+            , ") AS ("+            , fill w.body+            , ") SELECT "+            , Text.intercalate ", " (zipWith (\c ty -> c <> " :: " <> ty) columns columnTypes')+            , " FROM "+            , w.name+            ]+    _ -> fill t.whole+  where+    columns = ["c" <> Text.pack (show i) | i <- [1 .. length columnTypes']]+    fill = foldMap \case+        Sql sql -> sql+        ParamType n -> case drop (n - 1) paramTypes' of+            ty : _ | n >= 1 -> " :: " <> ty+            _ -> ""+++-- | A statement returning rows, given what to make of them.+statement ::+    forall p r a ps cs pl cl.+    ( Params p+    , Row r+    , ps ~ PgParamTypes p+    , cs ~ PgColumnTypes r+    , PostgresParams ps+    , PostgresColumns cs+    , pl ~ PgParamLabels p+    , cl ~ PgColumnLabelLists r+    , PostgresParamLabels pl+    , PostgresColumnLabels cl+    ) =>+    Template ->+    (D.Row r -> D.Result a) ->+    Statement p a+statement template result =+    Statement.preparable (render (symbolTexts @ps) (symbolTexts @cs) template) params (result row)+++-- | A statement returning no rows.+resultless ::+    forall p ps pl.+    (Params p, ps ~ PgParamTypes p, PostgresParams ps, pl ~ PgParamLabels p, PostgresParamLabels pl) =>+    Template ->+    Statement p ()+resultless template = Statement.preparable (render (symbolTexts @ps) [] template) params D.noResult

@@ -0,0 +1,393 @@+-- |+-- Module      : Hasql.Check.Inferred.Quote+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Quotes of "Hasql.Check.Inferred.TH", with the Haskell types GHC used them+-- at, as @hasql-check-hie@ writes them: one JSON object a line.+--+-- Each is checked as the hasql-th quote it stands for - the same SQL, with+-- the annotations the Haskell types give it - so that every check of an+-- annotated quote applies to it too.+module Hasql.Check.Inferred.Quote (+    Inferred (..),+    Column (..),+    readInferred,+    annotated,+    sent,+    columns,+    checkSent,+    checkInferred,+) where++import Data.Aeson ((.!=), (.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Functor ((<&>))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Word (Word32)+import Hasql.Check (parsePlainStmt, quoterSettings, renderStmt)+import Hasql.Check.Annotate (annotate, typename, untypedLiterals)+import Hasql.Check.Finding (Finding (..), statementHash)+import Hasql.Check.Inferred (Piece (..), Template (..), render)+import Hasql.Check.Inferred.TH (template)+import Hasql.Check.Nullability (Catalogue, query)+import Hasql.Check.Nullability qualified as Nullability+import Hasql.Check.Types qualified as Types+import PostgresqlSyntax qualified as Ast+import Pqi qualified+import Text.Read (readMaybe)+import Prelude+++data Inferred = Inferred+    { file :: FilePath+    , line :: Int+    , column :: Int+    , quoter :: Text+    , sql :: Text+    , params :: [Column]+    , row :: Maybe [Column]+    -- ^ Nothing for a statement that returns no rows.+    }+++-- | A parameter or result column: the qualified name of its Haskell type,+-- its Postgres type, and whether it is a 'Maybe'.+data Column = Column+    { haskellType :: Text+    , postgres :: Text+    -- ^ As GHC worked it out from the Haskell type's 'Hasql.Check.Inferred.PgType'.+    , labels :: [Text]+    -- ^ The labels of the enum it is, if it is one.+    , nullable :: Bool+    }+++instance Aeson.FromJSON Inferred where+    parseJSON = Aeson.withObject "quote" \o ->+        Inferred+            <$> o .: "file"+            <*> o .: "line"+            <*> o .: "column"+            <*> o .: "quoter"+            <*> o .: "sql"+            <*> o .: "params"+            <*> o .:? "row"+++instance Aeson.FromJSON Column where+    parseJSON = Aeson.withObject "column" \o -> Column <$> o .: "type" <*> o .: "postgres" <*> (o .:? "labels" .!= []) <*> o .: "nullable"+++-- | Everything checking an inferred statement finds: why it fails, or the+-- warnings asked for - nullability, narrowing - in terms of its Haskell+-- types, and its fingerprint for baselines: the SQL it sends, so that+-- reading a column as another type is another statement.+checkInferred :: Pqi.Connection -> Maybe Catalogue -> Bool -> Bool -> Inferred -> IO (Either String ([Finding], Text))+checkInferred conn catalogue nullable narrowing q =+    checkSent conn q >>= \case+        errors@(_ : _) -> pure (Left (unlines errors))+        [] -> case annotated q >>= parsePlainStmt True of+            Left err -> pure (Left err)+            Right ast -> do+                let readAs = columns q+                found <- case catalogue of+                    Nothing -> pure []+                    Just cat -> do+                        nullables <- if nullable then maybe (pure []) (\cs -> Nullability.checkColumns conn cat (map snd cs) ast) readAs else pure []+                        narrowed <-+                            if narrowing+                                then (<>) <$> Types.check conn cat ast <*> maybe (pure []) (\cs -> Types.checkColumns conn cat (map fst cs) ast) readAs+                                else pure []+                        pure (nullables <> narrowed)+                let fingerprint = either (const (statementHash (renderStmt ast))) (statementHash . Text.encodeUtf8) (sent q)+                pure (Right ([f{message = inHaskellTerms f.message} | f <- found], fingerprint))+++-- | A finding about an inferred quote, in terms of its Haskell types rather+-- than the annotations they stand for.+inHaskellTerms :: String -> String+inHaskellTerms m =+    Text.unpack+        . Text.replace "is annotated " (if "parameter " `Text.isPrefixOf` t then "is sent as " else "is read as ")+        . Text.replace "is annotated non-null" "is not a Maybe in Haskell"+        $ t+  where+    t = Text.pack m+++-- | Quotes, one JSON object a line.+readInferred :: ByteString -> Either String [Inferred]+readInferred contents =+    traverse+        (\(n, l) -> either (\e -> Left ("line " <> show n <> ": " <> e)) Right (Aeson.eitherDecodeStrict l))+        [(n, l) | (n :: Int, l) <- zip [1 ..] (ByteString.Char8.lines contents), not (ByteString.Char8.null l)]+++-- | The statement with its parameters annotated, as a hasql-th quote: its+-- result columns are cast around it, which the warnings see through+-- 'columns'.+annotated :: Inferred -> Either String Text+annotated q = do+    stmt <- parsePlainStmt False q.sql+    params <- traverse (\c -> typename c.postgres c.nullable) q.params+    let param n = case drop (n - 1) params of+            t : _ | n >= 1 -> Just t+            _ -> Nothing+    pure (Ast.toText quoterSettings (annotate param stmt))+++-- | The statement as the quoter sends it, casts and all.+sent :: Inferred -> Either String Text+sent q = do+    t <- template q.sql+    params <- traverse postgresType q.params+    row <- traverse (traverse postgresType) q.row+    pure (render (map fst params) (maybe [] (map fst) row) t)+++-- | The Postgres type each result column is read as, and whether it may be+-- NULL.+columns :: Inferred -> Maybe [(Text, Bool)]+columns q = either (const Nothing) Just . traverse postgresType =<< q.row+++postgresType :: Column -> Either String (Text, Bool)+postgresType c = Right (c.postgres, c.nullable)+++-- | Whether the statement, as the quoter sends it, prepares; whether it+-- takes as many parameters as the Haskell type sends, and returns as many+-- columns as it reads, each of a type it can be read as. Prepared, as hasql+-- prepares it, with the parameters' types, which Postgres could not tell for+-- a parameter the statement does not use.+--+-- A result column is cast to the type it is read as, and Postgres casts+-- anything it can convert, even text to a number, which fails at runtime for+-- text that is not one. So the column must have that type already, or one+-- Postgres converts to it without being told to: implicitly, or on+-- assignment.+checkSent :: Pqi.Connection -> Inferred -> IO [String]+checkSent conn q = case (,,) <$> template q.sql <*> traverse postgresType q.params <*> traverse (traverse postgresType) q.row of+    Left err -> pure [err]+    Right (t, params, row) -> do+        oids <- traverse (oid . fst) params+        case sequence oids of+            Nothing -> pure ["a parameter's type does not exist: " <> unwords [Text.unpack name | ((name, _), Nothing) <- zip params oids]]+            Just paramOids -> do+                shape <- described (render (map fst params) [] t) paramOids+                case shape of+                    Left err -> pure [err]+                    Right found -> do+                        -- From the statement itself: prepared with the+                        -- types hasql sends, it takes them all, used or not.+                        let used = [n | ParamType n <- t.whole]+                            sends = length q.params+                            paramErrors =+                                [ concat ["the Haskell type sends parameter $", show n, ", which the statement does not use"]+                                | n <- [1 .. sends]+                                , n `notElem` used+                                ]+                                    <> [ "the statement uses $" <> show (maximum used) <> ", but the Haskell type sends " <> count "parameter" sends+                                       | not (null used)+                                       , maximum used > sends+                                       ]+                        columnErrors <- case (row, t.wrapped) of+                            (Nothing, _) -> pure []+                            (Just readAs, _)+                                | length found /= length readAs ->+                                    pure ["the statement returns " <> count "column" (length found) <> ", but the Haskell type reads " <> show (length readAs)]+                            (Just readAs, wrapped) -> do+                                expected <- traverse (oid . fst) readAs+                                let literals = either (const []) untypedLiterals (parsePlainStmt False q.sql)+                                    missing = [Text.unpack name | ((name, _), Nothing) <- zip readAs expected]+                                if not (null missing)+                                    then pure ["no such Postgres type: " <> unwords missing]+                                    else+                                        fmap concat . sequence $+                                            [ case wrapped of+                                                -- A CALL cannot be wrapped, so its+                                                -- columns are not cast: they must+                                                -- already be of the types read, or+                                                -- domains over them.+                                                Nothing -> do+                                                    same <- sameBase found' e+                                                    if same then pure [] else (\pg -> ["column " <> show i <> " (" <> name <> ") is " <> pg <> ", but is read as " <> Text.unpack c.haskellType]) <$> nameOf found'+                                                Just _ -> case lookup i literals of+                                                    Just literal -> literalError i name c literal+                                                    Nothing -> conversionError i name c found' e+                                            | (i :: Int, c, (name, found'), Just e) <- zip4 [1 ..] (concat q.row) found expected+                                            , found' /= e+                                            ]+                        -- What is sent, wrapped in its casts.+                        sentErrors <-+                            if null (paramErrors <> columnErrors)+                                then either pure (const []) <$> described (render (map fst params) (maybe [] (map fst) row) t) paramOids+                                else pure []+                        labelErrors <-+                            if null (paramErrors <> columnErrors)+                                then+                                    (<>)+                                        <$> (concat <$> traverse paramLabels (zip [1 ..] q.params))+                                        <*> (concat <$> traverse columnLabels (zip3 [1 ..] (concat q.row) (map fst found)))+                                else pure []+                        pure (paramErrors <> columnErrors <> sentErrors <> labelErrors)+  where+    -- A label the database does not have fails to be sent; one the Haskell+    -- type does not have fails to be read.+    paramLabels (n :: Int, c) = labelsAgainst c \enum labels ->+        [ concat ["parameter $", show n, " is sent as ", Text.unpack c.haskellType, ", with labels ", Text.unpack enum, " does not have: ", list missing]+        | let missing = filter (`notElem` labels) c.labels+        , not (null missing)+        ]+    columnLabels (i :: Int, c, name) = labelsAgainst c \enum labels ->+        [ concat ["column ", show i, " (", name, ") is read as ", Text.unpack c.haskellType, ", which cannot read labels ", Text.unpack enum, " has: ", list missing]+        | let missing = filter (`notElem` c.labels) labels+        , not (null missing)+        ]+    labelsAgainst c compare'+        | null c.labels = pure []+        | otherwise =+            enumLabels c.postgres <&> \case+                Nothing -> [Text.unpack c.postgres <> " is sent and read as an enum, but is not one in the database"]+                Just labels -> compare' c.postgres labels+    list = Text.unpack . Text.intercalate ", "+    -- The labels of the enum a type is, through any domains over it and+    -- arrays of it.+    enumLabels name =+        query+            conn+            ( mconcat+                [ "WITH RECURSIVE t (oid, typtype, typcategory, typbasetype, typelem) AS ("+                , "SELECT oid, typtype, typcategory, typbasetype, typelem FROM pg_catalog.pg_type WHERE oid = to_regtype("+                , quoteLiteral name+                , ") UNION ALL SELECT p.oid, p.typtype, p.typcategory, p.typbasetype, p.typelem FROM pg_catalog.pg_type p, t"+                , " WHERE p.oid = CASE WHEN t.typtype = 'd' THEN t.typbasetype WHEN t.typcategory = 'A' THEN t.typelem END)"+                , " SELECT e.enumlabel FROM pg_catalog.pg_enum e WHERE e.enumtypid = (SELECT oid FROM t WHERE typtype = 'e')"+                , " ORDER BY e.enumsortorder"+                ]+            )+            <&> \case+                Right [] -> Nothing+                Right rows -> Just [Text.decodeUtf8Lenient l | [Just l] <- rows]+                Left _ -> Nothing+    described sql paramOids = do+        prepared <- conn.prepare "" (Text.encodeUtf8 sql) (Just paramOids)+        case prepared of+            Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage+            Just result -> do+                status <- result.resultStatus+                if status /= Pqi.CommandOk+                    then Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> result.resultErrorMessage+                    else+                        conn.describePrepared "" >>= \case+                            Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage+                            Just d -> do+                                n <- d.nfields+                                found <- traverse (\i -> (,) <$> (maybe "?column?" (Text.unpack . Text.decodeUtf8Lenient) <$> d.fname i) <*> d.ftype i) [0 .. n - 1]+                                pure (Right found)+    -- A literal is converted once and for all: try it.+    literalError i name c literal =+        query conn (Text.encodeUtf8 (mconcat ["SELECT (", literal, ") :: ", c.postgres])) <&> \case+            Right _ -> []+            Left err -> [concat ["column ", show i, " (", name, ") is ", Text.unpack literal, ", which cannot be read as ", Text.unpack c.haskellType, ": ", err]]+    conversionError i name c from to = do+        converts <- convertsWithoutBeingTold from to+        fromName <- nameOf from+        toName <- nameOf to+        pure+            [ concat+                [ "column "+                , show i+                , " ("+                , name+                , ") is "+                , fromName+                , ", but is read as "+                , Text.unpack c.haskellType+                , " ("+                , toName+                , "), which Postgres converts it to only when told to, and can fail to at runtime"+                ]+            | not converts+            ]+    -- Through their base types, so that a domain converts as the type it is+    -- over; and an array as its elements, as Postgres converts arrays.+    convertsWithoutBeingTold :: Word32 -> Word32 -> IO Bool+    convertsWithoutBeingTold from to =+        query+            conn+            ( mconcat+                [ "SELECT f.typelem::text, t.typelem::text FROM pg_catalog.pg_type f, pg_catalog.pg_type t"+                , " WHERE f.oid = "+                , base from+                , " AND t.oid = "+                , base to+                , " AND f.typcategory = 'A' AND t.typcategory = 'A'"+                ]+            )+            >>= \case+                Right [[Just f, Just t]]+                    | Just f' <- readMaybe (ByteString.Char8.unpack f)+                    , Just t' <- readMaybe (ByteString.Char8.unpack t) ->+                        convertsWithoutBeingTold f' t'+                _ -> scalarConverts from to+    scalarConverts from to =+        query+            conn+            ( mconcat+                [ "SELECT (SELECT castcontext::text FROM pg_catalog.pg_cast WHERE castsource = "+                , base from+                , " AND casttarget = "+                , base to+                , "), "+                , base from+                , " = "+                , base to+                , ", (SELECT typcategory = 'S' FROM pg_catalog.pg_type WHERE oid = "+                , base to+                , ")"+                ]+            )+            >>= \case+                Right [[context, same, toString]] -> pure (same == Just "t" || toString == Just "t" || context `elem` [Just "i", Just "a"])+                _ -> pure False+    -- Through every domain a domain is over.+    base o =+        mconcat+            [ "(WITH RECURSIVE d (oid, typtype, typbasetype) AS (SELECT oid, typtype, typbasetype FROM pg_catalog.pg_type WHERE oid = "+            , ByteString.Char8.pack (show o)+            , " UNION ALL SELECT t.oid, t.typtype, t.typbasetype FROM pg_catalog.pg_type t, d WHERE t.oid = d.typbasetype AND d.typtype = 'd')"+            , " SELECT oid FROM d WHERE typtype <> 'd')"+            ]+    sameBase from to =+        query conn (mconcat ["SELECT ", base from, " = ", base to]) <&> \case+            Right [[Just "t"]] -> True+            _ -> False+    count :: String -> Int -> String+    count what 1 = "1 " <> what+    count what k = unwords [show k, what <> "s"]+    oid :: Text -> IO (Maybe Word32)+    oid name =+        query conn (mconcat ["SELECT to_regtype(", quoteLiteral name, ")::oid::text"]) >>= \case+            Right [[Just o]] -> pure (readMaybe (ByteString.Char8.unpack o))+            _ -> pure Nothing+    nameOf :: Word32 -> IO String+    nameOf o =+        query conn (mconcat ["SELECT ", ByteString.Char8.pack (show o), "::regtype::text"]) >>= \case+            Right [[Just name]] -> pure (Text.unpack (Text.decodeUtf8Lenient name))+            _ -> pure ("type " <> show o)+    quoteLiteral name = mconcat ["'", Text.encodeUtf8 (Text.replace "'" "''" name), "'"]+++zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]+zip4 (a : as) (b : bs) (c : cs) (d : ds) = (a, b, c, d) : zip4 as bs cs ds+zip4 _ _ _ _ = []

@@ -0,0 +1,129 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      : Hasql.Check.Inferred.TH+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Quoters for SQL without annotations: the Haskell types a statement is used+-- with decide its parameter and result types.+--+-- > profile :: Statement Int64 (Maybe (Text, Maybe Text))+-- > profile = [maybeStatement| select email, nickname from customer where id = $1 |]+--+-- sends+--+-- > WITH hasql_check_result (c1, c2) AS (SELECT email, nickname FROM customer WHERE id = $1 :: int8)+-- > SELECT c1 :: text, c2 :: text FROM hasql_check_result+--+-- GHC can only tell whether those types fit the schema with a database; see+-- the README for checking them with @hasql-check --inferred@.+module Hasql.Check.Inferred.TH (+    singletonStatement,+    maybeStatement,+    vectorStatement,+    resultlessStatement,+    template,+) where++import Data.Char (isAlphaNum)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Hasql.Check (parsePlainStmt, renderStmt)+import Hasql.Check.Annotate (annotate, placeholder)+import Hasql.Check.Inferred (Piece (..), Template (..), Wrapped (..), resultless, statement)+import Hasql.Decoders qualified as D+import Language.Haskell.TH (Exp, Q)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax (lift)+import PostgresqlSyntax qualified as Ast+import Text.Read (readMaybe)+import Prelude+++quoter :: (Q Exp -> Q Exp) -> QuasiQuoter+quoter make =+    QuasiQuoter+        { quoteExp = either fail (make . lift) . template . Text.pack+        , quotePat = const (fail "Not supported in patterns")+        , quoteType = const (fail "Not supported in types")+        , quoteDec = const (fail "Not supported in declarations")+        }+++singletonStatement, maybeStatement, vectorStatement, resultlessStatement :: QuasiQuoter+singletonStatement = quoter \t -> [|statement $t D.singleRow|]+maybeStatement = quoter \t -> [|statement $t D.rowMaybe|]+vectorStatement = quoter \t -> [|statement $t D.rowVector|]+resultlessStatement = quoter \t -> [|resultless $t|]+++-- | The statement, rendered as hasql-th would render it, cut where its+-- parameters' annotations go, and split where its result columns' cast+-- goes around it.+template :: Text -> Either String Template+template sql = do+    stmt <- parsePlainStmt False sql+    -- Names the statement does not already contain, in a string literal or+    -- as a table, say.+    let plain = Text.toLower (Text.decodeUtf8Lenient (renderStmt stmt))+        unused base = until (not . (`Text.isInfixOf` plain)) (<> "_") base+        prefix = unused "hasql_check_slot_"+        annotated = annotate (\n -> Just (placeholder (prefix <> Text.pack (show n)))) stmt+        cut = cutWith prefix+    pure+        Template+            { whole = cut (Text.decodeUtf8Lenient (renderStmt annotated))+            , wrapped =+                ( \(with, body) ->+                    Wrapped+                        { with = cut . Ast.toText mempty <$> with+                        , body = cut (Text.decodeUtf8Lenient (renderStmt body))+                        , name = unused "hasql_check_result"+                        }+                )+                    <$> splitWith annotated+            }+++-- | The statement's own WITH list, and the rest of it.+splitWith :: Ast.PreparableStmt -> Maybe (Maybe Ast.WithClause, Ast.PreparableStmt)+splitWith = \case+    -- "(WITH ... SELECT ...)" is a parenthesised select clause.+    Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens Nothing (Ast.WithParensSelectClause p) s l f)) ->+        let (w, p') = inParens p+         in Just (w, Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens Nothing (Ast.WithParensSelectClause p') s l f)))+    Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens w c s l f)) ->+        Just (w, Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens Nothing c s l f)))+    Ast.SelectPreparableStmt (Ast.WithParensSelectStmt s) -> Just (Ast.SelectPreparableStmt . Ast.WithParensSelectStmt <$> inParens s)+    Ast.InsertPreparableStmt (Ast.InsertStmt w a b c d) -> Just (w, Ast.InsertPreparableStmt (Ast.InsertStmt Nothing a b c d))+    Ast.UpdatePreparableStmt (Ast.UpdateStmt w a b c d e) -> Just (w, Ast.UpdatePreparableStmt (Ast.UpdateStmt Nothing a b c d e))+    Ast.DeletePreparableStmt (Ast.DeleteStmt w a b c d) -> Just (w, Ast.DeletePreparableStmt (Ast.DeleteStmt Nothing a b c d))+    Ast.CallPreparableStmt _ -> Nothing+++-- | A parenthesised SELECT's WITH list, and the rest of it: the list can go+-- outside the parentheses, and must, if it has a data-modifying statement.+inParens :: Ast.SelectWithParens -> (Maybe Ast.WithClause, Ast.SelectWithParens)+inParens = \case+    Ast.NoParensSelectWithParens (Ast.SelectNoParens w c s l f) -> (w, Ast.NoParensSelectWithParens (Ast.SelectNoParens Nothing c s l f))+    Ast.WithParensSelectWithParens s -> Ast.WithParensSelectWithParens <$> inParens s+++cutWith :: Text -> Text -> [Piece]+cutWith prefix = cut+  where+    cut t = case Text.breakOn (" :: " <> prefix) t of+        (before, "") -> [Sql before | not (Text.null before)]+        (before, rest) ->+            let (slot, after) = Text.span isAlphaNum (Text.drop (Text.length (" :: " <> prefix)) rest)+             in [Sql before | not (Text.null before)] <> piece slot <> cut after++    piece slot = case readMaybe (Text.unpack slot) of+        Just i -> [ParamType i]+        Nothing -> [Sql (" :: " <> prefix <> slot)]

@@ -0,0 +1,276 @@++{++{-# LANGUAGE NoStrictData #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}++module Hasql.Check.Lexer where++import           Prelude+import           Control.Monad (when)+import           Data.Maybe (isJust, fromJust)+import           Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as ByteString.Builder+import           Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString.Lazy+import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8+import           Data.Text (Text)+import qualified Data.Text.Encoding as Text.Encoding+import           System.Directory++}++%wrapper "monadUserState-bytestring"++$digit      = 0-9                                            -- digits+$small      = [a-z_]+$large      = [A-Z]+$alpha      = [A-Za-z]+$idchar     = [$alpha $digit _ \']                           -- identifier character+$symbol     = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]     -- ascii operator symbols+$pipe       = \|+$rbrack     = \]+$lbrack     = \[++@varid      = $small $idchar*+@modid      = $large $idchar*+-- GHC accepts a qualified quoter, [Hasql.TH.vectorStatement| ... |], as well+-- as a bare one.+@quoter     = (@modid \.)* @varid+@beginquote = $lbrack @quoter $pipe+@endquote   = $pipe $rbrack+-- A string gap: a backslash, whitespace including newlines, a backslash.+@gap        = \\ $white+ \\+@charlit    = \' ( [^\\ \' \n] | \\ [^\n] [^\' \n]* ) \'++tokens :-+<0>                        @beginquote   { enterQuote `andBegin` state_quote }+<0>                        \n            { skip }+-- Identifiers are consumed whole so the prime in x' is never read as the start+-- of a character literal.+<0>                        [$alpha \_] $idchar*  { skip }+-- Literals are skipped so that "{-", "--" or "[x|" inside one cannot open a+-- comment or a quote and hide the quotes that follow it.+<0>                        @charlit      { skip }+<0>                        \"\"\"        { skip `andBegin` state_multiline_string }+<0>                        \"            { skip `andBegin` state_string }+<state_string>             @gap          { skip }+<state_string>             \\ .          { skip }+<state_string>             \"            { skip `andBegin` state_initial }+<state_string>             \n            { skip }+<state_string>             .             { skip }+<state_multiline_string>   \\ .          { skip }+<state_multiline_string>   \"\"\"        { skip `andBegin` state_initial }+<state_multiline_string>   \n            { skip }+<state_multiline_string>   .             { skip }+-- A run of dashes followed by a symbol is an operator such as --> rather than+-- a comment.+<0>                        "--" \-* / ~$symbol { skip `andBegin` state_line_comment }+<state_line_comment>       \n            { skip `andBegin` state_initial }+<state_line_comment>       .             { skip }+<0>                        "{-"          { enterNewComment `andBegin` state_multi_comment }+<0>                        .             { skip }+<state_multi_comment>      "{-"          { embedComment }+<state_multi_comment>      "-}"          { unembedComment }+<state_multi_comment>      \n            { skip }+<state_multi_comment>      .             { skip }+<state_quote>              \n            { addCurrentToQuote }+<state_quote>              .             { addCurrentToQuote }+<state_quote>              @endquote     { leaveQuote `andBegin` state_initial }++{+data Lexeme = Lexeme AlexPosn LexemeClass+    deriving (Show, Eq)++data LexemeClass =+    Eof+    | Quoter Text+    | Quote Text+    deriving (Show, Eq)++mkLexemeClass :: LexemeClass -> AlexInput -> Int64 -> Alex Lexeme+mkLexemeClass c (p, _, _, _) _ = return (Lexeme p c)++-- states+state_initial :: Int+state_initial = 0++-- user state type++data AlexUserState = AlexUserState+    { lexerCommentDepth :: Int+    , lexerQuoterState :: Bool+    , lexerQuoterValue :: Builder+    , lexerQuoteState :: Bool+    , lexerQuoteValue :: Builder+    }++alexInitUserState :: AlexUserState+alexInitUserState = AlexUserState+    { lexerCommentDepth = 0+    , lexerQuoterState = False+    , lexerQuoterValue = mempty+    , lexerQuoteState = False+    , lexerQuoteValue = mempty+    }++getLexerCommentDepth :: Alex Int+getLexerCommentDepth = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerCommentDepth ust)++setLexerCommentDepth :: Int -> Alex ()+setLexerCommentDepth depth = Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerCommentDepth = depth}}, ())++enterNewComment :: AlexInput -> Int64 -> Alex Lexeme+enterNewComment input len = do+    setLexerCommentDepth 1+    skip input len++embedComment :: AlexInput -> Int64 -> Alex Lexeme+embedComment input len = do+    d <- getLexerCommentDepth+    setLexerCommentDepth (d + 1)+    skip input len++unembedComment :: AlexInput -> Int64 -> Alex Lexeme+unembedComment input len = do+    d <- getLexerCommentDepth+    setLexerCommentDepth (d - 1)+    if d == 1+    then do+        (skip `andBegin` state_initial) input len+    else skip input len++getLexerQuoteState :: Alex Bool+getLexerQuoteState = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoteState ust)++getLexerQuoterState :: Alex Bool+getLexerQuoterState = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoterState ust)++setLexerQuoteState :: Bool -> Alex ()+setLexerQuoteState quoteState =+    Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoteState = quoteState}}, ())++setLexerQuoterState :: Bool -> Alex ()+setLexerQuoterState quoterState =+    Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoterState = quoterState}}, ())++getLexerQuoteValue :: Alex Builder+getLexerQuoteValue = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoteValue ust)++setLexerQuoteValue :: Builder -> Alex ()+setLexerQuoteValue builder = Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoteValue = builder}}, ())++getLexerQuoterValue :: Alex Builder+getLexerQuoterValue = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoterValue ust)++setLexerQuoterValue :: Builder -> Alex ()+setLexerQuoterValue builder = Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoterValue = builder}}, ())++addCurrentToQuote :: AlexInput -> Int64 -> Alex Lexeme+addCurrentToQuote (_, _, bytestring, _) len = do+    builder <- getLexerQuoteValue+    setLexerQuoteValue (builder <> ByteString.Builder.lazyByteString (ByteString.Lazy.take len bytestring))+    alexMonadScan++enterQuote :: AlexInput -> Int64 -> Alex Lexeme+enterQuote input len = do+    setLexerQuoteState True+    setLexerQuoteValue mempty+    addQuoter input len++leaveQuote :: AlexInput -> Int64 -> Alex Lexeme+leaveQuote (posn, _, _, _) _ = do+    builder <- getLexerQuoteValue+    setLexerQuoteState False+    setLexerQuoterState False+    case Text.Encoding.decodeUtf8' (ByteString.Lazy.toStrict (ByteString.Builder.toLazyByteString builder)) of+        Left e -> lexerError $ "Malformed utf8 string: " <> show e+        Right string -> pure $ Lexeme posn (Quote string)++addQuoter :: AlexInput -> Int64 -> Alex Lexeme+addQuoter (posn, _, bytestring, _) len = do+    let bsVariable = ByteString.Lazy.dropEnd 1 (ByteString.Lazy.drop 1 (ByteString.Lazy.take len bytestring))+    case Text.Encoding.decodeUtf8' (ByteString.Lazy.toStrict bsVariable) of+        Right var -> do+            pure $ Lexeme posn (Quoter var)+        Left e -> lexerError $ "Malformed utf8 representation of quoter, expecting unicode: " <> show e++getPosn :: Alex AlexPosn+getPosn = Alex $ \s@AlexState{alex_pos = posn} -> Right (s, posn)++alexEOF :: Alex Lexeme+alexEOF = flip Lexeme Eof <$> getPosn++showPosn :: AlexPosn -> String+showPosn (AlexPn _ line col) = show line ++ ':': show col++-- the error message doesn't do a utf8 decoding of the input.+lexerError :: String -> Alex a+lexerError msg =+    do (p, c, inp, _) <- alexGetInput+       let inp1 = ByteString.Lazy.Char8.filter (/= '\r') (ByteString.Lazy.Char8.takeWhile (/='\n') inp)+       let inp2 = if (ByteString.Lazy.length inp1 > 30)+                     then trimBSL (ByteString.Lazy.take 30 inp1)+                     else trimBSL inp1+       let disp = if (ByteString.Lazy.null inp)+                     then " at end of file"+                     else if (ByteString.Lazy.null inp2)+                             then " before end of line"+                             else " on char " ++ show c ++ " before : '" ++ ByteString.Lazy.Char8.unpack inp2 ++ "'"+       let disp3 = if (null msg)+                      then "Lexer error"+                      else trim msg+       alexError (disp3 ++ " at " ++ showPosn p ++ disp)+  where+    trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ')+    trimBSL = ByteString.Lazy.Char8.takeWhile (/= ' ') . ByteString.Lazy.Char8.dropWhile (== ' ')++-- Execution++scanner :: ByteString -> Either String [Lexeme]+scanner str = let loop = do (t, m) <- alexComplementError alexMonadScan+                            when (isJust m) (lexerError (fromJust m))+                            let tok@(Lexeme _ cl) = t+                            if (cl == Eof)+                               then do f1 <- getLexerQuoterState+                                       d2 <- getLexerQuoteState+                                       if ((not f1) && (not d2))+                                          then return [tok]+                                          else alexError "Quote not closed at end of file"+                               else do toks <- loop+                                       return (tok : toks)+              in  runAlex str loop++-- we capture the error message in order to complement it with the file position+alexComplementError :: Alex a -> Alex (a, Maybe String)+alexComplementError (Alex al) = Alex $ \s ->+    case al s of+        Right (s', x) -> Right (s', (x, Nothing))+        Left  message -> Right (s, (undefined, Just message))+++lexer :: (Lexeme -> Alex a) -> Alex a+lexer f = do+  (t, m) <- alexComplementError alexMonadScan+  when (isJust m) (lexerError (fromJust m))+  let tok@(Lexeme _ cl) = t+  if (cl == Eof)+     then do+       f1 <- getLexerQuoterState+       d2 <- getLexerQuoteState+       if ((not f1) && (not d2))+          then f tok+          else alexError "Quote not closed at end of file"+     else f tok++lexFile :: FilePath -> IO (Either String [Lexeme])+lexFile fn = do+  flag <- doesFileExist fn+  if not flag+    then pure $ Left ("The following file does not exist : " ++ fn)+    else do+      putStrLn ("Beginning analysis of the hasql-th quotes in file " ++ fn)+      s <- ByteString.Lazy.readFile fn+      pure (reverse <$> scanner s)++}

@@ -0,0 +1,530 @@+{-# LANGUAGE CPP #-}++-- |+-- Module      : Hasql.Check.Nullability+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Warn about result columns annotated non-null that can be null.+--+-- The annotation on a result column is a cast, and a cast hides where the+-- column came from, so the statement is prepared a second time with the+-- outermost cast of every result column removed. Postgres then reports, for+-- each plain column reference, the table and column it reads, and the+-- catalogue says whether that column is @NOT NULL@.+--+-- The plan of that statement adds two things. Columns from the nullable side+-- of an outer join can be null whatever the catalogue says, as sqlx also+-- finds. And a column the plan filters with @IS NOT NULL@ cannot be null,+-- whatever the catalogue says. The plan rather than the statement's own+-- @WHERE@ clause is used for the second because the plan has the+-- conditions after Postgres has resolved precedence, pushed them down and+-- turned outer joins they make inner into inner joins.+--+-- Anything else - expressions, views - is not checked: Postgres does not say+-- whether they can be null.+module Hasql.Check.Nullability (+    Catalogue,+    baseType,+    prepareSession,+    Annotation (..),+    strip,+    query,+    check,+    checkColumns,+    resultQuoters,+) where++import Control.Exception (finally)+import Control.Monad (forM)+import Data.Aeson ((.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.Bifunctor (second)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Data (Data, cast, gmapT)+import Data.Foldable (toList)+import Data.Int (Int32)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Word (Word32)+import Hasql.Check (renderStmt)+import Hasql.Check.Finding (Finding (..), Rule (..))+import PostgresqlSyntax qualified as Ast+import Pqi qualified+import Text.Read (readMaybe)+import Prelude+++-- | The quoters whose statements return rows.+resultQuoters :: [Text]+resultQuoters = ["singletonStatement", "maybeStatement", "vectorStatement", "foldStatement"]+++-- * The catalogue+++data Column = Column+    { qualifiedName :: Text+    , notNull :: Bool+    , fromView :: Bool+    -- ^ A view's or materialized view's column, whose @attnotnull@ is always+    -- false and so says nothing.+    }+++data Catalogue = Catalogue+    { columns :: Map (Word32, Int32) Column+    -- ^ Every column of every relation, by table OID and column number.+    , domains :: Map Word32 Word32+    -- ^ The base type of every domain.+    }+++-- | A type with any domains it is built on looked through.+baseType :: Catalogue -> Word32 -> Word32+baseType catalogue t = maybe t (baseType catalogue) (Map.lookup t catalogue.domains)+++-- | Get the session ready for 'check': read the catalogue, and force generic+-- plans, so that EXPLAIN EXECUTE with NULL parameters shows the plan for any+-- parameters rather than one with the NULLs folded in.+prepareSession :: Pqi.Connection -> IO (Either String Catalogue)+prepareSession conn = do+    generic <- query conn "SET plan_cache_mode = force_generic_plan"+    catalogue <- loadCatalogue conn+    pure (generic *> catalogue)+++loadCatalogue :: Pqi.Connection -> IO (Either String Catalogue)+loadCatalogue conn = do+    result <-+        query+            conn+            ( ByteString.Char8.unwords+                [ "SELECT a.attrelid::text, a.attnum::text, n.nspname || '.' || c.relname || '.' || a.attname,"+                , "a.attnotnull::text, (c.relkind IN ('v', 'm'))::text"+                , "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"+                , "WHERE a.attnum > 0 AND NOT a.attisdropped"+                ]+            )+    domainRows <- query conn "SELECT oid::text, typbasetype::text FROM pg_catalog.pg_type WHERE typtype = 'd'"+    pure do+        rows <- result+        columns <- Map.fromList <$> traverse row rows+        domains <- Map.fromList <$> (domainRows >>= traverse domain)+        pure (Catalogue columns domains)+  where+    domain = \case+        [Just t, Just base]+            | Just t' <- readMaybe (ByteString.Char8.unpack t)+            , Just base' <- readMaybe (ByteString.Char8.unpack base) ->+                Right (t', base')+        other -> Left ("Unexpected domain row: " <> show other)+    row = \case+        [Just rel, Just num, Just name, Just nn, Just view]+            | Just rel' <- readMaybe (ByteString.Char8.unpack rel)+            , Just num' <- readMaybe (ByteString.Char8.unpack num) ->+                Right ((rel', num'), Column (Text.decodeUtf8Lenient name) (nn == "true") (view == "true"))+        other -> Left ("Unexpected catalogue row: " <> show other)+++-- * Stripping the result casts+++-- | A result column's outermost cast, if it has one: its nullability, and the+-- expression with and without it.+data Annotation = Annotation+    { nullable :: Maybe Bool+    , removed :: Maybe (Ast.AExpr, Ast.AExpr)+    }+++typenameNullable :: Ast.Typename -> Bool+typenameNullable (Ast.Typename _ _ nullable dims) = maybe nullable snd dims+++stripExpr :: Ast.AExpr -> (Annotation, Ast.AExpr)+stripExpr = \case+    whole@(Ast.TypecastAExpr e t) -> (Annotation (Just (typenameNullable t)) (Just (whole, e)), e)+    e -> (Annotation Nothing Nothing, e)+++stripTargetEl :: Ast.TargetEl -> Maybe (Annotation, Ast.TargetEl)+stripTargetEl = \case+    Ast.AliasedExprTargetEl a i -> Just (second (`Ast.AliasedExprTargetEl` i) (stripExpr a))+    Ast.ImplicitlyAliasedExprTargetEl a i -> Just (second (`Ast.ImplicitlyAliasedExprTargetEl` i) (stripExpr a))+    Ast.ExprTargetEl a -> Just (second Ast.ExprTargetEl (stripExpr a))+    Ast.AsteriskTargetEl -> Nothing+++stripTargetList :: Ast.TargetList -> Maybe ([Annotation], Ast.TargetList)+stripTargetList (Ast.TargetList els) = do+    stripped <- traverse stripTargetEl els+    pure (map fst (toList stripped), Ast.TargetList (fmap snd stripped))++#ifdef KRONOR_SYNTAX++-- | Kronor's fork keeps the select list as Haskell targets; once erased, every+-- one of them is a plain SQL target.+stripNormalTargeting :: Ast.HsTargetList -> Maybe ([Annotation], Ast.Targeting)+stripNormalTargeting (Ast.HsTargetList els) = do+    stripped <- traverse one els+    pure (map fst (toList stripped), Ast.NormalTargeting (Ast.HsTargetList (fmap snd stripped)))+  where+    one = \case+        Ast.SqlTargetEl te -> second Ast.SqlTargetEl <$> stripTargetEl te+        _ -> Nothing++#else++stripNormalTargeting :: Ast.TargetList -> Maybe ([Annotation], Ast.Targeting)+stripNormalTargeting l = second Ast.NormalTargeting <$> stripTargetList l++#endif+++stripTargeting :: Ast.Targeting -> Maybe ([Annotation], Ast.Targeting)+stripTargeting = \case+    Ast.NormalTargeting l -> stripNormalTargeting l+    Ast.AllTargeting (Just l) -> second (Ast.AllTargeting . Just) <$> stripTargetList l+    Ast.DistinctTargeting e l -> second (Ast.DistinctTargeting e) <$> stripTargetList l+    Ast.AllTargeting Nothing -> Nothing+++stripSimple :: Ast.SimpleSelect -> Maybe ([Annotation], Ast.SimpleSelect)+stripSimple = \case+    Ast.NormalSimpleSelect (Just t) b c d e f g -> second (\t' -> Ast.NormalSimpleSelect (Just t') b c d e f g) <$> stripTargeting t+    _ -> Nothing+++stripClause :: Ast.SelectClause -> Maybe ([Annotation], Ast.SelectClause)+stripClause = \case+    Ast.SimpleSelectSelectClause s -> second Ast.SimpleSelectSelectClause <$> stripSimple s+    Ast.WithParensSelectClause s -> second Ast.WithParensSelectClause <$> stripWithParens s+++stripNoParens :: Ast.SelectNoParens -> Maybe ([Annotation], Ast.SelectNoParens)+stripNoParens (Ast.SelectNoParens a c s l f) = second (\c' -> Ast.SelectNoParens a c' s l f) <$> stripClause c+++stripWithParens :: Ast.SelectWithParens -> Maybe ([Annotation], Ast.SelectWithParens)+stripWithParens = \case+    Ast.NoParensSelectWithParens s -> second Ast.NoParensSelectWithParens <$> stripNoParens s+    Ast.WithParensSelectWithParens s -> second Ast.WithParensSelectWithParens <$> stripWithParens s+++stripReturning :: Maybe Ast.ReturningClause -> Maybe ([Annotation], Maybe Ast.ReturningClause)+stripReturning = \case+    Just (Ast.ReturningClause l) -> second (Just . Ast.ReturningClause) <$> stripTargetList l+    Nothing -> Nothing+++-- | The annotation of every result column, and the statement without them.+--+-- An annotated expression is replaced wherever it occurs, not only in the+-- result columns: @select distinct amount :: int4 ... order by amount :: int4@+-- would otherwise order by an expression it no longer selects, and fail to+-- prepare.+strip :: Ast.PreparableStmt -> Maybe ([Annotation], Ast.PreparableStmt)+strip stmt = do+    (annotations, stripped) <- stripResults stmt+    let replacements = [r | Annotation{removed = Just r} <- annotations]+    pure (annotations, replaceEverywhere replacements stripped)+++-- | Replace every occurrence of the given expressions.+replaceEverywhere :: Data a => [(Ast.AExpr, Ast.AExpr)] -> a -> a+replaceEverywhere [] = id+replaceEverywhere replacements = go+  where+    go :: Data b => b -> b+    go x = case cast x of+        Just e | Just replacement <- lookup e replacements, Just r <- cast replacement -> r+        _ -> gmapT go x+++stripResults :: Ast.PreparableStmt -> Maybe ([Annotation], Ast.PreparableStmt)+stripResults = \case+    Ast.SelectPreparableStmt (Ast.NoParensSelectStmt s) -> second (Ast.SelectPreparableStmt . Ast.NoParensSelectStmt) <$> stripNoParens s+    Ast.SelectPreparableStmt (Ast.WithParensSelectStmt s) -> second (Ast.SelectPreparableStmt . Ast.WithParensSelectStmt) <$> stripWithParens s+    Ast.InsertPreparableStmt (Ast.InsertStmt a b c d r) -> second (Ast.InsertPreparableStmt . Ast.InsertStmt a b c d) <$> stripReturning r+    Ast.UpdatePreparableStmt (Ast.UpdateStmt a b c d e r) -> second (Ast.UpdatePreparableStmt . Ast.UpdateStmt a b c d e) <$> stripReturning r+    Ast.DeletePreparableStmt (Ast.DeleteStmt a b c d r) -> second (Ast.DeletePreparableStmt . Ast.DeleteStmt a b c d) <$> stripReturning r+    Ast.CallPreparableStmt _ -> Nothing+++-- * The plan+++data Plan = Plan+    { nodeType :: Text+    , output :: [Text]+    , joinType :: Maybe Text+    , parentRelationship :: Maybe Text+    , filters :: [Text]+    -- ^ The conditions applied to the node's own rows. Not its join filter,+    -- which on an outer join only decides what matches.+    , plans :: [Plan]+    }+++instance Aeson.FromJSON Plan where+    parseJSON = Aeson.withObject "Plan" \o -> do+        filters <- catMaybes <$> traverse (o .:?) ["Filter", "Index Cond", "Recheck Cond"]+        Plan+            <$> (fromMaybe "" <$> o .:? "Node Type")+            <*> (fromMaybe [] <$> o .:? "Output")+            <*> o .:? "Join Type"+            <*> o .:? "Parent Relationship"+            <*> pure filters+            <*> (fromMaybe [] <$> o .:? "Plans")+++newtype Explained = Explained Plan+++instance Aeson.FromJSON Explained where+    parseJSON = Aeson.withObject "EXPLAIN" \o -> Explained <$> o .: "Plan"+++-- | What the plan says about the nullability of the expressions it outputs.+data PlanNullability = PlanNullability+    { outerJoined :: Set Text+    -- ^ Output by a node on the nullable side of an outer join: the inner side+    -- of a left join, the outer side of a right join, both sides of a full one.+    , filteredNotNull :: Set Text+    -- ^ Filtered with @IS NOT NULL@ by a node whose condition holds for every+    -- row: not one on such a side, under one branch of a @BitmapOr@, or in a+    -- subplan, whose rows are not the statement's.+    }+++instance Semigroup PlanNullability where+    PlanNullability a b <> PlanNullability c d = PlanNullability (a <> c) (b <> d)+++instance Monoid PlanNullability where+    mempty = PlanNullability Set.empty Set.empty+++planNullability :: Plan -> PlanNullability+planNullability = go False True+  where+    go nullable guarding plan =+        PlanNullability+            (if nullable then Set.fromList plan.output else Set.empty)+            (if guarding && not nullable then Set.fromList (concatMap notNullOperands plan.filters) else Set.empty)+            <> foldMap+                ( \child ->+                    go+                        (nullable || nullableChild plan child)+                        (guarding && plan.nodeType /= "BitmapOr" && child.parentRelationship `notElem` [Just "SubPlan", Just "InitPlan"])+                        child+                )+                plan.plans+    nullableChild parent child = case parent.joinType of+        Just "Left" -> child.parentRelationship == Just "Inner"+        Just "Right" -> child.parentRelationship == Just "Outer"+        Just "Full" -> True+        _ -> False+++-- | The operands of the @IS NOT NULL@ conjuncts of a condition as EXPLAIN+-- prints it: @((a.id > 0) AND (a.nickname IS NOT NULL))@ gives @a.nickname@.+notNullOperands :: Text -> [Text]+notNullOperands = mapMaybe (Text.stripSuffix " IS NOT NULL" . unwrap) . conjuncts . unwrap+  where+    conjuncts = splitTopLevel " AND "+++-- | Drop parentheses around the whole of an expression.+unwrap :: Text -> Text+unwrap t+    | Just inner <- Text.stripPrefix "(" t >>= Text.stripSuffix ")"+    , balanced inner =+        unwrap inner+    | otherwise = t+  where+    balanced = all (>= 0) . depths+++-- | The nesting depth after each character. The inside of a quoted literal or+-- identifier counts as one deeper, so nothing in it is ever at the top level.+depths :: Text -> [Int]+depths = go 0 Nothing . Text.unpack+  where+    go :: Int -> Maybe Char -> String -> [Int]+    go _ _ [] = []+    go d (Just q) (c : cs)+        | c == q = d : go d Nothing cs+        | otherwise = (d + 1) : go d (Just q) cs+    go d Nothing (c : cs) = case c of+        '(' -> (d + 1) : go (d + 1) Nothing cs+        ')' -> (d - 1) : go (d - 1) Nothing cs+        '\'' -> d : go d (Just '\'') cs+        '"' -> d : go d (Just '"') cs+        _ -> d : go d Nothing cs+++-- | Split on a separator that is outside any parentheses or quotes.+splitTopLevel :: Text -> Text -> [Text]+splitTopLevel sep t = go 0 (zip [0 ..] (0 : depths t))+  where+    n = Text.length sep+    go start [] = [Text.drop start t]+    go start ((i, d) : rest)+        | d == 0+        , i >= start+        , sep `Text.isPrefixOf` Text.drop i t =+            Text.take (i - start) (Text.drop start t) : go (i + n) (dropWhile ((< i + n) . fst) rest)+        | otherwise = go start rest+++-- | Whether the plan mentions an output. EXPLAIN qualifies output columns only+-- when the statement reads more than one relation, but qualifies them in+-- conditions regardless, so an unqualified output matches on the column name.+mentionedIn :: Text -> Set Text -> Bool+mentionedIn out set =+    out `Set.member` set+        || (not ("." `Text.isInfixOf` out) && any ((== out) . Text.takeWhileEnd (/= '.')) set)+++-- * Checking+++data Warning = Warning+    { column :: Int+    -- ^ From 1.+    , columnName :: Text+    , reason :: Text+    }+++-- | A warning as a sentence.+describe :: Warning -> String+describe w =+    concat+        [ "column "+        , show w.column+        , " ("+        , Text.unpack w.columnName+        , ") is annotated non-null, but "+        , Text.unpack w.reason+        ]+++-- | The name the stripped statement is prepared under, so that @EXPLAIN+-- EXECUTE@ can refer to it.+statementName :: ByteString+statementName = "hasql_check_nullability"+++-- | The warnings for a statement that prepares. A statement this cannot take+-- apart, or whose stripped form does not prepare, gets none.+check :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> IO [Finding]+check conn catalogue stmt = map toFinding <$> warningsFor conn catalogue stmt+  where+    toFinding w = Finding{rule = Nullable, subject = w.columnName, message = describe w}+++-- | 'check', for a statement whose result columns are not annotated, given+-- whether each may be NULL: one of "Hasql.Check.Inferred.TH", whose Haskell+-- types say so. Its columns may be behind a @*@.+checkColumns :: Pqi.Connection -> Catalogue -> [Bool] -> Ast.PreparableStmt -> IO [Finding]+checkColumns conn catalogue nullables stmt =+    map toFinding <$> warningsWith conn catalogue stmt ([Annotation (Just n) Nothing | n <- nullables], stmt)+  where+    toFinding w = Finding{rule = Nullable, subject = w.columnName, message = describe w}+++warningsFor :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> IO [Warning]+warningsFor conn catalogue stmt = maybe (pure []) (warningsWith conn catalogue stmt) (strip stmt)+++warningsWith :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> ([Annotation], Ast.PreparableStmt) -> IO [Warning]+warningsWith conn catalogue stmt = \case+    (annotations, stripped) -> do+        prepared <- conn.prepare statementName (renderStmt stripped) Nothing+        status <- maybe (pure Pqi.FatalError) (.resultStatus) prepared+        if status /= Pqi.CommandOk+            then pure []+            else warnings annotations `finally` query conn ("DEALLOCATE " <> statementName)+  where+    warnings annotations =+        conn.describePrepared statementName >>= \case+            Nothing -> pure []+            Just described -> do+                count <- described.nfields+                params <- described.nparams+                explained <- explain params+                if fromIntegral count /= length annotations+                    then pure []+                    else fmap concat . forM (zip [0 :: Int32 ..] annotations) $ \(i, annotation) -> do+                        table <- described.ftable i+                        tableColumn <- described.ftablecol i+                        name <- maybe "?column?" Text.decodeUtf8Lenient <$> described.fname i+                        let planned = case explained of+                                Just (outputs, nullability)+                                    | Just out <- lookup i (zip [0 ..] outputs) ->+                                        ( out `mentionedIn` nullability.outerJoined+                                        , guardsApply && out `mentionedIn` nullability.filteredNotNull+                                        )+                                _ -> (False, False)+                            warn r = [Warning (fromIntegral i + 1) name r]+                        pure case (annotation, planned, Map.lookup (table, tableColumn) catalogue.columns) of+                            (Annotation{nullable = Just False}, (_, True), _) -> []+                            (Annotation{nullable = Just False}, (True, _), _) -> warn "comes from the nullable side of an outer join"+                            (Annotation{nullable = Just False}, _, Just col)+                                | not col.fromView && not col.notNull -> warn (col.qualifiedName <> " is nullable")+                            _ -> []++    -- A filter in the plan is about the rows read. Those are the rows a SELECT+    -- returns, and those a DELETE returns, but an UPDATE returns the rows it+    -- wrote, and an INSERT the rows it made.+    guardsApply = case stmt of+        Ast.SelectPreparableStmt _ -> True+        Ast.DeletePreparableStmt _ -> True+        _ -> False++    -- The top node's outputs, one per result column, and what the plan says+    -- about them. Nothing if EXPLAIN fails.+    explain params = do+        let nulls = ByteString.Char8.intercalate ", " (replicate (fromIntegral params) "NULL")+            args = if params == 0 then "" else ByteString.Char8.cons '(' (ByteString.Char8.snoc nulls ')')+        result <- query conn ("EXPLAIN (VERBOSE, FORMAT JSON) EXECUTE " <> statementName <> args)+        pure case result of+            Right [[Just json]]+                | Right [Explained plan] <- Aeson.eitherDecodeStrict json ->+                    Just (plan.output, planNullability plan)+            _ -> Nothing+++-- | Run a statement, returning its rows as text or the server's error.+query :: Pqi.Connection -> ByteString -> IO (Either String [[Maybe ByteString]])+query conn sql =+    conn.exec sql >>= \case+        Nothing -> Left . maybe "no result" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage+        Just result -> do+            status <- result.resultStatus+            rows <-+                if status `elem` [Pqi.CommandOk, Pqi.TuplesOk]+                    then do+                        n <- result.ntuples+                        m <- result.nfields+                        Right <$> forM [0 .. n - 1] (forM [0 .. m - 1] . result.getvalue')+                    else Left . maybe "query failed" (Text.unpack . Text.decodeUtf8Lenient) <$> result.resultErrorMessage+            result.unsafeFreeResult+            pure rows

@@ -0,0 +1,60 @@+{+{-# LANGUAGE NoStrictData #-}++module Hasql.Check.Parser where++import Prelude+import Data.Text (Text)+import Hasql.Check.Lexer+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString.Lazy+import System.Directory+}++%expect 0+%name parse+%monad { Alex } { >>= } { return }+%lexer { lexer } { Lexeme _ Eof }+%tokentype { Lexeme }+%error { parseError }++%token++  quoter { Lexeme _ (Quoter _) }+  quote  { Lexeme _ (Quote _)  }++%%++quasiquotes : quasiquotes quasiquote    { $2 : $1 }+            | {- empty -}               { [] }++quasiquote  : quoter quote              { mkQuasiQuote $1 $2 }++{++type QuasiQuotes = [QuasiQuote]++data QuasiQuote =+  QuasiQuote (AlexPosn, Text) (AlexPosn, Text)+  deriving (Eq, Show)++mkQuasiQuote :: Lexeme -> Lexeme -> QuasiQuote+mkQuasiQuote (Lexeme posna (Quoter q))+  (Lexeme posnb (Quote qq))+  = QuasiQuote (posna, q) (posnb, qq)+mkQuasiQuote _ _ = error "mkQuasiQuote: Impossible"++parseError :: Lexeme -> Alex a+parseError (Lexeme (AlexPn _ line col) lc) = alexError ("Parsing failed at line: " <> show line <> ", col: " <> show col <> " " <> show lc)++-- | The quasiquotes in a Haskell source, in the order they appear.+parseQuasiQuotes :: ByteString -> Either String QuasiQuotes+parseQuasiQuotes s = reverse <$> runAlex s parse++parseFile :: FilePath -> IO (Either String QuasiQuotes)+parseFile fn = do+  flag <- doesFileExist fn+  if not flag+    then pure $ Left ("The following file does not exist : " ++ fn)+    else parseQuasiQuotes <$> ByteString.Lazy.readFile fn+}

@@ -0,0 +1,39 @@+-- |+-- Module      : Hasql.Check.Quoter+-- Copyright   : (c) 2022 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+module Hasql.Check.Quoter where++import Data.Text (Text)+import Data.Text qualified as Text+import Prelude+++-- | The hasql-th quoters whose SQL is a single preparable statement.+-- @uncheckedSql@ is deliberately absent: hasql-th neither parses nor prepares+-- it, because it is meant for scripts -- DDL, several statements -- that+-- PREPARE rejects.+quotersSupported :: [Text]+quotersSupported =+    [ "singletonStatement"+    , "maybeStatement"+    , "vectorStatement"+    , "foldStatement"+    , "resultlessStatement"+    , "rowsAffectedStatement"+    ]+++-- | The quoter's name without its module qualifier: @Hasql.TH.vectorStatement@+-- becomes @vectorStatement@.+unqualified :: Text -> Text+unqualified = Text.takeWhileEnd (/= '.')+++-- | Whether a quoter, qualified or not, is one of the given names.+isQuoterIn :: [Text] -> Text -> Bool+isQuoterIn names quoter = unqualified quoter `elem` names

@@ -0,0 +1,131 @@+-- |+-- Module      : Hasql.Check.TH+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- hasql-th's quasiquoters, checking their statements against a live database+-- while they compile. Import this module instead of "Hasql.TH".+--+-- Nothing is checked unless @HASQL_CHECK_DATABASE_URL@ is set, so builds+-- without a database - CI, nix - behave exactly as with "Hasql.TH". When it+-- is set, a statement that does not @PREPARE@ against that database is a+-- compile error at its quote.+--+-- * @HASQL_CHECK_DATABASE_URL@: a libpq connection string or URI.+-- * @HASQL_CHECK_SCHEMA_FILE@: a file that changes whenever the schema does,+--   such as a migration plan. Every module with a checked quote depends on+--   it, so a schema change rechecks them. Cabal only notices it if it is also+--   listed in the package's @extra-source-files@; GHCi notices it regardless.+-- * @HASQL_CHECK_NULLABILITY@: when set, the warnings of @hasql-check+--   --nullability@ become compiler warnings.+-- * @HASQL_CHECK_TYPES@: when set, so do the warnings of @hasql-check+--   --types@.+--+-- GHC runs a quote only when it compiles the module, so a module compiled+-- before the database was set, or before the schema changed, is not checked+-- until it recompiles. Run the @hasql-check@ executable in CI for a check+-- of everything.+module Hasql.Check.TH (+    -- * Statements+    singletonStatement,+    maybeStatement,+    vectorStatement,+    foldStatement,+    resultlessStatement,+    rowsAffectedStatement,+    uncheckedSql,+    uncheckedSqlFile,++    -- * Checking any quoter+    checked,+) where++import Control.Monad (forM_)+import Data.Text qualified as Text+import Hasql.Check (parseStmt, prepareStmt, renderStmt)+import Hasql.Check.Compile (Config (..), Session (..), readConfig, reportUnavailable, warning, warnings, withSession)+import Hasql.Check.Finding (Rule (..), statementHash)+import Hasql.Check.Nullability qualified as Nullability+import Hasql.Check.Types qualified as Types+import Hasql.TH (uncheckedSql, uncheckedSqlFile)+import Hasql.TH qualified as TH+import Language.Haskell.TH (Loc (..), Q, location, runIO)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax (addDependentFile)+import Prelude+++singletonStatement :: QuasiQuoter+singletonStatement = withRows TH.singletonStatement+++maybeStatement :: QuasiQuoter+maybeStatement = withRows TH.maybeStatement+++vectorStatement :: QuasiQuoter+vectorStatement = withRows TH.vectorStatement+++foldStatement :: QuasiQuoter+foldStatement = withRows TH.foldStatement+++resultlessStatement :: QuasiQuoter+resultlessStatement = checked TH.resultlessStatement+++rowsAffectedStatement :: QuasiQuoter+rowsAffectedStatement = checked TH.rowsAffectedStatement+++-- | Check a quoter's statements, then run it. For quoters built on hasql-th's+-- statement syntax.+checked :: QuasiQuoter -> QuasiQuoter+checked = wrap False+++-- | 'checked', also checking nullability when asked to.+withRows :: QuasiQuoter -> QuasiQuoter+withRows = wrap True+++wrap :: Bool -> QuasiQuoter -> QuasiQuoter+wrap rows quoter = quoter{quoteExp = \sql -> check rows sql *> quoteExp quoter sql}+++-- * Checking+++check :: Bool -> String -> Q ()+check rows sql = do+    config <- runIO readConfig+    forM_ config.schemaFile addDependentFile+    forM_ config.databaseUrl \url -> case parseStmt (Text.pack sql) of+        -- hasql-th reports the parse error itself.+        Left _ -> pure ()+        Right stmt -> do+            let rules = [Nullable | rows && config.nullability] <> [Narrowing | config.types]+            outcome <- runIO $ withSession config url (not (null rules)) \s ->+                prepareStmt s.connection "" stmt >>= \case+                    Left err -> pure (Left err)+                    Right () -> case s.catalogue of+                        Just (_, cat) | not (null rules) -> do+                            nullable <- if Nullable `elem` rules then Nullability.check s.connection cat stmt else pure []+                            narrowing <- if Narrowing `elem` rules then Types.check s.connection cat stmt else pure []+                            pure (Right (nullable <> narrowing))+                        _ -> pure (Right [])+            case outcome of+                Left why -> runIO (reportUnavailable why)+                Right (Left err) -> fail ("hasql-check: the statement does not prepare against HASQL_CHECK_DATABASE_URL:\n" <> err)+                -- Without warnings asked for, no location is needed: there is+                -- none outside GHC, under runQ.+                Right (Right _) | null rules -> pure ()+                Right (Right found) -> do+                    loc <- location+                    messages <- runIO (warnings config rules loc.loc_filename (fst loc.loc_start) (statementHash (renderStmt stmt)) found)+                    forM_ messages (runIO . warning loc.loc_filename loc.loc_start)

@@ -0,0 +1,276 @@+-- |+-- Module      : Hasql.Check.Types+-- Copyright   : (c) 2026 Kronor.io+--+-- License     : BSD-3-Clause+-- Maintainer  : lorenzo@kronor.io+-- Stability   : experimental+-- Portability : GHC+--+-- Warn about annotations that convert a value to a narrower type.+--+-- An annotation is a cast, and a cast between incompatible types is an error+-- @PREPARE@ already reports. A narrowing one is not: @bigint_column :: int4@+-- prepares, and fails or loses data at runtime only for values that do not+-- fit. To see what each annotation converts, the statement is prepared again+-- without the annotations on its result columns and on the parameters it+-- assigns to columns - in @INSERT ... VALUES@ and @UPDATE ... SET@ - and+-- Postgres reports the types it finds there.+--+-- Only result columns that read a table column are checked: an expression+-- converted to a narrower type - @count(*) :: int4@, @now() :: date@ - is+-- almost always converted on purpose.+--+-- Parameters anywhere else are not checked: comparing an @int4@ column with an+-- @int8@ parameter widens the column, and narrows nothing.+module Hasql.Check.Types (+    check,+    checkColumns,+) where++import Control.Exception (finally)+import Control.Monad (forM)+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Functor ((<&>))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Traversable (mapAccumL)+import Data.Word (Word32)+import Hasql.Check (renderStmt)+import Hasql.Check.Finding (Finding (..), Rule (..))+import Hasql.Check.Nullability (Annotation (..), Catalogue, baseType, query, strip)+import PostgresqlSyntax qualified as Ast+import Pqi qualified+import Text.Read (readMaybe)+import Prelude+++-- | The findings for a statement that prepares.+check :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> IO [Finding]+check conn catalogue stmt+    | null (fst (stripAssigned 0 stmt)) && maybe True (null . fst) (strip stmt) = pure []+    | otherwise =+        ( describe "hasql_check_types_annotated" stmt Nothing >>= \case+            Nothing -> pure []+            Just annotated -> do+                -- Every assigned occurrence gets a placeholder of its own, so+                -- that a parameter assigned to two columns is checked against+                -- both; the statement's own parameters keep their annotated+                -- types, declared, since some may now appear nowhere.+                let (assigned, withoutParams) = stripAssigned (length annotated.params) stmt+                    (annotations, stripped) = fromMaybe ([], withoutParams) (strip withoutParams)+                    declared = annotated.params <> map (const 0) assigned+                describe "hasql_check_types_stripped" stripped (Just declared) >>= \case+                    Nothing -> pure []+                    Just found -> (<>) <$> results annotations annotated found <*> params assigned annotated found+        )+            `finally` mapM_ (\name -> query conn ("DEALLOCATE " <> name)) ["hasql_check_types_annotated", "hasql_check_types_stripped"]+  where+    results annotations annotated found+        | length annotations /= length annotated.columns || length found.columns /= length annotated.columns = pure []+        | otherwise =+            fmap catMaybes . sequence $+                [ narrowing conn catalogue from to <&> fmap \(fromName, toName, consequence) ->+                    Finding Narrowing (Text.pack name) ("column " <> show i <> " (" <> name <> ") is annotated " <> toName <> ", but is " <> article fromName <> ": " <> consequence)+                | (i, Annotation{nullable = Just _}, (name, to, _), (_, from, fromTable)) <- zip4 [1 :: Int ..] annotations annotated.columns found.columns+                , fromTable+                ]++    params assigned annotated found =+        fmap catMaybes . sequence $+            [ narrowing conn catalogue from to <&> fmap \(fromName, toName, consequence) ->+                Finding Narrowing (Text.pack ("$" <> show n)) ("parameter $" <> show n <> " is annotated " <> fromName <> ", but is assigned to " <> article toName <> " column: " <> consequence)+            | (n, placeholder) <- assigned+            , Just from <- [lookupParam n annotated]+            , Just to <- [lookupParam placeholder found]+            ]++    lookupParam n d = lookup n (zip [1 ..] d.params)++    describe name s types = do+        prepared <- conn.prepare name (renderStmt s) types+        status <- maybe (pure Pqi.FatalError) (.resultStatus) prepared+        if status /= Pqi.CommandOk+            then pure Nothing+            else+                conn.describePrepared name >>= \case+                    Nothing -> pure Nothing+                    Just d -> do+                        nparams <- d.nparams+                        nfields <- d.nfields+                        ps <- forM [0 .. nparams - 1] d.paramtype+                        cs <- forM [0 .. nfields - 1] \i ->+                            (,,)+                                <$> (maybe "?column?" (Text.unpack . Text.decodeUtf8Lenient) <$> d.fname i)+                                <*> d.ftype i+                                <*> ((/= 0) <$> d.ftable i)+                        pure (Just (Described ps cs))+++-- | The findings for result columns read as the given Postgres types, by+-- name, rather than annotated: those of an inferred statement, cast around+-- it. Every column is checked, expressions too: nobody chose the conversion.+checkColumns :: Pqi.Connection -> Catalogue -> [Text.Text] -> Ast.PreparableStmt -> IO [Finding]+checkColumns conn catalogue types stmt = do+    prepared <- conn.prepare "hasql_check_types_columns" (renderStmt stmt) Nothing+    status <- maybe (pure Pqi.FatalError) (.resultStatus) prepared+    if status /= Pqi.CommandOk+        then pure []+        else+            ( conn.describePrepared "hasql_check_types_columns" >>= \case+                Nothing -> pure []+                Just d -> do+                    n <- d.nfields+                    found <- forM [0 .. n - 1] \i -> (,) <$> (maybe "?column?" (Text.unpack . Text.decodeUtf8Lenient) <$> d.fname i) <*> d.ftype i+                    expected <- traverse oid types+                    fmap catMaybes . sequence $+                        [ narrowing conn catalogue from to <&> fmap \(fromName, toName, consequence) ->+                            Finding Narrowing (Text.pack name) ("column " <> show i <> " (" <> name <> ") is annotated " <> toName <> ", but is " <> article fromName <> ": " <> consequence)+                        | length found == length types+                        , (i :: Int, (name, from), Just to) <- zip3 [1 ..] found expected+                        ]+            )+                `finally` query conn "DEALLOCATE hasql_check_types_columns"+  where+    oid name =+        query conn (mconcat ["SELECT to_regtype('", Text.encodeUtf8 (Text.replace "'" "''" name), "')::oid::text"]) >>= \case+            Right [[Just o]] -> pure (readMaybe (ByteString.Char8.unpack o))+            _ -> pure Nothing+++-- | 'lossy', through domains, and through arrays element by element, as+-- Postgres converts them: a bigint[] read as integer[] may overflow.+narrowing :: Pqi.Connection -> Catalogue -> Word32 -> Word32 -> IO (Maybe (String, String, String))+narrowing conn catalogue from to =+    query+        conn+        ( ByteString.Char8.pack+            ( concat+                [ "SELECT f.typelem::text, t.typelem::text FROM pg_catalog.pg_type f, pg_catalog.pg_type t WHERE f.oid = "+                , show from'+                , " AND t.oid = "+                , show to'+                , " AND f.typcategory = 'A' AND t.typcategory = 'A'"+                ]+            )+        )+        >>= \case+            Right [[Just f, Just t]]+                | Just f' <- readMaybe (ByteString.Char8.unpack f)+                , Just t' <- readMaybe (ByteString.Char8.unpack t) ->+                    fmap (\(fromName, toName, consequence) -> (fromName <> "[]", toName <> "[]", consequence)) <$> narrowing conn catalogue f' t'+            _ -> pure (lossy from' to')+  where+    from' = baseType catalogue from+    to' = baseType catalogue to+++data Described = Described+    { params :: [Word32]+    , columns :: [(String, Word32, Bool)]+    -- ^ Name, type, and whether it is a table column rather than an expression.+    }+++zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]+zip4 (a : as) (b : bs) (c : cs) (d : ds) = (a, b, c, d) : zip4 as bs cs ds+zip4 _ _ _ _ = []+++article :: String -> String+article name@(c : _) | c `elem` ("aeiou" :: String) = "an " <> name+article name = "a " <> name+++-- * Stripping assigned parameters+++-- | The statement with each parameter it assigns to a column replaced by a+-- new, unannotated placeholder numbered from after the given count, and the+-- pairs of parameter and placeholder.+stripAssigned :: Int -> Ast.PreparableStmt -> ([(Int, Int)], Ast.PreparableStmt)+stripAssigned count = \case+    Ast.InsertPreparableStmt+        ( Ast.InsertStmt+                w+                t+                (Ast.SelectInsertRest cols o (Ast.NoParensSelectStmt (Ast.SelectNoParens w2 (Ast.SimpleSelectSelectClause (Ast.ValuesSimpleSelect (Ast.ValuesClause rows))) s l f)))+                c+                r+            ) ->+            let (acc, rows') = mapAccumL (\a (Ast.ExprList es) -> Ast.ExprList <$> mapAccumL param a es) [] rows+             in (reverse acc, Ast.InsertPreparableStmt (Ast.InsertStmt w t (Ast.SelectInsertRest cols o (Ast.NoParensSelectStmt (Ast.SelectNoParens w2 (Ast.SimpleSelectSelectClause (Ast.ValuesSimpleSelect (Ast.ValuesClause rows'))) s l f))) c r))+    Ast.UpdatePreparableStmt (Ast.UpdateStmt w rel (Ast.SetClauseList clauses) f wh r) ->+        let (acc, clauses') = mapAccumL setClause [] clauses+         in (reverse acc, Ast.UpdatePreparableStmt (Ast.UpdateStmt w rel (Ast.SetClauseList clauses') f wh r))+    other -> ([], other)+  where+    setClause acc = \case+        Ast.TargetSetClause target e -> Ast.TargetSetClause target <$> param acc e+        other -> (acc, other)+    param acc = \case+        Ast.TypecastAExpr (Ast.CExprAExpr (Ast.ParamCExpr n Nothing)) _ ->+            let placeholder = count + length acc + 1+             in ((n, placeholder) : acc, Ast.CExprAExpr (Ast.ParamCExpr placeholder Nothing))+        e -> (acc, e)+++-- * Narrowing conversions+++-- | What converting a value of the first type to the second can do to it, with+-- the two types' names, if it is a narrowing conversion.+lossy :: Word32 -> Word32 -> Maybe (String, String, String)+lossy from to = do+    fromName <- lookup from names+    toName <- lookup to names+    consequence <- lookup (from, to) conversions+    pure (fromName, toName, consequence)+  where+    names =+        [ (int2, "smallint")+        , (int4, "integer")+        , (int8, "bigint")+        , (numeric, "numeric")+        , (float4, "real")+        , (float8, "double precision")+        , (timestamp, "timestamp")+        , (timestamptz, "timestamptz")+        , (date, "date")+        ]+    overflow = "it may overflow"+    rounding = "it may be rounded, or overflow"+    precision = "it may lose precision"+    conversions =+        [ ((int8, int4), overflow)+        , ((int8, int2), overflow)+        , ((int4, int2), overflow)+        , ((numeric, int8), rounding)+        , ((numeric, int4), rounding)+        , ((numeric, int2), rounding)+        , ((float8, int8), rounding)+        , ((float8, int4), rounding)+        , ((float8, int2), rounding)+        , ((float4, int8), rounding)+        , ((float4, int4), rounding)+        , ((float4, int2), rounding)+        , ((numeric, float8), precision)+        , ((numeric, float4), precision)+        , ((float8, float4), precision)+        , ((int8, float8), precision)+        , ((int8, float4), precision)+        , ((int4, float4), precision)+        , ((timestamptz, timestamp), "it becomes a local time in the session's time zone")+        , ((timestamptz, date), "it drops the time of day, in the session's time zone")+        , ((timestamp, date), "it drops the time of day")+        ]+    int2 = 21+    int4 = 23+    int8 = 20+    numeric = 1700+    float4 = 700+    float8 = 701+    timestamp = 1114+    timestamptz = 1184+    date = 1082

@@ -0,0 +1,993 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Control.Exception (SomeException, bracket_, try)+import Control.Monad (void)+import Data.ByteString.Lazy qualified as ByteString.Lazy+import Data.Either (isLeft)+import Data.Int (Int32, Int64)+import Data.List (isInfixOf)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Vector qualified as Vector+import GHC.Generics (Generic)+import Hasql.Check.Inferred (Domain (..), PgEnum (..), Value, qualifiedName, render)+import Hasql.Check.Inferred.TH qualified as Inferred+import Hasql.Check.Lexer (AlexPosn (..))+import Hasql.Check.Parser (QuasiQuote (..), parseQuasiQuotes)+import Hasql.Check.TH qualified as Checked+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Settings+import Hasql.Session qualified as Session+import Hasql.Statement (Statement)+import Language.Haskell.TH (runQ)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Pqi.Ffi qualified+import System.Directory (createDirectoryIfMissing, findExecutable)+import System.Environment (getEnvironment, setEnv, unsetEnv)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (callProcess, proc, readCreateProcessWithExitCode, readProcess)+import System.Process qualified as Process+import Test.Syd+import Prelude+++main :: IO ()+main = sydTest do+    describe "parseQuasiQuotes" lexerSpec+    describe "hasql-check" $ aroundAll withPostgres executableSpec+    describe "hasql-check --nullability" $ aroundAll withPostgres nullabilitySpec+    describe "hasql-check --types" $ aroundAll withPostgres typesSpec+    describe "suppressing warnings" $ aroundAll withPostgres suppressionSpec+    describe "Hasql.Check.Inferred.TH" piecesSpec+    describe "inferred statements" $ aroundAll withPostgres runtimeSpec+    describe "hasql-check --inferred" $ aroundAll withPostgres inferredSpec+    -- These share the process's environment and the module's one connection,+    -- so they run one at a time, in order.+    describe "Hasql.Check.TH" $ sequential $ doNotRandomiseExecutionOrder $ aroundAll withPostgres thSpec+++-- | The quoter, its line and column, and the SQL, of every quasiquote found.+quotes :: Text -> Either String [(Text, Int, Int, Text)]+quotes source =+    map (\(QuasiQuote (AlexPn _ line col, quoter) (_, sql)) -> (quoter, line, col, sql))+        <$> parseQuasiQuotes (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 source))+++lexerSpec :: Spec+lexerSpec = do+    it "finds a quote" $+        quotes "f = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 1, 5, "select 1 :: int4")]++    it "finds a qualified quote" $+        quotes "f = [Hasql.TH.vectorStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("Hasql.TH.vectorStatement", 1, 5, "select 1 :: int4")]++    it "keeps the newlines inside a quote" $+        quotes "f =\n  [resultlessStatement|\n    delete from t\n  |]\n"+            `shouldBe` Right [("resultlessStatement", 2, 3, "\n    delete from t\n  ")]++    it "skips a quote in a line comment" $+        quotes "-- f = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right []++    it "skips a quote in a nested block comment" $+        quotes "{- {- -} [singletonStatement|select 1 :: int4|] -}\n"+            `shouldBe` Right []++    it "does not read an operator made of dashes as a comment" $+        quotes "a --> b = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 1, 11, "select 1 :: int4")]++    it "does not open a comment from \"{-\" in a string" $+        quotes "s = \"{-\"\nf = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")]++    it "does not open a quote from \"[x|\" in a string" $+        quotes "s = \"[x|\"\nf = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")]++    it "does not open a string from a double quote character literal" $+        quotes "c = '\"'\nf = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")]++    it "does not open a character literal from a primed identifier" $+        quotes "g x' y' = \"{-\"\nf = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")]++    it "skips escaped quotes and gaps in a string" $+        quotes "s = \"a\\\"{-\\\n    \\b\"\nf = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 3, 5, "select 1 :: int4")]++    it "skips a multiline string" $+        quotes "s = \"\"\"\n  say \"hi\" {-\n  \"\"\"\nf = [singletonStatement|select 1 :: int4|]\n"+            `shouldBe` Right [("singletonStatement", 4, 5, "select 1 :: int4")]++    it "rejects a quote left open" $+        quotes "f = [singletonStatement|select 1 :: int4\n"+            `shouldSatisfy` either ("not closed" `isInfixOf`) (const False)+++-- | A connection string for a throwaway server, reachable only over a socket+-- in a temporary directory.+withPostgres :: (Text -> IO ()) -> IO ()+withPostgres action =+    withSystemTempDirectory "hasql-check" \dir -> do+        initdb <- findExecutable "initdb"+        case initdb of+            Nothing -> expectationFailure "initdb is not on PATH; the executable tests need a PostgreSQL installation"+            Just _ -> pure ()+        let dataDir = dir </> "data"+            conn = Text.pack ("host=" <> dir <> " port=5432 user=postgres dbname=postgres")+        _ <- readProcess "initdb" ["--pgdata", dataDir, "--username", "postgres", "--auth", "trust", "--no-sync"] ""+        bracket_+            (callProcess "pg_ctl" ["--pgdata", dataDir, "--log", dir </> "postgres.log", "--options", "-k " <> dir <> " -c listen_addresses=''", "--wait", "--silent", "start"])+            (callProcess "pg_ctl" ["--pgdata", dataDir, "--mode", "immediate", "--silent", "stop"])+            do+                callProcess "psql" [Text.unpack conn, "--quiet", "--command", "create table account (id int4 primary key, name text not null, nickname text); create index on account (nickname); create table note (account_id int4 not null references account, body text not null); create domain cents as int8; create domain positive_cents as cents check (value > 0); create table wallet (balance positive_cents not null); create table ledger (id int8 primary key, small int2, amount int8 not null, rate float8, at timestamptz, price cents); create table tag (id int4 primary key, label varchar(20) not null); insert into tag values (1, 'red'); create table tagged (id int4 primary key, labels text[] not null, scores int4[]); insert into tagged values (1, '{a,b}', '{1,NULL,3}'); create table totals (id int4 primary key, amounts int8[] not null); create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED'); create table payment (id int4 primary key, state payment_state not null); insert into payment values (1, 'PAID'); create domain payment_status as payment_state; create table payment_log (id int4 primary key, status payment_status not null); insert into payment_log values (1, 'REFUNDED')"]+                action conn+++-- | Run the executable on a source file and the given flags, with extra+-- environment variables; return the exit code and stdout.+runOn :: [(String, String)] -> [String] -> Text -> IO (ExitCode, String)+runOn env args source =+    withSystemTempDirectory "hasql-check-src" \dir -> do+        let file = dir </> "Fixture.hs"+        ByteString.Lazy.writeFile file (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 source))+        inherited <- getEnvironment+        let unset = ["DATABASE_URL", "psql_conn_string"]+            procEnv = env <> filter ((`notElem` (unset <> map fst env)) . fst) inherited+        (code, out, err) <-+            readCreateProcessWithExitCode+                (proc "hasql-check" (args <> [file])){Process.env = Just procEnv}+                ""+        pure (code, out <> err)+++executableSpec :: TestDef '[Text] ()+executableSpec = do+    itWithOuter "accepts a statement that matches the schema" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [singletonStatement|select name :: text from account where id = $1 :: int4|]\n"+        (code, out) `shouldBe` (ExitSuccess, "")++    itWithOuter "rejects a statement that does not, and says where it is" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = 1\ng = [singletonStatement|select nope :: text from account|]\n"+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("Fixture.hs:2:5" `isInfixOf`)+        out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`)++    itWithOuter "accepts nullability markers" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select name :: text? from account where id = $1 :: int4?|]\n"+        (code, out) `shouldBe` (ExitSuccess, "")++    syntaxSpec++    itWithOuter "checks a qualified quote" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [Hasql.TH.resultlessStatement|delete from nowhere|]\n"+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("relation \"nowhere\" does not exist" `isInfixOf`)++    itWithOuter "leaves uncheckedSql alone" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [uncheckedSql|create table t (); create table u ();|]\n"+        (code, out) `shouldBe` (ExitSuccess, "")++    itWithOuter "checks only the extra quoters it is given" \conn -> do+        let source = "f = [myStatement|select nope :: text from account|]\n"+        (codeWithout, _) <- runOn [] ["--database", Text.unpack conn] source+        codeWithout `shouldBe` ExitSuccess+        (codeWith, out) <- runOn [] ["--database", Text.unpack conn, "--quoter", "myStatement"] source+        codeWith `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`)++    itWithOuter "connects through DATABASE_URL" \conn -> do+        (code, out) <- runOn [("DATABASE_URL", Text.unpack conn)] [] "f = [singletonStatement|select nope :: text from account|]\n"+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`)++    it "lists the quotes it would check without connecting" do+        (code, out) <-+            runOn+                [("DATABASE_URL", "host=/nonexistent")]+                ["--list"]+                "f = [singletonStatement|select 1 :: int4|]\ng = [Hasql.TH.vectorStatement|select 1 :: int4|]\nh = [aesonQQ|{}|]\n"+        code `shouldBe` ExitSuccess+        lines out `shouldSatisfy` \case+            [first, second] ->+                "Fixture.hs:1:5: singletonStatement" `isSuffixOfStr` first+                    && "Fixture.hs:2:5: Hasql.TH.vectorStatement" `isSuffixOfStr` second+            _ -> False+  where+    isSuffixOfStr suffix s = Text.pack suffix `Text.isSuffixOf` Text.pack s+++-- | The syntax only Kronor's fork of hasql-th accepts.+syntaxSpec :: TestDef '[Text] ()+#ifdef KRONOR_SYNTAX+syntaxSpec = do+    itWithOuter "accepts Haskell targets and param fields" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select $Just (name :: text) from account where id = $1.$accountId :: int4|]\n"+        (code, out) `shouldBe` (ExitSuccess, "")++    itWithOuter "checks the columns inside a Haskell target" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select $Just (nope :: text) from account|]\n"+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`)+#else+syntaxSpec =+    itWithOuter "rejects Haskell targets, which upstream hasql-th does not accept" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select $Just (name :: text) from account|]\n"+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("Fixture.hs:1:5" `isInfixOf`)+#endif+++-- | Run with --nullability on one statement; return the exit code and output.+nullability :: Text -> Text -> IO (ExitCode, String)+nullability conn statement =+    runOn [] ["--database", Text.unpack conn, "--nullability"] ("f = [vectorStatement|" <> statement <> "|]\n")+++nullabilitySpec :: TestDef '[Text] ()+nullabilitySpec = do+    itWithOuter "warns about a nullable column annotated non-null, without failing" \conn -> do+        (code, out) <- nullability conn "select nickname :: text from account"+        code `shouldBe` ExitSuccess+        out `shouldSatisfy` ("Fixture.hs:1:5" `isInfixOf`)+        out `shouldSatisfy` ("column 1 (nickname) is annotated non-null, but public.account.nickname is nullable" `isInfixOf`)++    itWithOuter "warns only when asked" \conn -> do+        (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [vectorStatement|select nickname :: text from account|]\n"+        (code, out) `shouldBe` (ExitSuccess, "")++    itWithOuter "accepts a nullable column annotated nullable" \conn ->+        nullability conn "select nickname :: text? from account" `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a NOT NULL column annotated non-null" \conn ->+        nullability conn "select name :: text, id :: int4 from account" `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a column guarded by IS NOT NULL" \conn ->+        nullability conn "select nickname :: text from account where id > 0 and nickname is not null" `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a guard that leaves out the table" \conn ->+        nullability conn "select a.nickname :: text from account a where nickname is not null" `shouldReturn` (ExitSuccess, "")++    itWithOuter "does not check expressions" \conn ->+        nullability conn "select count(*) :: int8, max(nickname) :: text from account" `shouldReturn` (ExitSuccess, "")++    itWithOuter "warns about a NOT NULL column on the nullable side of a left join" \conn -> do+        (code, out) <- nullability conn "select a.name :: text, n.body :: text from account a left join note n on n.account_id = a.id"+        code `shouldBe` ExitSuccess+        out `shouldSatisfy` ("column 2 (body) is annotated non-null, but comes from the nullable side of an outer join" `isInfixOf`)+        out `shouldNotSatisfy` ("column 1" `isInfixOf`)++    -- Postgres plans the joins above as right joins with the tables swapped;+    -- a lateral join cannot be swapped, so this one is planned as a left join.+    itWithOuter "warns about the nullable side of a join planned as a left join" \conn -> do+        (_, out) <- nullability conn "select a.name :: text, n.body :: text from account a left join lateral (select body from note where note.account_id = a.id limit 1) n on true"+        out `shouldSatisfy` ("column 2 (body)" `isInfixOf`)+        out `shouldNotSatisfy` ("column 1" `isInfixOf`)++    itWithOuter "warns about the nullable side of a right join only" \conn -> do+        (_, out) <- nullability conn "select a.name :: text, n.body :: text from note n right join account a on n.account_id = a.id"+        out `shouldSatisfy` ("column 2 (body)" `isInfixOf`)+        out `shouldNotSatisfy` ("column 1" `isInfixOf`)++    itWithOuter "warns about both sides of a full join" \conn -> do+        (_, out) <- nullability conn "select a.name :: text, n.body :: text from account a full join note n on n.account_id = a.id"+        out `shouldSatisfy` ("column 1 (name)" `isInfixOf`)+        out `shouldSatisfy` ("column 2 (body)" `isInfixOf`)++    itWithOuter "lets IS NOT NULL clear the nullable side of a join" \conn ->+        nullability conn "select n.body :: text from account a left join note n on n.account_id = a.id where n.body is not null" `shouldReturn` (ExitSuccess, "")++    itWithOuter "does not let an UPDATE's filter on the old row clear RETURNING's new one" \conn -> do+        (_, out) <- nullability conn "update account set nickname = NULL where nickname is not null returning nickname :: text"+        out `shouldSatisfy` ("public.account.nickname is nullable" `isInfixOf`)++    itWithOuter "lets a DELETE's filter clear RETURNING, which returns the rows it read" \conn ->+        nullability conn "delete from account where nickname is not null returning nickname :: text" `shouldReturn` (ExitSuccess, "")++    -- With sequential scans off, Postgres answers the OR with a BitmapOr of+    -- two index scans, one of which has the IS NOT NULL as its condition.+    itWithOuter "does not take one branch of a BitmapOr for a guarantee" \conn -> do+        (_, out) <-+            runOn+                [("PGOPTIONS", "-c enable_seqscan=off")]+                ["--database", Text.unpack conn, "--nullability"]+                "f = [vectorStatement|select nickname :: text from account where nickname is not null or id = $1 :: int4|]\n"+        out `shouldSatisfy` ("public.account.nickname is nullable" `isInfixOf`)++    itWithOuter "checks a statement with parameters" \conn -> do+        (_, out) <- nullability conn "select nickname :: text from account where id = $1 :: int4"+        out `shouldSatisfy` ("public.account.nickname is nullable" `isInfixOf`)++    itWithOuter "checks RETURNING" \conn -> do+        (_, out) <- nullability conn "update account set name = name returning nickname :: text, name :: text"+        out `shouldSatisfy` ("column 1 (nickname)" `isInfixOf`)+        out `shouldNotSatisfy` ("column 2" `isInfixOf`)+++-- | Run a checked quoter as a splice would. Outside GHC a failing splice only+-- says that it failed - the message goes to stderr - so the tests that expect+-- a failure pair it with the same statement passing when nothing is checked.+quote :: QuasiQuoter -> String -> IO (Either String ())+quote quoter sql = either (Left . show) (const (Right ())) <$> (try (void (runQ (quoteExp quoter sql))) :: IO (Either SomeException ()))+++thSpec :: TestDef '[Text] ()+thSpec = do+    it "checks nothing when no database is set" do+        unsetEnv "HASQL_CHECK_DATABASE_URL"+        quote Checked.vectorStatement "select nope :: text from account" `shouldReturn` Right ()+        quote Checked.resultlessStatement "delete from nowhere" `shouldReturn` Right ()++    it "does not fail the build when the database cannot be reached" do+        setEnv "HASQL_CHECK_DATABASE_URL" "host=/nonexistent"+        quote Checked.maybeStatement "select nope :: text from account" `shouldReturn` Right ()++    itWithOuter "accepts a statement that prepares" \conn -> do+        setEnv "HASQL_CHECK_DATABASE_URL" (Text.unpack conn)+        quote Checked.maybeStatement "select name :: text from account where id = $1 :: int4" `shouldReturn` Right ()++    itWithOuter "fails on a statement that does not" \conn -> do+        setEnv "HASQL_CHECK_DATABASE_URL" (Text.unpack conn)+        result <- quote Checked.vectorStatement "select nope :: text from account"+        result `shouldSatisfy` isLeft++    itWithOuter "checks statements without rows" \conn -> do+        setEnv "HASQL_CHECK_DATABASE_URL" (Text.unpack conn)+        result <- quote Checked.resultlessStatement "delete from nowhere"+        result `shouldSatisfy` isLeft++    -- Run after the tests above have left a connection open to the test+    -- database: a broken statement fails there, but not when the database+    -- named cannot be reached.+    it "follows a change of database" do+        setEnv "HASQL_CHECK_DATABASE_URL" "host=/nonexistent"+        quote Checked.vectorStatement "select nope :: text from account" `shouldReturn` Right ()+++-- | Run with --types on one quote; return the exit code and output.+types :: Text -> Text -> Text -> IO (ExitCode, String)+types conn quoter statement =+    runOn [] ["--database", Text.unpack conn, "--types"] ("f = [" <> quoter <> "|" <> statement <> "|]\n")+++typesSpec :: TestDef '[Text] ()+typesSpec = do+    itWithOuter "warns about a column read as a narrower type, without failing" \conn -> do+        (code, out) <- types conn "vectorStatement" "select amount :: int4 from ledger"+        code `shouldBe` ExitSuccess+        out `shouldSatisfy` ("column 1 (amount) is annotated integer, but is a bigint: it may overflow" `isInfixOf`)++    itWithOuter "warns about an array read as one of narrower elements" \conn -> do+        (_, out) <- types conn "vectorStatement" "select amounts :: int4[] from totals"+        out `shouldSatisfy` ("column 1 (amounts) is annotated integer[], but is a bigint[]: it may overflow" `isInfixOf`)++    itWithOuter "warns about an array parameter assigned to a column of narrower elements" \conn -> do+        (_, out) <- types conn "resultlessStatement" "update tagged set scores = $1 :: int8[]"+        out `shouldSatisfy` ("parameter $1 is annotated bigint[], but is assigned to an integer[] column: it may overflow" `isInfixOf`)++    itWithOuter "warns only when asked" \conn ->+        runOn [] ["--database", Text.unpack conn] "f = [vectorStatement|select amount :: int4 from ledger|]\n" `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a column read as its own type, or a wider one" \conn ->+        types conn "vectorStatement" "select amount :: int8, small :: int4, id :: numeric from ledger" `shouldReturn` (ExitSuccess, "")++    itWithOuter "does not check expressions" \conn ->+        types conn "vectorStatement" "select count(*) :: int4, now() :: date from ledger" `shouldReturn` (ExitSuccess, "")++    itWithOuter "warns about lost precision" \conn -> do+        (_, out) <- types conn "vectorStatement" "select rate :: float4 from ledger"+        out `shouldSatisfy` ("is annotated real, but is a double precision: it may lose precision" `isInfixOf`)++    itWithOuter "warns about a dropped time of day" \conn -> do+        (_, out) <- types conn "vectorStatement" "select at :: date from ledger"+        out `shouldSatisfy` ("is annotated date, but is a timestamptz" `isInfixOf`)++    itWithOuter "looks through domains" \conn -> do+        (_, out) <- types conn "vectorStatement" "select price :: int4 from ledger"+        out `shouldSatisfy` ("column 1 (price) is annotated integer, but is a bigint" `isInfixOf`)++    -- Postgres reports a result column of a domain type as the base type, but+    -- a parameter assigned to one as the domain.+    itWithOuter "looks through a domain a parameter is assigned to" \conn -> do+        (_, out) <- types conn "resultlessStatement" "insert into ledger (id, amount, price) values ($1 :: int8, $2 :: int8, $3 :: numeric)"+        out `shouldSatisfy` ("parameter $3 is annotated numeric, but is assigned to a bigint column: it may be rounded, or overflow" `isInfixOf`)++    itWithOuter "warns about a parameter inserted into a narrower column" \conn -> do+        (_, out) <- types conn "resultlessStatement" "insert into account (id, name) values ($1 :: int8, $2 :: text)"+        out `shouldSatisfy` ("parameter $1 is annotated bigint, but is assigned to an integer column: it may overflow" `isInfixOf`)+        out `shouldNotSatisfy` ("parameter $2" `isInfixOf`)++    itWithOuter "accepts a parameter inserted into a column of its type" \conn ->+        types conn "resultlessStatement" "insert into account (id, name) values ($1 :: int4, $2 :: text)" `shouldReturn` (ExitSuccess, "")++    itWithOuter "checks parameters set by UPDATE, not those compared" \conn -> do+        (_, out) <- types conn "resultlessStatement" "update ledger set small = $1 :: int4 where amount = $2 :: int4"+        out `shouldSatisfy` ("parameter $1 is annotated integer, but is assigned to a smallint column" `isInfixOf`)+        out `shouldNotSatisfy` ("parameter $2" `isInfixOf`)++    itWithOuter "checks every column a parameter is assigned to" \conn -> do+        (_, out) <- types conn "resultlessStatement" "update ledger set amount = $1 :: int8, small = $1 :: int8 where id = $2 :: int8"+        out `shouldSatisfy` ("parameter $1 is annotated bigint, but is assigned to a smallint column" `isInfixOf`)++    itWithOuter "removes an annotation from ORDER BY too, so DISTINCT still prepares" \conn -> do+        (_, out) <- types conn "vectorStatement" "select distinct amount :: int4 from ledger order by amount :: int4"+        out `shouldSatisfy` ("column 1 (amount) is annotated integer, but is a bigint" `isInfixOf`)++    itWithOuter "removes an annotation from GROUP BY too" \conn -> do+        (_, out) <- types conn "vectorStatement" "select amount :: int4 from ledger group by amount :: int4"+        out `shouldSatisfy` ("column 1 (amount) is annotated integer, but is a bigint" `isInfixOf`)++    itWithOuter "checks RETURNING along with the assignments" \conn -> do+        (_, out) <- types conn "singletonStatement" "insert into account (id, name) values ($1 :: int8, $2 :: text) returning id :: int2"+        out `shouldSatisfy` ("column 1 (id) is annotated smallint, but is an integer" `isInfixOf`)+        out `shouldSatisfy` ("parameter $1" `isInfixOf`)+++-- | Run on a whole source with the given flags; return the exit code and output.+checkSource :: Text -> [String] -> Text -> IO (ExitCode, String)+checkSource conn flags = runOn [] (["--database", Text.unpack conn] <> flags)+++suppressionSpec :: TestDef '[Text] ()+suppressionSpec = do+    itWithOuter "a directive above the quote suppresses the finding it names" \conn ->+        checkSource conn ["--nullability"] "-- hasql-check: allow nullable(nickname)\nf = [vectorStatement|select nickname :: text from account|]\n"+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "a directive suppresses only what it names, and says what it did not use" \conn -> do+        (_, out) <- checkSource conn ["--nullability"] "-- hasql-check: allow nullable(name)\nf = [vectorStatement|select nickname :: text from account|]\n"+        out `shouldSatisfy` ("column 1 (nickname) is annotated non-null" `isInfixOf`)+        out `shouldSatisfy` ("allow nullable(name) suppresses nothing" `isInfixOf`)++    itWithOuter "a directive applies only directly above the quote" \conn -> do+        (_, out) <- checkSource conn ["--nullability"] "-- hasql-check: allow nullable(nickname)\n\nf = [vectorStatement|select nickname :: text from account|]\n"+        out `shouldSatisfy` ("column 1 (nickname) is annotated non-null" `isInfixOf`)++    itWithOuter "directives read every comment line directly above" \conn ->+        checkSource+            conn+            ["--nullability", "--types"]+            "f =\n    -- hasql-check: allow narrowing(amount)\n    -- Why: the amounts here are small.\n    -- hasql-check: allow nullable(nickname)\n    [vectorStatement|select nickname :: text, amount :: int4 from account, ledger|]\n"+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "a directive names parameters as $n" \conn ->+        checkSource conn ["--types"] "-- hasql-check: allow narrowing($1)\nf = [resultlessStatement|insert into account (id, name) values ($1 :: int8, $2 :: text)|]\n"+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "a directive for a rule that was not checked is not reported" \conn ->+        checkSource conn ["--nullability"] "-- hasql-check: allow narrowing(amount)\nf = [vectorStatement|select name :: text from account|]\n"+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "a malformed directive is reported" \conn -> do+        (_, out) <- checkSource conn ["--nullability"] "-- hasql-check: permit nullable(nickname)\nf = [vectorStatement|select name :: text from account|]\n"+        out `shouldSatisfy` ("directive not understood: permit nullable(nickname)" `isInfixOf`)++    itWithOuter "--fail-on-warnings fails on a finding, not on a suppressed one" \conn -> do+        (code, _) <- checkSource conn ["--nullability", "--fail-on-warnings"] "f = [vectorStatement|select nickname :: text from account|]\n"+        code `shouldBe` ExitFailure 1+        (suppressed, _) <- checkSource conn ["--nullability", "--fail-on-warnings"] "-- hasql-check: allow nullable(nickname)\nf = [vectorStatement|select nickname :: text from account|]\n"+        suppressed `shouldBe` ExitSuccess++    itWithOuter "a baseline ignores the findings it was written with, wherever the quote is" \conn ->+        withSystemTempDirectory "hasql-check-baseline" \dir -> do+            let baseline = dir </> "baseline"+                flags = ["--nullability", "--fail-on-warnings"]+            (written, _) <- checkSource conn (flags <> ["--write-baseline", baseline]) "f = [vectorStatement|select nickname :: text from account|]\n"+            written `shouldBe` ExitFailure 1+            contents <- readFile baseline+            contents `shouldSatisfy` (" nullable nickname # " `isInfixOf`)+            -- The same statement, laid out differently and somewhere else.+            checkSource conn (flags <> ["--baseline", baseline]) "g = 1\nf =\n  [vectorStatement|\n    select   nickname :: text\n    from account\n  |]\n"+                `shouldReturn` (ExitSuccess, "")+            (changed, out) <- checkSource conn (flags <> ["--baseline", baseline]) "f = [vectorStatement|select nickname :: text from account where id > 0|]\n"+            changed `shouldBe` ExitFailure 1+            out `shouldSatisfy` ("column 1 (nickname)" `isInfixOf`)++    itWithOuter "--files0-from checks every listed file in one run, so the baseline has them all" \conn ->+        withSystemTempDirectory "hasql-check-files" \dir -> do+            let a = dir </> "A.hs"+                b = dir </> "B's.hs"+                list = dir </> "files"+                baseline = dir </> "baseline"+            writeFile a "f = [vectorStatement|select nickname :: text from account|]\n"+            writeFile b "g = [vectorStatement|select amount :: int4 from ledger|]\n"+            writeFile list (a <> "\0" <> b <> "\0")+            (code, _, _) <-+                readCreateProcessWithExitCode+                    (proc "hasql-check" ["--database", Text.unpack conn, "--nullability", "--types", "--files0-from", list, "--write-baseline", baseline])+                    ""+            code `shouldBe` ExitSuccess+            contents <- readFile baseline+            contents `shouldSatisfy` (" nullable nickname # " `isInfixOf`)+            contents `shouldSatisfy` (" narrowing amount # " `isInfixOf`)++    itWithOuter "a baseline and a directive handle a quoted column name" \conn ->+        withSystemTempDirectory "hasql-check-quoted" \dir -> do+            let baseline = dir </> "baseline"+                source = "f = [vectorStatement|select nickname :: text as \"display name\" from account|]\n"+            _ <- checkSource conn ["--nullability", "--write-baseline", baseline] source+            contents <- readFile baseline+            contents `shouldSatisfy` (" nullable \"display name\" # " `isInfixOf`)+            checkSource conn ["--nullability", "--fail-on-warnings", "--baseline", baseline] source `shouldReturn` (ExitSuccess, "")+            checkSource conn ["--nullability", "--fail-on-warnings"] ("-- hasql-check: allow nullable(\"display name\")\n" <> source)+                `shouldReturn` (ExitSuccess, "")+++-- | The SQL the inferred quoters send for a statement, given the Postgres+-- types of its parameters and result columns.+sent :: Text -> [Text] -> [Text] -> Either String Text+sent sql paramTypes columnTypes = render paramTypes columnTypes <$> Inferred.template sql+++piecesSpec :: Spec+piecesSpec = do+    it "annotates each parameter, and casts each result column around the statement" $+        sent "select email, nickname from customer where id = $1" ["int8"] ["text", "text"]+            `shouldBe` Right "WITH hasql_check_result (c1, c2) AS (SELECT email, nickname FROM customer WHERE id = $1 :: int8) SELECT c1 :: text, c2 :: text FROM hasql_check_result"++    it "annotates every occurrence of a parameter" $+        sent "select a from t where b = $1 or c = $1" ["int4"] ["text"]+            `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT a FROM t WHERE b = $1 :: int4 OR c = $1 :: int4) SELECT c1 :: text FROM hasql_check_result"++    it "casts RETURNING" $+        sent "update t set a = $1 returning id" ["text"] ["int8"]+            `shouldBe` Right "WITH hasql_check_result (c1) AS (UPDATE t SET a = $1 :: text RETURNING id) SELECT c1 :: int8 FROM hasql_check_result"++    it "casts the columns behind a *" $+        sent "select * from t where id = $1" ["int8"] ["int8", "text"]+            `shouldBe` Right "WITH hasql_check_result (c1, c2) AS (SELECT * FROM t WHERE id = $1 :: int8) SELECT c1 :: int8, c2 :: text FROM hasql_check_result"++    it "leaves the statement itself as it is: its DISTINCT ON, ORDER BY and GROUP BY" $+        sent "select distinct on (t.id) t.id from t group by 1 order by id" [] ["int8"]+            `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT DISTINCT ON (t.id) t.id FROM t GROUP BY 1 ORDER BY id) SELECT c1 :: int8 FROM hasql_check_result"++    it "keeps the statement's own WITH list first, where a data-modifying one must be" $+        sent "with x as (update t set a = $1 returning a) select a from x" ["int8"] ["int8"]+            `shouldBe` Right "WITH x AS (UPDATE t SET a = $1 :: int8 RETURNING a), hasql_check_result (c1) AS (SELECT a FROM x) SELECT c1 :: int8 FROM hasql_check_result"++    it "keeps a parenthesised statement's WITH list first too" $+        sent "(with x as (update t set a = 1 returning a) select a from x)" [] ["int8"]+            `shouldBe` Right "WITH x AS (UPDATE t SET a = 1 RETURNING a), hasql_check_result (c1) AS ((SELECT a FROM x)) SELECT c1 :: int8 FROM hasql_check_result"++    it "picks a name the statement does not use" $+        sent "select a from hasql_check_result" [] ["int8"]+            `shouldBe` Right "WITH hasql_check_result_ (c1) AS (SELECT a FROM hasql_check_result) SELECT c1 :: int8 FROM hasql_check_result_"++    it "keeps text in a literal that looks like an annotation" $+        sent "select ' :: hasql_check_slot_1'" [] ["text"]+            `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT ' :: hasql_check_slot_1') SELECT c1 :: text FROM hasql_check_result"++    it "annotates an array parameter" $+        sent "select a from t where id = any($1)" ["int8[]"] ["text"]+            `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT a FROM t WHERE id = ANY ($1 :: int8[])) SELECT c1 :: text FROM hasql_check_result"++    it "annotates a subscripted parameter before its subscript" $+        sent "select $1['a']" ["jsonb"] ["jsonb"]+            `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT ($1 :: jsonb)['a']) SELECT c1 :: jsonb FROM hasql_check_result"++    it "sends a statement without rows as it is" $+        sent "delete from t where id = $1" ["int8"] []+            `shouldBe` Right "DELETE FROM t WHERE id = $1 :: int8"++    it "takes an enum's name as SQL, as a cast does, for the codecs" $+        map+            qualifiedName+            ["payment_state", "Public.Payment_State", "\"payment_state\"", "\"My Schema\".\"x.y\"", "app.public.payment_state"]+            `shouldBe` [(Nothing, "payment_state"), (Just "public", "payment_state"), (Nothing, "payment_state"), (Just "My Schema", "x.y"), (Just "public", "payment_state")]++    it "rejects SQL it cannot parse" $+        Inferred.template "select from where" `shouldSatisfy` isLeft+++data PaymentState = PENDING | PAID | REFUNDED+    deriving stock (Eq, Show, Generic)+    deriving (Value) via PgEnum "payment_state" PaymentState+++newtype Qualified = Qualified PaymentState+    deriving stock (Eq, Show)+    deriving (Value) via PgEnum "public.\"payment_state\"" PaymentState+++-- The test database is "postgres".+newtype InDatabase = InDatabase PaymentState+    deriving stock (Eq, Show)+    deriving (Value) via PgEnum "postgres.public.payment_state" PaymentState+++newtype Status = Status PaymentState+    deriving stock (Eq, Show)+    deriving (Value) via Domain "payment_status" PaymentState+++newtype Label = Label Text+    deriving stock (Eq, Show)+    deriving newtype (Value)+++newtype Cents = Cents Int64+    deriving stock (Eq, Show)+    deriving (Value) via Domain "cents" Int64+++-- | Run a statement on the test database.+runStatement :: Text -> params -> Statement params result -> IO result+runStatement conn params statement = do+    Right c <- Connection.acquire Pqi.Ffi.adapter (Settings.connectionString conn)+    result <- Connection.use c (Session.statement params statement)+    Connection.release c+    either (\e -> expectationFailure (show e) >> error "unreachable") pure result+++runtimeSpec :: TestDef '[Text] ()+runtimeSpec = do+    itWithOuter "reads a varchar column as Text" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select label from tag where id = $1|]+            `shouldReturn` ("red" :: Text)++    itWithOuter "reads an int4 column as Int64, and sends an Int64 parameter for it" \conn ->+        runStatement conn (1 :: Int64) [Inferred.singletonStatement|select id from tag where id = $1|]+            `shouldReturn` (1 :: Int64)++    itWithOuter "reads a tuple, with a Maybe for a NULL" \conn ->+        runStatement conn (1 :: Int32) [Inferred.maybeStatement|select label, null from tag where id = $1|]+            `shouldReturn` Just ("red" :: Text, Nothing :: Maybe Text)++    itWithOuter "sends a literal that looks like an annotation unchanged" \conn ->+        runStatement conn () [Inferred.singletonStatement|select ' :: hasql_check_slot_c1'|]+            `shouldReturn` (" :: hasql_check_slot_c1" :: Text)++    -- Ordered by the column the alias "id" names, label, rather than v.id.+    itWithOuter "keeps the order of SELECT DISTINCT by an alias" \conn ->+        runStatement conn () [Inferred.singletonStatement|select distinct id as key, label as id from (values (2, 'a'), (1, 'b')) v (id, label) order by id limit 1|]+            `shouldReturn` (2 :: Int64, "a" :: Text)++    itWithOuter "runs SELECT DISTINCT ON, ordered by an output name, with a cast column" \conn ->+        runStatement conn () [Inferred.vectorStatement|select distinct on (t.id) t.id from tag t where t.id = 1 order by id|]+            `shouldReturn` Vector.fromList [1 :: Int64]++    itWithOuter "runs GROUP BY a primary key, with a cast column" \conn ->+        runStatement conn () [Inferred.vectorStatement|select id, label from tag where id = 1 group by 1|]+            `shouldReturn` Vector.fromList [(1 :: Int64, "red" :: Text)]++    itWithOuter "runs a statement that does not use all its parameters" \conn ->+        runStatement conn (1 :: Int64, 2 :: Int64) [Inferred.singletonStatement|select $2|]+            `shouldReturn` (2 :: Int64)++    itWithOuter "reads a newtype as the type it wraps" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select label from tag where id = $1|]+            `shouldReturn` Label "red"++    itWithOuter "sends and reads a newtype as the domain it derives" \conn ->+        runStatement conn (Cents 5) [Inferred.singletonStatement|select $1|]+            `shouldReturn` Cents 5++    itWithOuter "reads an array as a Vector" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select labels from tagged where id = $1|]+            `shouldReturn` Vector.fromList ["a", "b" :: Text]++    itWithOuter "reads an int4[] with NULLs as a Vector of Maybe Int64" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select scores from tagged where id = $1|]+            `shouldReturn` Vector.fromList [Just 1, Nothing, Just (3 :: Int64)]++    itWithOuter "subscripts an array parameter" \conn ->+        runStatement conn [10, 20 :: Int64] [Inferred.singletonStatement|select $1[2]|]+            `shouldReturn` (20 :: Int64)++    itWithOuter "sends a list as an array" \conn ->+        runStatement conn [1, 2 :: Int64] [Inferred.vectorStatement|select id from tagged where id = any($1)|]+            `shouldReturn` Vector.fromList [1 :: Int64]++    itWithOuter "reads an enum as a Haskell enumeration" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select state from payment where id = $1|]+            `shouldReturn` PAID++    itWithOuter "reads an enum named with its schema and in quotes" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select state from payment where id = $1|]+            `shouldReturn` Qualified PAID++    itWithOuter "reads an enum named with the database too" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select state from payment where id = $1|]+            `shouldReturn` InDatabase PAID++    itWithOuter "reads a domain over an enum" \conn ->+        runStatement conn (1 :: Int32) [Inferred.singletonStatement|select status from payment_log where id = $1|]+            `shouldReturn` Status REFUNDED++    itWithOuter "sends a Haskell enumeration as an enum" \conn ->+        runStatement conn PENDING [Inferred.singletonStatement|select count(*) from payment where state = $1|]+            `shouldReturn` (0 :: Int64)++    itWithOuter "runs a statement without rows" \conn ->+        runStatement conn ("blue" :: Text, 2 :: Int64) [Inferred.resultlessStatement|insert into tag (label, id) values ($1, $2)|]+            `shouldReturn` ()+++-- | A quote as hasql-check-hie writes it: its SQL, and the qualified name and+-- Postgres type of each parameter and result column.+inferredQuote :: Text -> Text -> [Column] -> Maybe [Column] -> Text+inferredQuote quoter sql params row =+    "{\"file\":\"src/Fixture.hs\",\"line\":3,\"column\":7,\"quoter\":\""+        <> quoter+        <> "\",\"sql\":\""+        <> sql+        <> "\",\"params\":"+        <> columns params+        <> ",\"row\":"+        <> maybe "null" columns row+        <> "}"+  where+    columns cs = "[" <> Text.intercalate "," (map column cs) <> "]"+    column c =+        "{\"type\":\""+            <> c.haskell+            <> "\",\"postgres\":\""+            <> c.postgres+            <> "\",\"labels\":["+            <> Text.intercalate "," ["\"" <> l <> "\"" | l <- c.labels]+            <> "],\"nullable\":"+            <> (if c.nullable then "true" else "false")+            <> "}"+++data Column = Column {haskell :: Text, postgres :: Text, nullable :: Bool, labels :: [Text]}+++-- | The same column, as a 'Maybe'.+optional :: Column -> Column+optional c = c{nullable = True}+++-- | Run with --inferred on the given quotes and flags.+runInferred :: Text -> [String] -> [Text] -> IO (ExitCode, String)+runInferred conn args quotes' =+    withSystemTempDirectory "hasql-check-inferred" \dir -> do+        let file = dir </> "quotes.jsonl"+        ByteString.Lazy.writeFile file (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 (Text.unlines quotes')))+        (code, out, err) <- readCreateProcessWithExitCode (proc "hasql-check" (["--database", Text.unpack conn, "--inferred", file] <> args)) ""+        pure (code, out <> err)+++int32, int64, text :: Column+int32 = Column "GHC.Internal.Int.Int32" "int4" False []+int64 = Column "GHC.Internal.Int.Int64" "int8" False []+text = Column "Data.Text.Internal.Text" "text" False []+++inferredSpec :: TestDef '[Text] ()+inferredSpec = do+    itWithOuter "accepts a statement whose Haskell types fit" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select label, id from tag where id = $1" [int64] (Just [text, int64])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects one that does not prepare, and says where it is" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select nope from tag" [] (Just [text])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("src/Fixture.hs:3:7" `isInfixOf`)+        out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`)++    itWithOuter "rejects a Haskell type with too few columns" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select label, id from tag" [] (Just [text])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("the statement returns 2 columns, but the Haskell type reads 1" `isInfixOf`)++    itWithOuter "accepts the columns behind a *, cast to the types read" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select * from tag" [] (Just [int64, text])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a qualified * whose columns have the types read" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "select a.* from account a" [] (Just [int32, text, optional text])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts SELECT DISTINCT ordered by a column it annotates" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "select distinct id from tag order by id" [] (Just [int64])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts SELECT DISTINCT ordered by a qualified column and an expression" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "select distinct t.id, t.id + 1 from tag t order by t.id, t.id + 1" [] (Just [int64, int64])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts statements that a cast in place would break" \conn ->+        runInferred+            conn+            []+            [ inferredQuote "vectorStatement" "select distinct on (t.id) t.id from tag t order by id" [] (Just [int64])+            , inferredQuote "vectorStatement" "select id, label from tag group by 1" [] (Just [int64, text])+            ]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a parenthesised statement with a data-modifying WITH" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "(with x as (update tag set label = label returning id) select id from x)" [] (Just [int64])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "warns about a narrowed column of SELECT DISTINCT ON, which a cast in place would break" \conn -> do+        (_, out) <- runInferred conn ["--types"] [inferredQuote "vectorStatement" "select distinct on (t.id) t.id from ledger t order by id" [] (Just [int32])]+        out `shouldSatisfy` ("column 1 (id) is read as integer, but is a bigint: it may overflow" `isInfixOf`)++    itWithOuter "warns about a nullable column behind a *" \conn -> do+        (_, out) <- runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select * from account" [] (Just [int32, text, text])]+        out `shouldSatisfy` ("column 3 (nickname) is not a Maybe in Haskell, but public.account.nickname is nullable" `isInfixOf`)++    itWithOuter "still checks a source quote at the same place in another package" \conn ->+        withSystemTempDirectory "hasql-check-other" \dir -> do+            let source = dir </> "other" </> "src" </> "Fixture.hs"+                quotesFile = dir </> "quotes.jsonl"+            createDirectoryIfMissing True (dir </> "other" </> "src")+            writeFile source "module Fixture where\n\ng =   [singletonStatement|select nope :: text from account|]\n"+            ByteString.Lazy.writeFile quotesFile (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 (inferredQuote "singletonStatement" "select 1" [] (Just [int32]))))+            (code, out, err) <- readCreateProcessWithExitCode (proc "hasql-check" ["--database", Text.unpack conn, source, "--inferred", quotesFile]) ""+            code `shouldBe` ExitFailure 1+            (out <> err) `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`)++    itWithOuter "accepts a subscripted parameter, which it uses" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select $1['a']" [Column "Data.Aeson.Types.Internal.Value" "jsonb" False []] (Just [Column "Data.Aeson.Types.Internal.Value" "jsonb" True []])]+            `shouldReturn` (ExitSuccess, "")++    -- It runs, but whatever it was meant to do with $1, it does not.+    itWithOuter "rejects a statement that does not use a parameter the Haskell type sends" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select $2" [int64, int64] (Just [int64])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("the Haskell type sends parameter $1, which the statement does not use" `isInfixOf`)+        out `shouldNotSatisfy` ("could not determine" `isInfixOf`)++    itWithOuter "checks a quote in a source file it also has from --inferred once, as inferred" \conn ->+        withSystemTempDirectory "hasql-check-both" \dir -> do+            let source = dir </> "src" </> "Fixture.hs"+                quotesFile = dir </> "quotes.jsonl"+            createDirectoryIfMissing True (dir </> "src")+            -- Line 3, with the quote at column 7, as the inferred quote says.+            writeFile source "module Fixture where\n\ng =   [singletonStatement|select $1 + $2|]\n"+            ByteString.Lazy.writeFile quotesFile (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 (inferredQuote "singletonStatement" "select $1 + $2" [int64, int64] (Just [int64]))))+            (code, out, err) <- readCreateProcessWithExitCode (proc "hasql-check" ["--database", Text.unpack conn, source, "--inferred", quotesFile]) ""+            (code, out <> err) `shouldBe` (ExitSuccess, "")++    itWithOuter "rejects a Haskell type that sends more parameters than the statement uses" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select 1" [int64] (Just [int32])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("the Haskell type sends parameter $1, which the statement does not use" `isInfixOf`)++    itWithOuter "rejects a Haskell type that sends fewer, without rows too" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "resultlessStatement" "delete from tag where id = $1" [] Nothing]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("the statement uses $1, but the Haskell type sends 0 parameters" `isInfixOf`)++    itWithOuter "accepts a column of a domain, read as a newtype deriving it" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select price from ledger" [] (Just [Column "Shop.Cents" "cents" True []])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects a column Postgres converts to the type read only when told to" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "vectorStatement" "select name from account" [] (Just [Column "Shop.Nickname" "int8" False []])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column 1 (name) is text, but is read as Shop.Nickname (bigint), which Postgres converts it to only when told to" `isInfixOf`)++    itWithOuter "accepts an array whose elements Postgres converts on its own" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select scores from tagged" [] (Just [Column "Data.Vector.Vector (Maybe Int64)" "int8[]" True []])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects an array whose elements Postgres converts only when told to" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select labels from tagged" [] (Just [Column "Data.Vector.Vector Int64" "int8[]" False []])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column 1 (labels) is text[], but is read as Data.Vector.Vector Int64 (bigint[]), which Postgres converts it to only when told to" `isInfixOf`)++    itWithOuter "warns about an array read as one of narrower elements, whose cast is accepted" \conn -> do+        (code, out) <- runInferred conn ["--types"] [inferredQuote "vectorStatement" "select amounts from totals" [] (Just [Column "Data.Vector.Vector Int32" "int4[]" False []])]+        code `shouldBe` ExitSuccess+        out `shouldSatisfy` ("column 1 (amounts) is read as integer[], but is a bigint[]: it may overflow" `isInfixOf`)++    itWithOuter "warns about an array parameter sent to a column of narrower elements" \conn -> do+        (_, out) <- runInferred conn ["--types"] [inferredQuote "resultlessStatement" "update tagged set scores = $1" [Column "Data.Vector.Vector Int64" "int8[]" False []] Nothing]+        out `shouldSatisfy` ("parameter $1 is sent as bigint[], but is assigned to an integer[] column: it may overflow" `isInfixOf`)++    itWithOuter "warns about a nullable array read without a Maybe" \conn -> do+        (_, out) <- runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select scores from tagged" [] (Just [Column "Data.Vector.Vector (Maybe Int64)" "int8[]" False []])]+        out `shouldSatisfy` ("column 1 (scores) is not a Maybe in Haskell, but public.tagged.scores is nullable" `isInfixOf`)+    itWithOuter "accepts NULL and string literals, typed by the cast" \conn ->+        runInferred+            conn+            []+            [ inferredQuote "singletonStatement" "select NULL" [] (Just [Column "GHC.Internal.Int.Int64" "int8" True []])+            , inferredQuote "singletonStatement" "select '2026-10-29'" [] (Just [Column "Data.Time.Calendar.Days.Day" "date" False []])+            ]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects a string literal that is not of the type read" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select 'abc'" [] (Just [Column "Data.UUID.Types.Internal.UUID" "uuid" False []])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column 1 (?column?) is 'abc', which cannot be read as Data.UUID.Types.Internal.UUID" `isInfixOf`)++    itWithOuter "accepts any column read as text, which Postgres converts to on assignment" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "select id from account" [] (Just [text])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a domain over a domain, read as the type at the bottom" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "select balance from wallet" [] (Just [Column "Shop.Positive" "positive_cents" False []])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a domain column behind a *" \conn ->+        runInferred conn [] [inferredQuote "vectorStatement" "select x.* from (select price from ledger) x" [] (Just [Column "Shop.Cents" "cents" True []])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects a Postgres type that does not exist, behind a * too" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select x.* from (select 'abc'::text) x" [] (Just [Column "Shop.Missing" "missing_domain" False []])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("no such Postgres type: missing_domain" `isInfixOf`)++    itWithOuter "rejects a UNION whose branches do not agree, which fails as sent too" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select name from account union all select 1" [] (Just [int64])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("UNION types text and integer cannot be matched" `isInfixOf`)++    itWithOuter "accepts an enum read with all its labels" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select state from payment" [] (Just [Column "Shop.State" "payment_state" False ["PENDING", "PAID", "REFUNDED"]])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects an enum read without a label the database has" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select state from payment" [] (Just [Column "Shop.State" "payment_state" False ["PENDING", "PAID"]])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("column 1 (state) is read as Shop.State, which cannot read labels payment_state has: REFUNDED" `isInfixOf`)++    itWithOuter "accepts an enum sent with fewer labels than the database has" \conn ->+        runInferred conn [] [inferredQuote "resultlessStatement" "update payment set state = $1" [Column "Shop.Transition" "payment_state" False ["PAID"]] Nothing]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "accepts a domain over an enum, read with all its labels" \conn ->+        runInferred conn [] [inferredQuote "singletonStatement" "select status from payment_log" [] (Just [Column "Shop.Status" "payment_status" False ["PENDING", "PAID", "REFUNDED"]])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "rejects a domain over an enum read without a label the enum has" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select status from payment_log" [] (Just [Column "Shop.Status" "payment_status" False ["PENDING", "PAID"]])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("which cannot read labels payment_status has: REFUNDED" `isInfixOf`)++    itWithOuter "rejects an enum sent with a label the database does not have" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "resultlessStatement" "update payment set state = $1" [Column "Shop.Transition" "payment_state" False ["PAID", "CANCELLED"]] Nothing]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("parameter $1 is sent as Shop.Transition, with labels payment_state does not have: CANCELLED" `isInfixOf`)++    itWithOuter "rejects a Postgres type the database does not have" \conn -> do+        (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select label from tag" [] (Just [Column "Shop.Label" "nosuchtype" False []])]+        code `shouldBe` ExitFailure 1+        out `shouldSatisfy` ("no such Postgres type: nosuchtype" `isInfixOf`)++    itWithOuter "warns about a nullable column read without a Maybe" \conn -> do+        (_, out) <- runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select nickname from account" [] (Just [text])]+        out `shouldSatisfy` ("column 1 (nickname) is not a Maybe in Haskell, but public.account.nickname is nullable" `isInfixOf`)++    itWithOuter "accepts a nullable column read as a Maybe" \conn ->+        runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select nickname from account" [] (Just [optional text])]+            `shouldReturn` (ExitSuccess, "")++    itWithOuter "warns about a column read as a narrower type" \conn -> do+        (_, out) <- runInferred conn ["--types"] [inferredQuote "vectorStatement" "select amount from ledger" [] (Just [int32])]+        out `shouldSatisfy` ("column 1 (amount) is read as integer, but is a bigint: it may overflow" `isInfixOf`)++    itWithOuter "fingerprints an inferred statement by its result types too, for baselines" \conn ->+        withSystemTempDirectory "hasql-check-baseline" \dir -> do+            let baseline = dir </> "baseline"+                readAs t = inferredQuote "vectorStatement" "select amount from ledger" [] (Just [t])+                int16 = Column "GHC.Internal.Int.Int16" "int2" False []+            _ <- runInferred conn ["--types", "--write-baseline", baseline] [readAs int32]+            -- The same statement stays suppressed; read as a narrower type, it+            -- is another statement, and is not.+            runInferred conn ["--types", "--baseline", baseline, "--fail-on-warnings"] [readAs int32]+                `shouldReturn` (ExitSuccess, "")+            (code, out) <- runInferred conn ["--types", "--baseline", baseline, "--fail-on-warnings"] [readAs int16]+            code `shouldBe` ExitFailure 1+            out `shouldSatisfy` ("column 1 (amount) is read as smallint, but is a bigint: it may overflow" `isInfixOf`)++    itWithOuter "warns about a parameter assigned to a narrower column" \conn -> do+        (_, out) <- runInferred conn ["--types"] [inferredQuote "resultlessStatement" "update ledger set small = $1" [int64] Nothing]+        out `shouldSatisfy` ("parameter $1 is sent as bigint, but is assigned to a smallint column: it may overflow" `isInfixOf`)