diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,234 @@ +# hasql-th-format + +Format the SQL inside your +[hasql-th](https://hackage.haskell.org/package/hasql-th) quasiquotes, in place. + +It parses each statement with +[postgresql-syntax](https://hackage.haskell.org/package/postgresql-syntax) and +renders it again, so the layout comes from the statement's structure rather +than from whoever typed it: + +```haskell +recent = + [vectorStatement| + select o.id::int8, c.email::text, o.total::numeric from orders o join customer c on c.id = o.customer_id where o.placed_at > $1::timestamptz and o.status = $2::text order by o.placed_at desc limit 50 + |] +``` + +``` +$ hasql-th-format src/Shop/Orders.hs +Reformatted: src/Shop/Orders.hs +``` + +```haskell +recent = + [vectorStatement| + select + o.id::int8 + , c.email::text + , o.total::numeric + from orders o + join customer c + on c.id = o.customer_id + where o.placed_at > $1::timestamptz + and o.status = $2::text + order by o.placed_at desc + limit 50 + |] +``` + +## Contents + +- [Installing](#installing) +- [Formatting](#formatting) +- [It will not change what a statement means](#it-will-not-change-what-a-statement-means) +- [Checking a refactor did not either: `hasql-th-audit`](#checking-a-refactor-did-not-either-hasql-th-audit) +- [The `kronor-syntax` flag](#the-kronor-syntax-flag) +- [Reference](#reference) +- [Limitations](#limitations) +- [Development](#development) + +## Installing + +``` +git clone https://github.com/kronor-io/hasql-check +cd hasql-check/format +cabal install exe:hasql-th-format exe:hasql-th-audit +``` + +It reads quotes through `hasql-check`'s lexer, which links against libpq, so +install your platform's PostgreSQL client library first (`libpq-dev` on Debian +and Ubuntu). + +## Formatting + +Give it files. It rewrites every supported quasiquote in place and says which +files it touched: + +``` +$ hasql-th-format src/Shop/Orders.hs src/Shop/Customers.hs +Reformatted: src/Shop/Orders.hs +``` + +`--check` changes nothing and exits 1 if any file would be rewritten, which is +what you want in CI or a pre-commit hook: + +``` +$ hasql-th-format --check src/Shop/Orders.hs +Would reformat: src/Shop/Orders.hs +``` + +`--stdin` reads one file's worth of Haskell on standard input and writes the +formatted result to stdout, which is the quickest way to see what the formatter +does with a quote. It is Haskell it reads, not bare SQL: a statement on its own +has no quasiquote around it, and comes back untouched. + +``` +$ printf 'q =\n [vectorStatement|\n select c.id::int8, c.email::text from customer c where c.active\n |]\n' \ + | hasql-th-format --stdin +q = + [vectorStatement| + select + c.id::int8 + , c.email::text + from customer c + where c.active + |] +``` + +These quoters are recognised: `singletonStatement`, `maybeStatement`, +`vectorStatement`, `foldStatement`, `resultlessStatement`, +`rowsAffectedStatement`. + +## It will not change what a statement means + +After rendering, the formatter **re-parses its own output and compares the two +ASTs**. If they differ it writes nothing, leaves the file byte for byte as it +was, and fails: + +``` +$ hasql-th-format src/Report/Ledger.hs +Error processing src/Report/Ledger.hs: line 164: AST mismatch: formatter rendered semantically-different SQL (renderer bug) +``` + +That is a bug in this tool, not in your SQL — please report it. An earlier +version fell back silently to the unformatted text, and a renderer bug that +dropped a `DISTINCT ON` clause reached production that way. + +There is no false-positive risk: `postgresql-syntax` parses +semantically-equivalent text to identical ASTs — whitespace, keyword case and +`::` spacing all normalise — so a mismatch is always real. + +The other failure is `AST mismatch: formatter output did not re-parse`, meaning +the renderer emitted SQL that is not valid. It should be unreachable, and +reports the underlying parse error if it happens. + +## Checking a refactor did not either: `hasql-th-audit` + +The check above runs per quote, at format time, against the input the formatter +was just handed. It cannot see a hand-edit, a tree-wide rename, or any change +`hasql-th-format` was never run on — and if the formatter itself crashes, it +does not run at all. + +`hasql-th-audit` takes two versions of a file and compares their quotes by AST, +using only `postgresql-syntax`: + +``` +$ hasql-th-audit old/Orders.hs new/Orders.hs +new/Orders.hs:6 (qq #1): AST DIFFERS + --- old (line 6) --- + ... order by o.placed_at desc + limit 50 + --- new (line 6) --- + ... order by o.placed_at desc + limit 20 +``` + +Exit codes: `0` every quote is equivalent, `1` one or more differ (or the +counts differ), `2` usage error or lexer failure. + +Across a branch: + +```bash +BIN=$(cabal list-bin hasql-th-audit) +base=$(git merge-base origin/main HEAD) + +while read -r f; do + old=$(mktemp); new=$(mktemp) + git show "$base:$f" > "$old" 2>/dev/null || { rm -f "$old"; continue; } + git show "HEAD:$f" > "$new" 2>/dev/null || { rm -f "$old" "$new"; continue; } + "$BIN" "$old" "$new" || echo "REGRESSION: $f" + rm -f "$old" "$new" +done < <(git diff --name-only "$base" HEAD -- '*.hs') +``` + +## The `kronor-syntax` flag + +Off by default, the formatter handles what upstream `postgresql-syntax` accepts +plus hasql-th's `::type?` nullability markers. + +Kronor's fork of hasql-th adds two more forms, and `+kronor-syntax` parses +*and* renders both: + +```sql +select $Just (name :: text), $Row { id = o.id :: int8 } +from orders o +where o.customer_id = $1.$customerId :: int8 +``` + +The flag needs Kronor's fork of `postgresql-syntax`, where those constructors +live, so a build against Hackage must leave it off. It is the same flag, +meaning the same thing, as `hasql-check`'s. + +## Reference + +### `hasql-th-format` + +| | | +|---|---| +| `hasql-th-format FILES...` | Rewrite every quote in each file, in place | +| `--check` | Change nothing; exit 1 if any file would change | +| `--stdin` | Format one statement from stdin onto stdout | + +Exit codes: `0` success, `1` a file would change (`--check`) or a quote failed +to parse or round-trip, `2` usage error. + +### `hasql-th-audit` + +| | | +|---|---| +| `hasql-th-audit OLD NEW` | Compare the quotes of two versions of one file | + +## Limitations + +- **Long lines it cannot break.** The renderer wraps at a set of known + constructs. An expression built from others — a deeply nested `case` inside a + function argument, say — can still exceed the line budget. +- **`(select ...)` in a `join`** renders with both the subquery's parens and + the join's, so you get `((select ...))`. It parses the same; it just looks + odd. +- **Some `AExpr` / `CExpr` constructors have no multi-line form** and fall + through to the inline renderer whatever their length. + +## Development + +``` +cabal build +cabal test # 64 golden cases, each also asserting AST equivalence +``` + +The test suite in `test/Test.hs` is the right home for a minimised reproducer +once you have narrowed a layout bug down. Each case is an input and the exact +expected output, so a change in layout shows up as a diff rather than as a +judgement call. + +Two render paths run over the same AST: an inline one used inside subqueries +and short targets, and a multi-line one. Most layout bugs are a construct +handled by one and not the other. Wrapping is driven by three thresholds in +`SqlFormat.hs` — `inlineLengthThreshold` (60), `subqueryInlineThreshold` (100) +and `selectTargetInlineThreshold` (150) — and by the `isWrapEligible*` +predicates, which decide whether a construct has a multi-line form at all. + +`cabal test` rebuilds the test suite but **not** the executables. Run +`cabal build` before running the binary over a codebase, or you will be running +the previous one. diff --git a/app/Audit.hs b/app/Audit.hs new file mode 100644 --- /dev/null +++ b/app/Audit.hs @@ -0,0 +1,147 @@ +-- | Per-quasiquote AST diff between two versions of a Haskell file. +-- +-- Usage: hasql-th-audit +-- +-- Extracts every supported hasql-th quasiquote from both files (using the +-- same lexer/parser the formatter uses), parses each SQL block with +-- postgresql-syntax, and reports any pair whose AST differs. Designed to +-- audit a large reformat for accidental semantic regressions like the +-- `DISTINCT ON (...)` clause that a renderer bug once dropped silently. +-- +-- Exit codes: +-- 0 — all QQs in the file have semantically equivalent ASTs +-- 1 — one or more QQs differ +-- 2 — usage error or lexer error in one of the files +{-# LANGUAGE CPP #-} + +{-# LANGUAGE CPP #-} + +module Main where + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Hasql.Check.Lexer (AlexPosn (..), runAlex) +import Hasql.Check.Parser (QuasiQuote (..), parse) +import Hasql.Check.Quoter (quotersSupported) +import PostgresqlSyntax qualified as Ast +import System.Environment (getArgs) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) +import Prelude + + +-- | One per QQ pair: either an unauditable pair (input parser rejected one +-- side) or a real AST mismatch. Used to split reporting so parse-skips don't +-- count as failures. +data AuditEntry + = ParseSkip String + | AstDiff String + + +main :: IO () +main = do + args <- getArgs + case args of + [oldPath, newPath] -> do + oldBytes <- BS.readFile oldPath + newBytes <- BS.readFile newPath + case (,) <$> extractQqs oldBytes <*> extractQqs newBytes of + Left err -> do + putStrLn ("Lex error: " <> err) + exitWith (ExitFailure 2) + Right (oldQqs, newQqs) + | length oldQqs /= length newQqs -> do + putStrLn $ + "QQ count mismatch in " + <> newPath + <> ": old=" + <> show (length oldQqs) + <> " new=" + <> show (length newQqs) + exitWith (ExitFailure 1) + | otherwise -> do + let entries = classifyQqs newPath (zip oldQqs newQqs) + diffs = [m | AstDiff m <- entries] + skips = [m | ParseSkip m <- entries] + -- Parse-skips are informational (the formatter + -- itself tolerates unparseable input); emit them + -- on stderr so they don't conflate with regressions. + mapM_ (hPutStrLn stderr) skips + mapM_ putStrLn diffs + if null diffs + then pure () + else exitWith (ExitFailure 1) + _ -> do + putStrLn "Usage: hasql-th-audit " + exitWith (ExitFailure 2) + + +-- | Extract supported hasql-th QQs from a Haskell source ByteString. +extractQqs :: BS.ByteString -> Either String [QuasiQuote] +extractQqs bs = + case runAlex (BSL.fromStrict bs) parse of + Left err -> Left err + Right qqs -> Right (filter isSupportedQuoter qqs) + + +isSupportedQuoter :: QuasiQuote -> Bool +isSupportedQuoter (QuasiQuote (_, quoter) _) = quoter `elem` quotersSupported + + +-- | For each (old, new) QQ pair, parse the SQL content and classify the +-- outcome: parse-skip (one side unparseable — informational, never a +-- regression flag) or AST diff (real semantic divergence). QQ pairs where +-- both sides parse and the ASTs match are dropped (no entry). +classifyQqs :: FilePath -> [(QuasiQuote, QuasiQuote)] -> [AuditEntry] +classifyQqs filePath = mapMaybe go . zip [(1 :: Int) ..] + where + go (idx, (QuasiQuote (AlexPn _ oldLine _, _) (_, oldSql), QuasiQuote (AlexPn _ newLine _, _) (_, newSql))) = + case (parseSql oldSql, parseSql newSql) of + (Left _, _) -> + -- Old side didn't parse; can't audit semantic equivalence. + -- 'formatSql' itself tolerates unparseable input by leaving + -- it untouched, so we mirror that behaviour rather than + -- failing the build on it. + Just (ParseSkip (filePath <> ":" <> show oldLine <> " (qq #" <> show idx <> "): old SQL did not parse, skipping")) + (_, Left _) -> + Just (ParseSkip (filePath <> ":" <> show newLine <> " (qq #" <> show idx <> "): new SQL did not parse, skipping")) + (Right a, Right b) + | a == b -> Nothing + | otherwise -> + Just $ + AstDiff $ + filePath + <> ":" + <> show newLine + <> " (qq #" + <> show idx + <> "): AST DIFFERS" + <> "\n --- old (line " + <> show oldLine + <> ") ---\n" + <> T.unpack (T.strip oldSql) + <> "\n --- new (line " + <> show newLine + <> ") ---\n" + <> T.unpack (T.strip newSql) + + +-- | Parse with the Kronor extensions enabled, exactly as the quasiquoters +-- (and the formatter) do, so a quasiquote using @$f (..)@ or @$1.$field@ is +-- audited rather than skipped. +settings :: Ast.Settings +settings = + mconcat + [ Ast.nullabilityMarkers True +#ifdef KRONOR_SYNTAX + , Ast.haskellTargets True + , Ast.haskellParamFields True +#endif + ] + + +parseSql :: Text -> Either Text Ast.PreparableStmt +parseSql = Ast.parse settings . T.strip diff --git a/app/Hasql/ThFormat.hs b/app/Hasql/ThFormat.hs new file mode 100644 --- /dev/null +++ b/app/Hasql/ThFormat.hs @@ -0,0 +1,103 @@ +module Hasql.ThFormat ( + processFile, + processBytes, + ProcessResult (..), +) +where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Either (lefts, rights) +import Data.List (intercalate, sortBy) +import Data.Ord (Down (..), comparing) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Hasql.Check.Lexer (AlexPosn (..), runAlex) +import Hasql.Check.Parser (QuasiQuote (..), parse) +import Hasql.Check.Quoter (quotersSupported) +import Hasql.ThFormat.SqlFormat (formatSql) +import Prelude + + +data ProcessResult + = Unchanged + | Changed + | Error String + deriving (Show, Eq) + + +-- | Format a ByteString in memory, returning the result. The Alex lexer +-- requires a lazy ByteString so we convert at this single boundary; the rest +-- of the pipeline works on strict bytes. Returns 'Left' with a +-- newline-separated list of per-QQ errors if the formatter ever emitted +-- AST-divergent SQL; the bytes are left untouched in that case. +processBytes :: ByteString -> Either String ByteString +processBytes original = + case runAlex (BSL.fromStrict original) parse of + Left err -> Left err + Right qqs -> + let supported = reverse (filter isSupportedQuoter qqs) + results = map makeReplacement supported + errors = lefts results + replacements = rights results + in if null errors + then Right (applyReplacements original (sortReplacements replacements)) + else Left (intercalate "\n" errors) + + +processFile :: Bool -> FilePath -> IO ProcessResult +processFile checkOnly filePath = do + original <- BS.readFile filePath + case processBytes original of + Left err -> pure (Error err) + Right modified + | original == modified -> pure Unchanged + | checkOnly -> pure Changed + | otherwise -> do + BS.writeFile filePath modified + pure Changed + + +isSupportedQuoter :: QuasiQuote -> Bool +isSupportedQuoter (QuasiQuote (_, quoter) _) = quoter `elem` quotersSupported + + +data Replacement = Replacement + { rStartOffset :: Int + , rEndOffset :: Int + , rFormatted :: Text + } + deriving (Show) + + +makeReplacement :: QuasiQuote -> Either String Replacement +makeReplacement (QuasiQuote (AlexPn quoterOffset quoterLine quoterCol, quoterName) (AlexPn endOffset _ _, sqlContent)) = + let startOffset = quoterOffset + 1 + T.length quoterName + 1 + -- quoterCol is 1-based column of '[', so the base indent for SQL is (quoterCol - 1) spaces + qqIndent = quoterCol - 1 + in case formatSql qqIndent sqlContent of + Right formatted -> + Right + Replacement + { rStartOffset = startOffset + , rEndOffset = endOffset + , rFormatted = formatted + } + Left reason -> Left ("line " <> show quoterLine <> ": " <> T.unpack reason) + + +sortReplacements :: [Replacement] -> [Replacement] +sortReplacements = sortBy (comparing (Down . rStartOffset)) + + +applyReplacements :: ByteString -> [Replacement] -> ByteString +applyReplacements = foldl applyOne + where + applyOne :: ByteString -> Replacement -> ByteString + applyOne bs Replacement{rStartOffset, rEndOffset, rFormatted} = + let before = BS.take rStartOffset bs + after = BS.drop rEndOffset bs + formattedBS = TE.encodeUtf8 rFormatted + in before <> formattedBS <> after diff --git a/app/Hasql/ThFormat/SqlFormat.hs b/app/Hasql/ThFormat/SqlFormat.hs new file mode 100644 --- /dev/null +++ b/app/Hasql/ThFormat/SqlFormat.hs @@ -0,0 +1,1950 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Hasql.ThFormat.SqlFormat ( + formatSql, +) +where + +import Data.Char (toLower) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import PostgresqlSyntax qualified as Ast +import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..), align, hardline, hcat, indent, layoutPretty, nest, pretty, punctuate, vsep, (<+>)) +import Prettyprinter.Render.Text (renderStrict) +import TextBuilder (TextBuilder) +import TextBuilder qualified +import Prelude + + +-- | postgresql-syntax 0.5 wraps every comma-separated production in its own +-- newtype where 0.4 used a bare @NonEmpty@. Rather than unwrap at each of the +-- forty-odd call sites, 'toL' names "give me the elements" once and covers +-- both shapes. +class ToList a b | a -> b where + toL :: a -> [b] + + +instance ToList (NE.NonEmpty a) a where + toL = NE.toList + + +instance ToList Ast.ArrayExprList Ast.ArrayExpr where toL (Ast.ArrayExprList xs) = NE.toList xs +instance ToList Ast.Attrs Ast.Ident where toL (Ast.Attrs xs) = NE.toList xs +instance ToList Ast.ExprList Ast.AExpr where toL (Ast.ExprList xs) = NE.toList xs +instance ToList Ast.FromList Ast.TableRef where toL (Ast.FromList xs) = NE.toList xs +instance ToList Ast.FromClause Ast.TableRef where toL (Ast.FromClause xs) = toL xs +instance ToList Ast.GroupClause Ast.GroupByItem where toL (Ast.GroupClause xs) = NE.toList xs +instance ToList Ast.Indirection Ast.IndirectionEl where toL (Ast.Indirection xs) = NE.toList xs +#ifdef KRONOR_SYNTAX +instance ToList Ast.HsTargetList Ast.HsTargetEl where toL (Ast.HsTargetList xs) = NE.toList xs +#endif +instance ToList Ast.SetClauseList Ast.SetClause where toL (Ast.SetClauseList xs) = NE.toList xs +instance ToList Ast.SortClause Ast.SortBy where toL (Ast.SortClause xs) = NE.toList xs +instance ToList Ast.RowsfromList Ast.RowsfromItem where toL (Ast.RowsfromList xs) = NE.toList xs +instance ToList Ast.NameList Ast.Ident where toL (Ast.NameList xs) = NE.toList xs +instance ToList Ast.IndexParams Ast.IndexElem where toL (Ast.IndexParams xs) = NE.toList xs +instance ToList Ast.InsertColumnList Ast.InsertColumnItem where toL (Ast.InsertColumnList xs) = NE.toList xs +instance ToList Ast.TableFuncElementList Ast.TableFuncElement where toL (Ast.TableFuncElementList xs) = NE.toList xs +instance ToList Ast.TargetList Ast.TargetEl where toL (Ast.TargetList xs) = NE.toList xs +instance ToList Ast.ValuesClause Ast.ExprList where toL (Ast.ValuesClause xs) = NE.toList xs +instance ToList Ast.SetTargetList Ast.SetTarget where toL (Ast.SetTargetList xs) = NE.toList xs +instance ToList Ast.TypeList Ast.Typename where toL (Ast.TypeList xs) = NE.toList xs +instance ToList Ast.WhenClauseList Ast.WhenClause where toL (Ast.WhenClauseList xs) = NE.toList xs +instance ToList Ast.WindowClause Ast.WindowDefinition where toL (Ast.WindowClause xs) = NE.toList xs + + +-- | Indentation size: 4 spaces per level. +indentSize :: Int +indentSize = 4 + + +-- | Layout options: unbounded width so explicit `line`/`hardline` are the only +-- source of line breaks; the layout never tries to flatten or reflow. +layoutOpts :: LayoutOptions +layoutOpts = LayoutOptions Unbounded + + +-- | Format SQL content. qqIndent is the 0-based column of the quasiquote +-- opening bracket. The formatted output starts with a leading newline (so the +-- first SQL line is on its own line under the bracket) and ends with a newline +-- + qqIndent spaces (so the closing `|]` lines up under the opening bracket). +-- +-- Returns @Right formatted@ on success, @Left reason@ if the formatter +-- emitted an AST-divergent rewrite. Callers should surface @Left@ as a +-- hard failure (the file is left untouched; callers exit non-zero rather +-- than silently committing a renderer bug). Inputs the parser rejects are +-- not considered an error — they round-trip as @Right input@ since the +-- formatter never tried to rewrite them. +formatSql :: Int -> Text -> Either Text Text +formatSql qqIndent sql + | T.null (T.strip sql) = Right sql + -- Single-line queries (no newlines) are left untouched. + | not (T.isInfixOf "\n" sql) = Right sql + | otherwise = + case parseStmt (T.strip sql) of + Left _ -> Right sql + Right ast -> + let doc :: Doc () + doc = renderPreparableStmt ast + body = renderStrict (layoutPretty layoutOpts (indent (qqIndent + indentSize) doc)) + qqIndentText = T.replicate qqIndent " " + formatted = "\n" <> body <> "\n" <> qqIndentText + in -- Round-trip safety: compare the re-parsed AST to the original. + -- Parse-only equivalence isn't enough — the renderer could drop + -- or alter a clause and still produce valid SQL (see the + -- `DistinctTargeting` regression that motivated this check). + case parseStmt (T.strip formatted) of + Right ast' | ast' == ast -> Right formatted + Right _ -> + Left "AST mismatch: formatter rendered semantically-different SQL (renderer bug)" + Left err -> + Left ("AST mismatch: formatter output did not re-parse (" <> err <> ")") + + +-- | The formatter reads and writes the SQL that lives inside a hasql-th +-- quasiquote, so every Kronor extension has to survive the round trip: +-- @$1 :: int8?@ nullability markers, @$f (..)@ \/ @$R {..}@ Haskell targets +-- and @$1.$field@ Haskell param fields. Both the parser and the renderer run +-- with all three enabled, unlike the quasiquoter itself, which lowers and +-- erases them on the way to Postgres. +settings :: Ast.Settings +settings = + mconcat + [ Ast.nullabilityMarkers True +#ifdef KRONOR_SYNTAX + , Ast.haskellTargets True + , Ast.haskellParamFields True +#endif + ] + + +-- | Parse a statement with the extension syntax enabled. +parseStmt :: Text -> Either Text Ast.PreparableStmt +parseStmt = Ast.parse settings + + +-- | Render any AST node with postgresql-syntax's own renderer, extensions on. +render :: Ast.IsAst a => a -> TextBuilder +render = Ast.toTextBuilder settings + + +-- | 'Ast.VerbalExprBinOp' renders without its @NOT@, which lives in the +-- enclosing 'Ast.VerbalExprBinOpAExpr'. Mirrors postgresql-syntax's own +-- rendering of that node. +verbalExprBinOp :: Bool -> Ast.VerbalExprBinOp -> TextBuilder +verbalExprBinOp negated op = (if negated then "NOT " else mempty) <> render op + + +-- | Same story for 'Ast.AExprReversableOp': the negation is external to the +-- type, and each alternative places it differently (@IS NOT NULL@ but +-- @NOT BETWEEN@). Mirrors postgresql-syntax's @renderAExprReversableOp@. +aExprReversableOp :: Bool -> Ast.AExprReversableOp -> TextBuilder +aExprReversableOp negated = \case + Ast.NullAExprReversableOp -> isNot <> "NULL" + Ast.TrueAExprReversableOp -> isNot <> "TRUE" + Ast.FalseAExprReversableOp -> isNot <> "FALSE" + Ast.UnknownAExprReversableOp -> isNot <> "UNKNOWN" + Ast.DistinctFromAExprReversableOp a -> isNot <> "DISTINCT FROM " <> render a + Ast.OfAExprReversableOp a -> isNot <> "OF (" <> render a <> ")" + Ast.BetweenAExprReversableOp asymmetric a b -> + notPfx <> (if asymmetric then "BETWEEN ASYMMETRIC " else "BETWEEN ") <> render a <> " AND " <> render b + Ast.BetweenSymmetricAExprReversableOp a b -> + notPfx <> "BETWEEN SYMMETRIC " <> render a <> " AND " <> render b + Ast.InAExprReversableOp a -> notPfx <> "IN " <> render a + Ast.DocumentAExprReversableOp -> isNot <> "DOCUMENT" + where + isNot = if negated then "IS NOT " else "IS " + notPfx = if negated then "NOT " else mempty + + +-- | 0.5 models @ROW ()@ as its own 'Ast.ExplicitRow' type where 0.4 used a +-- @Maybe@ of the expression list. The formatter still branches on the @Maybe@. +explicitRowExprs :: Ast.ExplicitRow -> Maybe Ast.ExprList +explicitRowExprs = \case + Ast.EmptyExplicitRow -> Nothing + Ast.ExprListExplicitRow xs -> Just xs + + +-- | JSON/JSONB access operators rendered without surrounding spaces, since +-- they act like field accessors. +jsonOps :: [Text] +jsonOps = ["->", "->>", "#>", "#>>"] + + +-- | Render via postgresql-syntax's renderer as a 'Doc'. Output is lowercased +-- and @:: @ typecast spacing is tightened to @::@, while content inside +-- single-quoted string literals (@'...'@) and double-quoted identifiers +-- (@"..."@) is preserved verbatim. +inline :: (a -> TextBuilder) -> a -> Doc ann +inline f = pretty . inlineText f + + +-- | Same as 'inline' but stays at the Text layer. Useful when we need to do +-- a string comparison on the rendered output (e.g. detecting a JSON access +-- operator) before lifting it into a 'Doc'. +inlineText :: (a -> TextBuilder) -> a -> Text +inlineText f = inlineNormalize . TextBuilder.toText . f + + +-- | Lowercase keywords and tighten @ :: @ to @::@ in a single pass, while +-- preserving the contents of single-quoted string literals and double-quoted +-- identifiers verbatim. Standard SQL doubled-quote escapes (@''@ and @""@) +-- are recognised so the scanner stays inside the literal until the real +-- closing quote. +inlineNormalize :: Text -> Text +inlineNormalize = T.pack . goCode . T.unpack + where + goCode :: String -> String + goCode [] = [] + goCode ('\'' : rest) = '\'' : goString '\'' rest + goCode ('"' : rest) = '"' : goString '"' rest + goCode (' ' : ':' : ':' : ' ' : rest) = "::" ++ goCode rest + goCode (c : rest) = toLower c : goCode rest + + goString :: Char -> String -> String + goString _ [] = [] + -- Doubled-quote escape: stay inside the literal. + goString q (c1 : c2 : rest) | c1 == q && c2 == q = c1 : c2 : goString q rest + goString q (c : rest) + | c == q = c : goCode rest + | otherwise = c : goString q rest + + +---------------------------------------------------------------------- +-- Expression / leaf renderers (return 'Doc ann' — inline single-line by +-- construction; structural renderers below use the same type for +-- multi-line layouts). +---------------------------------------------------------------------- + +renderExpr :: Ast.AExpr -> Doc ann +renderExpr = \case + Ast.TypecastAExpr expr tn -> + renderExpr expr <> "::" <> renderTypename tn + Ast.AndAExpr left right -> + renderExpr left <+> "and" <+> renderExpr right + Ast.OrAExpr left right -> + renderExpr left <+> "or" <+> renderExpr right + Ast.NotAExpr expr -> + "not" <+> renderExpr expr + Ast.CExprAExpr cexpr -> renderCExpr cexpr + Ast.SymbolicBinOpAExpr left op right -> + let opText = inlineText render op + opDoc = pretty opText + in if opText `elem` jsonOps + then renderExpr left <> opDoc <> renderExpr right + else renderExpr left <+> opDoc <+> renderExpr right + Ast.PlusAExpr expr -> "+" <> renderExpr expr + Ast.MinusAExpr expr -> "-" <> renderExpr expr + Ast.ReversableOpAExpr expr negated op -> + renderExpr expr <+> renderReversableOp negated op + Ast.IsnullAExpr expr -> renderExpr expr <+> "isnull" + Ast.NotnullAExpr expr -> renderExpr expr <+> "notnull" + Ast.CollateAExpr expr name -> renderExpr expr <+> "collate" <+> inline render name + Ast.AtTimeZoneAExpr expr tz -> renderExpr expr <+> "at time zone" <+> renderExpr tz + Ast.PrefixQualOpAExpr op expr -> inline render op <+> renderExpr expr + Ast.VerbalExprBinOpAExpr left negated op right mEscape -> + renderExpr left + <+> inline (verbalExprBinOp negated) op + <+> renderExpr right + <> maybe mempty (\e -> " escape" <+> renderExpr e) mEscape + Ast.SubqueryAExpr expr op subType subq -> + renderExpr expr + <+> inline render op + <+> inline render subType + <> either + ((" " <>) . renderSelectWithParensMaybeWrap) + (\e -> "(" <> renderExprMaybeWrap e <> ")") + subq + Ast.DefaultAExpr -> "default" + Ast.UniqueAExpr swp -> "unique" <+> renderSelectWithParensMaybeWrap swp + Ast.OverlapsAExpr r1 r2 -> inline render r1 <+> "overlaps" <+> inline render r2 + + +renderCExpr :: Ast.CExpr -> Doc ann +renderCExpr = \case + Ast.ParamCExpr n mInd -> + "$" <> pretty n <> maybe mempty renderIndirection mInd + Ast.InParensCExpr expr mInd -> + "(" <> renderExpr expr <> ")" <> maybe mempty renderIndirection mInd + Ast.FuncCExpr fe -> renderFuncExpr fe + Ast.ColumnrefCExpr cr -> inline render cr + Ast.AexprConstCExpr ac -> inline render ac + Ast.SelectWithParensCExpr swp mInd -> + renderSelectWithParensMaybeWrap swp <> maybe mempty renderIndirection mInd + Ast.ExistsCExpr swp -> "exists" <+> renderSelectWithParensMaybeWrap swp + Ast.CaseCExpr caseExpr -> renderCaseExpr caseExpr + Ast.ArrayCExpr arr -> "array" <> either renderSelectWithParensMaybeWrap renderArrayExpr arr + Ast.ExplicitRowCExpr row -> + "row(" <> maybe mempty (commaJoin . map renderExpr . toL) (explicitRowExprs row) <> ")" + Ast.ImplicitRowCExpr (Ast.ImplicitRow exprs expr) -> + "(" <> commaJoin (map renderExpr (toL exprs) ++ [renderExpr expr]) <> ")" + other -> inline render other + + +-- | Comma-and-space-separated concatenation of inline 'Doc's. Used wherever +-- the previous Text-based renderer used 'T.intercalate ", "'. +commaJoin :: [Doc ann] -> Doc ann +commaJoin = hcat . punctuate ", " + + +renderArrayExpr :: Ast.ArrayExpr -> Doc ann +renderArrayExpr = \case + Ast.ExprListArrayExpr exprs -> + "[" <> commaJoin (map renderExpr (toL exprs)) <> "]" + Ast.ArrayExprListArrayExpr nested -> + "[" <> commaJoin (map renderArrayExpr (toL nested)) <> "]" + Ast.EmptyArrayExpr -> "[]" + + +renderCaseExpr :: Ast.CaseExpr -> Doc ann +renderCaseExpr (Ast.CaseExpr mArg whenClauses mDefault) = + "case" + <> maybe mempty (\arg -> " " <> renderExpr arg) mArg + <> mconcat [" " <> renderWhenClause w | w <- toL whenClauses] + <> maybe mempty (\d -> " else" <+> renderExpr d) mDefault + <+> "end" + + +renderWhenClause :: Ast.WhenClause -> Doc ann +renderWhenClause (Ast.WhenClause cond result) = + "when" <+> renderExpr cond <+> "then" <+> renderExpr result + + +renderIndirection :: Ast.Indirection -> Doc ann +renderIndirection = mconcat . map renderIndirectionEl . toL + + +renderIndirectionEl :: Ast.IndirectionEl -> Doc ann +renderIndirectionEl = \case + Ast.AttrNameIndirectionEl ident -> "." <> renderIdent ident + Ast.AllIndirectionEl -> ".*" + Ast.ExprIndirectionEl expr -> "[" <> renderExpr expr <> "]" + Ast.SliceIndirectionEl mFrom mTo -> + "[" <> maybe mempty renderExpr mFrom <> ":" <> maybe mempty renderExpr mTo <> "]" +#ifdef KRONOR_SYNTAX + -- Kronor extension: a Haskell field selector on a @$n@ placeholder. + Ast.HsAttrNameIndirectionEl t -> ".$" <> pretty t +#endif + + +renderIdent :: Ast.Ident -> Doc ann +renderIdent = \case + Ast.QuotedIdent t -> "\"" <> pretty t <> "\"" + Ast.UnquotedIdent t -> pretty t + + +renderFuncExpr :: Ast.FuncExpr -> Doc ann +renderFuncExpr = \case + Ast.ApplicationFuncExpr app mWithin mFilter mOver -> + renderFuncApplication app + <> maybe mempty (\w -> " " <> inline render w) mWithin + <> maybe mempty (\f -> " filter (where" <+> renderExpr f <> ")") mFilter + <> maybe mempty (\o -> " " <> inline render o) mOver + Ast.SubexprFuncExpr sub -> renderFuncExprCommonSubexpr sub + + +renderFuncApplication :: Ast.FuncApplication -> Doc ann +renderFuncApplication (Ast.FuncApplication name mParams) = + inline render name <> "(" <> maybe mempty renderFuncAppParams mParams <> ")" + + +-- | Threshold (number of positional arguments) at which a function call's +-- argument list is broken onto its own line per argument. A call with +-- fewer args than this threshold renders inline; one with this many or more +-- wraps. Currently set to 2, so single-arg calls (e.g. @count(*)@, +-- @md5(x)@, @unnest(arr)@) stay inline. +funcWrapThreshold :: Int +funcWrapThreshold = 2 + + +-- | Number of positional arguments in a function application (variadic args +-- count as one each, star/none count as zero). +funcAppArgCount :: Ast.FuncApplication -> Int +funcAppArgCount (Ast.FuncApplication _ mParams) = case mParams of + Nothing -> 0 + Just (Ast.NormalFuncApplicationParams _ args _) -> length (toL args) + Just (Ast.VariadicFuncApplicationParams mArgs _ _) -> maybe 0 (length . toL) mArgs + 1 + Just Ast.StarFuncApplicationParams -> 0 + + +-- | Multi-line rendering of a function application using the leading-comma +-- block-list layout that's standard elsewhere in this formatter: +-- +-- @ +-- fn( +-- arg1 +-- , arg2 +-- , arg3 +-- ) +-- @ +-- +-- The args sit at @outer + indentSize + 2@ (first) and @outer + indentSize@ +-- (`, ` prefix on subsequent), where @outer@ is the surrounding nesting +-- level. The closing paren returns to @outer@; this can put it visually +-- left of the function name when the function call is itself indented +-- (e.g. as a leading-comma item), but it keeps the layout predictable. +renderFuncApplicationWrapped :: Ast.FuncApplication -> Doc ann +renderFuncApplicationWrapped (Ast.FuncApplication name mParams) = + inline render name + <> "(" + <> nest indentSize (maybe mempty wrappedBody mParams) + <> hardline + <> ")" + where + wrappedBody params = case params of + Ast.NormalFuncApplicationParams mDistinct args mSort -> + let argList = toL args + argDocs = map renderFuncArgExprMaybeWrap argList + prefix = maybe mempty (\b -> if b then "distinct " else "all ") mDistinct + rows = + if looksLikeKeyValuePairs argList + then renderArgPairRows argDocs + else renderArgRows argDocs + sortDoc = maybe mempty (\sc -> hardline <> inline render sc) mSort + in prefix <> rows <> sortDoc + Ast.VariadicFuncApplicationParams mArgs varArg mSort -> + let regular = maybe [] (map renderFuncArgExprMaybeWrap . toL) mArgs + variadic = "variadic " <> renderFuncArgExprMaybeWrap varArg + rows = renderArgRows (regular ++ [variadic]) + sortDoc = maybe mempty (\sc -> hardline <> inline render sc) mSort + in rows <> sortDoc + Ast.StarFuncApplicationParams -> hardline <> "*" + + +-- | First arg: hardline, then 2 extra spaces (so arg sits at col + 6), then +-- the arg. Subsequent args: hardline, then @, @ (so the comma sits at col + +-- 4 and the arg content also at col + 6). Used by every wrapped renderer +-- that emits a leading-comma block-list. +renderArgRows :: [Doc ann] -> Doc ann +renderArgRows = \case + [] -> mempty + (x : xs) -> + (hardline <> " " <> x) + <> mconcat [hardline <> ", " <> r | r <- xs] + + +-- | Pair layout for key/value-shaped arg lists. Each pair lives on its own +-- line (key + inline @, @ + value). The first pair uses the same " " row +-- prefix as 'renderArgRows'; subsequent pairs use the leading @, @ row +-- separator. Caller guarantees an even-length input. +renderArgPairRows :: [Doc ann] -> Doc ann +renderArgPairRows = goFirst . pairs + where + pairs (a : b : rest) = (a, b) : pairs rest + pairs _ = [] + + goFirst [] = mempty + goFirst ((k, v) : rest) = + (hardline <> " " <> k <> ", " <> v) + <> mconcat [hardline <> ", " <> k' <> ", " <> v' | (k', v') <- rest] + + +-- | If an expression is a top-level function call (optionally wrapped in any +-- number of chained typecasts), return the function application along with a +-- function that re-attaches the typecasts to a Doc, preserving their order. +-- Used to detect "wrap-eligible" expressions in select target lists. +topLevelFuncApp :: Ast.AExpr -> Maybe (Ast.FuncApplication, Doc ann -> Doc ann) +topLevelFuncApp = \case + Ast.TypecastAExpr inner tn + | Just (app, attach) <- topLevelFuncApp inner -> + Just (app, \d -> attach d <> "::" <> renderTypename tn) + Ast.CExprAExpr (Ast.FuncCExpr (Ast.ApplicationFuncExpr app Nothing Nothing Nothing)) -> + Just (app, id) + _ -> Nothing + + +-- | Heuristic: an arg list "looks like" alternating key/value pairs when it +-- has at least 4 args, an even count, and every even-indexed argument +-- (positions 0, 2, 4, ...) is a string-literal expression. This catches +-- @jsonb_build_object('k1', v1, 'k2', v2, ...)@ and friends without naming +-- specific functions, so the layout adapts to anything with the same shape. +looksLikeKeyValuePairs :: [Ast.FuncArgExpr] -> Bool +looksLikeKeyValuePairs args = + let n = length args + in even n && n >= 4 && all isLiteralKey (zip [0 :: Int ..] args) + where + isLiteralKey (i, arg) + | even i = case arg of + Ast.ExprFuncArgExpr e -> isStringLiteral e + _ -> False + | otherwise = True + + isStringLiteral :: Ast.AExpr -> Bool + isStringLiteral = \case + Ast.CExprAExpr (Ast.AexprConstCExpr (Ast.SAexprConst _)) -> True + _ -> False + + +-- | An expression is "wrap-eligible" when it has a structural shape the +-- multi-line renderers know how to lay out: a function call (optionally +-- under chained typecasts), an @array[...]@ literal whose elements +-- themselves contain wrap-eligible content, a @row(...)@ / @(a, b, c)@ +-- tuple, a parenthesized expression, a @case@ expression, or one of the +-- SQL keyword-form pseudo-functions (@coalesce@, @cast@, @nullif@, +-- @greatest@, @least@, @position@, @substring@, @trim@, @overlay@, +-- @treat@). The decision to actually wrap (vs render inline) is made by +-- 'renderFuncArgExprMaybeWrap' / 'renderExprMaybeWrap' based on the +-- inline rendered length. +isWrapEligibleExpr :: Ast.AExpr -> Bool +isWrapEligibleExpr = \case + Ast.TypecastAExpr inner _ -> isWrapEligibleExpr inner + Ast.CExprAExpr cexpr -> isWrapEligibleCExpr cexpr + _ -> False + + +isWrapEligibleCExpr :: Ast.CExpr -> Bool +isWrapEligibleCExpr = \case + Ast.FuncCExpr (Ast.ApplicationFuncExpr _ Nothing Nothing Nothing) -> True + Ast.FuncCExpr (Ast.SubexprFuncExpr sub) -> isWrapEligibleSubexpr sub + Ast.ArrayCExpr (Right arr) -> isWrapEligibleArray arr + Ast.InParensCExpr inner _ -> isWrapEligibleExpr inner + Ast.ExplicitRowCExpr row -> + any isWrapEligibleExpr (maybe [] toL (explicitRowExprs row)) + Ast.ImplicitRowCExpr (Ast.ImplicitRow exprs expr) -> + any isWrapEligibleExpr (toL exprs) || isWrapEligibleExpr expr + -- @case ... when ... end@ is always wrap-eligible: even when the + -- WHEN/THEN bodies are simple, the multi-line layout reads much + -- better once the inline form gets long (e.g. multi-clause SET RHS + -- assignments). The length gate decides when to actually wrap. + Ast.CaseCExpr _ -> True + _ -> False + + +-- | An array literal is wrap-eligible when any of its elements is itself +-- wrap-eligible (so a long @array[fn(...)]@ expands to multi-line by +-- propagating the wrap into the contained function call). +isWrapEligibleArray :: Ast.ArrayExpr -> Bool +isWrapEligibleArray = \case + Ast.ExprListArrayExpr exprs -> any isWrapEligibleExpr (toL exprs) + Ast.ArrayExprListArrayExpr nested -> any isWrapEligibleArray (toL nested) + Ast.EmptyArrayExpr -> False + + +-- | The SQL keyword-form pseudo-functions (@coalesce@, @cast@, @nullif@, +-- @greatest@, @least@, @position@, @substring@, @trim@, @overlay@, +-- @treat@, @extract@) are always wrap-eligible — when their inline form +-- gets too long, the wrapped layout puts each argument on its own line +-- using 'renderArgRows'. +isWrapEligibleSubexpr :: Ast.FuncExprCommonSubexpr -> Bool +isWrapEligibleSubexpr = \case + Ast.CoalesceFuncExprCommonSubexpr _ -> True + Ast.CastFuncExprCommonSubexpr _ _ -> True + Ast.NullIfFuncExprCommonSubexpr _ _ -> True + Ast.GreatestFuncExprCommonSubexpr _ -> True + Ast.LeastFuncExprCommonSubexpr _ -> True + Ast.PositionFuncExprCommonSubexpr _ -> True + Ast.SubstringFuncExprCommonSubexpr _ -> True + Ast.TrimFuncExprCommonSubexpr _ _ -> True + Ast.OverlayFuncExprCommonSubexpr _ -> True + Ast.TreatFuncExprCommonSubexpr _ _ -> True + Ast.ExtractFuncExprCommonSubexpr _ -> True + _ -> False + + +-- | Inline-length threshold above which a wrap-eligible sub-expression +-- switches from inline to multi-line rendering inside an already-wrapped +-- function call. Short calls like @jsonb_build_object('a', $1)@ stay on +-- one line; long ones like +-- @array_agg(mk_payload(caller => '...', payload => ...))::jsonb[]@ break +-- onto multiple lines, recursing into their own arguments. +inlineLengthThreshold :: Int +inlineLengthThreshold = 60 + + +-- | Wrap-aware variant of 'renderFuncArgExpr'. Used inside +-- 'renderFuncApplicationWrapped' so that nested function-call arguments +-- expand to multi-line when their inline form exceeds +-- 'inlineLengthThreshold', and stay inline otherwise. Pair-shaped +-- sub-calls (e.g. nested @jsonb_build_object(...)@) always wrap when +-- they appear inside an already-wrapped parent — keeping the visual +-- consistency of the @(key, value)@ pairs even when the inner call's +-- inline form would fit under the threshold. +renderFuncArgExprMaybeWrap :: Ast.FuncArgExpr -> Doc ann +renderFuncArgExprMaybeWrap arg = + let inlineDoc = renderFuncArgExpr arg + inlineLen = T.length (renderToText inlineDoc) + forceWrap = isPairShapedArg arg + in if (inlineLen > inlineLengthThreshold || forceWrap) && argIsWrapEligible arg + then renderFuncArgExprWrapped arg + else inlineDoc + where + argIsWrapEligible :: Ast.FuncArgExpr -> Bool + argIsWrapEligible = \case + Ast.ExprFuncArgExpr e -> isWrapEligibleExpr e + Ast.ColonEqualsFuncArgExpr _ e -> isWrapEligibleExpr e + Ast.EqualsGreaterFuncArgExpr _ e -> isWrapEligibleExpr e + + isPairShapedArg :: Ast.FuncArgExpr -> Bool + isPairShapedArg = \case + Ast.ExprFuncArgExpr e -> hasPairShapedCall e + Ast.ColonEqualsFuncArgExpr _ e -> hasPairShapedCall e + Ast.EqualsGreaterFuncArgExpr _ e -> hasPairShapedCall e + + +-- | True when the expression is a function call (optionally under chained +-- typecasts) whose argument list satisfies 'looksLikeKeyValuePairs'. Used +-- to force-wrap nested @jsonb_build_object@-shaped values so a wrapped +-- pair-grouped parent doesn't have inline pair-grouped children +-- (visually inconsistent). +hasPairShapedCall :: Ast.AExpr -> Bool +hasPairShapedCall = \case + Ast.TypecastAExpr inner _ -> hasPairShapedCall inner + Ast.CExprAExpr (Ast.FuncCExpr (Ast.ApplicationFuncExpr (Ast.FuncApplication _ (Just (Ast.NormalFuncApplicationParams _ args _))) Nothing Nothing Nothing)) -> + looksLikeKeyValuePairs (toL args) + _ -> False + + +-- | Render a wrap-eligible 'FuncArgExpr' multi-line. The named-arg prefix +-- (@name := @ / @name => @) stays on the same line as the function name and +-- @(@; only the function body wraps. +renderFuncArgExprWrapped :: Ast.FuncArgExpr -> Doc ann +renderFuncArgExprWrapped = \case + Ast.ExprFuncArgExpr e -> renderExprWrapped e + Ast.ColonEqualsFuncArgExpr ident e -> inline render ident <> " := " <> renderExprWrapped e + Ast.EqualsGreaterFuncArgExpr ident e -> inline render ident <> " => " <> renderExprWrapped e + + +-- | Render a wrap-eligible expression multi-line: peel chained typecasts, +-- then dispatch the underlying function application through +-- 'renderFuncApplicationWrapped' (or @array[...]@ literals through +-- 'renderArrayExprWrapped'). Recursion into deeper levels happens via +-- those wrappers calling 'renderFuncArgExprMaybeWrap' / +-- 'renderExprMaybeWrap' on their own elements. +renderExprWrapped :: Ast.AExpr -> Doc ann +renderExprWrapped = \case + Ast.TypecastAExpr inner tn -> + renderExprWrapped inner <> "::" <> renderTypename tn + Ast.CExprAExpr (Ast.FuncCExpr (Ast.ApplicationFuncExpr app Nothing Nothing Nothing)) -> + renderFuncApplicationWrapped app + Ast.CExprAExpr (Ast.FuncCExpr (Ast.SubexprFuncExpr sub)) -> + renderFuncExprCommonSubexprWrapped sub + Ast.CExprAExpr (Ast.ArrayCExpr (Right arr)) -> + "array" <> renderArrayExprWrapped arr + Ast.CExprAExpr (Ast.InParensCExpr inner mInd) -> + renderInParensWrapped inner mInd + Ast.CExprAExpr (Ast.ExplicitRowCExpr row) -> + renderExplicitRowWrapped (explicitRowExprs row) + Ast.CExprAExpr (Ast.ImplicitRowCExpr row) -> + renderImplicitRowWrapped row + Ast.CExprAExpr (Ast.CaseCExpr caseExpr) -> + renderCaseExprWrapped caseExpr + other -> renderExpr other + + +-- | Multi-line @(expr)@: open paren on the current line, inner expression +-- nested one level deeper on its own block, closing paren back at the +-- caller's column. The optional indirection (@.field@, @[index]@) appends +-- after the closing paren on the same line. +-- +-- When the inner expression is a @case@ (with optional surrounding parens +-- / typecasts) we force-wrap it via 'renderExprWrapped' regardless of its +-- inline length, matching the top-level @case@-always-wraps rule used in +-- 'renderExprDoc' — otherwise a short CASE inside a wrapped parens would +-- collapse onto a single line while its enclosing parens stay multi-line. +-- +-- When the inner is a direct @CaseCExpr@ (with no indirection) we emit +-- the compact form @(case ... end)@ — the @case@ keyword on the same +-- line as @(@, and @end)@ together at the close. The @case@/@end@ +-- keywords already give the block clear visual structure; opening/closing +-- parens on their own lines are redundant ceremony. +renderInParensWrapped :: Ast.AExpr -> Maybe Ast.Indirection -> Doc ann +renderInParensWrapped expr mInd = + case (mInd, expr) of + (Nothing, Ast.CExprAExpr (Ast.CaseCExpr c)) -> + -- Compact form: `(case ... end)`. We use 'align' to capture + -- the actual column at @(@ so the case body indents relative + -- to that column regardless of how the caller positioned us + -- mid-line (e.g. via explicit @firstPad@ in a SELECT block + -- list, or via the @" "@ prefix from 'renderArgRows' inside + -- a wrapped function call). Body lands at @(-col + + -- indentSize@; @end@ lines up with @(@; @)@ follows @end@ on + -- the same line. + align ("(" <> renderCaseExprWrapped c <> ")") + _ -> + let body = + if isTopLevelCase expr + then renderExprWrapped expr + else renderExprMaybeWrap expr + in "(" + <> nest indentSize (hardline <> body) + <> hardline + <> ")" + <> maybe mempty renderIndirection mInd + + +-- | Multi-line @row(...)@ / @(a, b, c)@: same leading-comma block-list +-- as a wrapped function call. +renderExplicitRowWrapped :: Maybe Ast.ExprList -> Doc ann +renderExplicitRowWrapped mExprs = + let argDocs = maybe [] (map renderExprMaybeWrap . toL) mExprs + in "row(" <> nest indentSize (renderArgRows argDocs) <> hardline <> ")" + + +renderImplicitRowWrapped :: Ast.ImplicitRow -> Doc ann +renderImplicitRowWrapped (Ast.ImplicitRow exprs expr) = + let argDocs = map renderExprMaybeWrap (toL exprs) ++ [renderExprMaybeWrap expr] + in "(" <> nest indentSize (renderArgRows argDocs) <> hardline <> ")" + + +-- | Multi-line @case@ expression: each @when ... then ...@ on its own line, +-- @else@ and @end@ on their own lines too. Matches the layout convention +-- used by hand-written SQL. +-- +-- Inside a wrapped CASE, any @(select ...)@ subquery in a THEN or ELSE +-- body force-wraps as a multi-line SELECT block (regardless of length) +-- via 'renderExprForceSubqueryWrap'. The convention is that once we've +-- decided the CASE itself reads better multi-line, an inline +-- @(select x from t)@ inside one of its arms looks visually inconsistent +-- next to the multi-line WHEN/ELSE structure — so we expand it too. +renderCaseExprWrapped :: Ast.CaseExpr -> Doc ann +renderCaseExprWrapped (Ast.CaseExpr mArg whenClauses mDefault) = + "case" + <> maybe mempty (\arg -> " " <> renderExpr arg) mArg + <> nest + indentSize + ( mconcat [hardline <> renderWhenClauseWrapped w | w <- toL whenClauses] + <> maybe mempty (\d -> hardline <> "else" <+> renderExprForceSubqueryWrap d) mDefault + ) + <> hardline + <> "end" + + +renderWhenClauseWrapped :: Ast.WhenClause -> Doc ann +renderWhenClauseWrapped (Ast.WhenClause cond result) = + "when" <+> renderExprMaybeWrap cond <+> "then" <+> renderExprForceSubqueryWrap result + + +-- | Like 'renderExprMaybeWrap' but force-wraps any directly-applied +-- @(select ...)@ subquery (with optional chained typecast) regardless of +-- inline length. Used inside wrapped CASE arms; falls through to +-- 'renderExprMaybeWrap' for everything that isn't a parenthesized SELECT. +renderExprForceSubqueryWrap :: Ast.AExpr -> Doc ann +renderExprForceSubqueryWrap = \case + Ast.CExprAExpr (Ast.SelectWithParensCExpr swp mInd) -> + renderSelectWithParensWrapped swp <> maybe mempty renderIndirection mInd + Ast.TypecastAExpr inner tn -> + renderExprForceSubqueryWrap inner <> "::" <> renderTypename tn + e -> renderExprMaybeWrap e + + +-- | Multi-line keyword-form pseudo-function. Each constructor knows the +-- syntactic separator between its operands (commas for @coalesce@, +-- @greatest@, @least@; @ as @ for @cast@/@treat@; @ from @ for @extract@, +-- @substring@, @trim@; @ in @ for @position@; @ placing @ /@ from @/@ for @ +-- for @overlay@), and uses 'renderArgRows' for the comma-separated cases. +renderFuncExprCommonSubexprWrapped :: Ast.FuncExprCommonSubexpr -> Doc ann +renderFuncExprCommonSubexprWrapped = \case + Ast.CoalesceFuncExprCommonSubexpr exprs -> + let argDocs = map renderExprMaybeWrap (toL exprs) + in "coalesce(" <> nest indentSize (renderArgRows argDocs) <> hardline <> ")" + Ast.GreatestFuncExprCommonSubexpr exprs -> + let argDocs = map renderExprMaybeWrap (toL exprs) + in "greatest(" <> nest indentSize (renderArgRows argDocs) <> hardline <> ")" + Ast.LeastFuncExprCommonSubexpr exprs -> + let argDocs = map renderExprMaybeWrap (toL exprs) + in "least(" <> nest indentSize (renderArgRows argDocs) <> hardline <> ")" + Ast.NullIfFuncExprCommonSubexpr e1 e2 -> + let argDocs = [renderExprMaybeWrap e1, renderExprMaybeWrap e2] + in "nullif(" <> nest indentSize (renderArgRows argDocs) <> hardline <> ")" + Ast.CastFuncExprCommonSubexpr expr tn -> + "cast(" + <> nest indentSize (hardline <> renderExprMaybeWrap expr <+> "as" <+> renderTypename tn) + <> hardline + <> ")" + Ast.TreatFuncExprCommonSubexpr expr tn -> + "treat(" + <> nest indentSize (hardline <> renderExprMaybeWrap expr <+> "as" <+> renderTypename tn) + <> hardline + <> ")" + -- Keyword-form functions whose argument structure isn't a simple + -- comma-separated list. We render them inline; if length is the + -- problem we fall back to the inline renderer (which is short + -- compared to other cases). + other -> renderFuncExprCommonSubexpr other + + +-- | Wrap-aware variant for an 'AExpr'. Renders inline first; if the inline +-- form exceeds 'inlineLengthThreshold' AND the expression is structurally +-- wrap-eligible, switches to 'renderExprWrapped'. Pair-shaped sub-calls +-- (nested @jsonb_build_object@-style) force-wrap regardless of length so a +-- wrapped pair-grouped parent doesn't have inline pair-grouped children. +renderExprMaybeWrap :: Ast.AExpr -> Doc ann +renderExprMaybeWrap e = + let inlineDoc = renderExpr e + inlineLen = T.length (renderToText inlineDoc) + forceWrap = hasPairShapedCall e + in if (inlineLen > inlineLengthThreshold || forceWrap) && isWrapEligibleExpr e + then renderExprWrapped e + else inlineDoc + + +-- | Multi-line render of an @array[...]@ literal: open bracket on the +-- current line, elements laid out with the same leading-comma block-list +-- as 'renderFuncApplicationWrapped', closing bracket back at the caller's +-- column. Each element is rendered through 'renderExprMaybeWrap', so a +-- long inner function call wraps recursively. +renderArrayExprWrapped :: Ast.ArrayExpr -> Doc ann +renderArrayExprWrapped = \case + Ast.ExprListArrayExpr exprs -> + let argDocs = map renderExprMaybeWrap (toL exprs) + in "[" <> nest indentSize (renderArgRows argDocs) <> hardline <> "]" + Ast.ArrayExprListArrayExpr nested -> + let argDocs = map (\a -> "array" <> renderArrayExprWrapped a) (toL nested) + in "[" <> nest indentSize (renderArgRows argDocs) <> hardline <> "]" + Ast.EmptyArrayExpr -> "[]" + + +renderFuncAppParams :: Ast.FuncApplicationParams -> Doc ann +renderFuncAppParams = \case + Ast.NormalFuncApplicationParams mDistinct args mSort -> + maybe mempty (\b -> if b then "distinct " else "all ") mDistinct + <> commaJoin (map renderFuncArgExpr (toL args)) + <> maybe mempty (\sc -> " " <> inline render sc) mSort + Ast.VariadicFuncApplicationParams mArgs varArg mSort -> + maybe mempty (\args -> commaJoin (map renderFuncArgExpr (toL args)) <> ", ") mArgs + <> "variadic " + <> renderFuncArgExpr varArg + <> maybe mempty (\sc -> " " <> inline render sc) mSort + Ast.StarFuncApplicationParams -> "*" + + +renderFuncArgExpr :: Ast.FuncArgExpr -> Doc ann +renderFuncArgExpr = \case + Ast.ExprFuncArgExpr e -> renderExpr e + Ast.ColonEqualsFuncArgExpr ident e -> inline render ident <> " := " <> renderExpr e + Ast.EqualsGreaterFuncArgExpr ident e -> inline render ident <> " => " <> renderExpr e + + +renderFuncExprCommonSubexpr :: Ast.FuncExprCommonSubexpr -> Doc ann +renderFuncExprCommonSubexpr = \case + Ast.CoalesceFuncExprCommonSubexpr exprs -> + "coalesce(" <> commaJoin (map renderExpr (toL exprs)) <> ")" + Ast.CastFuncExprCommonSubexpr expr tn -> + "cast(" <> renderExpr expr <+> "as" <+> renderTypename tn <> ")" + Ast.NullIfFuncExprCommonSubexpr e1 e2 -> + "nullif(" <> renderExpr e1 <> ", " <> renderExpr e2 <> ")" + Ast.GreatestFuncExprCommonSubexpr exprs -> + "greatest(" <> commaJoin (map renderExpr (toL exprs)) <> ")" + Ast.LeastFuncExprCommonSubexpr exprs -> + "least(" <> commaJoin (map renderExpr (toL exprs)) <> ")" + Ast.ExtractFuncExprCommonSubexpr mList -> + "extract(" <> maybe mempty renderExtractList mList <> ")" + Ast.TreatFuncExprCommonSubexpr expr tn -> + "treat(" <> renderExpr expr <+> "as" <+> renderTypename tn <> ")" + Ast.PositionFuncExprCommonSubexpr mList -> + "position(" <> maybe mempty renderPositionList mList <> ")" + Ast.SubstringFuncExprCommonSubexpr mList -> + "substring(" <> maybe mempty renderSubstrList mList <> ")" + Ast.TrimFuncExprCommonSubexpr mModifier list -> + "trim(" <> renderTrimModifier mModifier <> renderTrimList list <> ")" + Ast.OverlayFuncExprCommonSubexpr list -> + "overlay(" <> renderOverlayList list <> ")" + other -> inline render other + + +renderPositionList :: Ast.PositionList -> Doc ann +renderPositionList (Ast.PositionList needle haystack) = + inline render needle <+> "in" <+> inline render haystack + + +renderSubstrList :: Ast.SubstrList -> Doc ann +renderSubstrList = \case + Ast.ExprListSubstrList exprs -> commaJoin (map renderExpr (toL exprs)) + Ast.ExprSubstrList expr fromFor -> renderExpr expr <+> renderSubstrListFromFor fromFor + + +renderSubstrListFromFor :: Ast.SubstrListFromFor -> Doc ann +renderSubstrListFromFor = \case + Ast.FromForSubstrListFromFor e1 e2 -> + "from" <+> renderExpr e1 <+> "for" <+> renderExpr e2 + Ast.ForFromSubstrListFromFor e1 e2 -> + "for" <+> renderExpr e1 <+> "from" <+> renderExpr e2 + Ast.FromSubstrListFromFor e -> "from" <+> renderExpr e + Ast.ForSubstrListFromFor e -> "for" <+> renderExpr e + + +renderTrimModifier :: Maybe Ast.TrimModifier -> Doc ann +renderTrimModifier = \case + Nothing -> mempty + Just Ast.BothTrimModifier -> "both " + Just Ast.LeadingTrimModifier -> "leading " + Just Ast.TrailingTrimModifier -> "trailing " + + +renderTrimList :: Ast.TrimList -> Doc ann +renderTrimList = \case + Ast.ExprFromExprListTrimList chars from -> + renderExpr chars <+> "from" <+> commaJoin (map renderExpr (toL from)) + Ast.FromExprListTrimList from -> + "from" <+> commaJoin (map renderExpr (toL from)) + Ast.ExprListTrimList exprs -> + commaJoin (map renderExpr (toL exprs)) + + +renderOverlayList :: Ast.OverlayList -> Doc ann +renderOverlayList (Ast.OverlayList target placing fromE mForE) = + renderExpr target + <+> "placing" + <+> renderExpr placing + <+> "from" + <+> renderExpr fromE + <> maybe mempty (\forE -> " for" <+> renderExpr forE) mForE + + +renderExtractList :: Ast.ExtractList -> Doc ann +renderExtractList (Ast.ExtractList arg expr) = + renderExtractArg arg <+> "from" <+> renderExpr expr + + +renderExtractArg :: Ast.ExtractArg -> Doc ann +renderExtractArg = \case + Ast.IdentExtractArg ident -> renderIdent ident + Ast.YearExtractArg -> "year" + Ast.MonthExtractArg -> "month" + Ast.DayExtractArg -> "day" + Ast.HourExtractArg -> "hour" + Ast.MinuteExtractArg -> "minute" + Ast.SecondExtractArg -> "second" + Ast.SconstExtractArg (Ast.Sconst s) -> "'" <> pretty s <> "'" + + +renderBExpr :: Ast.BExpr -> Doc ann +renderBExpr = \case + Ast.CExprBExpr ce -> renderCExpr ce + Ast.TypecastBExpr be tn -> renderBExpr be <> "::" <> renderTypename tn + Ast.PlusBExpr be -> "+" <> renderBExpr be + Ast.MinusBExpr be -> "-" <> renderBExpr be + Ast.SymbolicBinOpBExpr left op right -> + renderBExpr left <+> inline render op <+> renderBExpr right + other -> inline render other + + +renderReversableOp :: Bool -> Ast.AExprReversableOp -> Doc ann +renderReversableOp negated = \case + Ast.BetweenAExprReversableOp symmetric low high -> + (if negated then "not " else mempty) + <> (if symmetric then "between symmetric " else "between ") + <> renderBExpr low + <+> "and" + <+> renderExpr high + Ast.InAExprReversableOp inExpr -> + (if negated then "not in " else "in ") <> inline render inExpr + Ast.DistinctFromAExprReversableOp expr -> + "is " <> (if negated then "not " else mempty) <> "distinct from" <+> renderExpr expr + other -> inline (aExprReversableOp negated) other + + +renderTypename :: Ast.Typename -> Doc ann +renderTypename (Ast.Typename _setof stn questionMark mArrayDims) = + inline render stn + <> (if questionMark then "?" else mempty) + <> maybe mempty (\(ad, q) -> inline render ad <> if q then "?" else mempty) mArrayDims + + +renderTargetEl :: Ast.TargetEl -> Doc ann +renderTargetEl = \case + Ast.AsteriskTargetEl -> "*" + Ast.ExprTargetEl e -> renderExpr e + Ast.AliasedExprTargetEl e alias -> renderExpr e <+> "as" <+> inline render alias + Ast.ImplicitlyAliasedExprTargetEl e alias -> renderExpr e <+> inline render alias + + +-- | Wrap-aware target renderer that prefers a multi-line layout when the +-- expression is a top-level function call (optionally with a trailing +-- typecast) and the call has enough arguments to trigger wrapping. +renderTargetElDoc :: Ast.TargetEl -> Doc ann +renderTargetElDoc = \case + Ast.ExprTargetEl e -> renderExprDoc e + Ast.AliasedExprTargetEl e alias -> renderExprDoc e <+> "as" <+> inline render alias + Ast.ImplicitlyAliasedExprTargetEl e alias -> renderExprDoc e <+> inline render alias + other -> renderTargetEl other + + +-- | Inline-length threshold used at the top-level select-target / SET-RHS +-- position. Higher than 'inlineLengthThreshold' (which gates wrapping +-- inside a function-arg context) because a select target is allowed to be +-- somewhat longer before wrapping pays off — e.g. @select enqueue(array +-- [mk_payload(...)])@ at ~110 chars reads fine inline, but @select unnest +-- (array[format(...), format(...)])@ at 500+ chars does not. +selectTargetInlineThreshold :: Int +selectTargetInlineThreshold = 150 + + +-- | Wrap-aware expression renderer for SELECT targets and similar +-- top-level positions. Wraps a top-level function application (or a +-- chained-typecast over one) whenever it has enough arguments to trigger +-- the existing arg-count rule. A top-level @case ... end@ (with optional +-- surrounding parens / typecast) always wraps regardless of length — +-- inline @case@ in a SELECT target reads poorly even at moderate widths, +-- and the wrapped form matches the convention of hand-written SQL. +-- Additionally, when the expression's inline form exceeds +-- 'selectTargetInlineThreshold' and the expression is structurally +-- wrap-eligible, it expands multi-line — covers single-arg calls with +-- deeply nested content (e.g. @unnest(array[fn(...), fn(...)])::text@) +-- and other wrap-eligible shapes (parenthesized expressions, +-- @row(...)@, @coalesce@/@cast@, etc.). +renderExprDoc :: Ast.AExpr -> Doc ann +renderExprDoc e = case topLevelFuncApp e of + Just (app, wrapTypecast) + | funcAppArgCount app >= funcWrapThreshold -> + wrapTypecast (renderFuncApplicationWrapped app) + _ + | isTopLevelCase e -> + -- 'align' captures the actual column where this expression + -- starts (which is mid-line after the block-list's + -- @firstPad@ / @, @ prefix). Subsequent nest-driven indents + -- inside 'renderExprWrapped' / 'renderCaseExprWrapped' add + -- to that column, so body @when@ / @else@ land at + -- @case-col + indentSize@ and @end@ aligns under @case@. + -- Without this, a bare @case ... end@ has its body indent + -- driven by the outer nest level, which makes @when@ land + -- at the same column as @case@ (visually confusing). + align (renderExprWrapped e) + | otherwise -> + let inlineDoc = renderExpr e + inlineLen = T.length (renderToText inlineDoc) + in if inlineLen > selectTargetInlineThreshold && isWrapEligibleExpr e + then renderExprWrapped e + else inlineDoc + + +-- | True when the expression is a @case ... end@ (with optional surrounding +-- parens and/or chained typecasts). Used in 'renderExprDoc' to force CASE +-- expressions in SELECT-target position to always wrap multi-line. +isTopLevelCase :: Ast.AExpr -> Bool +isTopLevelCase = \case + Ast.TypecastAExpr inner _ -> isTopLevelCase inner + Ast.CExprAExpr (Ast.InParensCExpr inner _) -> isTopLevelCase inner + Ast.CExprAExpr (Ast.CaseCExpr _) -> True + _ -> False + + +-- | Wrap-aware table reference renderer used for JOIN right-hand sides. +-- Wraps the call when the operand is a 'FuncTableRef' with a wrap-eligible +-- function call; any other table ref falls back to the inline renderer. +renderTableRefDoc :: Ast.TableRef -> Doc ann +renderTableRefDoc = \case + Ast.FuncTableRef lp ft mFuncAlias + | Just (app, ordinality) <- wrapEligibleFuncTable ft -> + (if lp then "lateral " else mempty) + <> renderFuncApplicationWrapped app + <> (if ordinality then " with ordinality" else mempty) + <> maybe mempty (\a -> " " <> renderFuncAliasClauseDoc a) mFuncAlias + Ast.SelectTableRef lp swp mAlias -> + (if lp then "lateral " else mempty) + <> renderSelectWithParensMaybeWrap swp + <> maybe mempty (\a -> " " <> inline render a) mAlias + other -> renderTableRefInline other + + +-- | Render a function-alias clause (the @as alias_name (col1, col2, ...)@ +-- after a FROM-list / JOIN function call). Short column lists stay inline; +-- lists of more than 3 columns wrap onto their own bracket-list block +-- below the alias name. +renderFuncAliasClauseDoc :: Ast.FuncAliasClause -> Doc ann +renderFuncAliasClauseDoc = \case + Ast.AliasFuncAliasClause (Ast.AliasClause hasAs name (Just cols)) + | length (toL cols) > 3 -> + let prefix = if hasAs then "as " else mempty + colDocs = map (inline render) (toL cols) + in prefix + <> inline render name + <> hardline + <> indent indentSize (renderBracketList colDocs) + other -> inline render other + + +-- | If the FuncTable wraps a single ApplicationFuncExprWindowless with enough +-- arguments to trigger wrapping, return the application and its WITH ORDINALITY +-- flag; otherwise Nothing. +wrapEligibleFuncTable :: Ast.FuncTable -> Maybe (Ast.FuncApplication, Bool) +wrapEligibleFuncTable = \case + Ast.FuncExprFuncTable (Ast.ApplicationFuncExprWindowless app) (Ast.OptOrdinality ordinality) + | funcAppArgCount app >= funcWrapThreshold + , T.length (renderToText (renderFuncApplication app)) > inlineLengthThreshold -> + Just (app, ordinality) + _ -> Nothing + + +renderTargetListInline :: Ast.TargetList -> Doc ann +renderTargetListInline = commaJoin . map renderTargetEl . toL + + +renderSetClause :: Ast.SetClause -> Doc ann +renderSetClause = \case + Ast.TargetSetClause target expr -> + inline render target + <+> "=" + <+> nest indentSize (renderExprMaybeWrap expr) + Ast.TargetListSetClause targets expr -> + "(" + <> commaJoin (map (inline render) (toL targets)) + <> ") =" + <+> nest indentSize (renderExprMaybeWrap expr) + + +renderInsertTarget :: Ast.InsertTarget -> Doc ann +renderInsertTarget (Ast.InsertTarget name mAlias) = + inline render name <> maybe mempty (\a -> " as " <> inline render a) mAlias + + +-- Inline renderers for table refs / function tables — used inside FROM lists +-- that fit on a single line, and inside joined-table renderings where the +-- right-hand side is always inline. + +renderTableRefInline :: Ast.TableRef -> Doc ann +renderTableRefInline = \case + Ast.RelationExprTableRef re mAlias mSample -> + let base = inline render re + aliased = maybe base (\a -> base <+> inline render a) mAlias + in maybe aliased (\s -> aliased <+> inline render s) mSample + Ast.FuncTableRef lp ft mFuncAlias -> + (if lp then "lateral " else mempty) <> renderFuncTable ft <> maybe mempty (\a -> " " <> renderFuncAliasClauseDoc a) mFuncAlias + Ast.SelectTableRef lp swp mAlias -> + (if lp then "lateral " else mempty) <> renderSelectWithParensInline swp <> maybe mempty (\a -> " " <> inline render a) mAlias + Ast.JoinTableRef jt mAlias -> + inline render jt <> maybe mempty (\a -> " " <> inline render a) mAlias + + +renderFuncTable :: Ast.FuncTable -> Doc ann +renderFuncTable = \case + Ast.FuncExprFuncTable few (Ast.OptOrdinality ordinality) -> + renderFuncExprWindowless few <> if ordinality then " with ordinality" else mempty + Ast.RowsFromFuncTable rowsList (Ast.OptOrdinality ordinality) -> + "rows from (" <> commaJoin (map renderRowsfromItem (toL rowsList)) <> ")" <> if ordinality then " with ordinality" else mempty + + +renderFuncExprWindowless :: Ast.FuncExprWindowless -> Doc ann +renderFuncExprWindowless = \case + Ast.ApplicationFuncExprWindowless app -> renderFuncApplication app + Ast.CommonSubexprFuncExprWindowless sub -> renderFuncExprCommonSubexpr sub + + +renderRowsfromItem :: Ast.RowsfromItem -> Doc ann +renderRowsfromItem (Ast.RowsfromItem few mColDef) = + renderFuncExprWindowless few <> maybe mempty (\cd -> " as (" <> inline render cd <> ")") mColDef + + +-- Inline select renderers for subqueries that appear on a single line +-- (e.g. inside `EXISTS (...)`, `= (select ...)`, etc.). + +renderSelectWithParensInline :: Ast.SelectWithParens -> Doc ann +renderSelectWithParensInline = \case + Ast.NoParensSelectWithParens snp -> "(" <> renderSelectNoParensInline snp <> ")" + Ast.WithParensSelectWithParens swp -> "(" <> renderSelectWithParensInline swp <> ")" + + +-- | Inline-length threshold for in-expression parenthesized SELECTs. Higher +-- than 'inlineLengthThreshold' (which gates function-argument wrapping) +-- because subqueries are naturally wider than a function arg, so the +-- threshold needs to admit shapes like @(select 1::int from gen(...))@ +-- without forcing them onto multiple lines. +subqueryInlineThreshold :: Int +subqueryInlineThreshold = 100 + + +-- | Render an in-expression parenthesized SELECT (used for @EXISTS (...)@, +-- @ARRAY (...)@, @UNIQUE (...)@, scalar subselects, and @ANY/ALL (subquery)@) +-- inline when its inline form fits within 'subqueryInlineThreshold', +-- otherwise expand it onto multiple lines so the inner query reads as a +-- normal block (FROM split off, WHERE on its own line with right-aligned +-- AND continuations, leading-comma SELECT lists, etc. — the same layout +-- principles a top-level SELECT uses). +renderSelectWithParensMaybeWrap :: Ast.SelectWithParens -> Doc ann +renderSelectWithParensMaybeWrap swp = + let inlineDoc = renderSelectWithParensInline swp + inlineLen = T.length (renderToText inlineDoc) + in if inlineLen > subqueryInlineThreshold + then renderSelectWithParensWrapped swp + else inlineDoc + + +-- | Multi-line render of a parenthesized SELECT: open paren on the current +-- line, inner statement on its own block one indent deeper, closing paren +-- back at the caller's column. Mirrors the layout used by +-- 'renderCte' / @WITH ... AS (...)@. +renderSelectWithParensWrapped :: Ast.SelectWithParens -> Doc ann +renderSelectWithParensWrapped = \case + Ast.NoParensSelectWithParens snp -> + "(" <> nest indentSize (hardline <> renderSelectNoParens snp) <> hardline <> ")" + Ast.WithParensSelectWithParens inner -> + "(" <> nest indentSize (hardline <> renderSelectWithParensWrapped inner) <> hardline <> ")" + + +renderSelectNoParensInline :: Ast.SelectNoParens -> Doc ann +renderSelectNoParensInline (Ast.SelectNoParens mWith selectClause mSort mLimit mLocking) = + spaceJoin $ + catMaybes + [ inline render <$> mWith + , Just (renderSelectClauseInline selectClause) + , inline render <$> mSort + , inline render <$> mLimit + , inline render <$> mLocking + ] + + +-- | Concatenate inline 'Doc's with a single space between each. Used wherever +-- the previous Text-based renderer used 'T.unwords'. +spaceJoin :: [Doc ann] -> Doc ann +spaceJoin = hcat . punctuate " " + + +renderSelectClauseInline :: Ast.SelectClause -> Doc ann +renderSelectClauseInline = \case + Ast.SimpleSelectSelectClause ss -> renderSimpleSelectInline ss + Ast.WithParensSelectClause swp -> renderSelectWithParensInline swp + + +renderSimpleSelectInline :: Ast.SimpleSelect -> Doc ann +renderSimpleSelectInline = \case + Ast.NormalSimpleSelect mTargeting mInto mFrom mWhere mGroup mHaving mWindow -> + spaceJoin $ + catMaybes + [ Just (renderTargetingInline mTargeting) + , inline render <$> mInto + , renderFromClauseInline <$> mFrom + , (\(Ast.WhereClause w) -> "where" <+> renderExpr w) <$> mWhere + , inline render <$> mGroup + , (\(Ast.HavingClause h) -> "having" <+> renderExpr h) <$> mHaving + , inline render <$> mWindow + ] + Ast.BinSimpleSelect op left mAll right -> + renderSelectClauseInline left + <+> inline render op + <> maybe mempty (\distinct -> if distinct then " distinct" else " all") mAll + <+> renderSelectClauseInline right + other -> inline render other + + +renderFromClauseInline :: Ast.FromClause -> Doc ann +renderFromClauseInline fromList = + "from " <> commaJoin (map renderTableRefInline (toL fromList)) + + +renderTargetingInline :: Maybe Ast.Targeting -> Doc ann +renderTargetingInline = \case + Nothing -> "select" +#ifdef KRONOR_SYNTAX + Just (Ast.NormalTargeting tl) -> "select " <> commaJoin (map renderHsTargetElInline (toL tl)) +#else + Just (Ast.NormalTargeting tl) -> "select " <> commaJoin (map renderTargetEl (toL tl)) +#endif + Just (Ast.AllTargeting Nothing) -> "select all" + Just (Ast.AllTargeting (Just tl)) -> "select all " <> commaJoin (map renderTargetEl (toL tl)) + Just (Ast.DistinctTargeting mExprs tl) -> + let prefix = case mExprs of + Nothing -> "select distinct" + Just exprs -> "select distinct on (" <> inline render exprs <> ")" + in prefix <> " " <> commaJoin (map renderTargetEl (toL tl)) + + +#ifdef KRONOR_SYNTAX + +-- | Render a hasql-th target element on a single line. Used in inline subquery +-- contexts. The multi-line `$Name{...}` layout is handled separately by +-- 'renderHsTargetEl'. +renderHsTargetElInline :: Ast.HsTargetEl -> Doc ann +renderHsTargetElInline = \case + Ast.HsFuncTargetEl name args -> + "$" <> pretty name <> " (" <> commaJoin (map renderHsTargetElInline args) <> ")" + Ast.HsRecTargetEl name fields -> + "$" + <> pretty name + <> "{ " + <> commaJoin (map renderHsFieldContentInline (toL fields)) + <> " }" + Ast.SqlTargetEl te -> renderTargetEl te + + +renderHsFieldContentInline :: Ast.HsFieldTargetEl -> Doc ann +renderHsFieldContentInline (Ast.HsFieldEl name target) = + pretty name <> " = " <> renderHsTargetElInline target + +#endif + + +---------------------------------------------------------------------- +-- Multi-line statement / clause renderers (return Doc). +---------------------------------------------------------------------- + +renderPreparableStmt :: Ast.PreparableStmt -> Doc ann +renderPreparableStmt = \case + Ast.SelectPreparableStmt s -> renderSelectStmt s + Ast.InsertPreparableStmt s -> renderInsertStmt s + Ast.UpdatePreparableStmt s -> renderUpdateStmt s + Ast.DeletePreparableStmt s -> renderDeleteStmt s + Ast.CallPreparableStmt s -> inline render s + + +renderSelectStmt :: Ast.SelectStmt -> Doc ann +renderSelectStmt = \case + Ast.NoParensSelectStmt snp -> renderSelectNoParens snp + Ast.WithParensSelectStmt swp -> renderSelectWithParens swp + + +renderSelectWithParens :: Ast.SelectWithParens -> Doc ann +renderSelectWithParens = \case + Ast.NoParensSelectWithParens snp -> "(" <> renderSelectNoParens snp <> ")" + Ast.WithParensSelectWithParens swp -> "(" <> renderSelectWithParens swp <> ")" + + +renderSelectNoParens :: Ast.SelectNoParens -> Doc ann +renderSelectNoParens (Ast.SelectNoParens mWith selectClause mSort mLimit mLocking) = + vsep $ + catMaybes + [ renderWithClause <$> mWith + , Just (renderSelectClause selectClause) + , inline render <$> mSort + , renderSelectLimit <$> mLimit + , inline render <$> mLocking + ] + + +renderSelectClause :: Ast.SelectClause -> Doc ann +renderSelectClause = \case + Ast.SimpleSelectSelectClause ss -> renderSimpleSelect ss + Ast.WithParensSelectClause swp -> renderSelectWithParens swp + + +renderSimpleSelect :: Ast.SimpleSelect -> Doc ann +renderSimpleSelect = \case + Ast.NormalSimpleSelect mTargeting mInto mFrom mWhere mGroup mHaving mWindow -> + vsep $ + catMaybes + [ Just (renderTargeting mTargeting) + , inline render <$> mInto + , renderFromClause <$> mFrom + , renderWhereClause <$> mWhere + , inline render <$> mGroup + , (\(Ast.HavingClause h) -> renderCondWithAndAligned (T.length "having") "having" h) <$> mHaving + , inline render <$> mWindow + ] + Ast.ValuesSimpleSelect vc -> + renderValuesClause vc + Ast.TableSimpleSelect re -> + "table" <+> inline render re + Ast.BinSimpleSelect op left mAll right -> + vsep + [ renderSelectClause left + , inline render op <> maybe mempty (\d -> if d then " distinct" else " all") mAll + , renderSelectClause right + ] + + +-- | Render the SELECT targeting (column list). +renderTargeting :: Maybe Ast.Targeting -> Doc ann +renderTargeting = \case + Nothing -> "select" +#ifdef KRONOR_SYNTAX + Just (Ast.NormalTargeting tl) -> renderHsTargetList "select" tl +#else + Just (Ast.NormalTargeting tl) -> renderSqlTargetList "select" tl +#endif + Just (Ast.AllTargeting Nothing) -> "select all" + Just (Ast.AllTargeting (Just tl)) -> renderSqlTargetList "select all" tl + Just (Ast.DistinctTargeting mExprs tl) -> + let prefix = case mExprs of + Nothing -> "select distinct" + Just exprs -> "select distinct on (" <> inline render exprs <> ")" + in renderSqlTargetList prefix tl + + +#ifdef KRONOR_SYNTAX + +-- | Block-list layout for hasql-th target lists. First item lands at one +-- indent past the SELECT keyword; subsequent items are emitted as `, item` at +-- (indent - 2), so every item's content column lines up vertically. +-- +-- A single target that's a top-level @case ... end@ (with optional +-- surrounding parens / typecasts) forces the block-list layout too, so +-- @case@ lands at the item-content column rather than mid-line after +-- @select @. Otherwise the @align@ inside 'renderExprDoc' would capture +-- the @case@ keyword's mid-line column and push the body / @end@ far to +-- the right. +renderHsTargetList :: Doc ann -> Ast.HsTargetList -> Doc ann +renderHsTargetList prefix tl = + let items = toL tl + hasRecord = any isRecTarget items + in case items of + [single] + | not hasRecord && not (singleHsItemForcesMultiLine single) -> + prefix <+> renderHsTargetEl single + _ -> renderBlockListWith prefix renderHsTargetEl items + where + isRecTarget (Ast.HsRecTargetEl _ _) = True + isRecTarget _ = False + +#endif + + +renderSqlTargetList :: Doc ann -> Ast.TargetList -> Doc ann +renderSqlTargetList prefix tl = + let items = toL tl + in case items of + [single] + | not (singleSqlItemForcesMultiLine single) -> + prefix <+> renderTargetElDoc single + _ -> renderBlockListWith prefix renderTargetElDoc items + + +-- | A single SELECT target item forces block-list layout when its +-- expression would render multi-line via 'renderExprDoc'. Currently this +-- is just the top-level CASE rule (peeling typecasts and parens) — keeping +-- the predicate narrow avoids unintended layout changes for short single +-- targets. +#ifdef KRONOR_SYNTAX +singleHsItemForcesMultiLine :: Ast.HsTargetEl -> Bool +singleHsItemForcesMultiLine = \case + Ast.SqlTargetEl te -> singleSqlItemForcesMultiLine te + _ -> False +#endif + + +singleSqlItemForcesMultiLine :: Ast.TargetEl -> Bool +singleSqlItemForcesMultiLine = \case + Ast.ExprTargetEl e -> isTopLevelCase e + Ast.AliasedExprTargetEl e _ -> isTopLevelCase e + Ast.ImplicitlyAliasedExprTargetEl e _ -> isTopLevelCase e + _ -> False + + +-- | Build the block-list layout used by SELECT target lists and the +-- multi-assignment UPDATE SET. Pattern: +-- +-- @ +-- prefix +-- first +-- , second +-- , third +-- @ +-- +-- The body sits at indent 4; commas at indent 2. +-- +-- Note: padding is applied as explicit spaces in the Doc rather than via +-- 'indent'/'nest'. This is deliberate — we want the *first* item one indent +-- deeper than the comma rows, so that the comma column lines up under the +-- prefix while item content aligns. 'indent' would push every row to the same +-- column. +renderBlockListWith :: Doc ann -> (a -> Doc ann) -> [a] -> Doc ann +renderBlockListWith prefix renderItem items = + prefix + <> hardline + <> vsep (zipWith renderRow [(0 :: Int) ..] items) + where + firstPad = pretty (T.replicate indentSize " ") + commaPad = pretty (T.replicate (max 0 (indentSize - 2)) " ") + renderRow 0 item = firstPad <> renderItem item + renderRow _ item = commaPad <> ", " <> renderItem item + + +#ifdef KRONOR_SYNTAX + +-- | Multi-line `$Name{...}` record layout: +-- +-- @ + +-- $Name +-- { field1 = ... +-- , field2 = ... +-- } +-- @ +-- +-- Wrapped in 'align' so any hard line break within the record body picks up +-- the column where `$Name` was placed (rather than the outer block's column); +-- 'indent' then takes us one level deeper for the brace/fields/closing brace. + + +renderHsTargetEl :: Ast.HsTargetEl -> Doc ann +renderHsTargetEl = \case + Ast.HsFuncTargetEl name args -> + let inlineDoc = "$" <> pretty name <> " (" <> commaJoin (map renderHsTargetElInline args) <> ")" + inlineLen = T.length (renderToText inlineDoc) + in if not (null args) && inlineLen > selectTargetInlineThreshold + then renderHsFuncTargetWrapped name args + else inlineDoc + Ast.HsRecTargetEl name fields -> + align $ + "$" + <> pretty name + <> hardline + <> indent indentSize (renderRecordFields fields) + Ast.SqlTargetEl te -> renderTargetElDoc te + + +-- | Multi-line layout for hasql-th @$Name (...)@: each arg on its own +-- line in a leading-comma block, same shape as +-- 'renderFuncApplicationWrapped'. Each arg is rendered wrap-aware so a +-- long inner SQL expression (CASE, function call, parenthesized cast, +-- etc.) wraps the same way it would at the top-level SELECT-target +-- position. Used both for top-level @$Foo (...)@ targets (gated by +-- 'selectTargetInlineThreshold') and for nested @$Foo (...)@ values +-- inside record fields (gated by 'inlineLengthThreshold' via +-- 'renderHsTargetElMaybeWrap'). +renderHsFuncTargetWrapped :: Text -> [Ast.HsTargetEl] -> Doc ann +renderHsFuncTargetWrapped name args = + "$" + <> pretty name + <> " (" + <> nest indentSize (renderArgRows (map renderHsFuncTargetArg args)) + <> hardline + <> ")" + + +-- | Render one arg of a wrapped @$Name (...)@. SQL args go through +-- 'renderTargetElDoc' (the wrap-aware SELECT-target renderer); nested +-- @$Foo (...)@ / @$Foo{...}@ args recurse via 'renderHsTargetElMaybeWrap' +-- so a deeply nested splice picks up the same inline-vs-wrap rule it +-- would in a record field. +renderHsFuncTargetArg :: Ast.HsTargetEl -> Doc ann +renderHsFuncTargetArg = \case + Ast.SqlTargetEl te -> renderTargetElDoc te + other -> renderHsTargetElMaybeWrap other + + +-- | Same as 'renderHsTargetEl' but without the outer 'align' — for use +-- when this target is a nested record value (rendered inside +-- 'renderRecordFields'). We rely on the surrounding @indent indentSize@ +-- to give us the right base column, and propagate it via plain +-- @hardline + indent indentSize@ so each nesting level adds exactly +-- @indentSize@ of indent rather than capturing the field's mid-line +-- column (which would cascade rightward). +renderHsTargetElWrappedInner :: Ast.HsTargetEl -> Doc ann +renderHsTargetElWrappedInner = \case + Ast.HsRecTargetEl name fields -> + "$" + <> pretty name + <> hardline + <> indent indentSize (renderRecordFields fields) + Ast.HsFuncTargetEl name args -> + renderHsFuncTargetWrapped name args + other -> renderHsTargetEl other + + +renderRecordFields :: NE.NonEmpty Ast.HsFieldTargetEl -> Doc ann +renderRecordFields fields = + let firstField = NE.head fields + restFields = NE.tail fields + renderField (Ast.HsFieldEl name target) = + pretty name <> " = " <> renderHsTargetElMaybeWrap target + firstLine = "{ " <> renderField firstField + restLines = map (\f -> ", " <> renderField f) restFields + in vsep $ firstLine : restLines ++ ["}"] + + +-- | Wrap-aware renderer for hasql-th @$Foo@ / @$Foo{...}@ target +-- expressions used inside record fields. Renders inline first; if the +-- inline form exceeds 'inlineLengthThreshold' AND the target is a +-- record-shaped @$Foo{...}@ (or a function-shaped @$f(...)@ that +-- contains a wrap-eligible record), expands to multi-line via +-- 'renderHsTargetElWrappedInner' so each nested level adds exactly +-- @indentSize@ of indent rather than cascading rightward. +renderHsTargetElMaybeWrap :: Ast.HsTargetEl -> Doc ann +renderHsTargetElMaybeWrap el = + let inlineDoc = renderHsTargetElInline el + inlineLen = T.length (renderToText inlineDoc) + in if inlineLen > inlineLengthThreshold && isHsTargetWrapEligible el + then renderHsTargetElWrappedInner el + else inlineDoc + + +isHsTargetWrapEligible :: Ast.HsTargetEl -> Bool +isHsTargetWrapEligible = \case + Ast.HsRecTargetEl _ _ -> True + Ast.HsFuncTargetEl _ args -> not (null args) + Ast.SqlTargetEl _ -> False + +#endif + + +-- | Render the FROM clause. A list with no joins stays on a single line +-- (`from t1, t2`). Any join forces multi-line layout so each join lands on its +-- own line with its ON/USING qualification below. +renderFromClause :: Ast.FromClause -> Doc ann +renderFromClause fromList = + let items = toL fromList + lastIdx = length items - 1 + in if any forcesMultiLine items + then + vsep $ + zipWith + ( \i item -> + renderTableRef (i == (0 :: Int)) item + <> if i < lastIdx then "," else mempty + ) + [0 ..] + items + else "from" <+> commaJoin (map renderTableRefInline items) + where + -- A FROM item forces multi-line layout when it's a JOIN (each arm on + -- its own line), a wrap-eligible function call (e.g. + -- @from job_queue.enqueue_payload(array[...]::jsonb[], priority_ := + -- 5000)@), or a parenthesized SELECT whose inline form exceeds + -- 'subqueryInlineThreshold'. + forcesMultiLine (Ast.JoinTableRef _ _) = True + forcesMultiLine (Ast.FuncTableRef _ ft _) = + case wrapEligibleFuncTable ft of + Just _ -> True + Nothing -> False + forcesMultiLine (Ast.SelectTableRef _ swp _) = + T.length (renderToText (renderSelectWithParensInline swp)) > subqueryInlineThreshold + forcesMultiLine _ = False + + +renderTableRef :: Bool -> Ast.TableRef -> Doc ann +renderTableRef isFirst = \case + Ast.RelationExprTableRef re mAlias mSample -> + let base = inline render re + aliased = maybe base (\a -> base <> " " <> inline render a) mAlias + sampled = maybe aliased (\s -> aliased <> " " <> inline render s) mSample + in pfx <> sampled + Ast.FuncTableRef lp ft mFuncAlias + | Just (app, ordinality) <- wrapEligibleFuncTable ft -> + pfx + <> (if lp then "lateral " else mempty) + <> renderFuncApplicationWrapped app + <> (if ordinality then " with ordinality" else mempty) + <> maybe mempty (\a -> " " <> renderFuncAliasClauseDoc a) mFuncAlias + Ast.FuncTableRef lp ft mFuncAlias -> + pfx + <> ( (if lp then "lateral " else mempty) + <> renderFuncTable ft + <> maybe mempty (\a -> " " <> renderFuncAliasClauseDoc a) mFuncAlias + ) + Ast.SelectTableRef lp swp mAlias -> + pfx + <> (if lp then "lateral " else mempty) + <> renderSelectWithParensMaybeWrap swp + <> maybe mempty (\a -> " " <> inline render a) mAlias + Ast.JoinTableRef jt mAlias -> + pfx <> renderJoinedTable jt <> maybe mempty (\a -> " " <> inline render a) mAlias + where + pfx = if isFirst then "from " else mempty + + +-- | Render a joined table. The @from @ prefix is the caller's responsibility +-- (added by 'renderTableRef' when the surrounding 'JoinTableRef' is the first +-- FROM item) so that parenthesized or non-first joins don't end up with the +-- @from@ keyword inside the parens or duplicated mid-list. +renderJoinedTable :: Ast.JoinedTable -> Doc ann +renderJoinedTable = \case + Ast.InParensJoinedTable jt -> "(" <> renderJoinedTable jt <> ")" + Ast.CrossJoinedTable left right -> + renderTableRef False left <> hardline <> ("cross join" <+> renderTableRefDoc right) + Ast.NaturalJoinedTable left mType right -> + let prefix = "natural " <> maybe "" (\t -> renderJoinType t <> " ") mType <> "join" + in renderTableRef False left <> hardline <> (pretty prefix <+> renderTableRefDoc right) + Ast.QualJoinedTable left mType right qual -> + -- Right-align the ON keyword (and any AND continuations) under the + -- first word of the JOIN-block (`join` itself for a plain join, or + -- `left` / `right` / `inner` / `full` for a prefixed one). This keeps + -- the qualifier visually attached to the join opener regardless of + -- how long the full keyword sequence is. + let mTypePrefix = maybe "" (\t -> renderJoinType t <> " ") mType + keyword = mTypePrefix <> "join" + anchor = firstWordLen keyword + joinHeader = pretty keyword <+> renderTableRefDoc right + in renderTableRef False left <> hardline <> joinHeader <> hardline <> renderJoinQual anchor qual + + +-- | Length of the first whitespace-delimited word in @t@ (or 0 for empty). +firstWordLen :: Text -> Int +firstWordLen = T.length . T.takeWhile (/= ' ') + + +renderJoinType :: Ast.JoinType -> Text +renderJoinType = \case + Ast.FullJoinType outer -> "full" <> if outer then " outer" else "" + Ast.LeftJoinType outer -> "left" <> if outer then " outer" else "" + Ast.RightJoinType outer -> "right" <> if outer then " outer" else "" + Ast.InnerJoinType -> "inner" + + +renderJoinQual :: Int -> Ast.JoinQual -> Doc ann +renderJoinQual anchor = \case + Ast.OnJoinQual expr -> renderCondWithAndAligned anchor "on" expr + Ast.UsingJoinQual cols -> + "using (" <> commaJoin (map (inline render) (toL cols)) <> ")" + + +-- | Render WHERE clause; AND continuations right-align with `where`'s end. +renderWhereClause :: Ast.WhereClause -> Doc ann +renderWhereClause (Ast.WhereClause expr) = renderCondWithAndAligned (T.length "where") "where" expr + + +-- | Render a condition expression. AND continuations are emitted with explicit +-- left-padding so their last letter lines up with the @anchor@-wide opening +-- keyword (e.g. @anchor = 5@ for `where`, @anchor = 4@ for `join`-block ON). +-- +-- AND splitting works on the rendered Text rather than the AST because +-- @postgresql-syntax@ parses @a = 1 AND b = 2@ as +-- @SymbolicBinOpAExpr a (=) (AndAExpr 1 (SymbolicBinOpAExpr b (=) ...))@ — +-- the AND ends up nested inside the comparison rather than at the top level. +renderCondWithAndAligned :: Int -> Text -> Ast.AExpr -> Doc ann +renderCondWithAndAligned anchor keyword expr = + let renderedText = renderToText (renderExpr expr) + parts = splitOnAnd renderedText + kwPadLen = max 0 (anchor - T.length keyword) + andPadLen = max 0 (anchor - T.length "and") + kwPad = pretty (T.replicate kwPadLen " ") + andPad = pretty (T.replicate andPadLen " ") + in case parts of + -- Single condition (no top-level AND): if its inline form is + -- long and the expression is wrap-eligible, hand it off to + -- 'renderExprMaybeWrap' so the inner shape (e.g. a long + -- function call or @case@) can expand multi-line. + [single] + | T.length single > inlineLengthThreshold && isWrapEligibleExpr expr -> + kwPad <> pretty keyword <+> renderExprMaybeWrap expr + | otherwise -> + kwPad <> pretty keyword <+> pretty single + (first : rest) -> + vsep $ + (kwPad <> pretty keyword <+> pretty first) + : map (\p -> andPad <> "and" <+> pretty p) rest + [] -> mempty + + +-- | Render an inline 'Doc' down to 'Text'. Used in the few places we need +-- to do text-level operations (e.g. AND splitting) on the rendered output +-- before re-wrapping into a 'Doc'. +renderToText :: Doc ann -> Text +renderToText = renderStrict . layoutPretty layoutOpts + + +-- | Split rendered SQL text at top-level @ and @ boundaries. Skips +-- occurrences inside parens, under a @between@, and inside single-quoted +-- string literals or double-quoted identifiers (@'@ / @"@, with standard +-- doubled-quote escapes). +splitOnAnd :: Text -> [Text] +splitOnAnd = go 0 False Nothing "" . T.unpack + where + go :: Int -> Bool -> Maybe Char -> String -> String -> [Text] + go _ _ _ acc [] = [T.strip (T.pack (reverse acc))] + -- Inside a string/quoted-identifier: doubled-quote escape stays inside; + -- otherwise the real closing quote exits. + go d btwn (Just q) acc (c1 : c2 : rest) + | c1 == q && c2 == q = go d btwn (Just q) (c2 : c1 : acc) rest + go d btwn (Just q) acc (c : rest) + | c == q = go d btwn Nothing (c : acc) rest + | otherwise = go d btwn (Just q) (c : acc) rest + -- Outside strings: + go d btwn Nothing acc ('\'' : rest) = go d btwn (Just '\'') ('\'' : acc) rest + go d btwn Nothing acc ('"' : rest) = go d btwn (Just '"') ('"' : acc) rest + go d btwn Nothing acc ('(' : rest) = go (d + 1) btwn Nothing ('(' : acc) rest + go d btwn Nothing acc (')' : rest) = go (max 0 (d - 1)) btwn Nothing (')' : acc) rest + go 0 True Nothing acc (' ' : 'a' : 'n' : 'd' : ' ' : rest) = + go 0 False Nothing (reverse " and " ++ acc) rest + go 0 _ Nothing acc (' ' : 'a' : 'n' : 'd' : ' ' : rest) = + T.strip (T.pack (reverse acc)) : go 0 False Nothing "" rest + go d _ Nothing acc ('b' : 'e' : 't' : 'w' : 'e' : 'e' : 'n' : ' ' : rest) = + go d True Nothing (reverse "between " ++ acc) rest + go d btwn st acc (c : rest) = go d btwn st (c : acc) rest + + +renderSelectLimit :: Ast.SelectLimit -> Doc ann +renderSelectLimit = \case + Ast.LimitOffsetSelectLimit lc oc -> + inline render lc <> hardline <> inline render oc + Ast.OffsetLimitSelectLimit oc lc -> + inline render oc <> hardline <> inline render lc + Ast.LimitSelectLimit lc -> inline render lc + Ast.OffsetSelectLimit oc -> inline render oc + + +renderWithClause :: Ast.WithClause -> Doc ann +renderWithClause (Ast.WithClause recursive ctes) = + let keyword :: Text + keyword = if recursive then "with recursive" else "with" + cteList = toL ctes + lastIdx = length cteList - 1 + in vsep $ + zipWith + ( \i cte -> + let isLast = i == lastIdx + prefix = if i == (0 :: Int) then pretty keyword <> " " else mempty + in prefix <> renderCte isLast cte + ) + [0 :: Int ..] + cteList + + +renderCte :: Bool -> Ast.CommonTableExpr -> Doc ann +renderCte isLast (Ast.CommonTableExpr name mCols mMaterialized stmt) = + let suffix = if isLast then ")" else ")," + materializedKeyword = case mMaterialized of + Nothing -> "" + Just True -> "materialized " + Just False -> "not materialized " + header = + inline render name + <> maybe + mempty + (\cols -> " (" <> commaJoin (map (inline render) (toL cols)) <> ")") + mCols + <> " as " + <> materializedKeyword + <> "(" + in header + <> hardline + <> indent indentSize (renderPreparableStmt stmt) + <> hardline + <> suffix + + +-- | Render INSERT statement. +renderInsertStmt :: Ast.InsertStmt -> Doc ann +renderInsertStmt (Ast.InsertStmt mWith target rest mConflict mReturning) = + vsep $ + catMaybes + [ renderWithClause <$> mWith + , Just ("insert into" <+> renderInsertTarget target) + , Just (renderInsertRest rest) + , renderOnConflict <$> mConflict + , (\(Ast.ReturningClause rc) -> "returning" <+> renderTargetListInline rc) <$> mReturning + ] + + +renderInsertRest :: Ast.InsertRest -> Doc ann +renderInsertRest = \case + Ast.SelectInsertRest mCols mOverride selectStmt -> + let colsDoc = maybe mempty renderInsertColumnList mCols + overrideDoc = case mOverride of + Nothing -> mempty + Just o -> "overriding " <> inline render o <> " value" <> hardline + selectDoc = overrideDoc <> renderSelectStmt selectStmt + in case mCols of + Nothing -> selectDoc + Just _ -> colsDoc <> hardline <> selectDoc + Ast.DefaultValuesInsertRest -> "default values" + + +-- | Render the bracketed INSERT column list. Short lists (≤ 3 cols) stay on +-- one line wrapped in `(...)`; longer lists use the bracket-list block-comma +-- layout. +renderInsertColumnList :: Ast.InsertColumnList -> Doc ann +renderInsertColumnList cols = + let items = toL cols + rendered = map (inline render) items + in if length items <= 3 + then indent indentSize ("(" <> commaJoin rendered <> ")") + else indent indentSize (renderBracketList rendered) + + +-- | Build the bracket-list layout used for long INSERT column lists and +-- VALUES tuples: +-- +-- @ +-- ( first +-- , second +-- , third +-- ) +-- @ +renderBracketList :: [Doc ann] -> Doc ann +renderBracketList = \case + [] -> "()" + (x : xs) -> + vsep $ + ("( " <> x) + : map (", " <>) xs + ++ [")"] + + +-- | Render VALUES clause. The keyword `values` lands on its own line with the +-- tuples emitted as bracket-lists below it. +renderValuesClause :: Ast.ValuesClause -> Doc ann +renderValuesClause vc = + let rows = toL vc + lastIdx = length rows - 1 + renderRow i row = + let bracketed = renderValuesRow row + in if i < lastIdx then bracketed <> "," else bracketed + in "values" + <> hardline + <> indent indentSize (vsep (zipWith renderRow [(0 :: Int) ..] rows)) + + +renderValuesRow :: Ast.ExprList -> Doc ann +renderValuesRow exprs = + let items = toL exprs + rendered = map renderExpr items + in case items of + [_] -> "(" <> commaJoin rendered <> ")" + _ -> renderBracketList rendered + + +renderOnConflict :: Ast.OnConflict -> Doc ann +renderOnConflict (Ast.OnConflict mConfExpr onDo) = + let header = "on conflict" <> maybe mempty (\ce -> " " <> inline render ce) mConfExpr + in header <> hardline <> renderOnConflictDo onDo + + +renderOnConflictDo :: Ast.OnConflictDo -> Doc ann +renderOnConflictDo = \case + Ast.NothingOnConflictDo -> "do nothing" + Ast.UpdateOnConflictDo setClauses mWhere -> + let items = toL setClauses + base = case items of + [single] -> + "do update set" + <> hardline + <> indent indentSize (renderSetClause single) + _ -> + let renderItem i clause = + let d = renderSetClause clause + in if i < length items - 1 + then d <> "," + else d + in "do update set" + <> hardline + <> indent indentSize (vsep (zipWith renderItem [(0 :: Int) ..] items)) + in case mWhere of + Nothing -> base + Just w -> base <> hardline <> renderWhereClause (Ast.WhereClause w) + + +-- | Render UPDATE statement. +renderUpdateStmt :: Ast.UpdateStmt -> Doc ann +renderUpdateStmt (Ast.UpdateStmt mWith rel setClauses mFrom mWhere mReturning) = + vsep $ + catMaybes + [ renderWithClause <$> mWith + , Just ("update" <+> inline render rel) + , Just (renderSetClauseLines setClauses) + , renderFromClause <$> mFrom + , renderWhereOrCurrent <$> mWhere + , (\(Ast.ReturningClause rc) -> "returning" <+> renderTargetListInline rc) <$> mReturning + ] + + +-- | Render DELETE statement. +renderDeleteStmt :: Ast.DeleteStmt -> Doc ann +renderDeleteStmt (Ast.DeleteStmt mWith rel mUsing mWhere mReturning) = + vsep $ + catMaybes + [ renderWithClause <$> mWith + , Just ("delete from" <+> inline render rel) + , (\(Ast.UsingClause u) -> "using" <+> inline render u) <$> mUsing + , renderWhereOrCurrent <$> mWhere + , (\(Ast.ReturningClause rc) -> "returning" <+> renderTargetListInline rc) <$> mReturning + ] + + +renderWhereOrCurrent :: Ast.WhereOrCurrentClause -> Doc ann +renderWhereOrCurrent = \case + Ast.ExprWhereOrCurrentClause expr -> renderWhereClause (Ast.WhereClause expr) + Ast.CursorWhereOrCurrentClause name -> "where current of" <+> inline render name + + +-- | Multi-assignment SETs put `set` on its own line and use the same +-- block-list layout as multi-target SELECTs. Single-assignment SETs stay +-- inline (`set col = val`). +renderSetClauseLines :: Ast.SetClauseList -> Doc ann +renderSetClauseLines setClauses = + let items = toL setClauses + in case items of + [single] -> "set" <+> renderSetClause single + _ -> renderBlockListWith "set" renderSetClause items diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,103 @@ +module Main where + +import Control.Monad (when) +import Data.ByteString qualified as BS +import Hasql.ThFormat (ProcessResult (..), processBytes, processFile) +import System.Environment (getArgs, getProgName) +import System.Exit (ExitCode (..), exitWith) +import Prelude + + +data Mode + = -- | checkOnly, files + ModeFiles Bool [FilePath] + | ModeStdin + + +main :: IO () +main = do + args <- getArgs + progName <- getProgName + case parseArgs args of + Left err -> do + putStrLn err + putStrLn (usage progName) + exitWith (ExitFailure 2) + Right ModeStdin -> do + input <- BS.getContents + case processBytes input of + Left err -> do + putStrLn ("Error: " <> err) + exitWith (ExitFailure 1) + Right output -> + BS.putStr output + Right (ModeFiles checkOnly files) + | null files -> do + putStrLn (usage progName) + exitWith (ExitFailure 2) + | otherwise -> do + results <- mapM (processOneFile checkOnly) files + let hasErrors = any isError results + hasChanges = any isChanged results + when hasErrors (exitWith (ExitFailure 1)) + when (checkOnly && hasChanges) (exitWith (ExitFailure 1)) + + +processOneFile :: Bool -> FilePath -> IO ProcessResult +processOneFile checkOnly filePath = do + result <- processFile checkOnly filePath + case result of + Error err -> do + putStrLn ("Error processing " <> filePath <> ": " <> err) + pure result + Changed + | checkOnly -> do + putStrLn ("Would reformat: " <> filePath) + pure result + | otherwise -> do + putStrLn ("Reformatted: " <> filePath) + pure result + Unchanged -> pure result + + +isError :: ProcessResult -> Bool +isError (Error _) = True +isError _ = False + + +isChanged :: ProcessResult -> Bool +isChanged Changed = True +isChanged _ = False + + +parseArgs :: [String] -> Either String Mode +parseArgs = go Nothing False [] + where + go mStdin checkOnly files [] = + case mStdin of + Just True + | not (null files) -> Left "Cannot combine --stdin with file arguments." + | checkOnly -> Left "Cannot combine --stdin with --check." + | otherwise -> Right ModeStdin + _ -> Right (ModeFiles checkOnly (reverse files)) + go mStdin _ files ("--check" : rest) = + go mStdin True files rest + go _ checkOnly files ("--stdin" : rest) = + go (Just True) checkOnly files rest + go _ _ _ (('-' : '-' : opt) : _) = + Left ("Unknown option: --" <> opt) + go mStdin checkOnly files (f : rest) = + go mStdin checkOnly (f : files) rest + + +usage :: String -> String +usage progName = + "Usage: " + <> progName + <> " [--check] files...\n" + <> " " + <> progName + <> " --stdin\n\n" + <> "Options:\n" + <> " --check Don't modify files, exit with code 1 if any file would change\n" + <> " --stdin Read from stdin, write formatted output to stdout\n" diff --git a/hasql-th-format.cabal b/hasql-th-format.cabal new file mode 100644 --- /dev/null +++ b/hasql-th-format.cabal @@ -0,0 +1,160 @@ +cabal-version: 3.0 +name: hasql-th-format +version: 0.1.0.0 +synopsis: Format the SQL inside hasql-th quasiquotes +description: + Rewrites the SQL in every hasql-th quasiquote of a Haskell source file into + one house layout, in place. It parses each statement, renders it again, and + re-parses the result, so a formatting pass that would change what the + statement means fails instead of being written out. + . + Ships two executables: @hasql-th-format@, the formatter itself, and + @hasql-th-audit@, which diffs the statements of two revisions of a file + quasiquote by quasiquote, so a reformatting commit can be shown to have + changed no SQL. + +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: Kronor +maintainer: lorenzo@kronor.io +copyright: 2026 Kronor +build-type: Simple +tested-with: GHC ==9.10.3 || ==9.12.4 || ==9.14.1 +extra-doc-files: 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) and format them. Needs Kronor's fork of + postgresql-syntax. + + manual: True + default: False + +executable hasql-th-format + main-is: Main.hs + + -- cabal-fmt: expand app -Main -Audit + other-modules: + Hasql.ThFormat + Hasql.ThFormat.SqlFormat + + hs-source-dirs: app + default-language: GHC2021 + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RecordWildCards + ScopedTypeVariables + StrictData + TupleSections + TypeApplications + TypeFamilies + 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: + , base >=4.20 && <4.23 + , bytestring >=0.11 && <0.13 + , hasql-check >=0.5 && <0.6 + , postgresql-syntax >=0.5 && <0.6 + , prettyprinter >=1.7 && <1.8 + , text >=2.0 && <2.2 + , text-builder >=1.0 && <1.1 + + if flag(kronor-syntax) + cpp-options: -DKRONOR_SYNTAX + +executable hasql-th-audit + main-is: Audit.hs + hs-source-dirs: app + default-language: GHC2021 + default-extensions: + ImportQualifiedPost + LambdaCase + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + + ghc-options: -Wall + + if flag(lint) + ghc-options: -Werror + build-depends: + , base >=4.20 && <4.23 + , bytestring >=0.11 && <0.13 + , hasql-check >=0.5 && <0.6 + , postgresql-syntax >=0.5 && <0.6 + , text >=2.0 && <2.2 + + if flag(kronor-syntax) + cpp-options: -DKRONOR_SYNTAX + +test-suite hasql-th-format-test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: Hasql.ThFormat.SqlFormat + hs-source-dirs: test app + default-language: GHC2021 + default-extensions: + ImportQualifiedPost + LambdaCase + NoImplicitPrelude + OverloadedStrings + QuasiQuotes + + ghc-options: -Wall + + if flag(lint) + ghc-options: -Werror + build-depends: + , base >=4.20 && <4.23 + , hasql-check >=0.5 && <0.6 + , postgresql-syntax >=0.5 && <0.6 + , prettyprinter >=1.7 && <1.8 + , string-interpolate >=0.3 && <0.4 + , text >=2.0 && <2.2 + , text-builder >=1.0 && <1.1 + + if flag(kronor-syntax) + cpp-options: -DKRONOR_SYNTAX diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,1343 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Data.String.Interpolate (__i) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Hasql.ThFormat.SqlFormat (formatSql) +import PostgresqlSyntax qualified as Ast +import System.Exit (ExitCode (..), exitWith) +import Prelude + + +-- | Parse a SQL snippet, ignoring surrounding whitespace. Returns 'Nothing' if +-- the parser rejects the input. Used to compare the AST of input/expected/actual +-- as a semantic-equivalence guard on top of string equality. +parseAst :: Text -> Maybe Ast.PreparableStmt +parseAst t = either (const Nothing) Just (Ast.parse settings (T.strip t)) + where + settings = + mconcat + [ Ast.nullabilityMarkers True +#ifdef KRONOR_SYNTAX + , Ast.haskellTargets True + , Ast.haskellParamFields True +#endif + ] + + +data TestCase = TestCase + { name :: Text + , qqCol :: Int + , input :: Text + , expected :: Text + } + + +-- | Prepend @n@ spaces to each non-blank line. +indent :: Int -> Text -> Text +indent n = T.intercalate "\n" . map addPrefix . T.lines + where + prefix = T.replicate n " " + addPrefix line + | T.null (T.strip line) = line + | otherwise = prefix <> line + + +-- | Build a test case. @rawInput@ and @rawExpected@ are dedented SQL snippets; +-- the input is indented to column @qqCol@ (simulating the real quasiquote +-- context), and the expected output is indented to @qqCol + 4@ (the formatter +-- indents content one level deeper than the opening bracket). Both are given a +-- leading newline, matching what a quasiquote block contains. +mkCase :: Text -> Int -> Text -> Text -> TestCase +mkCase nm col rawInput rawExpected = + TestCase + { name = nm + , qqCol = col + , input = "\n" <> indent col rawInput + , expected = "\n" <> indent (col + 4) rawExpected + } + + +tests :: [TestCase] +tests = + [ TestCase + { name = "[01] single-line query (no newlines) is left untouched" + , qqCol = 4 + , input = " update releaser.config set is_frozen = $1::bool where id = 42 " + , expected = " update releaser.config set is_frozen = $1::bool where id = 42 " + } + , mkCase + "[02] SELECT ... WHERE: inlined FROM is split out, trailing LIMIT moves to its own line, ANDs are indented under WHERE" + 4 + [__i| + select response_body::jsonb from history.idempotency + where customer_id = $1::bigint + and namespace = $2::text + and idempotency_key = $3::text + and request_params = $4::jsonb limit 1 + |] + [__i| + select response_body::jsonb + from history.idempotency + where customer_id = $1::bigint + and namespace = $2::text + and idempotency_key = $3::text + and request_params = $4::jsonb + limit 1 + |] + , mkCase + "[03] INSERT with 4+ columns and a VALUES tuple: both are split into leading-comma lists" + 4 + [__i| + insert into history.idempotency (customer_id, namespace, idempotency_key, request_params) + values ($1::bigint, $2::text, $3::text, $4::jsonb) + |] + [__i| + insert into history.idempotency + ( customer_id + , namespace + , idempotency_key + , request_params + ) + values + ( $1::bigint + , $2::text + , $3::text + , $4::jsonb + ) + |] + , mkCase + "[04] UPDATE ... WHERE normalizes inconsistent AND indentation (2 spaces -> 4) under the WHERE keyword" + 4 + [__i| + update history.idempotency + set response_body = $4::jsonb + where customer_id = $1::bigint + and namespace = $2::text + and idempotency_key = $3::text + |] + [__i| + update history.idempotency + set response_body = $4::jsonb + where customer_id = $1::bigint + and namespace = $2::text + and idempotency_key = $3::text + |] + , mkCase + "[05] JOIN with multi-condition ON: the AND continuation sits at the same indent as ON, not nested further" + 4 + [__i| + select payment.id::bigint, + payment.vendor_handle::text? + from storefront_core.transaction_archive + join config.vendor_setting + on vendor_setting.customer_id = transaction_archive.customer_id + join storefront_core.payment + on payment.id = transaction_archive.payment_id + and payment.customer_id = transaction_archive.customer_id + where transaction_archive.customer_id = $1::bigint + and transaction_archive.id = $2::bigint + |] + [__i| + select + payment.id::bigint + , payment.vendor_handle::text? + from storefront_core.transaction_archive + join config.vendor_setting + on vendor_setting.customer_id = transaction_archive.customer_id + join storefront_core.payment + on payment.id = transaction_archive.payment_id + and payment.customer_id = transaction_archive.customer_id + where transaction_archive.customer_id = $1::bigint + and transaction_archive.id = $2::bigint + |] +#ifdef KRONOR_SYNTAX + , mkCase + "[06] hasql-th $CanBeValidated(...) splice is preserved verbatim in a select list" + 4 + [__i| + select + $CanBeValidated (api_key::text, 'config.t'::text, 'api_key'::text), + $CanBeValidated (private_key::text, 'config.t'::text, 'private_key'::text) + from config.northwind_provider_setting + where customer_id = $1::bigint + and id = $2::bigint + |] + [__i| + select + $CanBeValidated (api_key::text, 'config.t'::text, 'api_key'::text) + , $CanBeValidated (private_key::text, 'config.t'::text, 'private_key'::text) + from config.northwind_provider_setting + where customer_id = $1::bigint + and id = $2::bigint + |] +#endif +#ifdef KRONOR_SYNTAX + , mkCase + "[07] hasql-th $Name{...} record syntax: inlined braces are reformatted to Haskell-style leading-comma record" + 8 + [__i| + select $AuthRowData{ isCardSame = x::bool?, + rowServer = tse.row_server::text, + country = ae.country::text } + from app.row_details + where id = $1::uuid + |] + [__i| + select + $AuthRowData + { isCardSame = x::bool? + , rowServer = tse.row_server::text + , country = ae.country::text + } + from app.row_details + where id = $1::uuid + |] +#endif +#ifdef KRONOR_SYNTAX + , mkCase + "[08] hasql-th $1.$field record access survives inside BETWEEN x AND y and coalesce() args" + 8 + [__i| + select 1 + from t ext + where ext.org = $1.$orgId::bigint + and ext.d between $1.$start::date and $1.$end::date + and ext.acq = coalesce($1.$acq::text?, ext.acq) + |] + [__i| + select 1 + from t ext + where ext.org = $1.$orgId::bigint + and ext.d between $1.$start::date and $1.$end::date + and ext.acq = coalesce($1.$acq::text?, ext.acq) + |] +#endif + , mkCase + "[09] INSERT ... ON CONFLICT DO UPDATE SET puts the updated column assignment on its own indented line" + 4 + [__i| + insert into t (org_id, batch_id, data) + select $1::bigint, $2::text, unnest($3::jsonb[]) + on conflict (batch_id, md5(data::text)) + do update set data = excluded.data + |] + [__i| + insert into t + (org_id, batch_id, data) + select + $1::bigint + , $2::text + , unnest($3::jsonb[]) + on conflict (batch_id, md5(data::text)) + do update set + data = excluded.data + |] + , mkCase + "[10] WITH CTE + LEFT JOIN LATERAL fn(...): CTE body is multi-lined, last CTE closes with ')' not '),', ::text? survives inside the lateral function" + 8 + [__i| + with details as ( + select * from app.row_details + where id = $1::uuid ) + select details.id::uuid + from details + left join lateral fsm.notify ( shard := details.mid, event := $2::text, data := jsonb_build_object( 'error', $3::text? ) ) + on true + |] + [__i| + with details as ( + select * + from app.row_details + where id = $1::uuid + ) + select details.id::uuid + from details + left join lateral fsm.notify( + shard := details.mid + , event := $2::text + , data := jsonb_build_object('error', $3::text?) + ) + on true + |] + , mkCase + "[11] content inside single-quoted string literals ('U', 'Y', 'FM000') is not lowercased or otherwise touched" + 4 + [__i| + select (case when x is null then 'U' when x then 'Y' else 'N' end)::text, + to_char(n, 'FM000')::text + from t + where id = $1::uuid + |] + [__i| + select + (case + when x is null then 'U' + when x then 'Y' + else 'N' + end)::text + , to_char( + n + , 'FM000' + )::text + from t + where id = $1::uuid + |] + , mkCase + "[12] chained typecasts like ::text?::uuid? preserve both nullability markers (not just the last)" + 4 + [__i| + select (x->>'a')::text?, + (x->>'b')::text?::uuid?, + (x->>'c')::text? + from t + where id = $1::uuid + |] + [__i| + select + (x->>'a')::text? + , (x->>'b')::text?::uuid? + , (x->>'c')::text? + from t + where id = $1::uuid + |] + , mkCase + "[13] UPDATE ... SET: assigned expressions keep nullability chains like ::text?::uuid on the right-hand side" + 4 + [__i| + update app.row_details + set auth_response = $2::jsonb, + ds_trans_id = $3::text?::uuid + where id = $1::uuid + |] + [__i| + update app.row_details + set + auth_response = $2::jsonb + , ds_trans_id = $3::text?::uuid + where id = $1::uuid + |] + , mkCase + "[14] UNION ALL: both arms are formatted independently with their own multi-line select layout" + 4 + [__i| + select id::bigint, name::text from table_a where active = true + union all + select id::bigint, name::text from table_b where active = true + |] + [__i| + select + id::bigint + , name::text + from table_a + where active = true + union all + select + id::bigint + , name::text + from table_b + where active = true + |] + , mkCase + "[15] GROUP BY / ORDER BY / LIMIT each land on their own line at the base clause indent after WHERE" + 4 + [__i| + select provider::text, count(*)::bigint + from classification.ext + where org_id = $1::bigint + group by provider + order by count(*) desc + limit 10 + |] + [__i| + select + provider::text + , count(*)::bigint + from classification.ext + where org_id = $1::bigint + group by provider + order by count(*) desc + limit 10 + |] + , mkCase + "[16] DELETE FROM with a multi-predicate WHERE: ANDs are split onto their own indented lines" + 4 + [__i| + delete from history.some_table + where customer_id = $1::bigint + and id = $2::bigint + |] + [__i| + delete from history.some_table + where customer_id = $1::bigint + and id = $2::bigint + |] + , mkCase + "[17] FROM can be a set-returning function call (not just a table name) without losing the FROM keyword" + 4 + [__i| + select count(*)::bigint + from app.set_opts_and_config($1::text, $2::jsonb) + |] + [__i| + select count(*)::bigint + from app.set_opts_and_config($1::text, $2::jsonb) + |] + , mkCase + "[18] regression: ORDER BY inside an inline subquery is not emitted as 'order by order by' (R.sortClause already includes the keyword)" + 4 + [__i| + select id::bigint + from t + where id = (select id from u order by created_at desc limit 1) + |] + [__i| + select id::bigint + from t + where id = (select id from u order by created_at desc limit 1) + |] + , mkCase + "[19] regression: GROUP BY inside an inline subquery is not emitted as 'group by group by' (R.groupClause already includes the keyword)" + 4 + [__i| + select id::bigint + from t + where id = (select max(id) from u group by org_id) + |] + [__i| + select id::bigint + from t + where id = (select max(id) from u group by org_id) + |] + , mkCase + "[20] regression: ORDER BY inside an aggregate's argument list (string_agg(x, ',' order by y)) is not doubled" + 4 + [__i| + select string_agg(name, ', ' order by id)::text + from t + where org_id = $1::bigint + |] + [__i| + select string_agg( + name + , ', ' + order by id + )::text + from t + where org_id = $1::bigint + |] + , mkCase + "[21] x = ANY(array_expr) keeps the parens around the array expression (Postgres requires them when the operand isn't a subquery)" + 4 + [__i| + select id::bigint + from t + where customer_id = ANY($1::bigint[]) + |] + [__i| + select id::bigint + from t + where customer_id = any($1::bigint[]) + |] + , mkCase + "[22] CASE WHEN ... THEN ... ELSE ... END arms preserve hasql-th's ::text? nullable marker (don't fall through to the generic renderer)" + 4 + [__i| + update t + set x = case when $2::text? = 'Y' then $1::jsonb else x end + where id = $3::uuid + |] + [__i| + update t + set x = case when $2::text? = 'Y' then $1::jsonb else x end + where id = $3::uuid + |] + , mkCase + "[23] FROM with multiple tables and no joins stays on a single line (no 'from t1\\nfrom t2' duplication)" + 4 + [__i| + select t1.id::bigint + from t1, t2 + where t1.id = t2.id + |] + [__i| + select t1.id::bigint + from t1, t2 + where t1.id = t2.id + |] + , mkCase + "[24] nullable array typecast ::text[]? keeps the trailing ? (the second Bool in the array-dims tuple must be rendered)" + 4 + [__i| + update t + set statuses = $1::text[]? + where id = $2::uuid + |] + [__i| + update t + set statuses = $1::text[]? + where id = $2::uuid + |] +#ifdef KRONOR_SYNTAX + , mkCase + "[25] array[...] literal preserves hasql-th $1.$field access inside its element expressions" + 4 + [__i| + select enqueue(array[mk_payload(organization_id => $1.$organizationId::bigint, frequency => $2::text)])::text + |] + [__i| + select enqueue(array[mk_payload(organization_id => $1.$organizationId::bigint, frequency => $2::text)])::text + |] +#endif +#ifdef KRONOR_SYNTAX + , mkCase + "[26] ROW(...) constructor preserves $1.$field access and ::text? nullability on its elements" + 4 + [__i| + select create_payment(capture_input := ROW($2::bigint, $3::bigint::currency_unit, $4::text?)::capture_input, created_by := $5::text?) + |] + [__i| + select create_payment( + capture_input := row($2::bigint, $3::bigint::currency_unit, $4::text?)::capture_input + , created_by := $5::text? + ) + |] +#endif +#ifdef KRONOR_SYNTAX + , mkCase + "[27] inline subquery's FROM function-call (inside EXISTS (...)) preserves $1.$field in its argument list" + 4 + [__i| + select exists (select 1::int from gen($1.$orgId::bigint, $1.$cursor::text?))::bool + |] + [__i| + select exists (select 1::int from gen($1.$orgId::bigint, $1.$cursor::text?))::bool + |] +#endif +#ifdef KRONOR_SYNTAX + , mkCase + "[28] UNION ALL inside EXISTS (...) wraps when the inline form gets long; each arm preserves $1.$field" + 4 + [__i| + select exists (select 1::int from gen1($1.$orgId::bigint, $1.$cursor::text?) union all select 1::int from gen2($1.$orgId::bigint, $1.$cursor::text?))::bool + |] + [__i| + select exists ( + select 1::int + from gen1($1.$orgId::bigint, $1.$cursor::text?) + union all + select 1::int + from gen2($1.$orgId::bigint, $1.$cursor::text?) + )::bool + |] +#endif +#ifdef KRONOR_SYNTAX + , mkCase + "[29] EXTRACT(field FROM $1.$field::type) preserves the hasql-th field access inside the extracted expression" + 4 + [__i| + select extract(epoch from ($2.$expiresAt::timestamptz - now())) + |] + [__i| + select extract(epoch from ($2.$expiresAt::timestamptz - now())) + |] +#endif + , mkCase + "[30] multi-row VALUES emits the 'values' keyword once with comma-separated row tuples (not 'values (...) values (...)')" + 4 + [__i| + insert into t (a, b, c, d) + values + ($1::bigint, 'A', null, 'x'), + ($1::bigint, 'B', null, 'y') + |] + [__i| + insert into t + ( a + , b + , c + , d + ) + values + ( $1::bigint + , 'A' + , null + , 'x' + ), + ( $1::bigint + , 'B' + , null + , 'y' + ) + |] + , mkCase + "[31] LEFT JOIN with multi-condition ON: AND continuations under the ON clause" + 4 + [__i| + select t1.id::bigint + from t1 + left join t2 on t1.id = t2.t1_id and t1.kind = t2.kind and t1.org = t2.org + where t1.id = $1::bigint + |] + [__i| + select t1.id::bigint + from t1 + left join t2 + on t1.id = t2.t1_id + and t1.kind = t2.kind + and t1.org = t2.org + where t1.id = $1::bigint + |] + , mkCase + "[32] WITH chains multiple CTEs separated by '),' and ends the last with ')'" + 4 + [__i| + with parsed (parsed_cursor) as ( + select coalesce($1::jsonb, '{}'::jsonb) + ), + data as (select 1::int from parsed) + select 1::int from data + |] + [__i| + with parsed (parsed_cursor) as ( + select coalesce($1::jsonb, '{}'::jsonb) + ), + data as ( + select 1::int + from parsed + ) + select 1::int + from data + |] + , mkCase + "[33] CTE with explicit column list: 'with name (col1, col2) as (...)' preserves the column list parens" + 4 + [__i| + with rolled (a, b) as ( + select 1::int, 2::int + ) + select rolled.a::int from rolled + |] + [__i| + with rolled (a, b) as ( + select + 1::int + , 2::int + ) + select rolled.a::int + from rolled + |] + , mkCase + "[34] CROSS JOIN renders on its own line with no ON/USING qualifier" + 4 + [__i| + select t1.id::bigint + from t1 + cross join t2 + where t1.id = $1::bigint + |] + [__i| + select t1.id::bigint + from t1 + cross join t2 + where t1.id = $1::bigint + |] + , mkCase + "[35] INSERT ... ON CONFLICT DO NOTHING: 'on conflict' and 'do nothing' each go on their own line" + 4 + [__i| + insert into t (a, b, c) + values ($1::bigint, $2::text, $3::text) + on conflict + do nothing + |] + [__i| + insert into t + (a, b, c) + values + ( $1::bigint + , $2::text + , $3::text + ) + on conflict + do nothing + |] + , mkCase + "[36] UPDATE ... FROM: the FROM clause goes on its own line between SET and WHERE" + 4 + [__i| + update t1 set x = t2.y from t2 where t1.id = t2.id and t1.id = $1::bigint + |] + [__i| + update t1 + set x = t2.y + from t2 + where t1.id = t2.id + and t1.id = $1::bigint + |] + , mkCase + "[37] DELETE ... USING: the USING clause goes on its own line between DELETE and WHERE" + 4 + [__i| + delete from t1 using t2 where t1.id = t2.id and t1.id = $1::bigint + |] + [__i| + delete from t1 + using t2 + where t1.id = t2.id + and t1.id = $1::bigint + |] + , mkCase + "[38] Function call with multiple arguments wraps each argument onto its own line, with closing paren back at the function's column" + 4 + [__i| + select app.save_records_pre_commit($2::text, $1::jsonb, $3::jsonb, $4::bytea, $5::jsonb)::uuid + |] + [__i| + select app.save_records_pre_commit( + $2::text + , $1::jsonb + , $3::jsonb + , $4::bytea + , $5::jsonb + )::uuid + |] + , mkCase + "[39] LEFT JOIN LATERAL with a function call that has multiple named args wraps the call onto multiple lines" + 4 + [__i| + select 1::int + from t + left join lateral fsm.notify_state_machine(shard := $1::bigint, machine := $2::bigint, event := 'foo', data := jsonb_build_object('a', $3::text)) on true + |] + [__i| + select 1::int + from t + left join lateral fsm.notify_state_machine( + shard := $1::bigint + , machine := $2::bigint + , event := 'foo' + , data := jsonb_build_object('a', $3::text) + ) + on true + |] + , mkCase + "[40] Single-argument function call stays inline (no wrap when args < threshold)" + 4 + [__i| + select md5($1::text)::text + |] + [__i| + select md5($1::text)::text + |] + , mkCase + "[41] Two-argument function call wraps onto multiple lines (threshold is 2)" + 4 + [__i| + select to_char(n, 'FM000')::text from t + |] + [__i| + select to_char( + n + , 'FM000' + )::text + from t + |] + , mkCase + "[42] string literal containing ' and ' is not split as a boolean AND" + 4 + [__i| + select id::bigint from t + where label = 'apple and orange' + and other = $1::text + |] + [__i| + select id::bigint + from t + where label = 'apple and orange' + and other = $1::text + |] + , mkCase + "[43] string literal containing ' :: ' is preserved verbatim" + 4 + [__i| + select id::bigint from t + where note = 'see x :: y for details' + |] + [__i| + select id::bigint + from t + where note = 'see x :: y for details' + |] + , mkCase + "[44] FOR UPDATE inside an inline subquery is preserved" + 4 + [__i| + select id::bigint from t + where exists (select 1 from u where u.t_id = t.id for update) + |] + [__i| + select id::bigint + from t + where exists (select 1 from u where u.t_id = t.id for update) + |] + , mkCase + "[45] Chained typecasts on a function-call select target keep every cast" + 4 + [__i| + select jsonb_build_object($1::text, $2::text)::text::bytea from t + |] + [__i| + select jsonb_build_object( + $1::text + , $2::text + )::text::bytea + from t + |] + , mkCase + "[46] Top-level WINDOW clause is preserved on its own line" + 4 + [__i| + select row_number() over w::bigint from t window w as (partition by x order by y) + |] + [__i| + select row_number() over w::bigint + from t + window w as (partition by x order by y) + |] + , mkCase + "[47] CTE materialization hint (MATERIALIZED) is preserved" + 4 + [__i| + with cte as materialized (select 1::bigint as x) + select x::bigint from cte + |] + [__i| + with cte as materialized ( + select 1::bigint as x + ) + select x::bigint + from cte + |] + , mkCase + "[48] INSERT ... OVERRIDING SYSTEM VALUE is preserved on its own line" + 4 + [__i| + insert into t (id, name, kind, source) overriding system value + select x.id::bigint, x.name::text, x.kind::text, x.source::text from src x + |] + [__i| + insert into t + ( id + , name + , kind + , source + ) + overriding system value + select + x.id::bigint + , x.name::text + , x.kind::text + , x.source::text + from src x + |] + , mkCase + "[49] Nested function calls wrap recursively; jsonb_build_object groups (key, value) pairs onto one line when wrapped; trailing args after a wrapped sub-call line up with the leading-comma column" + 4 + [__i| + select job_queue.enqueue_payload( + array_agg( + job_queue.mk_payload( + caller => 'Sample.Vantage.FetchSettlements', + provider => 'Vantage', + payload => jsonb_build_object( + 'tag', 'FetchVantageBatchesTag', + 'contents', jsonb_build_object( + 'organizationId', inserted.organization_id, + 'vantageSettlementId', inserted.id, + 'stateMachineId', $4::bigint + ) + ), + run_at => now(), + timeout => '1 day'::interval + ) + )::jsonb[], + priority_ := 100 + )::text + from inserted + |] + [__i| + select job_queue.enqueue_payload( + array_agg( + job_queue.mk_payload( + caller => 'Sample.Vantage.FetchSettlements' + , provider => 'Vantage' + , payload => jsonb_build_object( + 'tag', 'FetchVantageBatchesTag' + , 'contents', jsonb_build_object( + 'organizationId', inserted.organization_id + , 'vantageSettlementId', inserted.id + , 'stateMachineId', $4::bigint + ) + ) + , run_at => now() + , timeout => '1 day'::interval + ) + )::jsonb[] + , priority_ := 100 + )::text + from inserted + |] + , mkCase + "[50] EXISTS subquery in a CTE wraps multi-line when the inline form gets too long" + 4 + [__i| + with customer_note as ( + select exists (select * from storefront_core.customer_note where customer_id = current_setting('app.customer_id')::bigint and customer_reference = current_setting('app.customer_reference')::text and fingerprint = $2::uuid) card_exists + ) + select (save_card_details and not customer_note.card_exists)::boolean + from app.row_details, customer_note + where row_details.customer_id = current_setting('app.customer_id')::bigint + and row_details.id = $1::uuid + |] + [__i| + with customer_note as ( + select exists ( + select * + from storefront_core.customer_note + where customer_id = current_setting('app.customer_id')::bigint + and customer_reference = current_setting('app.customer_reference')::text + and fingerprint = $2::uuid + ) card_exists + ) + select (save_card_details and not customer_note.card_exists)::boolean + from app.row_details, customer_note + where row_details.customer_id = current_setting('app.customer_id')::bigint + and row_details.id = $1::uuid + |] + , mkCase + "[51] SQL keyword-form functions (position / substring / trim / overlay) emit no space before '('" + 4 + [__i| + select position(' ' in name)::int + , substring(s from 1 for 5)::text + , substring(s, 1, 5)::text + , trim(both ' ' from name)::text + , overlay(name placing 'x' from 1 for 1)::text + from t + where id = $1::bigint + |] + [__i| + select + position(' ' in name)::int + , substring(s from 1 for 5)::text + , substring(s, 1, 5)::text + , trim(both ' ' from name)::text + , overlay(name placing 'x' from 1 for 1)::text + from t + where id = $1::bigint + |] + , mkCase + "[52] array[fn(...)] literal whose element is a wrap-eligible call expands the inner call across multiple lines" + 4 + [__i| + select job_queue.enqueue_payload( + array[job_queue.mk_payload(caller => 'X', provider => 'PayWallet', payload => jsonb_build_object('tag', 'FetchTag', 'contents', jsonb_build_object('organizationId', $1::bigint, 'ledgerId', $2::bigint, 'cursor', $3::text)))] + , priority_ := 5000 + )::text + |] + [__i| + select job_queue.enqueue_payload( + array[ + job_queue.mk_payload( + caller => 'X' + , provider => 'PayWallet' + , payload => jsonb_build_object( + 'tag', 'FetchTag' + , 'contents', jsonb_build_object( + 'organizationId', $1::bigint + , 'ledgerId', $2::bigint + , 'cursor', $3::text + ) + ) + ) + ] + , priority_ := 5000 + )::text + |] + , mkCase + "[53] FROM-list `from fn(args)` wraps when the function call has multiple args" + 4 + [__i| + select count(*)::bigint + from job_queue.enqueue_payload(array[job_queue.mk_payload(customer_id => $1::bigint, caller => 'Foo', payload => jsonb_build_object('tag', 'X', 'contents', jsonb_build_object('orgId', $2::bigint, 'cursor', $3::text)))]::jsonb[], priority_ := 5000) + |] + [__i| + select count(*)::bigint + from job_queue.enqueue_payload( + array[ + job_queue.mk_payload( + customer_id => $1::bigint + , caller => 'Foo' + , payload => jsonb_build_object( + 'tag', 'X' + , 'contents', jsonb_build_object( + 'orgId', $2::bigint + , 'cursor', $3::text + ) + ) + ) + ]::jsonb[] + , priority_ := 5000 + ) + |] + , mkCase + "[54] Single-arg outer call (e.g. unnest) with a long array arg wraps via the select-target length gate" + 4 + [__i| + select unnest(array[format('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa', $1::text), format('bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb', $2::text)])::text + from t + |] + [__i| + select unnest( + array[ + format( + 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' + , $1::text + ) + , format( + 'bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb' + , $2::text + ) + ] + )::text + from t + |] + , mkCase + "[55] (expr)::type — parenthesized wrap-eligible expression with a typecast wraps when too long" + 4 + [__i| + select (json_build_object('https://myapp.dev/jwt/claims', $2::jsonb?, 'iat', extract(epoch from now()), 'exp', extract(epoch from now() + interval '1 hour'), 'uid', $4::text?, 'utype', $3::text?, 'uname', null, 'registered_email', $1::text?)::jsonb)::json + |] + [__i| + select ( + json_build_object( + 'https://myapp.dev/jwt/claims', $2::jsonb? + , 'iat', extract(epoch from now()) + , 'exp', extract(epoch from now() + interval '1 hour') + , 'uid', $4::text? + , 'utype', $3::text? + , 'uname', null + , 'registered_email', $1::text? + )::jsonb + )::json + |] + , mkCase + "[56] FROM unnest(...) AS alias (col1, col2, ..., colN) wraps the column list when it has more than 3 columns" + 4 + [__i| + select count(*)::bigint from unnest($1::int[]) as txn_row (entry_reference, external_status, currency, amount, transaction_type, name, booking_date, value_date) + |] + [__i| + select count(*)::bigint + from unnest($1::int[]) as txn_row + ( entry_reference + , external_status + , currency + , amount + , transaction_type + , name + , booking_date + , value_date + ) + |] +#ifdef KRONOR_SYNTAX + , mkCase + "[57] hasql-th nested $Record{...} fields expand multi-line when an inner record's inline form is long" + 8 + [__i| + select $PaymentSource{ wallet = $Wallet{ experienceContext = $ExperienceContext{ brandName = customer.name::text, returnUrl = wallet_payment.return_url::text, cancelUrl = wallet_payment.return_url::text } } } + from t + where id = $1::uuid + |] + [__i| + select + $PaymentSource + { wallet = $Wallet + { experienceContext = $ExperienceContext + { brandName = customer.name::text + , returnUrl = wallet_payment.return_url::text + , cancelUrl = wallet_payment.return_url::text + } + } + } + from t + where id = $1::uuid + |] +#endif + , mkCase + "[58] CROSS JOIN (VALUES ...) with many tuples wraps multi-line; each tuple > 3 cols also expands to bracket-list" + 4 + [__i| + select m.id::bigint, payment_method.column1::text, payment_method.column2::int + from config.customer m + cross join (values ('SUCCESSFUL_WALLET_PAYMENT', 71, 400, 'SEK', 'Wallet payment charge'), ('SUCCESSFUL_DIRECT_DEBIT_PAYMENTS', 72, 300, 'SEK', 'Direct Debit (Open Banking)'), ('SUCCESSFUL_CREDIT_CARD_PAYMENTS', 83, 45, 'SEK', 'Credit card fee')) as payment_method + |] + [__i| + select + m.id::bigint + , payment_method.column1::text + , payment_method.column2::int + from config.customer m + cross join ( + values + ( 'SUCCESSFUL_WALLET_PAYMENT' + , 71 + , 400 + , 'SEK' + , 'Wallet payment charge' + ), + ( 'SUCCESSFUL_DIRECT_DEBIT_PAYMENTS' + , 72 + , 300 + , 'SEK' + , 'Direct Debit (Open Banking)' + ), + ( 'SUCCESSFUL_CREDIT_CARD_PAYMENTS' + , 83 + , 45 + , 'SEK' + , 'Credit card fee' + ) + ) as payment_method + |] + , mkCase + "[59] CASE expressions in SET RHS expand multi-line when the inline form gets long; body aligns under the CASE keyword" + 4 + [__i| + update app.row_details + set + challenge_response = case when $3::text? = 'Y' then $2::jsonb else challenge_response end + , post_auth_response = case when $3::text? = 'Y' then $2::jsonb else post_auth_response end + , error_response = case when $3::text? != 'Y' or $3::text? is null then $2::jsonb else error_response end + where id = $1::uuid + |] + [__i| + update app.row_details + set + challenge_response = case + when $3::text? = 'Y' then $2::jsonb + else challenge_response + end + , post_auth_response = case + when $3::text? = 'Y' then $2::jsonb + else post_auth_response + end + , error_response = case + when $3::text? != 'Y' or $3::text? is null then $2::jsonb + else error_response + end + where id = $1::uuid + |] +#ifdef KRONOR_SYNTAX + , mkCase + "[60] hasql-th $Foo (...) splice wraps multi-line when inline form is long; SQL inside its args (CASE, parens, casts) wraps the same way it would at the top-level SELECT-target position" + 4 + [__i| + select + mobile_charge.id::uuid + , $CanBeValidated ((case mobile_charge.payment_category when 'StandAlone' then (select client_credentials_public from customer_as_target) else (select client_credentials_public from vendor_as_target) end)::text, 'config.wallet_config'::text, 'client_credentials_public'::text) + from history.mobile_charge + |] + [__i| + select + mobile_charge.id::uuid + , $CanBeValidated ( + (case mobile_charge.payment_category + when 'StandAlone' then ( + select client_credentials_public + from customer_as_target + ) + else ( + select client_credentials_public + from vendor_as_target + ) + end)::text + , 'config.wallet_config'::text + , 'client_credentials_public'::text + ) + from history.mobile_charge + |] +#endif + , mkCase + "[61] CASE expression in a top-level SELECT target always wraps multi-line, even when its inline form would fit under the length threshold" + 4 + [__i| + select + pma.country::text + , (case when row_details.row_method_invoked then 'Y' else 'N' end)::text + , row_details.row_trans_id::uuid + from app.row_details + join config.payment_method_provider pma on pma.id = row_details.pma_id + where row_details.id = $1::uuid + |] + [__i| + select + pma.country::text + , (case + when row_details.row_method_invoked then 'Y' + else 'N' + end)::text + , row_details.row_trans_id::uuid + from app.row_details + join config.payment_method_provider pma + on pma.id = row_details.pma_id + where row_details.id = $1::uuid + |] + , mkCase + "[62] bare CASE in SELECT target (no surrounding parens, optional trailing typecast on @end@) wraps with body indented relative to the @case@ keyword's column, not the outer block's nest level" + 4 + [__i| + select + id::text + , currency::text + , case transaction_type when 'CAPTURE' then 'Purchase' when 'REFUND' then 'Refund' end::text + , amount::int + from storefront_core.ledger + where customer_id = $1::bigint + |] + [__i| + select + id::text + , currency::text + , case transaction_type + when 'CAPTURE' then 'Purchase' + when 'REFUND' then 'Refund' + end::text + , amount::int + from storefront_core.ledger + where customer_id = $1::bigint + |] + , mkCase + "[63] single-target SELECT whose target is a top-level CASE forces block-list layout (`select` ends the line, `case` starts at item-content column) so @end@ lines up under @case@ — instead of @case@ landing mid-line after `select ` and the body / @end@ being pushed far right by 'align'" + 4 + [__i| + select case when status = 'won' then fsm.notify_state_machine(shard := organization_id, machine := state_machine_id, event := 'dispute.won') when status = 'lost' then fsm.notify_state_machine(shard := organization_id, machine := state_machine_id, event := 'dispute.lost') end::text + from classification.provider_dispute dispute + where organization_id = $1::bigint + and dispute.id = $2::uuid + |] + [__i| + select + case + when status = 'won' then fsm.notify_state_machine( + shard := organization_id + , machine := state_machine_id + , event := 'dispute.won' + ) + when status = 'lost' then fsm.notify_state_machine( + shard := organization_id + , machine := state_machine_id + , event := 'dispute.lost' + ) + end::text + from classification.provider_dispute dispute + where organization_id = $1::bigint + and dispute.id = $2::uuid + |] + , mkCase + "[64] inline subquery `SELECT DISTINCT ON (...)` keeps the `ON (...)` clause — regression guard" + 4 + [__i| + insert into reference.code_bins (start_num, end_num, num_length) + select (row_data->>'start_num')::numeric, (row_data->>'end_num')::numeric, (row_data->>'num_length')::bigint + from (select distinct on (row_data->>'start_num', row_data->>'end_num') row_data from jsonb_array_elements($1::jsonb) as row_data) s + on conflict (start_num, end_num) do nothing + |] + [__i| + insert into reference.code_bins + (start_num, end_num, num_length) + select + (row_data->>'start_num')::numeric + , (row_data->>'end_num')::numeric + , (row_data->>'num_length')::bigint + from ( + select distinct on (row_data ->> 'start_num', row_data ->> 'end_num') row_data + from jsonb_array_elements($1::jsonb) as row_data + ) s + on conflict (start_num, end_num) + do nothing + |] + ] + + +main :: IO () +main = do + let results = map runTest tests + failures = filter (not . fst) results + mapM_ + ( \(_, msg) -> do + TIO.putStrLn "---" + TIO.putStrLn msg + ) + failures + if null failures + then do + putStrLn $ "All " <> show (length tests) <> " tests passed." + else do + putStrLn $ "\n" <> show (length failures) <> " of " <> show (length tests) <> " tests FAILED." + exitWith (ExitFailure 1) + + +runTest :: TestCase -> (Bool, Text) +runTest TestCase{name, qqCol, input, expected} = + -- 'formatSql' now returns 'Left' on AST mismatch; treating that as a + -- failure is the whole point of this test suite — if the formatter ever + -- emits semantically-different SQL, the test reports it as such. + let actual = either ("ERROR: " <>) id (formatSql qqCol (T.stripEnd input)) + stringEq = T.stripEnd actual == T.stripEnd expected + -- Semantic guard on the test fixture itself: the hand-written + -- `expected` must parse to the same AST as `input`. Catches a + -- fixture-authoring mistake even before the formatter runs. + astFixtureEq = case (parseAst input, parseAst expected) of + (Just a, Just b) -> a == b + _ -> True -- can't parse one side; defer to string check + -- Semantic guard on the formatter output: parsing `actual` must + -- yield the same AST as `input`. Catches a renderer that drops + -- or alters a clause but still emits valid SQL (the + -- `DISTINCT ON (...)` regression that motivated this guard). + astFormatterEq = case (parseAst input, parseAst actual) of + (Just a, Just b) -> a == b + _ -> True + pass = stringEq && astFixtureEq && astFormatterEq + reason + | not stringEq = "string mismatch" + | not astFixtureEq = "AST mismatch: expected fixture is not semantically equivalent to input" + | not astFormatterEq = "AST mismatch: formatter output is not semantically equivalent to input" + | otherwise = "" + msg = + if pass + then "PASS: " <> name + else + "FAIL (" + <> reason + <> "): " + <> name + <> "\n=== INPUT ===\n" + <> showWhitespace input + <> "\n=== EXPECTED ===\n" + <> showWhitespace expected + <> "\n=== ACTUAL ===\n" + <> showWhitespace actual + in (pass, msg) + + +-- | Show whitespace characters for debugging +showWhitespace :: Text -> Text +showWhitespace = T.pack . concatMap showC . T.unpack + where + showC '\n' = "\\n\n" + showC c = [c]