packages feed

hq-json (empty) → 0.1.1

raw patch · 50 files changed

+8985/−0 lines, 50 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, file-embed, hq-json, megaparsec, optparse-applicative, parser-combinators, relude, scientific, streaming, sydtest, sydtest-discover, text, vector

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2022 damianfral <huevofritopamojarpan@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,285 @@+# hq++`hq` is a JSON processor inspired by `jq`. It queries JSON with optics and+rewrites values with transformations, streaming input so large documents+never load fully into memory.++## Usage++```sh+hq [OPTIONS] COMMAND OPTIC [ARGS] < input.json+```++```text+hq v0.1.0++Usage: hq [-f|--file FILE] [-r|--raw] [-c|--compact] [-j|--join] COMMAND++  Query JSON using optics++Available options:+  -f,--file FILE           Input JSON file, or '-' for stdin+  -r,--raw                 Print strings without JSON quotes+  -c,--compact             Print compact JSON+  -j,--join                Print without separators+  -h,--help                Show this help text++Available commands:+  fold                     +  preview                  +  set                      +  over                     +  delete+```++## Commands++Optics are used with different queries:++| Command | Meaning |+| --- | --- |+| `fold OPTIC` | Print every focused value, one per line. |+| `preview OPTIC` | Print at most the first focused value. |+| `set OPTIC VALUE` | Replace each focus with `VALUE`. |+| `over OPTIC TRANSFORMATION` | Rewrite each focused value in place. |+| `delete OPTIC` | Remove each focused value. |++`preview` accepts any optic and prints its first focus in document+order, stopping input there; it is `fold` capped at one value.+`set` takes a JSON literal and+is `over` with a constant transformation. `over` fails the whole query+when a focused value rejects the transformation (adding to a string,+for example). Deleting a missing field, or an empty focus, leaves the+input unchanged.++Input may hold any number of whitespace-separated JSON values+(JSON-lines style); every command except `preview` processes each+top-level value in turn.++## Optic language++Optics select and traverse JSON values. Optics are composed with `.`;+each component focuses on a new set of values. Spaces around `.` are+optional, so `@a.each.@b` means `@a . each . @b`. Parentheses group+explicitly: `(@a . each) . @b`.++An optic may focus on nothing at all (a missing field, a value of the+wrong shape, an out-of-bounds `ix`); such focuses simply select no+values. Rewriting through `keys` renames object members.++| Optic | Meaning |+| --- | --- |+| `@field` | Focus the `"field"` member of an object. |+| `each` | Focus every element of an array, or every value of an object. |+| `keys` | Focus every object key, as a string. |+| `values` | Focus every value of an object. For arrays use `each` or `ix`. |+| `id` | Focus the whole value unchanged (the unit of `.`). |+| `_String` | Focus the value only if it is a string, and nothing otherwise. |+| `_Number` | Focus the value only if it is a number, and nothing otherwise. |+| `_Bool` | Focus the value only if it is a boolean, and nothing otherwise. |+| `_Null` | Focus the value only if it is null, and nothing otherwise. |+| `_Array` | Focus the value only if it is an array, and nothing otherwise. |+| `_Object` | Focus the value only if it is an object, and nothing otherwise. |+| `_Just` | Focus any non-null value. |+| `ix N` | Focus array element `N` (0-based). |+| `A . B` | Composition: focus `A`, then `B` within each target. |++### `filter OPTIC TRANSFORMATION`++Keep the input when `TRANSFORMATION` maps some value focused by `OPTIC`+to `true`, and focus on nothing otherwise. The transformation must+produce a boolean.++Single atoms stay bare:++```sh+filter @age == 30+```++Anything longer takes its own paren group per side:++```sh+filter (each . @age) (== 30)+```++A `.` after a bare optic starts an outer composition, so a dotted optic+inside `filter` needs its sides parenthesized:++```sh+each . filter (@tags . each) (== "x")+```++Examples:++- `@name` : Focus the `"name"` field.+- `@users . each . @name` : Focus the `"name"` field of every+  element in `"users"`.+- `@users . each . @age` : Focus the `"age"` field of every element+  in `"users"`.+- `each . _Number` : Focus every number inside an array.+- `@a . ix 1` : Focus the second element of the array in `"a"`.++## Transformations++Transformations describe how a focused value is rewritten. They apply+to one value at a time and compose right-to-left with `.`: in `A . B`,+`B` runs first and `A` runs over its result. So `+ 1 . * 2` doubles+first, then adds one.++Operators bind tightest at the atoms, then `.`, then `and`/`&&`, then+`xor`/`^^`, then `or`/`||` loosest. Parentheses override:+`(== "x") or (== "hi")`.++### Numbers (input and output are numbers)++| Transformation | Meaning |+| --- | --- |+| `+ N` | Add `N`. Example: `+ 1`. |+| `* N` | Multiply by `N`. Example: `* 2`. |+| `- N` | Subtract `N`. Example: `- 1`. |++### Comparisons (input is a number, output is a boolean)++| Transformation | Meaning |+| --- | --- |+| `< N` | Test whether the value is less than `N`. Example: `< 30`. |+| `<= N` | Test whether the value is at most `N`. Example: `<= 30`. |+| `> N` | Test whether the value is greater than `N`. Sugar for `not . <= N`. |+| `>= N` | Test whether the value is at least `N`. Sugar for `not . < N`. |++### Strings (input is a string)++| Transformation | Meaning |+| --- | --- |+| `++ "s"` | Append `s`. Example: `++ "!"`. |+| `trim` | Strip surrounding whitespace. |+| `replace "a" "b"` | Replace occurrences of `a` with `b`. |+| `stripPrefix "p"` | Remove the prefix when present. |+| `stripSuffix "s"` | Remove the suffix when present. |+| `isPrefixOf "p"` | Test whether the value starts with `p`. |+| `isSuffixOf "s"` | Test whether the value ends with `s`. |+| `isInfixOf "i"` | Test whether the value contains `i`. |++`stripPrefix` and `stripSuffix` leave the value unchanged when the+affix is absent. The `is*` tests yield a boolean.++### Arrays (input is an array)++| Transformation | Meaning |+| --- | --- |+| `concat [...]` | Append the given elements. Example: `concat [3, 4]`. |+| `reverse` | Reverse the elements. |+| `unique` | Drop duplicates, keeping first occurrences. |+| `sort` | Sort (canonical order): null, bools, nums, strings, arrays, objs. |+| `length` | Element count, as a number. |+| `isEmpty` | Test whether the array is empty, yielding a boolean. |++### Objects (input is an object)++| Transformation | Meaning |+| --- | --- |+| `merge {...}` | Shallow-merge the operand into the value (operand has pref). |+| `deepMerge {...}` | Recursively merge the operand into the value. |++### Any value++| Transformation | Meaning |+| --- | --- |+| `== VALUE` (or `= VALUE`) | Test equality with a JSON literal. |+| `const VALUE` | Replace with `VALUE`. |++Equality examples: `== 30`, `== "hi"`, `== true`. `set` is `over`+with `const`.++### Booleans (inputs are booleans, outputs are booleans)++| Transformation | Meaning |+| --- | --- |+| `not` | Negate the value. |+| `A or B` (or `A \|\| B`) | Disjunction; `B` runs only when `A` is `false`. |+| `A and B` (or `A && B`) | Conjunction; `B` runs only when `A` is `true`. |+| `A xor B` (or `A ^^ B`) | Exclusive disjunction. |+| `A . B` | Composition: apply `B` first, then `A` over its result. |++For example:++```sh+hq over '@users . each . @age' '+ 1'+```++increments every user's age, and++```sh+hq over '@users . each . @name' 'stripPrefix "dr. "'+```++strips the prefix from every user's name when present.++### Static checks++Queries are checked before running. Steps that cannot work are+rejected up front instead of failing mid-stream:++- `/ 0` is rejected: division by zero.+- A transformation applied where it cannot fit is rejected:+  `over 'each._Number' '++ "x"'` fails because the optic focuses+  numbers and the transformation needs a string. Optics without a+  pinned shape (`@field`, `each`, `ix`) focus values of unknown+  type and accept anything; only prisms (and `keys`) narrow the+  focus, so only provable mismatches are reported.+- `filter` predicates must produce booleans, and accept their+  sub-optic's focus type.++## Examples++```sh+echo '{"name":"ada","score":96}' | hq fold '@name'+# "ada"++echo '{"name":"ada"}' | hq fold '@name' -r+# ada (raw: strings print without quotes)++echo '{"a":[1,2,3]}' | hq fold '@a . each'+# 1, 2, 3 (one per line)++echo '[{"a":90},{"a":96}]' | hq fold 'each . filter (@a) (== 90)' -c+# [{"a":90}]++echo '{"a":1}' | hq over '@a' '+ 1' -c+# {"a":2}++echo '{"a":1,"b":2}' | hq set '@b' '3' -c+# {"a":1,"b":3}++echo '{"a":1,"b":2}' | hq delete '@b' -c+# {"a":1}++# nix+nix build . --json \+  | hq -r fold 'each . @outputs . values' \+  | cachix push my-cachix-cache++# Kubernetes+kubectl get pods -o json \+  | hq -r fold '@items . each . @metadata . @name'++# ffmpeg+ffprobe -v quiet -print_format json -show_streams video.mp4 \+  | hq -r fold 'each . @codec_name'++# Github+curl -s https://api.github.com/repos/damianfral/hq \+  | hq -r fold '@topics.each'+```++## Performance++On the 100 MB hq-bench-data benchmark (bench/bench.sh), fold runs about+3x faster than jq, while over/set/delete perform around 1.2x faster.++hq streams the input without materializing the document, keeping peak+RSS at \~14MB versus \~600 MB for jq.++![runtime](https://raw.githubusercontent.com/damianfral/hq/refs/heads/master/bench/v0.1.1/bench_runtime.svg)++![memory](https://raw.githubusercontent.com/damianfral/hq/refs/heads/master/bench/v0.1.1/bench_memory.svg)
+ app/Main.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Main (main) where++import HQ.CLI (runCLI)+import Relude++main :: IO ()+main = runCLI
+ docs/LANG.md view
@@ -0,0 +1,242 @@+# hq language reference++## Commands++Optics are used with different queries:++| Command | Meaning |+| --- | --- |+| `fold OPTIC` | Print every focused value, one per line. |+| `preview OPTIC` | Print at most the first focused value. |+| `set OPTIC VALUE` | Replace each focus with `VALUE`. |+| `over OPTIC TRANSFORMATION` | Rewrite each focused value in place. |+| `delete OPTIC` | Remove each focused value. |++`preview` accepts any optic and prints its first focus in document+order, stopping input there; it is `fold` capped at one value.+`set` takes a JSON literal and+is `over` with a constant transformation. `over` fails the whole query+when a focused value rejects the transformation (adding to a string,+for example). Deleting a missing field, or an empty focus, leaves the+input unchanged.++Input may hold any number of whitespace-separated JSON values+(JSON-lines style); every command except `preview` processes each+top-level value in turn. Trailing bytes that do not parse as JSON are+an error.++## Optic language++Optics select and traverse JSON values. Optics are composed with `.`;+each component focuses on a new set of values. Spaces around `.` are+optional, so `@a.each.@b` means `@a . each . @b`. Parentheses group+explicitly: `(@a . each) . @b`.++An optic may focus on nothing at all (a missing field, a value of the+wrong shape, an out-of-bounds `ix`); such focuses simply select no+values. Rewriting through `keys` renames object members.++| Optic | Meaning |+| --- | --- |+| `@field` | Focus the `"field"` member of an object. |+| `each` | Focus every element of an array, or every value of an object. |+| `keys` | Focus every object key, as a string. |+| `values` | Focus every value of an object. For arrays use `each` or `ix`. |+| `id` | Focus the whole value unchanged (the unit of `.`). |+| `_String` | Focus the value only if it is a string, and nothing otherwise. |+| `_Number` | Focus the value only if it is a number, and nothing otherwise. |+| `_Bool` | Focus the value only if it is a boolean, and nothing otherwise. |+| `_Null` | Focus the value only if it is null, and nothing otherwise. |+| `_Array` | Focus the value only if it is an array, and nothing otherwise. |+| `_Object` | Focus the value only if it is an object, and nothing otherwise. |+| `_Just` | Focus any non-null value. |+| `ix N` | Focus array element `N` (0-based). |+| `A . B` | Composition: focus `A`, then `B` within each target. |++### `filter OPTIC TRANSFORMATION`++Keep the input when `TRANSFORMATION` maps some value focused by `OPTIC`+to `true`, and focus on nothing otherwise. The transformation must+produce a boolean.++Single atoms stay bare:++```hq+filter @age == 30+```++Anything longer takes its own paren group per side:++```hq+filter (each . @age) (== 30)+```++A `.` after a bare optic starts an outer composition, so a dotted optic+inside `filter` needs its sides parenthesized:++```hq+each . filter (@tags . each) (== "x")+```++Examples:++- `@name` : Focus the `"name"` field.+- `@users . each . @name` : Focus the `"name"` field of every+  element in `"users"`.+- `@users . each . @age` : Focus the `"age"` field of every element+  in `"users"`.+- `each . _Number` : Focus every number inside an array.+- `@a . ix 1` : Focus the second element of the array in `"a"`.++## Transformations++Transformations describe how a focused value is rewritten. They apply+to one value at a time and compose right-to-left with `.`: in `A . B`,+`B` runs first and `A` runs over its result. So `+ 1 . * 2` doubles+first, then adds one.++Operators bind tightest at the atoms, then `.`, then `and`/`&&`, then+`xor`/`^^`, then `or`/`||` loosest. Parentheses override:+`(== "x") or (== "hi")`.++### Numbers (input and output are numbers)++| Transformation | Meaning |+| --- | --- |+| `+ N` | Add `N`. Example: `+ 1`. |+| `* N` | Multiply by `N`. Example: `* 2`. |+| `- N` | Subtract `N`. Example: `- 1`. |++### Comparisons (input is a number, output is a boolean)++| Transformation | Meaning |+| --- | --- |+| `< N` | Test whether the value is less than `N`. Example: `< 30`. |+| `<= N` | Test whether the value is at most `N`. Example: `<= 30`. |+| `> N` | Test whether the value is greater than `N`. Sugar for `not . <= N`. |+| `>= N` | Test whether the value is at least `N`. Sugar for `not . < N`. |++### Strings (input is a string)++| Transformation | Meaning |+| --- | --- |+| `++ "s"` | Append `s`. Example: `++ "!"`. |+| `trim` | Strip surrounding whitespace. |+| `replace "a" "b"` | Replace occurrences of `a` with `b`. |+| `stripPrefix "p"` | Remove the prefix when present. |+| `stripSuffix "s"` | Remove the suffix when present. |+| `isPrefixOf "p"` | Test whether the value starts with `p`. |+| `isSuffixOf "s"` | Test whether the value ends with `s`. |+| `isInfixOf "i"` | Test whether the value contains `i`. |++`stripPrefix` and `stripSuffix` leave the value unchanged when the+affix is absent. The `is*` tests yield a boolean.++### Arrays (input is an array)++| Transformation | Meaning |+| --- | --- |+| `concat [...]` | Append the given elements. Example: `concat [3, 4]`. |+| `reverse` | Reverse the elements. |+| `unique` | Drop duplicates, keeping first occurrences. |+| `sort` | Sort (canonical order): null, bools, nums, strings, arrays, objs. |+| `length` | Element count, as a number. |+| `isEmpty` | Test whether the array is empty, yielding a boolean. |++### Objects (input is an object)++| Transformation | Meaning |+| --- | --- |+| `merge {...}` | Shallow-merge the operand into the value (operand has pref). |+| `deepMerge {...}` | Recursively merge the operand into the value. |++### Any value++| Transformation | Meaning |+| --- | --- |+| `== VALUE` (or `= VALUE`) | Test equality with a JSON literal. |+| `const VALUE` | Replace with `VALUE`. |++Equality examples: `== 30`, `== "hi"`, `== true`. `set` is `over`+with `const`.++### Booleans (inputs are booleans, outputs are booleans)++| Transformation | Meaning |+| --- | --- |+| `not` | Negate the value. |+| `A or B` (or `A \|\| B`) | Disjunction; `B` runs only when `A` is `false`. |+| `A and B` (or `A && B`) | Conjunction; `B` runs only when `A` is `true`. |+| `A xor B` (or `A ^^ B`) | Exclusive disjunction. |+| `A . B` | Composition: apply `B` first, then `A` over its result. |++For example:++```sh+hq over '@users . each . @age' '+ 1'+```++increments every user's age, and++```sh+hq over '@users . each . @name' 'stripPrefix "dr. "'+```++strips the prefix from every user's name when present.++### Static checks++Queries are checked before running. Steps that cannot work are+rejected up front instead of failing mid-stream:++- `/ 0` is rejected: division by zero.+- A transformation applied where it cannot fit is rejected:+  `over 'each._Number' '++ "x"'` fails because the optic focuses+  numbers and the transformation needs a string. Optics without a+  pinned shape (`@field`, `each`, `ix`) focus values of unknown+  type and accept anything; only prisms (and `keys`) narrow the+  focus, so only provable mismatches are reported.+- `filter` predicates must produce booleans, and accept their+  sub-optic's focus type.++## Examples++```sh+echo '{"name":"ada","score":96}' | hq fold '@name'+# "ada"++echo '{"name":"ada"}' | hq fold '@name' -r+# ada (raw: strings print without quotes)++echo '{"a":[1,2,3]}' | hq fold '@a . each'+# 1, 2, 3 (one per line)++echo '[{"a":90},{"a":96}]' | hq fold 'each . filter (@a) (== 90)' -c+# [{"a":90}]++echo '{"a":1}' | hq over '@a' '+ 1' -c+# {"a":2}++echo '{"a":1,"b":2}' | hq set '@b' '3' -c+# {"a":1,"b":3}++echo '{"a":1,"b":2}' | hq delete '@b' -c+# {"a":1}++# nix+nix build . --json \+  | hq -r fold 'each . @outputs . values' \+  | cachix push my-cachix-cache++# Kubernetes+kubectl get pods -o json \+  | hq -r fold '@items . each . @metadata . @name'++# ffmpeg+ffprobe -v quiet -print_format json -show_streams video.mp4 \+  | hq -r fold 'each . @codec_name'++# Github+curl -s https://api.github.com/repos/damianfral/hq \+  | hq -r fold '@topics.each'+```
+ hq-json.cabal view
@@ -0,0 +1,148 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name:           hq-json+version:        0.1.1+synopsis:       A streaming JSON processor inspired by jq, with a lens-based query language.+description:    hq is a JSON processor inspired by jq. It queries JSON with optics+                and rewrites values with transformations, streaming input so large+                documents never load fully into memory.+category:       json,+                cli,+                optics,+                streaming,+                data-processing,+                tools+stability:      experimental+homepage:       https://github.com/damianfral/hq#readme+bug-reports:    https://github.com/damianfral/hq/issues+author:         damianfral <huevofritopamojarpan@gmail.com>+maintainer:     damianfral <huevofritopamojarpan@gmail.com>+copyright:      Damian Franco Alvarez, 2026+license:        MIT+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.10.3+extra-source-files:+    docs/LANG.md+extra-doc-files:+    README.md+    docs/LANG.md++source-repository head+  type: git+  location: https://github.com/damianfral/hq++flag dev+  description: Treat warnings as errors during development+  manual: True+  default: False++library+  exposed-modules:+      HQ.CLI+      HQ.Early+      HQ.Error+      HQ.JSON.Decoder+      HQ.JSON.Decoder.Core+      HQ.JSON.Decoder.Error+      HQ.JSON.Decoder.Keyword+      HQ.JSON.Decoder.Number+      HQ.JSON.Decoder.Skip+      HQ.JSON.Decoder.String+      HQ.JSON.Encoder+      HQ.JSON.Event+      HQ.JSON.Parser+      HQ.Optic+      HQ.Optic.AST+      HQ.Optic.OpticType+      HQ.Optic.Parser+      HQ.Parser+      HQ.Query+      HQ.Query.Parser+      HQ.Runner+      HQ.Runner.Cursor+      HQ.Runner.Error+      HQ.Runner.Fold+      HQ.Runner.Rewrite+      HQ.Runner.Rewrite.Emit+      HQ.Runner.Take+      HQ.Transformation+      HQ.Transformation.AST+      HQ.Transformation.Error+      HQ.Transformation.Parser+      HQ.Transformation.TransformationType+  other-modules:+      Paths_hq_json+  hs-source-dirs:+      ./src/+  ghc-options: -O2 -fshow-warning-groups -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -fwrite-ide-info -funbox-strict-fields -flate-dmd-anal -fno-omit-interface-pragmas -fregs-graph -fspec-constr-recursive=32 -fmax-worker-args=32 -fexpose-all-unfoldings -fspecialise-aggressively -fdo-clever-arg-eta-expansion -Wno-unused-packages+  build-depends:+      aeson >=2.2.4 && <2.3+    , base >=4.20.2 && <4.21+    , bytestring >=0.12.2 && <0.13+    , file-embed >=0.0.16 && <0.1+    , megaparsec ==9.7.*+    , optparse-applicative >=0.18.1 && <0.19+    , parser-combinators >=1.3.1 && <1.4+    , relude >=1.2.2 && <1.3+    , scientific >=0.3.8 && <0.4+    , streaming >=0.2.4 && <0.3+    , text >=2.1.3 && <2.2+    , vector >=0.13.2 && <0.14+  default-language: Haskell2010+  if flag(dev)+    ghc-options: -Werror++executable hq+  main-is: Main.hs+  other-modules:+      Paths_hq_json+  hs-source-dirs:+      ./app/+  ghc-options: -O2 -fshow-warning-groups -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -fwrite-ide-info -funbox-strict-fields -flate-dmd-anal -fno-omit-interface-pragmas -fregs-graph -fspec-constr-recursive=32 -fmax-worker-args=32 -fexpose-all-unfoldings -fspecialise-aggressively -fdo-clever-arg-eta-expansion -Wno-unused-packages -rtsopts -threaded -with-rtsopts=-qg+  build-depends:+      base >=4.20.2 && <4.21+    , hq-json+    , relude >=1.2.2 && <1.3+  default-language: Haskell2010+  if flag(dev)+    ghc-options: -Werror++test-suite hq-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      HQ.CLISpec+      HQ.JSON.DecoderSpec+      HQ.JSON.EncoderSpec+      HQ.JSON.ParserSpec+      HQ.OpticSpec+      HQ.Query.ParserSpec+      HQ.QuerySpec+      HQ.Runner.FoldSpec+      HQ.Runner.RewriteSpec+      HQ.Transformation.ASTSpec+      HQ.Transformation.ParserSpec+      Test.HQ+      Paths_hq_json+  hs-source-dirs:+      test+  ghc-options: -O2 -fshow-warning-groups -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -fwrite-ide-info -funbox-strict-fields -flate-dmd-anal -fno-omit-interface-pragmas -fregs-graph -fspec-constr-recursive=32 -fmax-worker-args=32 -fexpose-all-unfoldings -fspecialise-aggressively -fdo-clever-arg-eta-expansion -Wno-unused-packages -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      aeson >=2.2.4 && <2.3+    , base >=4.20.2 && <4.21+    , hq-json+    , optparse-applicative >=0.18.1 && <0.19+    , relude >=1.2.2 && <1.3+    , scientific >=0.3.8 && <0.4+    , streaming >=0.2.4 && <0.3+    , sydtest ==0.20.*+    , sydtest-discover >=0.0.0.4 && <0.1+  default-language: Haskell2010+  if flag(dev)+    ghc-options: -Werror
+ src/HQ/CLI.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.CLI (CLIOptions (..), optParserInfo, runCLI, renderIOError, withInput) where++import Control.Exception (IOException, catch)+import Data.Aeson (Value)+import Data.FileEmbed (embedStringFile, makeRelativeToProject)+import Data.Text.IO (hPutStrLn)+import Data.Version (showVersion)+import HQ.JSON.Encoder (Join (..), Raw (..))+import HQ.JSON.Encoder qualified as Enc+import HQ.JSON.Parser (parseValue)+import HQ.Optic (Optic)+import HQ.Optic.Parser (parseOptic)+import HQ.Query+import HQ.Runner (executeRunnerAction, jsonRunner)+import HQ.Transformation (Transformation (..))+import HQ.Transformation.Parser (parseTransformation)+import Options.Applicative hiding (Const)+import Paths_hq_json (version)+import Relude hiding (Const)+import System.IO hiding (hPutStrLn, hSetBuffering)+import Text.Megaparsec (errorBundlePretty)++data CLIOptions = CLIOptions+  { optQuery :: Query,+    optFile :: Maybe FilePath,+    optRaw :: Raw,+    optCompact :: Enc.EncodeStyle,+    optJoin :: Join+  }++opticReader :: ReadM Optic+opticReader = eitherReader $ first errorBundlePretty . parseOptic . toText++valueReader :: ReadM Value+valueReader = eitherReader $ parseValue . toText++transformationReader :: ReadM Transformation+transformationReader =+  eitherReader $ first errorBundlePretty . parseTransformation . toText++queryParser :: Parser Query+queryParser =+  hsubparser+    $ command "fold" (info (Fold <$> opticArg) mempty)+    <> command "preview" (info (Preview <$> opticArg) mempty)+    <> command "set" (info (Over <$> opticArg <*> (Const <$> valueArg)) mempty)+    <> command "over" (info (Over <$> opticArg <*> transformationArg) mempty)+    <> command "delete" (info (Delete <$> opticArg) mempty)+  where+    opticArg = argument opticReader $ metavar "OPTIC"+    valueArg = argument valueReader $ metavar "VALUE"+    transformationArg = argument transformationReader $ metavar "TRANSFORMATION"++optParser :: Parser CLIOptions+optParser = do+  file <- optional $ strOption fileMod+  raw <- bool NoRaw Raw <$> switch rawMod+  compact <- bool (Enc.Pretty 2) Enc.Compact <$> switch compactMod+  join' <- bool NoJoin Join <$> switch joinMod+  query <- queryParser+  pure $ CLIOptions query file raw compact join'+  where+    fileHelp = "Input JSON file, or '-' for stdin"+    fileMod = long "file" <> short 'f' <> metavar "FILE" <> help fileHelp+    rawMod = long "raw" <> short 'r' <> help "Print strings without JSON quotes"+    compactMod = long "compact" <> short 'c' <> help "Print compact JSON"+    joinMod = long "join" <> short 'j' <> help "Print without separators"++langHelp :: String+langHelp = $(embedStringFile =<< makeRelativeToProject "./docs/LANG.md")++optParserInfo :: ParserInfo CLIOptions+optParserInfo = info (optParser <**> helper) infoMod+  where+    infoMod =+      mconcat+        [ fullDesc,+          progDesc headerMsg,+          header description,+          footerDoc $ Just $ fromString langHelp+        ]+    headerMsg = "Query JSON using optics"+    description = "hq v" <> showVersion version++-- | Open the input and run the query over it: stdin for 'Nothing' and+-- @-@, a file otherwise. An unopenable file is a CLI-level failure,+-- reported on stderr.+withInput :: Maybe FilePath -> (Handle -> IO a) -> IO a+withInput Nothing useHandle = useHandle stdin+withInput (Just "-") useHandle = useHandle stdin+withInput (Just path) useHandle =+  catch open $ \err -> do+    hPutStrLn stderr (renderIOError err)+    exitFailure+  where+    open = withFile path ReadMode $ \h -> do+      hSetBuffering h $ BlockBuffering Nothing+      hSetBinaryMode h True+      useHandle h++-- | Render an I/O failure for the CLI boundary, prefixed like every+-- other hq error.+renderIOError :: IOException -> Text+renderIOError err = "hq: " <> toText (displayException err)++runCLI :: IO ()+runCLI = do+  CLIOptions {..} <- execParser optParserInfo+  query <- case typecheckQuery optQuery of+    Left err -> hPutStrLn stderr (renderTypeError err) >> exitFailure+    Right q -> pure q+  let cfg = Enc.EncoderConfig optCompact $ Enc.ValueOptions optRaw optJoin+  withInput optFile $ executeRunnerAction jsonRunner query cfg
+ src/HQ/Early.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Type-safe early return without 'ExceptT':+-- https://burningwitness.github.io/blog/posts/against-effect-systems/+--+-- 'ExceptT' threads an 'Either' through every action, taxing every+-- bind even on the success path. Instead, failures throw a private+-- exception ('ReturningEarly') caught once at the edge ('runEarly').+-- The 'Early' token scopes the power to throw: only code holding it+-- can fail with @e@, tracked as a plain function argument.+module HQ.Early where++import Control.Exception (catch, throwIO)+import GHC.Show+import Relude++type role Early nominal++type Early :: Type -> Type+data Early e = Early++type role ReturningEarly nominal++type ReturningEarly :: Type -> Type+newtype ReturningEarly e = ReturningEarly e++instance (Typeable e) => Show (ReturningEarly e) where+  show = displayException++instance (Typeable e) => Exception (ReturningEarly e) where+  displayException (ReturningEarly _) = "Early return exception"++-- | Abort with @e@; only code holding the 'Early' token can fail this way.+leave :: (Typeable e) => Early e -> e -> IO a+leave _ e = throwIO (ReturningEarly e)++-- | Run an action that may leave early, catching the failure at the edge.+runEarly :: (Typeable e) => (Early e -> IO a) -> IO (Either e a)+runEarly f = catch (Right <$> f Early) (\(ReturningEarly e) -> pure (Left e))++-- | Lift an 'Either' into 'IO', leaving early on failure.+orLeave :: (Typeable e) => Early e -> Either e a -> IO a+orLeave early r = case r of+  Left e -> leave early e+  Right v -> pure v
+ src/HQ/Error.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Every error hq can report, with per-domain precise types.+module HQ.Error where++import HQ.JSON.Decoder.Error (DecodeError (..), renderDecodeError)+import HQ.Runner.Error (RunnerError (..), renderRunnerError)+import HQ.Transformation.Error (TransformationError (..), renderTransformationError)+import Relude hiding (Compose, id, many, some, state)++data HQError+  = HQDecodeError DecodeError+  | HQTransformationError TransformationError+  | HQRunnerError RunnerError++-- | Render an error for the CLI boundary; nothing else renders errors.+renderHQError :: HQError -> Text+renderHQError err = case err of+  HQDecodeError e -> renderDecodeError e+  HQTransformationError e -> renderTransformationError e+  HQRunnerError e -> renderRunnerError e
+ src/HQ/JSON/Decoder.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Streaming JSON decoder over text chunks.+module HQ.JSON.Decoder+  ( module HQ.Error,+    module HQ.JSON.Decoder.Core,+    module HQ.JSON.Decoder.Error,+    initialDecoder,+    feed,+    finish,+    step,+    decodeTexts,+    pullEvent,+    Terminal (..),+    TerminalEmitted (..),+    classifyTerminal,+  )+where++import Data.Text qualified as T+import HQ.Early (Early, leave)+import HQ.Error+import HQ.JSON.Decoder.Core+import HQ.JSON.Decoder.Error+import HQ.JSON.Decoder.Keyword+import HQ.JSON.Decoder.Number+import HQ.JSON.Decoder.String+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming.Prelude qualified as S++initialDecoder :: DecoderState+initialDecoder =+  DecoderState+    { decoderInput = mempty,+      decoderStack = [],+      decoderNestDepth = initialDepth,+      decoderPhase = DecoderPhaseValue+    }++feed :: Text -> DecoderState -> Either DecodeError DecoderResult+feed input decoder = step decoder {decoderInput = decoderInput decoder <> input}++finish :: DecoderState -> Either DecodeError DecoderResult+finish decoder = case decoderPhase decoder of+  DecoderPhaseString (AfterHighSurrogate _ _) -> Left InvalidSurrogatePair+  DecoderPhaseString (AfterLowBackslash _ _) -> Left InvalidSurrogatePair+  DecoderPhaseString (InLowSurrogateEscape {}) -> Left InvalidSurrogatePair+  DecoderPhaseString _ -> Left UnexpectedEnd+  DecoderPhaseNumber numState+    | isValidNumberFinal (numberPhase numState) -> finalizeNumber decoder+    | otherwise -> Left $ InvalidNumber (numberErrorText numState)+  DecoderPhaseKeyword _ -> finalizeKeyword decoder+  DecoderPhaseFinished -> case decoderStack decoder of+    [] ->+      let isEmpty = T.null (decoderInput decoder)+       in if isEmpty then Right (Done decoder) else Left TrailingInput+    _ -> Left UnexpectedEnd+  _ -> Left UnexpectedEnd++step :: DecoderState -> Either DecodeError DecoderResult+step !decoder = case decoderPhase decoder of+  DecoderPhaseString state -> stepString decoder state+  DecoderPhaseNumber numState -> stepNumber decoder numState+  DecoderPhaseKeyword state -> stepKeyword decoder state+  _ -> stepStructural decoder++stepStructural :: DecoderState -> Either DecodeError DecoderResult+stepStructural !decoder = case T.uncons input of+  Nothing -> case decoderPhase decoder of+    DecoderPhaseFinished ->+      let newDecoder = decoder {decoderInput = mempty}+       in Right+            $ if null (decoderStack decoder)+              then Done newDecoder+              else NeedInput newDecoder+    _ -> Right (NeedInput decoder {decoderInput = mempty})+  Just (c, rest) -> parseStructuralChar c rest decoder+  where+    input = T.dropWhile isWhitespace (decoderInput decoder)++parseStructuralChar ::+  Char -> Text -> DecoderState -> Either DecodeError DecoderResult+parseStructuralChar !c !rest !decoder = case decoderPhase decoder of+  DecoderPhaseValue -> parseValueChar c rest decoder+  DecoderPhaseObjectKey+    | c == '}' -> case decoderStack decoder of+        (_ : contexts) ->+          let newDecoder = decoder {decoderStack = contexts}+           in emitEvent JSONEndObject rest newDecoder+        [] -> Left ExpectedObjectKey+    | c == '"' -> startString StringKey rest decoder+    | otherwise -> Left ExpectedObjectKey+  DecoderPhaseObjectColon+    | c == ':' ->+        step decoder {decoderInput = rest, decoderPhase = DecoderPhaseValue}+    | otherwise -> Left ExpectedColon+  DecoderPhaseObjectComma+    | c == ',' ->+        step+          decoder {decoderInput = rest, decoderPhase = DecoderPhaseObjectKey}+    | c == '}' -> case decoderStack decoder of+        (_ : contexts) ->+          let newDecoder = decoder {decoderStack = contexts}+           in emitEvent JSONEndObject rest newDecoder+        [] -> Left ExpectedCommaOrEnd+    | otherwise -> Left ExpectedCommaOrEnd+  DecoderPhaseArrayComma+    | c == ',' ->+        step decoder {decoderInput = rest, decoderPhase = DecoderPhaseValue}+    | c == ']' -> case decoderStack decoder of+        (_ : contexts) ->+          emitEvent JSONEndArray rest decoder {decoderStack = contexts}+        [] -> Left ExpectedCommaOrEnd+    | otherwise -> Left ExpectedCommaOrEnd+  DecoderPhaseFinished -> Left TrailingInput+  DecoderPhaseString _ -> Left (UnexpectedChar c)+  DecoderPhaseNumber _ -> Left (UnexpectedChar c)+  DecoderPhaseKeyword _ -> Left (UnexpectedChar c)++parseValueChar :: Char -> Text -> DecoderState -> Either DecodeError DecoderResult+parseValueChar !c !rest !decoder = case decoderStack decoder of+  DecodeArray : contexts+    | c == ']' ->+        emitEvent JSONEndArray rest decoder {decoderStack = contexts}+  _ -> startValue c rest decoder++startValue :: Char -> Text -> DecoderState -> Either DecodeError DecoderResult+startValue !c !rest !decoder = case c of+  '{' ->+    Right+      $ Emit+        JSONBeginObject+        decoder+          { decoderInput = rest,+            decoderStack = DecodeObject : decoderStack decoder,+            decoderPhase = DecoderPhaseObjectKey+          }+  '[' ->+    Right+      $ Emit+        JSONBeginArray+        decoder+          { decoderInput = rest,+            decoderStack = DecodeArray : decoderStack decoder,+            decoderPhase = DecoderPhaseValue+          }+  '"' -> startString StringValue rest decoder+  'n' -> startKeyword decoder rest "null" 1+  't' -> startKeyword decoder rest "true" 1+  'f' -> startKeyword decoder rest "false" 1+  _+    | isNumberStart c ->+        let numState = startNumberState c+         in stepNumber+              decoder {decoderInput = rest, decoderPhase = DecoderPhaseNumber numState}+              numState+    | otherwise -> Left (UnexpectedChar c)++-- Root value complete: empty stack + finished state.+isRootDone :: DecoderState -> Bool+isRootDone decoder =+  decoderPhase decoder == DecoderPhaseFinished && null (decoderStack decoder)++isEmptyDecoder :: DecoderState -> Bool+isEmptyDecoder dec = nullInputPred && nullStackPred && depthPred && phasePred+  where+    nullInputPred = T.null (decoderInput dec)+    nullStackPred = null (decoderStack dec)+    depthPred = decoderNestDepth dec == initialDepth+    phasePred = decoderPhase dec == DecoderPhaseValue++-- | Terminal reading of a finished decoder; keep 'decodeTexts',+-- 'pullEvent' and Take's finisher in sync.+data Terminal+  = TerminalEnd+  | TerminalError DecodeError+  | TerminalEmit TerminalEmitted++-- | Payload of a 'TerminalEmit': one trailing event with the decoder after it.+data TerminalEmitted = TerminalEmitted+  { terminalEvent :: JSONEvent,+    terminalDecoder :: DecoderState+  }++classifyTerminal :: DecoderState -> Terminal+classifyTerminal dec = case finish dec of+  Left UnexpectedEnd+    | decoderPhase dec == DecoderPhaseValue && null (decoderStack dec) -> TerminalEnd+  Left err -> TerminalError err+  Right (Done _) -> TerminalEnd+  Right (NeedInput _) -> TerminalError UnexpectedEnd+  Right (Emit event dec') -> TerminalEmit (TerminalEmitted event dec')++-- | Decode complete text chunks to events (single-shot driver for literals and tests).+decodeTexts :: [Text] -> Either DecodeError [JSONEvent]+decodeTexts = go initialDecoder+  where+    go dec [] = atEnd dec+    go dec (chunk : rest) = case feed chunk dec of+      Left err -> Left err+      Right res -> drain res rest+    drain (Emit event dec') rest = (event :) <$> stepped dec' rest+    drain (NeedInput dec') rest+      | not (T.null (decoderInput dec')) = stepped dec' rest+      | isRootDone dec' = trailing dec' rest+      | otherwise = go dec' rest+    drain (Done dec') rest = trailing dec' rest+    stepped dec' rest = case step dec' of+      Left err -> Left err+      Right res -> drain res rest+    trailing dec' [] = atEnd dec'+    trailing dec' (chunk : rest)+      | isRootDone dec' =+          if T.all isWhitespace chunk+            then trailing dec' rest+            else Left TrailingInput+      | otherwise = Left TrailingInput+    atEnd dec' = case classifyTerminal dec' of+      TerminalEnd -> Right []+      TerminalError err -> Left err+      TerminalEmit (TerminalEmitted event dec'') -> (event :) <$> atEnd dec''++-- | Pull a single event; bulk loops drive 'step' directly.+pullEvent :: Early HQError -> DecoderState -> StreamIO Text () -> IO Next+pullEvent early decoder txtStream = case step decoder of+  Left err -> leave early (HQDecodeError err)+  Right (Emit event dec') -> pure $ NextEvent (NextEmitted event dec' txtStream)+  Right (NeedInput dec') -> pullMore dec' txtStream+  Right (Done dec') -> endCheck dec' txtStream+  where+    pullMore :: DecoderState -> StreamIO Text () -> IO Next+    pullMore dec txt+      -- Pending input takes precedence over pulling more text; only a drained decoder may end.+      | not (T.null (decoderInput dec)) = case step dec of+          Left err -> leave early (HQDecodeError err)+          Right (Emit event dec') -> pure (NextEvent (NextEmitted event dec' txt))+          Right (NeedInput dec') -> pullMore dec' txt+          Right (Done dec') -> endCheck dec' txt+      | otherwise = do+          result <- S.next txt+          case result of+            Left ()+              | isRootDone dec || isEmptyDecoder dec -> pure EndOfInput+              | otherwise -> finishEnd dec+            Right (chunk, rest) -> case feed chunk dec of+              Left err -> leave early (HQDecodeError err)+              Right (Emit event dec') -> pure (NextEvent (NextEmitted event dec' rest))+              Right (NeedInput dec') -> pullMore dec' rest+              Right (Done dec') -> endCheck dec' rest+    endCheck :: DecoderState -> StreamIO Text () -> IO Next+    endCheck dec txt = do+      result <- S.next txt+      case result of+        Left () -> finishEnd dec+        Right (chunk, rest)+          | isRootDone dec ->+              if T.all isWhitespace chunk+                then endCheck dec rest+                else leave early (HQDecodeError TrailingInput)+          | otherwise -> leave early (HQDecodeError TrailingInput)+    finishEnd :: DecoderState -> IO Next+    finishEnd dec = case classifyTerminal dec of+      TerminalEnd -> pure EndOfInput+      TerminalError err -> leave early (HQDecodeError err)+      TerminalEmit (TerminalEmitted event dec') -> pure $ NextEvent (NextEmitted event dec' (pure ()))
+ src/HQ/JSON/Decoder/Core.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Shared vocabulary of the streaming JSON decoder.+module HQ.JSON.Decoder.Core where++import Data.Char (digitToInt, isHexDigit)+import Data.Text qualified as T+import HQ.JSON.Decoder.Error (DecodeError)+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming (Of, Stream)++-- | Buffered string fragments (reversed for O(1) prepend).+newtype StringBuffer = StringBuffer [Text] deriving (Eq)++emptyStringBuffer :: StringBuffer+emptyStringBuffer = StringBuffer []++appendStringBuffer :: Text -> StringBuffer -> StringBuffer+appendStringBuffer t (StringBuffer ts)+  | T.null t = StringBuffer ts+  | otherwise = StringBuffer (t : ts)++appendCharStringBuffer :: Char -> StringBuffer -> StringBuffer+appendCharStringBuffer c = appendStringBuffer (T.singleton c)++finishStringBuffer :: StringBuffer -> Text+finishStringBuffer (StringBuffer ts) = T.concat (reverse ts)++-- | Nesting depth: the number of enclosing containers.+newtype NestDepth = NestDepth Int deriving (Eq, Ord)++initialDepth :: NestDepth+initialDepth = NestDepth 0++deeper :: NestDepth -> NestDepth+deeper (NestDepth n) = NestDepth (n + 1)++shallower :: NestDepth -> NestDepth+shallower (NestDepth n) = NestDepth (n - 1)++data DecoderState = DecoderState+  { decoderInput :: Text,+    decoderStack :: [DecodeContext],+    decoderNestDepth :: NestDepth,+    decoderPhase :: DecoderPhase+  }++data DecoderPhase+  = DecoderPhaseValue+  | DecoderPhaseObjectKey+  | DecoderPhaseObjectColon+  | DecoderPhaseObjectComma+  | DecoderPhaseArrayComma+  | DecoderPhaseString StringState+  | DecoderPhaseNumber NumberState+  | DecoderPhaseKeyword KeywordState+  | DecoderPhaseFinished+  deriving (Eq)++data DecodeContext = DecodeArray | DecodeObject++data NumberState = NumberState+  { numberNegative :: Bool,+    numberCoeff :: Integer,+    -- | Exponent digits accumulated so far.+    numberExp :: Integer,+    -- | Fraction digits folded into 'numberCoeff'.+    numberFracDigits :: Int,+    -- | '-' seen after 'e'/'E'.+    numberExpNeg :: Bool,+    numberPhase :: NumberPhase,+    -- Error payloads only: retained, never decoded, on the success path.+    numberFrags :: [Text]+  }+  deriving (Eq)++-- | Tracks how much of a JSON number has been consumed.+data NumberPhase+  = -- | Saw leading '-'+    NumberSign+  | -- | Saw '0' (must not be followed by more digits)+    NumberZero+  | -- | Saw [1-9] and possibly more digits+    NumberNonZero+  | -- | Saw '.' after integer part (need fractional digits)+    NumberDot+  | -- | Saw '.' + at least one digit+    NumberFraction+  | -- | Saw 'e'/'E' (waiting for optional sign or digit)+    NumberExpSign+  | -- | Saw 'e'/'E' then '+'/'-' (need digits)+    NumberExpAfterSign+  | -- | Saw exponent digits+    NumberExpDigit+  deriving (Eq)++data NumberStep+  = NumberStep NumberPhase+  | NumberEnd+  | NumberError++data StringTarget = StringKey | StringValue+  deriving (Eq)++data BufferedStringTarget = BufferedStringTarget StringTarget StringBuffer+  deriving (Eq)++data Unicode = Unicode {unicodeValue :: Int, unicodeDigits :: Int}+  deriving (Eq)++data StringState+  = InString BufferedStringTarget+  | AfterEscape BufferedStringTarget+  | InUnicodeEscape BufferedStringTarget Unicode+  | AfterHighSurrogate BufferedStringTarget Int+  | -- Mid low-surrogate digits; separate so split escapes resume in the low half.+    InLowSurrogateEscape BufferedStringTarget Int Unicode+  | -- Low escape's backslash at a chunk end; next chunk must start with @u@.+    AfterLowBackslash BufferedStringTarget Int+  deriving (Eq)++data KeywordState+  = KeywordNull Int+  | KeywordTrue Int+  | KeywordFalse Int+  deriving (Eq)++data DecoderResult+  = Emit JSONEvent DecoderState+  | NeedInput DecoderState+  | Done DecoderState++-- | Emit one event, continuing after the value (container ends pop+-- and mark the parent via 'finishValue'). Single policy for scalars+-- and container ends. Inlined into the call sites.+{-# INLINE emitEvent #-}+emitEvent :: JSONEvent -> Text -> DecoderState -> Either DecodeError DecoderResult+emitEvent event remaining decoder =+  let newDec = decoder {decoderInput = remaining}+   in Right $ Emit event $ finishValue newDec++finishValue :: DecoderState -> DecoderState+finishValue decoder = case decoderStack decoder of+  [] -> decoder {decoderPhase = DecoderPhaseFinished}+  DecodeArray : _ -> decoder {decoderPhase = DecoderPhaseArrayComma}+  DecodeObject : _ -> decoder {decoderPhase = DecoderPhaseObjectComma}++isWhitespace :: Char -> Bool+isWhitespace c = c `elem` [' ', '\t', '\n', '\r']++isJsonDelimiter :: Char -> Bool+isJsonDelimiter c = isWhitespace c || c `elem` [',', ']', '}']++isHighSurrogate :: Int -> Bool+isHighSurrogate x = x >= 0xD800 && x <= 0xDBFF++isLowSurrogate :: Int -> Bool+isLowSurrogate x = x >= 0xDC00 && x <= 0xDFFF++-- | Verbatim string bytes; shared so decoding, skipping and collection+-- split identically.+isStringChar :: Char -> Bool+isStringChar c = c /= '"' && c /= '\\' && ord c >= 0x20++-- | Simple (non-\u) escapes in the JSON string table.+isSimpleEscape :: Char -> Bool+isSimpleEscape c = c `elem` ['"', '\\', '/', 'b', 'f', 'n', 'r', 't']++-- | Decode a simple escape to its character. Caller must have checked+-- 'isSimpleEscape' (except 'u', handled separately).+decodeSimpleEscape :: Char -> Char+decodeSimpleEscape '"' = '"'+decodeSimpleEscape '\\' = '\\'+decodeSimpleEscape '/' = '/'+decodeSimpleEscape 'b' = '\b'+decodeSimpleEscape 'f' = '\f'+decodeSimpleEscape 'n' = '\n'+decodeSimpleEscape 'r' = '\r'+decodeSimpleEscape 't' = '\t'+decodeSimpleEscape c = c++-- | Accumulate up to @needed@ hex digits from the head of @input@.+-- Returns @(value', digits', rest)@ where @value'@ folds the new digits+-- into @value@ and @rest@ is the unconsumed remainder.+accumulateHex :: Int -> Int -> Text -> (Int, Int, Text)+accumulateHex value digits input =+  let needed = 4 - digits+      hex = T.take needed (T.takeWhile isHexDigit input)+      rest = T.drop (T.length hex) input+      value' = T.foldl' (\v c -> v * 16 + digitToInt c) value hex+      digits' = digits + T.length hex+   in (value', digits', rest)++data Next = EndOfInput | NextEvent NextEmitted++-- | One decoded event with the decoder and text positioned after it.+data NextEmitted = NextEmitted+  { nextEvent :: JSONEvent,+    nextDecoder :: DecoderState,+    nextText :: StreamIO Text ()+  }++-- | Stream over 'IO'. Failures abort via 'HQ.Early' exceptions.+type StreamIO s = Stream (Of s) IO
+ src/HQ/JSON/Decoder/Error.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | What can go wrong while decoding the streaming JSON grammar.+module HQ.JSON.Decoder.Error where++import Data.Text qualified as T+import Relude hiding (Compose, id, many, some, state)++data DecodeError+  = UnexpectedEnd+  | UnexpectedChar Char+  | ExpectedColon+  | ExpectedCommaOrEnd+  | ExpectedObjectKey+  | InvalidEscape Char+  | InvalidUnicodeEscape+  | InvalidSurrogatePair+  | InvalidNumber Text+  | InvalidKeyword Text+  | TrailingInput+  deriving (Eq, Show)++-- | Render a decode error for the CLI boundary; nothing else renders+-- decode errors. Prose only: 'show' leaks constructors like+-- @InvalidKeyword "null"@ to users.+renderDecodeError :: DecodeError -> Text+renderDecodeError err = case err of+  UnexpectedEnd -> "unexpected end of JSON input"+  UnexpectedChar c -> "unexpected character " <> show c <> " in JSON input"+  ExpectedColon -> "expected ':' after an object key"+  ExpectedCommaOrEnd -> "expected ',' or the end of an object or array"+  ExpectedObjectKey -> "expected an object key"+  InvalidEscape c ->+    "invalid escape sequence '\\" <> T.singleton c <> "' in a JSON string"+  InvalidUnicodeEscape -> "invalid unicode escape sequence in a JSON string"+  InvalidSurrogatePair -> "invalid surrogate pair in a JSON string"+  InvalidNumber t+    | T.null t -> "invalid JSON number"+    | otherwise -> "invalid JSON number " <> t+  InvalidKeyword kw+    | T.null kw -> "expected a JSON value"+    | otherwise -> "expected JSON keyword " <> kw+  TrailingInput -> "trailing input after a JSON value"
+ src/HQ/JSON/Decoder/Keyword.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Keyword parsing (null/true/false) for the streaming JSON decoder.+module HQ.JSON.Decoder.Keyword where++import Data.Text qualified as T+import HQ.JSON.Decoder.Core+import HQ.JSON.Decoder.Error (DecodeError (..))+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)++startKeyword ::+  DecoderState -> Text -> Text -> Int -> Either DecodeError DecoderResult+startKeyword decoder input keyword consumed =+  case keywordState keyword consumed of+    Nothing -> Left (InvalidKeyword keyword)+    Just state ->+      stepKeyword+        decoder {decoderInput = input, decoderPhase = DecoderPhaseKeyword state}+        state++-- | The state for a keyword literal; 'Nothing' for anything else.+-- The dispatcher passes literals only, so 'Nothing' is unreachable+-- from valid input — but reported, never silently matched as null.+keywordState :: Text -> Int -> Maybe KeywordState+keywordState keyword n+  | keyword == "null" = Just (KeywordNull n)+  | keyword == "true" = Just (KeywordTrue n)+  | keyword == "false" = Just (KeywordFalse n)+  | otherwise = Nothing++-- | Single table for a keyword state's literal, progress and event.+-- Inlined into 'stepKeyword' and 'finalizeKeyword'.+{-# INLINE keywordInfo #-}+keywordInfo :: KeywordState -> (Text, Int, JSONEvent)+keywordInfo (KeywordNull n) = ("null", n, JSONNull)+keywordInfo (KeywordTrue n) = ("true", n, JSONBool True)+keywordInfo (KeywordFalse n) = ("false", n, JSONBool False)++stepKeyword :: DecoderState -> KeywordState -> Either DecodeError DecoderResult+stepKeyword decoder state =+  if index == T.length keyword+    then case T.uncons $ decoderInput decoder of+      Nothing -> finalizeKeyword decoder+      Just (c, _) | isJsonDelimiter c -> finalizeKeyword decoder+      Just _ -> Left (InvalidKeyword keyword)+    else case T.uncons (decoderInput decoder) of+      Nothing ->+        Right $ NeedInput decoder {decoderPhase = DecoderPhaseKeyword state}+      Just (c, rest)+        | c == T.index keyword index ->+            let state' = advanceKeyword state+             in stepKeyword+                  decoder+                    { decoderInput = rest,+                      decoderPhase = DecoderPhaseKeyword state'+                    }+                  state'+      _ -> Left (InvalidKeyword keyword)+  where+    (keyword, index, _) = keywordInfo state++advanceKeyword :: KeywordState -> KeywordState+advanceKeyword state = case state of+  KeywordNull n -> KeywordNull (n + 1)+  KeywordTrue n -> KeywordTrue (n + 1)+  KeywordFalse n -> KeywordFalse (n + 1)++finalizeKeyword :: DecoderState -> Either DecodeError DecoderResult+finalizeKeyword decoder = case decoderPhase decoder of+  DecoderPhaseKeyword state -> do+    let (keyword, index, event) = keywordInfo state+    if index == T.length keyword+      then emitEvent event (decoderInput decoder) decoder+      else Left $ InvalidKeyword keyword+  _ -> Left $ InvalidKeyword mempty
+ src/HQ/JSON/Decoder/Number.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Number parsing: state machine plus stepping and finalization.+module HQ.JSON.Decoder.Number where++import Data.Char (digitToInt, isDigit)+import Data.Scientific (Scientific, scientific)+import Data.Text qualified as T+import HQ.JSON.Decoder.Core+import HQ.JSON.Decoder.Error (DecodeError (..))+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)++-- | Is this phase valid at end-of-input?+isValidNumberFinal :: NumberPhase -> Bool+isValidNumberFinal NumberZero = True+isValidNumberFinal NumberNonZero = True+isValidNumberFinal NumberFraction = True+isValidNumberFinal NumberExpDigit = True+isValidNumberFinal _ = False++-- | Advance the number state machine for one character. Digits are+-- tested before delimiters: digits are the common case and never+-- delimit, so leading with 'isDigit' skips two list scans per digit.+-- (Order is behaviour-preserving: no character is both.)+advanceNumber :: NumberPhase -> Char -> NumberStep+advanceNumber phase c+  | isDigit c = case phase of+      NumberSign+        | c == '0' -> NumberStep NumberZero+        | otherwise -> NumberStep NumberNonZero+      NumberZero -> NumberError+      NumberNonZero -> NumberStep NumberNonZero+      NumberDot -> NumberStep NumberFraction+      NumberFraction -> NumberStep NumberFraction+      NumberExpSign -> NumberStep NumberExpDigit+      NumberExpAfterSign -> NumberStep NumberExpDigit+      NumberExpDigit -> NumberStep NumberExpDigit+  | isJsonDelimiter c = NumberEnd+  | otherwise = case phase of+      NumberSign -> NumberError+      NumberZero+        | c == '.' -> NumberStep NumberDot+        | c == 'e' || c == 'E' -> NumberStep NumberExpSign+        | otherwise -> NumberError+      NumberNonZero+        | c == '.' -> NumberStep NumberDot+        | c == 'e' || c == 'E' -> NumberStep NumberExpSign+        | otherwise -> NumberError+      NumberDot -> NumberError+      NumberFraction+        | c == 'e' || c == 'E' -> NumberStep NumberExpSign+        | otherwise -> NumberError+      NumberExpSign+        | c == '+' || c == '-' -> NumberStep NumberExpAfterSign+        | otherwise -> NumberError+      NumberExpAfterSign -> NumberError+      NumberExpDigit -> NumberError++-- | Phases where digits self-loop: a maximal digit run can be consumed+-- without per-character dispatch, leaving the phase unchanged.+acceptsDigitRun :: NumberPhase -> Bool+acceptsDigitRun NumberNonZero = True+acceptsDigitRun NumberFraction = True+acceptsDigitRun NumberExpDigit = True+acceptsDigitRun _ = False++-- | Determine the starting number phase for the first character of a number.+numberPhaseFromFirstChar :: Char -> Maybe NumberPhase+numberPhaseFromFirstChar '-' = Just NumberSign+numberPhaseFromFirstChar '0' = Just NumberZero+numberPhaseFromFirstChar c+  | isDigit c = Just NumberNonZero+  | otherwise = Nothing++-- | Single source for "can this char start a JSON number?".+-- Canonical home next to 'numberPhaseFromFirstChar' (same char set);+-- 'Decoder.startValue' and 'Take.peekRawScalar' share it.+{-# INLINE isNumberStart #-}+isNumberStart :: Char -> Bool+isNumberStart c = isJust (numberPhaseFromFirstChar c)++startNumberState :: Char -> NumberState+startNumberState c =+  NumberState+    { numberNegative = c == '-',+      numberCoeff = if isDigit c then fromIntegral (digitToInt c) else 0,+      numberExp = 0,+      numberFracDigits = 0,+      numberExpNeg = False,+      numberPhase = fromMaybe NumberSign (numberPhaseFromFirstChar c),+      -- First char belongs to the error payload; freed on completion.+      numberFrags = [T.singleton c]+    }++-- | Text consumed for the current number: prior chunks (newest+-- first) plus a slice of the current input. Forced on the error path+-- only.+numberText :: NumberState -> Text -> Int -> Text+numberText ns cur pos = T.concat (reverse (numberFrags ns)) <> T.take pos cur++-- | Error payload: exactly the consumed text.+numberErrorText :: NumberState -> Text+numberErrorText ns = T.concat (reverse (numberFrags ns))++-- | Render the accumulated components as a 'Scientific', folding+-- fraction digits into the coefficient and offsetting the exponent.+finishNumber :: NumberState -> Scientific+finishNumber ns =+  (if numberNegative ns then negate else identity) (numberCoeff ns)+    `scientific` fromInteger (expVal - fromIntegral (numberFracDigits ns))+  where+    expVal = (if numberExpNeg ns then negate else identity) (numberExp ns)++-- | Continue parsing a number: tight index loop with the numeric+-- components accumulated inline, so completion needs no intermediate+-- buffer and no re-scan. State is written back once at end, failure,+-- or input exhaustion.+stepNumber :: DecoderState -> NumberState -> Either DecodeError DecoderResult+stepNumber decoder ns0@(NumberState {..}) =+  scan 0 numberCoeff numberExp numberFracDigits numberExpNeg numberPhase+  where+    input = decoderInput decoder+    len = T.length input+    scan ::+      Int ->+      Integer ->+      Integer ->+      Int ->+      Bool ->+      NumberPhase ->+      Either DecodeError DecoderResult+    scan !pos !coeff !expP !nFrac !expNeg !phase+      | pos >= len =+          Right+            $ NeedInput+              decoder+                { decoderInput = mempty,+                  decoderPhase =+                    DecoderPhaseNumber+                      NumberState+                        { numberNegative = numberNegative,+                          numberCoeff = coeff,+                          numberExp = expP,+                          numberFracDigits = nFrac,+                          numberExpNeg = expNeg,+                          numberPhase = phase,+                          numberFrags = if T.null input then numberFrags else input : numberFrags+                        }+                }+      | otherwise =+          let c = T.index input pos+           in case advanceNumber phase c of+                NumberEnd ->+                  finalizeNumber+                    decoder+                      { decoderInput = T.drop pos input,+                        decoderPhase =+                          DecoderPhaseNumber+                            (pushSlice ns0 input pos)+                              { numberCoeff = coeff,+                                numberExp = expP,+                                numberFracDigits = nFrac,+                                numberExpNeg = expNeg,+                                numberPhase = phase+                              }+                      }+                NumberError ->+                  Left (InvalidNumber (numberText ns0 input pos <> T.singleton c))+                NumberStep phase' ->+                  scan (pos + 1) coeff' expP' nFrac' expNeg' phase'+                  where+                    (coeff', expP', nFrac', expNeg')+                      | isDigit c =+                          let d = fromIntegral (digitToInt c) :: Integer+                           in if isExpPhase phase+                                then (coeff, expP * 10 + d, nFrac, expNeg)+                                else+                                  if phase == NumberDot || phase == NumberFraction+                                    then (coeff * 10 + d, expP, nFrac + 1, expNeg)+                                    else (coeff * 10 + d, expP, nFrac, expNeg)+                      | c == '-' = (coeff, expP, nFrac, True)+                      | otherwise = (coeff, expP, nFrac, expNeg)++-- | Record the consumed slice of the current chunk, so a later+-- rejection ('finalizeNumber', 'finish') reports the full consumed+-- text. One slice header per number; freed on completion.+pushSlice :: NumberState -> Text -> Int -> NumberState+pushSlice ns cur pos+  | pos <= 0 = ns+  | otherwise = ns {numberFrags = T.take pos cur : numberFrags ns}++-- | Digit runs accumulate into the exponent once one started.+isExpPhase :: NumberPhase -> Bool+isExpPhase NumberExpSign = True+isExpPhase NumberExpAfterSign = True+isExpPhase NumberExpDigit = True+isExpPhase _ = False++finalizeNumber :: DecoderState -> Either DecodeError DecoderResult+finalizeNumber decoder = case decoderPhase decoder of+  DecoderPhaseNumber numState+    | isValidNumberFinal (numberPhase numState) ->+        emitEvent+          (JSONNumber (finishNumber numState))+          (decoderInput decoder)+          decoder+    | otherwise -> Left (InvalidNumber (numberErrorText numState))+  _ -> Left (InvalidNumber mempty)
+ src/HQ/JSON/Decoder/Skip.hs view
@@ -0,0 +1,560 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Text-level value skipping: validate like the decoder but materialize nothing.+module HQ.JSON.Decoder.Skip+  ( skipContainerText,+    skipMemberValueText,+    skipStringCollect,+    skipNumberCollect,+    collectExpect,+    skipExpect,+    finishContainer,+    SkipExpect (..),+    SkipRest (..),+    Collected (..),+    CollectPaused (..),+    RawBody (..),+    RawSink (..),+    collectBudget,+  )+where++import Control.Exception (throwIO)+import Data.Char (isDigit)+import Data.Text qualified as T+import GHC.Show (Show (showsPrec), showString)+import HQ.Early (Early, leave)+import HQ.Error (HQError (..))+import HQ.JSON.Decoder.Core+import HQ.JSON.Decoder.Error (DecodeError (..))+import HQ.JSON.Decoder.Number+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming.Prelude qualified as S++-- | Raw collected bytes: fragments newest-first with their total character count.+data RawBody = RawBody {rawFrags :: [Text], rawSize :: Int}++-- | Where decoding stands: pending input text and the live text stream after it.+data SkipRest = SkipRest+  { skipRestInput :: Text,+    skipRestStream :: StreamIO Text ()+  }++-- | Result of collecting one value: where decoding stands and the collected body.+data Collected = Collected+  { collectedRest :: SkipRest,+    collectedBody :: RawBody+  }++instance Semigroup RawBody where+  RawBody f1 s1 <> RawBody f2 s2 = RawBody (f1 <> f2) (s1 + s2)++instance Monoid RawBody where mempty = RawBody [] 0++-- | One collected character.+rawChar :: Char -> RawBody+rawChar c = RawBody [T.singleton c] 1++-- | Output of the structural/string scanners: either discarded ('()')+-- or accumulated ('RawBody'). The two instances specialize away, so the+-- discard path compiles to the old hand-written skip code (no fragment+-- allocation) while both modes share one scanner. See SPECIALIZE pragmas+-- below.+class RawSink s where+  sinkChar :: Char -> s -> s+  sinkText :: Text -> s -> s+  sinkAppend :: s -> s -> s+  sinkEmbed :: RawBody -> s++  -- | Budget check at the top of 'generalExpect': a no-op for the+  -- discard path, a bounded-segment pause for the collect path.+  sinkCheck ::+    s ->+    SkipExpect ->+    NestDepth ->+    NestDepth ->+    [DecodeContext] ->+    Text ->+    StreamIO Text () ->+    IO ()++instance RawSink () where+  sinkChar _ _ = ()+  sinkText _ _ = ()+  sinkAppend _ _ = ()+  sinkEmbed _ = ()+  sinkCheck _ _ _ _ _ _ _ = pure ()++instance RawSink RawBody where+  sinkChar c body = rawChar c <> body+  sinkText t body+    | T.null t = body+    | otherwise = RawBody (t : rawFrags body) (rawSize body + T.length t)+  sinkAppend = (<>)+  sinkEmbed = identity+  sinkCheck body expect base depth stack input text+    | rawSize body > collectBudget =+        throwIO (CollectPaused body expect base depth stack input text)+    | otherwise = pure ()++data SkipExpect+  = ExpectValue+  | ExpectKey+  | ExpectColon+  | ExpectObjComma+  | ExpectArrComma++-- | Bodies collected past this size pause for emission: fragment+-- transients scale ~150x the body (measured), so collection proceeds+-- in bounded segments that emit verbatim and resume. Small values+-- (the common case) complete in one segment.+collectBudget :: Int+collectBudget = 16384++-- | A raw container collect paused for exceeding 'collectBudget': the+-- body so far and the exact state to resume from (position, depth+-- context and live input). The caller emits the body verbatim, then+-- resumes; the concatenation is byte-identical to one uninterrupted+-- collect.+data CollectPaused = CollectPaused+  { pausedBody :: RawBody,+    pausedExpect :: SkipExpect,+    pausedBase :: NestDepth,+    pausedDepth :: NestDepth,+    pausedStack :: [DecodeContext],+    pausedInput :: Text,+    pausedStream :: StreamIO Text ()+  }++instance Show CollectPaused where+  showsPrec _ _ =+    showString "CollectPaused: raw container segment ready, resuming collect"++instance Exception CollectPaused++-- | Pull the next chunk, skipping empties. Exhaustion here is+-- 'UnexpectedEnd'.+pullSkipText :: Early HQError -> Text -> StreamIO Text () -> IO SkipRest+pullSkipText early !input !text+  | T.null input =+      S.next text >>= \case+        Left () -> leave early (HQDecodeError UnexpectedEnd)+        Right (chunk, rest) -> pullSkipText early chunk rest+  | otherwise = pure (SkipRest input text)++-- | The next non-whitespace character, pulling more chunks as needed.+nextSkipChar :: Early HQError -> Text -> StreamIO Text () -> IO (Char, SkipRest)+nextSkipChar early input text = case T.uncons (T.dropWhile isWhitespace input) of+  Just (c, rest) -> pure (c, SkipRest rest text)+  Nothing ->+    S.next text >>= \case+      Left () -> leave early (HQDecodeError UnexpectedEnd)+      Right (chunk, rest) -> nextSkipChar early chunk rest++-- | Skip an object member value; a colon is required first.+skipMemberValueText ::+  Early HQError ->+  NestDepth ->+  [DecodeContext] ->+  Text ->+  StreamIO Text () ->+  IO SkipRest+skipMemberValueText early !depth !stack !input !text = do+  (c, SkipRest rest text') <- nextSkipChar early input text+  case c of+    ':' -> skipExpect early depth depth stack ExpectValue rest text'+    _ -> leave early (HQDecodeError ExpectedColon)++-- | Skip the rest of the container whose opening event was just emitted.+skipContainerText ::+  Early HQError ->+  JSONEvent ->+  DecoderState ->+  StreamIO Text () ->+  IO (DecoderState, StreamIO Text ())+skipContainerText early open decoder@DecoderState {..} text = case open of+  JSONBeginArray -> skipRest ExpectValue+  JSONBeginObject -> skipRest ExpectKey+  _ -> pure (decoder, text)+  where+    -- The opener is already consumed, so the skip ends when the depth+    -- pops back below its entry level.+    skipRest expect = do+      let depth = decoderNestDepth+          base = shallower depth+      (SkipRest remainder rest) <-+        skipExpect early base depth decoderStack expect decoderInput text+      case decoderStack of+        _ : ctxs ->+          pure (finishValue decoder {decoderInput = remainder, decoderStack = ctxs}, rest)+        [] -> pure (finishValue decoder {decoderInput = remainder}, rest)++-- | Pop one container context and mark the parent, after the+-- container's closing bracket was consumed. Shared by every raw+-- container collect, however many segments it took.+finishContainer :: DecoderState -> Text -> DecoderState+finishContainer decoder remainder = case decoderStack decoder of+  _ : ctxs -> finishValue decoder {decoderInput = remainder, decoderStack = ctxs}+  [] -> finishValue decoder {decoderInput = remainder}++-- | Structural loop shared by skipping (discard, '()') and collecting+-- ('RawBody'): same states, same errors, same termination; only the+-- accumulator differs. Thin wrappers below specialize it, so both call+-- sites keep their old signatures and performance.+{-# INLINE generalExpect #-}+generalExpect ::+  (RawSink s) =>+  Early HQError ->+  s ->+  NestDepth ->+  NestDepth ->+  [DecodeContext] ->+  SkipExpect ->+  Text ->+  StreamIO Text () ->+  IO (SkipRest, s)+generalExpect early body base depth stack expect input text = do+  sinkCheck body expect base depth stack input text+  case expect of+    ExpectValue -> do+      (c, SkipRest rest text') <- nextSkipChar early input text+      case c of+        '{' ->+          generalExpect early (sinkChar '{' body) base (deeper depth) (DecodeObject : stack) ExpectKey rest text'+        '[' ->+          generalExpect early (sinkChar '[' body) base (deeper depth) (DecodeArray : stack) ExpectValue rest text'+        '"' -> do+          (SkipRest rest' text'', body') <-+            generalStringGo early (sinkChar '"' body) rest text'+          generalAfterValue early body' base depth stack rest' text''+        't' -> scalarKeyword "true" rest text'+        'f' -> scalarKeyword "false" rest text'+        'n' -> scalarKeyword "null" rest text'+        _+          | c == '-' || isDigit c -> do+              let phase = fromMaybe NumberSign (numberPhaseFromFirstChar c)+              (Collected (SkipRest rest' text'') nbody) <-+                collectNumber early (rawChar c) phase rest text'+              generalAfterValue early (sinkAppend (sinkEmbed nbody) body) base depth stack rest' text''+          | c == ']' -> case stack of+              DecodeArray : ctxs ->+                generalAfterValue early (sinkChar ']' body) base (shallower depth) ctxs rest text'+              _ -> leave early (HQDecodeError (UnexpectedChar c))+          | otherwise -> leave early (HQDecodeError (UnexpectedChar c))+      where+        scalarKeyword lit r t = do+          (Collected (SkipRest rest' text'') kbody) <-+            scanKeyword early 1 r t lit+          generalAfterValue early (sinkAppend (sinkEmbed kbody) body) base depth stack rest' text''+    ExpectKey -> do+      (c, SkipRest rest text') <- nextSkipChar early input text+      case c of+        '}' -> case stack of+          _ : ctxs ->+            generalAfterValue early (sinkChar '}' body) base (shallower depth) ctxs rest text'+          [] -> leave early (HQDecodeError ExpectedObjectKey)+        '"' -> do+          (SkipRest rest' text'', body') <- generalStringGo early (sinkChar '"' body) rest text'+          generalExpect early body' base depth stack ExpectColon rest' text''+        _ -> leave early (HQDecodeError ExpectedObjectKey)+    ExpectColon -> do+      (c, SkipRest rest text') <- nextSkipChar early input text+      case c of+        ':' -> generalExpect early (sinkChar ':' body) base depth stack ExpectValue rest text'+        _ -> leave early (HQDecodeError ExpectedColon)+    ExpectObjComma -> do+      (c, SkipRest rest text') <- nextSkipChar early input text+      case c of+        ',' -> generalExpect early (sinkChar ',' body) base depth stack ExpectKey rest text'+        '}' -> case stack of+          _ : ctxs ->+            generalAfterValue early (sinkChar '}' body) base (shallower depth) ctxs rest text'+          [] -> leave early (HQDecodeError ExpectedCommaOrEnd)+        _ -> leave early (HQDecodeError ExpectedCommaOrEnd)+    ExpectArrComma -> do+      (c, SkipRest rest text') <- nextSkipChar early input text+      case c of+        ',' -> generalExpect early (sinkChar ',' body) base depth stack ExpectValue rest text'+        ']' -> case stack of+          _ : ctxs ->+            generalAfterValue early (sinkChar ']' body) base (shallower depth) ctxs rest text'+          [] -> leave early (HQDecodeError ExpectedCommaOrEnd)+        _ -> leave early (HQDecodeError ExpectedCommaOrEnd)++{-# INLINE generalAfterValue #-}+generalAfterValue ::+  (RawSink s) =>+  Early HQError ->+  s ->+  NestDepth ->+  NestDepth ->+  [DecodeContext] ->+  Text ->+  StreamIO Text () ->+  IO (SkipRest, s)+generalAfterValue early body base depth stack rest text'+  | depth <= base = pure (SkipRest rest text', body)+  | otherwise = case stack of+      DecodeArray : _ ->+        generalExpect early body base depth stack ExpectArrComma rest text'+      DecodeObject : _ ->+        generalExpect early body base depth stack ExpectObjComma rest text'+      [] -> pure (SkipRest rest text', body)++-- | Structural collect loop; ends when the depth pops back to its+-- entry level. Specialization of 'generalExpect'.+collectExpect ::+  Early HQError ->+  RawBody ->+  NestDepth ->+  NestDepth ->+  [DecodeContext] ->+  SkipExpect ->+  Text ->+  StreamIO Text () ->+  IO Collected+collectExpect early body base depth stack expect input text = do+  (rest, body') <- generalExpect early body base depth stack expect input text+  pure (Collected rest body')+{-# INLINE collectExpect #-}++-- | Structural skip loop; ends when the depth pops back to its entry level.+-- Specialization of 'generalExpect'.+skipExpect ::+  Early HQError ->+  NestDepth ->+  NestDepth ->+  [DecodeContext] ->+  SkipExpect ->+  Text ->+  StreamIO Text () ->+  IO SkipRest+skipExpect early base depth stack expect input text = do+  (rest, _) <- generalExpect early () base depth stack expect input text+  pure rest+{-# INLINE skipExpect #-}++{-# SPECIALIZE generalExpect :: Early HQError -> () -> NestDepth -> NestDepth -> [DecodeContext] -> SkipExpect -> Text -> StreamIO Text () -> IO (SkipRest, ()) #-}+{-# SPECIALIZE generalExpect :: Early HQError -> RawBody -> NestDepth -> NestDepth -> [DecodeContext] -> SkipExpect -> Text -> StreamIO Text () -> IO (SkipRest, RawBody) #-}++{-# SPECIALIZE generalAfterValue :: Early HQError -> () -> NestDepth -> NestDepth -> [DecodeContext] -> Text -> StreamIO Text () -> IO (SkipRest, ()) #-}+{-# SPECIALIZE generalAfterValue :: Early HQError -> RawBody -> NestDepth -> NestDepth -> [DecodeContext] -> Text -> StreamIO Text () -> IO (SkipRest, RawBody) #-}++-- Single string scanner shared by both modes: validates escapes exactly+-- like the decoder; '()' discards bytes, 'RawBody' captures them+-- (quotes included). Specialized below so the skip path allocates nothing.+{-# INLINE generalStringGo #-}+generalStringGo ::+  (RawSink s) => Early HQError -> s -> Text -> StreamIO Text () -> IO (SkipRest, s)+generalStringGo early !body !inp !txt = do+  let (safe, rest) = T.span isStringChar inp+      body' = sinkText safe body+  case T.uncons rest of+    Nothing -> do+      (SkipRest chunk rest') <- pullSkipText early mempty txt+      generalStringGo early body' chunk rest'+    Just (c, rest')+      | c == '"' -> pure (SkipRest rest' txt, sinkChar '"' body')+      | c == '\\' -> generalEscape early body' rest' txt+      | otherwise -> leave early (HQDecodeError (UnexpectedChar c))++{-# INLINE generalEscape #-}+generalEscape ::+  (RawSink s) => Early HQError -> s -> Text -> StreamIO Text () -> IO (SkipRest, s)+generalEscape early !body !input !text = do+  (SkipRest chunk rest) <- pullSkipText early input text+  case T.uncons chunk of+    Nothing -> generalEscape early body mempty rest+    Just (c, rest')+      | c == 'u' -> generalUnicode early (sinkText (T.pack ['\\', 'u']) body) rest' rest 0 0+      | isSimpleEscape c -> generalStringGo early (sinkText (T.pack ['\\', c]) body) rest' rest+      | otherwise -> leave early (HQDecodeError (InvalidEscape c))++{-# INLINE generalUnicode #-}+generalUnicode ::+  (RawSink s) => Early HQError -> s -> Text -> StreamIO Text () -> Int -> Int -> IO (SkipRest, s)+generalUnicode early !body !input !text !value !digits = do+  (SkipRest chunk rest0) <- pullSkipText early input text+  let (value', digits', rest') = accumulateHex value digits chunk+      piece = T.take (T.length chunk - T.length rest') chunk+      body' = sinkText piece body+  if digits' >= 4+    then generalFinishUnicode early body' rest' rest0 value'+    else+      if T.null rest'+        then generalUnicode early body' mempty rest0 value' digits'+        else leave early (HQDecodeError InvalidUnicodeEscape)++{-# INLINE generalFinishUnicode #-}+generalFinishUnicode ::+  (RawSink s) => Early HQError -> s -> Text -> StreamIO Text () -> Int -> IO (SkipRest, s)+generalFinishUnicode early !body !input !text !value+  | isHighSurrogate value = generalLowSurrogate early body input text+  | isLowSurrogate value = leave early (HQDecodeError InvalidSurrogatePair)+  | otherwise = generalStringGo early body input text++{-# INLINE generalLowSurrogate #-}+generalLowSurrogate ::+  (RawSink s) => Early HQError -> s -> Text -> StreamIO Text () -> IO (SkipRest, s)+generalLowSurrogate early !body !input !text = do+  (SkipRest chunk rest) <- pullSkipText early input text+  case T.uncons chunk of+    Nothing -> generalLowSurrogate early body mempty rest+    Just ('\\', rest') -> case T.uncons rest' of+      Nothing -> generalLowBackslash early (sinkChar '\\' body) rest+      Just ('u', rest'') ->+        generalLowDigits early (sinkText (T.pack ['\\', 'u']) body) rest'' rest 0 0+      _ -> leave early (HQDecodeError InvalidSurrogatePair)+    _ -> leave early (HQDecodeError InvalidSurrogatePair)++{-# INLINE generalLowBackslash #-}+generalLowBackslash ::+  (RawSink s) => Early HQError -> s -> StreamIO Text () -> IO (SkipRest, s)+generalLowBackslash early !body !text = do+  (SkipRest chunk rest) <- pullSkipText early mempty text+  case T.uncons chunk of+    Nothing -> generalLowBackslash early body rest+    Just ('u', rest') -> generalLowDigits early (sinkChar 'u' body) rest' rest 0 0+    _ -> leave early (HQDecodeError InvalidSurrogatePair)++{-# INLINE generalLowDigits #-}+generalLowDigits ::+  (RawSink s) => Early HQError -> s -> Text -> StreamIO Text () -> Int -> Int -> IO (SkipRest, s)+generalLowDigits early !body !input !text !value !digits+  | digits == 4 =+      if isLowSurrogate value+        then generalStringGo early body input text+        else leave early $ HQDecodeError InvalidSurrogatePair+  | otherwise = do+      (SkipRest chunk rest) <- pullSkipText early input text+      case T.uncons chunk of+        Nothing -> generalLowDigits early body mempty rest value digits+        Just _ -> do+          let (value', digits', rest') = accumulateHex value digits chunk+              consumed = digits' - digits+              piece = T.take consumed chunk+              body' = sinkText piece body+          if digits' == 4+            then+              if isLowSurrogate value'+                then generalStringGo early body' rest' rest+                else leave early $ HQDecodeError InvalidSurrogatePair+            else+              if T.null rest'+                then generalLowDigits early body' mempty rest value' digits'+                else leave early $ HQDecodeError InvalidUnicodeEscape++{-# SPECIALIZE generalStringGo :: Early HQError -> () -> Text -> StreamIO Text () -> IO (SkipRest, ()) #-}+{-# SPECIALIZE generalStringGo :: Early HQError -> RawBody -> Text -> StreamIO Text () -> IO (SkipRest, RawBody) #-}++{-# SPECIALIZE generalEscape :: Early HQError -> () -> Text -> StreamIO Text () -> IO (SkipRest, ()) #-}+{-# SPECIALIZE generalEscape :: Early HQError -> RawBody -> Text -> StreamIO Text () -> IO (SkipRest, RawBody) #-}++-- | The shared keyword scanner both modes use: match the literal from+-- @index@, then require a JSON delimiter. The literal is fixed, so+-- the body is returned whole on success.+scanKeyword ::+  Early HQError -> Int -> Text -> StreamIO Text () -> Text -> IO Collected+scanKeyword early ix0 inp0 txt0 keyword = go ix0 inp0 txt0+  where+    go !ix !inp !txt+      | ix == T.length keyword = checkDelim inp txt+      | T.null inp = do+          result <- S.next txt+          case result of+            Left () -> leave early $ HQDecodeError $ InvalidKeyword keyword+            Right (chunk, rest) -> go ix chunk rest+      | otherwise = case T.uncons inp of+          Nothing -> go ix mempty txt+          Just (c, rest)+            | c == T.index keyword ix -> go (ix + 1) rest txt+            | otherwise -> leave early $ HQDecodeError $ InvalidKeyword keyword+    checkDelim !inp !txt+      | T.null inp = do+          result <- S.next txt+          case result of+            Left () ->+              let rawBody = RawBody [keyword] (T.length keyword)+               in pure $ Collected (SkipRest mempty txt) rawBody+            Right (chunk, rest) -> checkDelim chunk rest+      | otherwise = case T.uncons inp of+          Nothing -> checkDelim mempty txt+          Just (c, _)+            | isJsonDelimiter c ->+                let rawBody = RawBody [keyword] (T.length keyword)+                 in pure $ Collected (SkipRest inp txt) rawBody+            | otherwise -> leave early (HQDecodeError (InvalidKeyword keyword))++-- | Skip a number, capturing its raw bytes.+skipNumberCollect :: Early HQError -> Text -> StreamIO Text () -> IO Collected+skipNumberCollect early input text = case T.uncons input of+  Nothing -> do+    (SkipRest chunk rest) <- pullSkipText early mempty text+    skipNumberCollect early chunk rest+  Just (c, rest) ->+    let phase = fromMaybe NumberSign (numberPhaseFromFirstChar c)+     in collectNumber early (rawChar c) phase rest text++collectNumber ::+  Early HQError ->+  RawBody ->+  NumberPhase ->+  Text ->+  StreamIO Text () ->+  IO Collected+collectNumber early body phase inp txt+  | T.null inp = do+      result <- S.next txt+      case result of+        Left ()+          | isValidNumberFinal phase -> pure (Collected (SkipRest mempty txt) body)+          | otherwise ->+              leave early $ HQDecodeError $ InvalidNumber (T.concat (reverse (rawFrags body)))+        Right (chunk, rest) -> collectNumber early body phase chunk rest+  | otherwise = loop body phase 0+  where+    len = T.length inp+    loop b p pos+      | pos >= len = collectNumber early (RawBody (inp : rawFrags b) (rawSize b + len)) p mempty txt+      | acceptsDigitRun p = runDigits b p pos+      | otherwise = stepChar b p pos+    -- Digits self-loop in these phases: consume the maximal run with+    -- one span, then dispatch once on the terminating character.+    runDigits b' p' pos' =+      let pos'' = pos' + T.length (T.takeWhile isDigit (T.drop pos' inp))+       in if pos'' >= len+            then collectNumber early (RawBody (inp : rawFrags b') (rawSize b' + len)) p' mempty txt+            else stepChar b' p' pos''+    stepChar b' p' pos' =+      let c = T.index inp pos'+          piece = T.take pos' inp+          body' = RawBody (piece : rawFrags b') (rawSize b' + pos')+       in case advanceNumber p' c of+            NumberEnd+              | isValidNumberFinal p' -> pure (Collected (SkipRest (T.drop pos' inp) txt) body')+              | otherwise ->+                  leave early+                    $ HQDecodeError+                    $ InvalidNumber (T.concat (reverse (rawFrags b') <> [piece]))+            NumberError ->+              leave early+                $ HQDecodeError+                $ InvalidNumber (T.concat (reverse (rawFrags b') <> [piece]) <> T.singleton c)+            NumberStep p'' -> loop b' p'' (pos' + 1)++-- | Skip a string, capturing its raw bytes, quotes included. The+-- opening quote seeds the body (oldest position); the closing quote+-- is consed at the end.+skipStringCollect :: Early HQError -> Text -> StreamIO Text () -> IO Collected+skipStringCollect early inp txt = do+  (SkipRest rest txt', body) <- generalStringGo early (rawChar '"') inp txt+  pure (Collected (SkipRest rest txt') body)+{-# INLINE skipStringCollect #-}
+ src/HQ/JSON/Decoder/String.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | String parsing for the streaming JSON decoder, including escapes,+-- unicode escapes and surrogate pairs.+module HQ.JSON.Decoder.String where++import Data.Bits (Bits (..), shiftL)+import Data.Text qualified as T+import HQ.JSON.Decoder.Core+import HQ.JSON.Decoder.Error (DecodeError (..))+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)++startString ::+  StringTarget -> Text -> DecoderState -> Either DecodeError DecoderResult+startString target input = consumeString target input emptyStringBuffer++consumeString ::+  StringTarget ->+  Text ->+  StringBuffer ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeString target input buffer decoder = case T.uncons rest of+  Nothing ->+    let bufferedTarget = BufferedStringTarget target newBuffer+        parserString = DecoderPhaseString (InString bufferedTarget)+        decoder' = decoder {decoderInput = mempty, decoderPhase = parserString}+     in Right $ NeedInput decoder'+  Just (c, rest')+    | c == '"' -> case buffer of+        -- Single escape-free fragment (the common case for keys and+        -- short values): reference the input slice directly instead+        -- of copying it through 'StringBuffer' and 'T.concat'.+        StringBuffer [] -> finishStringText target chunk rest' decoder+        _ -> finishString target newBuffer rest' decoder+    | c == '\\' -> consumeStringEscape target rest' newBuffer decoder+    | otherwise -> Left (UnexpectedChar c)+  where+    (chunk, rest) = T.span isStringChar input+    newBuffer = appendStringBuffer chunk buffer++consumeStringEscape ::+  StringTarget ->+  Text ->+  StringBuffer ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeStringEscape target input buffer decoder = case T.uncons input of+  Nothing ->+    let parserString =+          DecoderPhaseString+            $ AfterEscape+            $ BufferedStringTarget target buffer+     in Right+          $ NeedInput decoder {decoderInput = mempty, decoderPhase = parserString}+  Just (c, rest)+    | c == 'u' -> consumeUnicode target rest buffer decoder+    | isSimpleEscape c ->+        let buf = appendCharStringBuffer (decodeSimpleEscape c) buffer+         in consumeString target rest buf decoder+    | otherwise -> Left (InvalidEscape c)++consumeUnicode ::+  StringTarget ->+  Text ->+  StringBuffer ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeUnicode target input buffer = consumeUnicode' target input buffer 0 0++consumeUnicode' ::+  StringTarget ->+  Text ->+  StringBuffer ->+  Int ->+  Int ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeUnicode' target input buffer value digits decoder+  | newDigits >= 4 = finishUnicode target rest buffer newValue decoder+  | T.null rest =+      let unicode = Unicode newValue newDigits+          bufferedString = BufferedStringTarget target buffer+          parserString = DecoderPhaseString $ InUnicodeEscape bufferedString unicode+          newDecoder = decoder {decoderInput = "", decoderPhase = parserString}+       in Right $ NeedInput newDecoder+  | otherwise = Left InvalidUnicodeEscape+  where+    -- Take at most the digits still needed to complete the escape: a+    -- further hex digit belongs to the text following the escape.+    (newValue, newDigits, rest) = accumulateHex value digits input++finishUnicode ::+  StringTarget ->+  Text ->+  StringBuffer ->+  Int ->+  DecoderState ->+  Either DecodeError DecoderResult+finishUnicode target input buffer value decoder+  | isHighSurrogate value =+      let bufferedStringT = BufferedStringTarget target buffer+          parserString = DecoderPhaseString $ AfterHighSurrogate bufferedStringT value+          newDecoder = decoder {decoderInput = input, decoderPhase = parserString}+       in Right $ NeedInput newDecoder+  | isLowSurrogate value = Left InvalidSurrogatePair+  | otherwise =+      consumeString target input (appendCharStringBuffer (chr value) buffer) decoder++stepString :: DecoderState -> StringState -> Either DecodeError DecoderResult+stepString decoder state = case state of+  InString (BufferedStringTarget target buffer) ->+    consumeString target (decoderInput decoder) buffer decoder+  AfterEscape (BufferedStringTarget target buffer) ->+    consumeStringEscape target (decoderInput decoder) buffer decoder+  InUnicodeEscape (BufferedStringTarget target buffer) (Unicode value digits) ->+    consumeUnicode' target (decoderInput decoder) buffer value digits decoder+  AfterHighSurrogate (BufferedStringTarget target buffer) high ->+    consumeLowSurrogate target (decoderInput decoder) buffer high decoder+  AfterLowBackslash (BufferedStringTarget target buffer) high ->+    consumeLowBackslash target (decoderInput decoder) buffer high decoder+  InLowSurrogateEscape (BufferedStringTarget target buffer) high (Unicode value digits) ->+    consumeLowSurrogateDigits target (decoderInput decoder) buffer high value digits decoder++consumeLowSurrogate ::+  StringTarget ->+  Text ->+  StringBuffer ->+  Int ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeLowSurrogate target input buffer high decoder = case T.uncons input of+  Nothing -> Right $ NeedInput decoder {decoderInput = mempty}+  Just ('\\', rest) -> case T.uncons rest of+    Nothing ->+      let parserString = DecoderPhaseString $ AfterLowBackslash (BufferedStringTarget target buffer) high+       in Right $ NeedInput decoder {decoderInput = mempty, decoderPhase = parserString}+    Just ('u', rest') ->+      consumeLowSurrogateDigits target rest' buffer high 0 0 decoder+    _ -> Left InvalidSurrogatePair+  _ -> Left InvalidSurrogatePair++-- | Resume after a chunk split between the low escape's backslash and+-- @u@: only @u@ may follow, continuing into the low hex digits.+consumeLowBackslash ::+  StringTarget ->+  Text ->+  StringBuffer ->+  Int ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeLowBackslash target input buffer high decoder = case T.uncons input of+  Nothing -> Right $ NeedInput decoder {decoderInput = mempty}+  Just ('u', rest) ->+    consumeLowSurrogateDigits target rest buffer high 0 0 decoder+  _ -> Left InvalidSurrogatePair++consumeLowSurrogateDigits ::+  StringTarget ->+  Text ->+  StringBuffer ->+  Int ->+  Int ->+  Int ->+  DecoderState ->+  Either DecodeError DecoderResult+consumeLowSurrogateDigits target input buffer high value digits decoder+  | digits == 4 =+      if isLowSurrogate value+        then+          let ch = chr (combineSurrogates high value)+              newBuffer = appendCharStringBuffer ch buffer+           in consumeString target input newBuffer decoder+        else Left InvalidSurrogatePair+  | otherwise =+      let (newValue, newDigits, rest) = accumulateHex value digits input+       in if newDigits == 4+            then+              if isLowSurrogate newValue+                then+                  let ch = chr (combineSurrogates high newValue)+                      newBuffer = appendCharStringBuffer ch buffer+                   in consumeString target rest newBuffer decoder+                else Left InvalidSurrogatePair+            else+              if T.null rest+                then+                  Right+                    $ NeedInput+                      decoder+                        { decoderInput = mempty,+                          decoderPhase =+                            DecoderPhaseString+                              $ InLowSurrogateEscape+                                (BufferedStringTarget target buffer)+                                high+                                (Unicode newValue newDigits)+                        }+                else+                  Left InvalidUnicodeEscape++-- | Combine a surrogate pair into its codepoint.+{-# INLINE combineSurrogates #-}+combineSurrogates :: Int -> Int -> Int+combineSurrogates high low =+  0x10000 + ((high - 0xD800) `shiftL` 10) + (low - 0xDC00)++finishString ::+  StringTarget ->+  StringBuffer ->+  Text ->+  DecoderState ->+  Either DecodeError DecoderResult+finishString target = finishStringText target . finishStringBuffer++-- | Finish a string from its materialized text. 'finishString' funnels+-- here after concatenating multi-fragment buffers, while the+-- single-fragment fast path in 'consumeString' calls it directly with+-- the input slice.+finishStringText ::+  StringTarget ->+  Text ->+  Text ->+  DecoderState ->+  Either DecodeError DecoderResult+finishStringText target text remaining decoder = case target of+  StringValue -> emitEvent (JSONString text) remaining decoder+  StringKey -> do+    let key = JSONObjectKey text+    let newDecoder =+          decoder+            { decoderInput = remaining,+              decoderPhase = DecoderPhaseObjectColon+            }+    Right $ Emit key newDecoder
+ src/HQ/JSON/Encoder.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.JSON.Encoder+  ( EncodeStyle (..),+    ValueOptions (..),+    encode,+    formatEvent,+    emitChunk,+    emitBuilder,+    emitRawBytes,+    emitRawOpen,+    emitRawTail,+    flushEmit,+    outputBatchSize,+    Builder,+    Chunk (..),+    BSStream,+    EncodeContext (..),+    EncoderState (..),+    EmitState (..),+    initialEncoderState,+    initialEmitState,+    Raw (..),+    Join (..),+    EncoderConfig (..),+  )+where++import Data.Bits (Bits (..))+import Data.ByteString qualified as BS+import Data.ByteString.Builder (Builder, byteString, char7, charUtf8, integerDec, string7, stringUtf8, toLazyByteString)+import Data.Scientific (Scientific, base10Exponent, coefficient)+import Data.Text qualified as Text+import Data.Text.Encoding (encodeUtf8Builder)+import HQ.JSON.Decoder.Core (NestDepth (..), deeper, initialDepth, isStringChar, shallower)+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming (Of, Stream)+import Streaming.Internal (Stream (..))+import Streaming.Prelude qualified as S++data EncoderConfig = EncoderConfig+  { outputStyle :: EncodeStyle,+    outputValueOptions :: ValueOptions+  }++-- | Output formatting style.+data EncodeStyle+  = -- | Compressed output with no whitespace.+    Compact+  | -- | Human-readable output using @n@ spaces per nesting+    -- level.+    Pretty Int+  deriving (Eq, Show)++-- | Render complete top-level string values without quotes or+-- escaping.  Strings nested inside containers, and object keys,+-- are unaffected.+data Raw = NoRaw | Raw deriving (Show, Eq)++-- | 'NoJoin' separates complete top-level values with a newline (like+-- jq); 'Join' concatenates them without separators (like @jq -j@).+data Join = NoJoin | Join deriving (Show, Eq)++-- | How back-to-back top-level values are rendered: newlines like+-- @jq@, and bare strings like @jq -r@.+data ValueOptions = ValueOptions Raw Join++-- | Container stack, head innermost. The 'Bool' marks a container that+-- already emitted a value; 'EncodeObjectAfterKey' awaits a key's value.+data EncodeContext+  = -- | Inside an array; 'True' once at least one element was emitted.+    EncodeArray !Bool+  | -- | Inside an object; 'True' once at least one pair was emitted.+    EncodeObject !Bool+  | -- | A key was just emitted; the next event is its value.+    EncodeObjectAfterKey++-- | Encoder state threaded through transcription: container contexts+-- plus their depth, kept in sync by construction (only 'formatEvent'+-- and 'closeContainer' reshape it). Output buffering lives in+-- 'EmitState', not here, so formatting stays pure.+data EncoderState = EncoderState ![EncodeContext] !NestDepth++initialEncoderState :: EncoderState+initialEncoderState = EncoderState [] initialDepth++-- | Output batching threshold; chunk boundaries never change bytes.+outputBatchSize :: Int+outputBatchSize = 65536++-- | Rewrite output accumulator: pending builder bytes plus the encoder+-- context. Events buffer here and flush as 'LByteString' once full.+data EmitState = EmitState !Builder !Int !EncoderState++initialEmitState :: EmitState+initialEmitState = EmitState mempty 0 initialEncoderState++-- | Append bytes to the pending builder, flushing once full.+{-# INLINE appendEmit #-}+appendEmit :: Builder -> Int -> Builder -> Int -> EncoderState -> BSStream IO EmitState+appendEmit b s pend pendSize st =+  let !pend' = pend <> b+      !pendSize' = pendSize + s+   in if pendSize' >= outputBatchSize+        then S.yield (toLazyByteString pend') >> pure (EmitState mempty 0 st)+        else pure (EmitState pend' pendSize' st)++-- | Buffer pre-encoded bytes without any separator bookkeeping.+emitBuilder :: Builder -> Int -> EmitState -> BSStream IO EmitState+emitBuilder b s (EmitState pend pendSize st) = appendEmit b s pend pendSize st++-- | Format one event and buffer it.+emitChunk :: EncoderConfig -> JSONEvent -> EmitState -> BSStream IO EmitState+emitChunk config event (EmitState pend pendSize st) =+  case formatEvent config st event of+    (Chunk b s, st') -> appendEmit b s pend pendSize st'++-- | Transcribe a pre-encoded scalar body exactly as 'formatEvent'+-- would for the equivalent scalar event, buffering the bytes.+-- Inlined: runs once per verbatim scalar on the raw take path.+{-# INLINE emitRawBytes #-}+emitRawBytes :: EncoderConfig -> Builder -> Int -> EmitState -> BSStream IO EmitState+emitRawBytes (EncoderConfig style valueOpts) bodyB bodyS (EmitState pend pendSize st) =+  appendEmit (sepB <> bodyB <> finB) (sepS + bodyS + finS) pend pendSize st2+  where+    (Chunk sepB sepS, st1) = beforeValue style st+    st2 = afterValue st1+    Chunk finB finS = finishTopValue joinOpt st2+    (ValueOptions _ joinOpt) = valueOpts++-- | Open a verbatim container body: the separator plus the opening+-- bracket. Split out so bounded-segment collection emits separators+-- once around the whole body instead of once per segment.+-- Inlined: runs once per verbatim container on the raw take path.+{-# INLINE emitRawOpen #-}+emitRawOpen :: EncoderConfig -> JSONEvent -> EmitState -> BSStream IO EmitState+emitRawOpen (EncoderConfig style _) open (EmitState pend pendSize st) =+  case beforeValue style st of+    (Chunk sepB sepS, st') ->+      let (brackB, brackS) = case open of+            JSONBeginArray -> (openBracket, 1)+            JSONBeginObject -> (openBrace, 1)+            _ -> (mempty, 0)+       in appendEmit (sepB <> brackB) (sepS + brackS) pend pendSize st'++-- | Close a verbatim container body: mark the parent non-empty and+-- emit the top-level separator. Split out so bounded-segment+-- collection composes byte-identically to one uninterrupted collect.+-- Inlined: runs once per verbatim container on the raw take path.+{-# INLINE emitRawTail #-}+emitRawTail :: EncoderConfig -> EmitState -> BSStream IO EmitState+emitRawTail (EncoderConfig _ (ValueOptions _ joinOpt)) (EmitState pend pendSize st) =+  let st' = afterValue st+      Chunk finB finS = finishTopValue joinOpt st'+   in appendEmit finB finS pend pendSize st'++-- | Flush pending bytes at end of document.+flushEmit :: EmitState -> BSStream IO EmitState+flushEmit es@(EmitState pend pendSize st)+  | pendSize > 0 = S.yield (toLazyByteString pend) >> pure (EmitState mempty 0 st)+  | otherwise = pure es++-- | Encode a 'Scientific' in compact JSON-compatible form, directly to+-- a 'Chunk'.+--+-- GHC's 'show' instance for 'Scientific' produces "42.0" for integer+-- values and "1.0e10" for exponent notation, neither of which is valid+-- JSON.  This function formats numbers correctly without intermediate+-- 'Text'/'String' conversions and without @10 ^ expo@ bignum+-- multiplications: non-negative exponents append @expo@ ASCII zeros,+-- negative exponents splice the decimal point into the coefficient+-- digits.+encodeNumber :: Scientific -> Chunk+encodeNumber n+  | c == 0 = Chunk (char7 '0') 1+  | e >= 0 =+      let signB = if c < 0 then char7 '-' else mempty+          signLen = if c < 0 then 1 else 0+          mag = abs c+          digLen = integerDigits mag+          zerosB = zeroBytes e+       in Chunk (signB <> integerDec mag <> zerosB) (signLen + digLen + e)+  | otherwise =+      let signB = if c < 0 then char7 '-' else mempty+          signLen = if c < 0 then 1 else 0+          digits = show (abs c)+          len = length digits+          na = negate e+       in if len <= na+            then+              Chunk+                (signB <> string7 "0." <> zeroBytes (na - len) <> string7 digits)+                (signLen + 2 + na)+            else+              let (prefix, suffix) = splitAt (len - na) digits+               in Chunk+                    (signB <> string7 prefix <> char7 '.' <> string7 suffix)+                    (signLen + len + 1)+  where+    c = coefficient n+    e = base10Exponent n++-- | Replicated bytes as a builder.+replicateBytes :: Word8 -> Int -> Builder+replicateBytes w k+  | k <= 0 = mempty+  | otherwise = byteString (BS.replicate k w)++-- | ASCII @'0'@ bytes as a builder: a @memset@, like 'indentSpaces'.+zeroBytes :: Int -> Builder+zeroBytes = replicateBytes 0x30++-- | Decimal digit count of a non-zero magnitude. Small values (the+-- common case: ages, balances, ids) take 1-2 steps; large values loop+-- once per digit without allocating a digit string.+integerDigits :: Integer -> Int+integerDigits x = go x (0 :: Int)+  where+    go v !acc+      | v < 10 = acc + 1+      | otherwise = go (v `quot` 10) (acc + 1)++-- | Events to 'ByteString' chunks, flushing roughly every @cSize@ bytes.+-- Formats and buffers in one loop: there is no intermediate chunk+-- stream (one fewer 'S.next'/'S.yield' pair and no per-event box).+-- Specialized for IO (the only production monad): the generic loop+-- threads a 'Monad' dictionary through every event, and the lib/test+-- drivers all run at IO.+{-# INLINEABLE encode #-}+{-# SPECIALIZE encode :: EncoderConfig -> Int -> JSONStream IO r -> BSStream IO r #-}+encode :: (Monad m) => EncoderConfig -> Int -> JSONStream m r -> BSStream m r+encode config size = go initialEncoderState mempty 0+  where+    go :: (Monad m) => EncoderState -> Builder -> Int -> JSONStream m r -> BSStream m r+    go !st !builder !size' stream = do+      nextResult <- lift $ S.next stream+      case nextResult of+        Left r ->+          if size' == 0 then Return r else S.yield (flush builder) >> Return r+        Right (event, rest) ->+          let (Chunk eventChunk eventSize, st') = formatEvent config st event+              newSize = size' + eventSize+              newBuilder = builder <> eventChunk+           in if size' > 0 && newSize >= size+                then S.yield (flush newBuilder) >> go st' mempty 0 rest+                else go st' newBuilder newSize rest++    flush :: Builder -> LByteString+    flush = toLazyByteString++-- | Format a single event to a 'Chunk', threading the container+-- context. This is one step of 'encode', exposed so fused+-- pipelines can format events without an intermediate event stream.+formatEvent :: EncoderConfig -> EncoderState -> JSONEvent -> (Chunk, EncoderState)+formatEvent config@(EncoderConfig style (ValueOptions rawOpt joinOpt)) st event =+  case event of+    e | e == JSONEndArray || e == JSONEndObject -> closeContainerAndFinish+    JSONBeginArray -> openWith openBracket (EncodeArray False)+    JSONBeginObject -> openWith openBrace (EncodeObject False)+    JSONObjectKey _ -> case beforeKey style st of+      (Chunk sepB sepS, st') -> case encodeEvent event of+        Chunk evB evS -> (Chunk (sepB <> evB) (sepS + evS), st')+    _ -> case valueChunk event st of+      Chunk evB evS -> emitChunkBytes config st evB evS+  where+    closeContainerAndFinish = case closeContainer style st of+      (Chunk sepB sepS, st') -> case finishTopValue joinOpt st' of+        Chunk finB finS -> (Chunk (sepB <> finB) (sepS + finS), st')++    -- Shared shape of the two container opens: separator, bracket,+    -- and a fresh empty context.+    openWith :: Builder -> EncodeContext -> (Chunk, EncoderState)+    openWith brack ctx = case beforeValue style st of+      (Chunk sepB sepS, st') ->+        (Chunk (sepB <> brack) (sepS + 1), pushCtx ctx st')++    -- Push one container context, tracking depth alongside.+    pushCtx :: EncodeContext -> EncoderState -> EncoderState+    pushCtx ctx (EncoderState ctxs depth) =+      EncoderState (ctx : ctxs) (deeper depth)++    -- Render one value event, honoring raw top-level string output.+    valueChunk :: JSONEvent -> EncoderState -> Chunk+    valueChunk (JSONString text) (EncoderState valueCtxs _)+      | rawOpt == Raw && null valueCtxs = encodeRawString text+    valueChunk ev _ = encodeEvent ev++-- | Separator after a complete top-level value: newline unless 'Join'.+finishTopValue :: Join -> EncoderState -> Chunk+finishTopValue joinOpt (EncoderState ctxs' _)+  | joinOpt == NoJoin && null ctxs' = Chunk newline 1+  | otherwise = Chunk mempty 0++-- | Pure core shared by 'formatEvent' and 'emitRawBytes': wrap a+-- pre-encoded scalar body with its separator and top-level finish.+emitChunkBytes ::+  EncoderConfig -> EncoderState -> Builder -> Int -> (Chunk, EncoderState)+emitChunkBytes (EncoderConfig style valueOpts) st bodyB bodyS =+  (Chunk (sepB <> bodyB <> finB) (sepS + bodyS + finS), st2)+  where+    (Chunk sepB sepS, st1) = beforeValue style st+    st2 = afterValue st1+    Chunk finB finS = finishTopValue joinOpt st2+    (ValueOptions _ joinOpt) = valueOpts++beforeKey :: EncodeStyle -> EncoderState -> (Chunk, EncoderState)+beforeKey style st@(EncoderState ctxs depth) = case ctxs of+  EncodeObject seen : rest ->+    ( elementSeparator style seen depth,+      EncoderState (EncodeObjectAfterKey : rest) depth+    )+  -- A key outside a container; emit it bare.+  _ -> (Chunk mempty 0, st)++-- | The structural pieces to emit before a value (a scalar or a+-- container opening).  The context is left unchanged; 'afterValue'+-- marks the parent non-empty once the value has arrived, or when a+-- nested container closes.+beforeValue :: EncodeStyle -> EncoderState -> (Chunk, EncoderState)+beforeValue style st@(EncoderState ctxs depth) = case ctxs of+  EncodeObjectAfterKey : _ -> (colonSeparator style, st)+  EncodeArray seen : _ -> member seen+  -- A value where a key was expected (malformed input); recover by+  -- treating it as an additional array-like member.+  EncodeObject seen : _ -> member seen+  -- A top-level value; no separator.+  [] -> (Chunk mempty 0, st)+  where+    member seen = (elementSeparator style seen depth, st)++-- | After a value was emitted, mark the innermost container non-empty.+afterValue :: EncoderState -> EncoderState+afterValue (EncoderState ctxs depth) = EncoderState (mark ctxs) depth+  where+    mark = \case+      [] -> []+      EncodeArray _ : rest -> EncodeArray True : rest+      EncodeObject _ : rest -> EncodeObject True : rest+      EncodeObjectAfterKey : rest -> EncodeObject True : rest++-- | Emit the closing delimiter for a container, then pop it and mark+-- the parent container as having received a value.+closeContainer :: EncodeStyle -> EncoderState -> (Chunk, EncoderState)+closeContainer _ st@(EncoderState [] _) = (Chunk mempty 0, st)+closeContainer style (EncoderState (ctx : rest) depth) =+  let depth' = shallower depth+   in (closingDelimiter style depth' ctx, afterValue (EncoderState rest depth'))++-- | The closing delimiter of the innermost container.  An empty+-- container stays on one line; a non-empty one is closed on its own+-- line, indented to the depth of the container itself (the parent+-- depth).+closingDelimiter :: EncodeStyle -> NestDepth -> EncodeContext -> Chunk+closingDelimiter style (NestDepth depth) ctx = case ctx of+  EncodeArray seen -> close seen ']'+  EncodeObject seen -> close seen '}'+  EncodeObjectAfterKey -> close True '}'+  where+    close seen delim = case style of+      Pretty width+        | seen ->+            let size = width * depth+             in Chunk (newline <> indentSpaces size <> char7 delim) (size + 2)+      _ -> Chunk (char7 delim) 1++-- | The chunk emitted before an array element or an object key.+--+-- In 'Compact' mode this is just a comma (or nothing for the first+-- item); in 'Pretty' mode a newline (preceded by a comma except for the+-- first item) and indentation to @depth@.+elementSeparator :: EncodeStyle -> Bool -> NestDepth -> Chunk+elementSeparator Compact seen _ = if seen then Chunk comma 1 else Chunk mempty 0+elementSeparator (Pretty width) seen (NestDepth depth) =+  let size = width * depth+      prefix = if seen then commaNewline else newline+   in Chunk (prefix <> indentSpaces size) (size + 1 + fromEnum seen)++-- | Indentation via O(1) slices of a shared padding string.+indentPadding :: BS.ByteString+indentPadding = BS.replicate 256 0x20++indentSpaces :: Int -> Builder+indentSpaces size+  | size <= BS.length indentPadding = byteString (BS.take size indentPadding)+  | otherwise = replicateBytes 0x20 size++-- | Shared output fragments, built once and reused per event.+commaNewline, newline, colonSpace, colon :: Builder+commaNewline = string7 ",\n"+newline = char7 '\n'+colonSpace = string7 ": "+colon = char7 ':'++comma :: Builder+comma = char7 ','++openBrace, closeBrace, openBracket, closeBracket :: Builder+openBrace = char7 '{'+closeBrace = char7 '}'+openBracket = char7 '['+closeBracket = char7 ']'++jsonNull, jsonTrue, jsonFalse :: Builder+jsonNull = string7 "null"+jsonTrue = string7 "true"+jsonFalse = string7 "false"++-- | The chunk emitted between an object key and its value.+colonSeparator :: EncodeStyle -> Chunk+colonSeparator Compact = Chunk colon 1+colonSeparator (Pretty _) = Chunk colonSpace 2++-- | An output fragment with its size. The size is a flush heuristic+-- (character count, not exact bytes for non-ASCII), so chunk+-- boundaries may shift with content; output bytes are unaffected.+-- Strict fields plus strict 'case' deconstruction keep every component+-- thunk-free.+data Chunk = Chunk {chunkBuilder :: !Builder, chunkSize :: !Int}++instance Semigroup Chunk where+  Chunk b1 s1 <> Chunk b2 s2 = let !s = s1 + s2 in Chunk (b1 <> b2) s++instance Monoid Chunk where mempty = Chunk mempty 0++encodeEvent :: JSONEvent -> Chunk+encodeEvent = \case+  JSONBeginObject -> Chunk openBrace 1+  JSONEndObject -> Chunk closeBrace 1+  JSONBeginArray -> Chunk openBracket 1+  JSONEndArray -> Chunk closeBracket 1+  JSONNull -> Chunk jsonNull 4+  JSONBool True -> Chunk jsonTrue 4+  JSONBool False -> Chunk jsonFalse 5+  JSONNumber n -> encodeNumber n+  JSONObjectKey text -> encodeString text+  JSONString text -> encodeString text++encodeString :: Text -> Chunk+encodeString text =+  case encodeStringBody text of+    Chunk body bodySize -> Chunk (char7 '"' <> body <> char7 '"') (bodySize + 2)++encodeRawString :: Text -> Chunk+encodeRawString text =+  Chunk (stringUtf8 (toString text)) (Text.length text)++-- | String body; safe runs share the input slice (no copy).+encodeStringBody :: Text -> Chunk+encodeStringBody text = let Chunk b s = go text in Chunk b s+  where+    go t+      | Text.null t = mempty+      | otherwise =+          let (safe, rest) = Text.span isStringChar t+              -- Estimated size (chars, not bytes): exact enough to drive+              -- flush decisions, and free, unlike a byte-counting pass.+              safeChunk = Chunk (encodeUtf8Builder safe) (Text.length safe)+           in case Text.uncons rest of+                Nothing -> safeChunk+                Just (c, rest') ->+                  safeChunk <> encodeEscapedChar c <> go rest'++encodeEscapedChar :: Char -> Chunk+encodeEscapedChar = \case+  '"' -> Chunk (string7 "\\\"") 2+  '\\' -> Chunk (string7 "\\\\") 2+  '\b' -> Chunk (string7 "\\b") 2+  '\f' -> Chunk (string7 "\\f") 2+  '\n' -> Chunk (string7 "\\n") 2+  '\r' -> Chunk (string7 "\\r") 2+  '\t' -> Chunk (string7 "\\t") 2+  c+    | c < '\x20' -> Chunk (encodeUnicodeEscape $ fromEnum c) 6+    | otherwise ->+        let size = utf8CharSize c+         in Chunk (charUtf8 c) size++encodeUnicodeEscape :: Int -> Builder+encodeUnicodeEscape n =+  string7 "\\u"+    <> char7 (hexDigit ((n `shiftR` 12) .&. 0xf))+    <> char7 (hexDigit ((n `shiftR` 8) .&. 0xf))+    <> char7 (hexDigit ((n `shiftR` 4) .&. 0xf))+    <> char7 (hexDigit (n .&. 0xf))++hexDigit :: Int -> Char+hexDigit x+  | x < 10 = toEnum (fromEnum '0' + x)+  | otherwise = toEnum (fromEnum 'a' + x - 10)++utf8CharSize :: Char -> Int+utf8CharSize c+  | n <= 0x7f = 1+  | n <= 0x7ff = 2+  | n <= 0xffff = 3+  | otherwise = 4+  where+    n = fromEnum c++type JSONStream m r = Stream (Of JSONEvent) m r++type BSStream m r = Stream (Of LByteString) m r
+ src/HQ/JSON/Event.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.JSON.Event where++import Data.Aeson (Value (..))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Scientific (Scientific)+import Data.Vector qualified as Vector+import HQ.Runner.Error (RunnerError (..))+import Relude hiding (Compose, id, many, some, state)++--------------------------------------------------------------------------------+-- Events+--------------------------------------------------------------------------------++data JSONEvent+  = JSONBeginObject+  | JSONEndObject+  | JSONBeginArray+  | JSONEndArray+  | JSONObjectKey Text+  | JSONNull+  | JSONBool Bool+  | JSONNumber Scientific+  | JSONString Text+  deriving stock (Eq, Show)++--------------------------------------------------------------------------------+-- Event classifiers+--------------------------------------------------------------------------------++-- | Matching close for a container open; 'Nothing' for non-opens.+-- Single table for the open/close dispatch in Take/Cursor.+matchingClose :: JSONEvent -> Maybe JSONEvent+matchingClose = \case+  JSONBeginArray -> Just JSONEndArray+  JSONBeginObject -> Just JSONEndObject+  _ -> Nothing++-- | Parse exactly one value from events; trailing events are rejected.+eventsToValue :: [JSONEvent] -> Either RunnerError Value+eventsToValue events = case parseValue events of+  Left err -> Left err+  Right (value, []) -> Right value+  Right _ -> Left TrailingEventsAfterValue+  where+    parseValue :: [JSONEvent] -> Either RunnerError (Value, [JSONEvent])+    parseValue (JSONNull : rest) = Right (Null, rest)+    parseValue (JSONBool b : rest) = Right (Bool b, rest)+    parseValue (JSONNumber n : rest) = Right (Number n, rest)+    parseValue (JSONString s : rest) = Right (String s, rest)+    parseValue (JSONBeginArray : rest) =+      first (Array . Vector.fromList) <$> parseElements rest+    parseValue (JSONBeginObject : rest) =+      first (Object . KeyMap.fromList) <$> parseMembers rest+    parseValue _ = Left ExpectedJSONValue++    parseElements :: [JSONEvent] -> Either RunnerError ([Value], [JSONEvent])+    parseElements = parseDelimited JSONEndArray parseValue++    withKey k v = (Key.fromText k, v)+    parseMembers :: [JSONEvent] -> Either RunnerError ([(Key.Key, Value)], [JSONEvent])+    parseMembers = parseDelimited JSONEndObject $ \case+      (JSONObjectKey key : rest) -> first (withKey key) <$> parseValue rest+      _ -> Left ExpectedObjectKeyEvent++-- | Parse a delimited list ending in @end@; @parseOne@ parses a+-- single element (failing on anything else). Shared by 'parseElements'+-- and 'parseMembers', which differ only in end token and element shape.+-- Inlined so @parseOne@ specializes per list kind.+{-# INLINE parseDelimited #-}+parseDelimited ::+  JSONEvent ->+  ([JSONEvent] -> Either RunnerError (a, [JSONEvent])) ->+  [JSONEvent] ->+  Either RunnerError ([a], [JSONEvent])+parseDelimited end parseOne = go+  where+    go (ev : rest) | ev == end = Right ([], rest)+    go input = do+      (x, rest) <- parseOne input+      (xs, rest') <- go rest+      Right (x : xs, rest')++-- | Encode a JSON value as a sequence of events.+valueToEvents :: Value -> [JSONEvent]+valueToEvents Null = [JSONNull]+valueToEvents (Bool b) = [JSONBool b]+valueToEvents (Number n) = [JSONNumber n]+valueToEvents (String s) = [JSONString s]+valueToEvents (Array values) =+  JSONBeginArray : (concatMap valueToEvents (Vector.toList values) <> [JSONEndArray])+valueToEvents (Object members) =+  JSONBeginObject : (concatMap member (KeyMap.toList members) <> [JSONEndObject])+  where+    member (key, value) = JSONObjectKey (Key.toText key) : valueToEvents value
+ src/HQ/JSON/Parser.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.JSON.Parser where++import Data.Aeson (Value (..))+import Data.Aeson.Decoding (eitherDecodeStrictText, toEitherValue)+import Data.Aeson.Decoding.Text (textToTokens)+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Scientific (Scientific)+import HQ.JSON.Decoder qualified as Decoder+import HQ.JSON.Event (JSONEvent (..))+import HQ.Parser (Parser, lexeme)+import Relude hiding (Compose, id, many, some)+import Text.Megaparsec (getInput, setInput)++-- | Parse a whole JSON value (CLI @VALUE@ arguments, tests).+-- Single validation via aeson.+parseValue :: Text -> Either String Value+parseValue = eitherDecodeStrictText++-- | Parse a value into ordered events ('Value' forgets member order).+-- Single streaming pass (no megaparsec pre-validation).+parseValueEvents :: Text -> Either Text [JSONEvent]+parseValueEvents input = case decodeValueEvents input of+  Left err -> Left (fromString (show err))+  Right events -> Right events++decodeValueEvents :: Text -> Either Decoder.DecodeError [JSONEvent]+decodeValueEvents input = Decoder.decodeTexts [input]++-- | Parse one JSON literal embedded in the DSL directly with aeson.+jsonValueParser :: Parser Value+jsonValueParser = lexeme $ do+  input <- getInput+  case toEitherValue (textToTokens input) of+    Left err -> fail ("invalid JSON value: " <> err)+    Right (v, rest) -> setInput rest >> pure v++jsonTyped :: Text -> (Value -> Maybe a) -> Parser a+jsonTyped msg project = do+  value <- jsonValueParser+  case project value of+    Just a -> pure a+    Nothing -> fail (toString msg)++jsonNumber :: Parser Scientific+jsonNumber = jsonTyped "expected a JSON number" $ \case+  Number n -> Just n+  _ -> Nothing++jsonText :: Parser Text+jsonText = jsonTyped "expected a JSON string" $ \case+  String s -> Just s+  _ -> Nothing++jsonArray :: Parser [Value]+jsonArray = jsonTyped "expected a JSON array" $ \case+  Array items -> Just (toList items)+  _ -> Nothing++jsonObject :: Parser (KeyMap.KeyMap Value)+jsonObject = jsonTyped "expected a JSON object" $ \case+  Object members -> Just members+  _ -> Nothing
+ src/HQ/Optic.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Optic where++import GHC.Show (Show (showsPrec), appPrec, showParen, showString, shows)+import HQ.JSON.Event (JSONEvent (..))+import HQ.Transformation (Transformation)+import HQ.Transformation qualified as Trans+import Relude hiding (Compose, Const, filter, id, many, some)++-- | JSON value shapes selectable by a prism.+data PrismKind+  = PString+  | PNumber+  | PBool+  | PNull+  | PArray+  | PObject+  deriving stock (Eq)++-- | Optic paths over JSON values. 'Field', 'Ix' and+-- '_Just' are affine; 'Id' is a lens; 'Each', 'Keys', 'Values' are+-- traversals; '_String'-style constructors are prisms; 'Filter' is+-- affine. See 'OpticType' for the cardinality lattice.+data Optic+  = -- | Focus on a named field of a JSON object. Fails on non-objects.+    Field Text+  | -- | Traverse all elements of a JSON array, or the values of an object.+    -- Composed with another optic, it distributes that optic over each element:+    -- @@users.each.@name@ focuses on the @name@ field of each array element.+    Each+  | -- | Traverse object keys as string values (objects only).+    -- Focuses on each member name (@JSONString@) in document order.+    -- Arrays and scalars focus on nothing. Rewriting through @keys@+    -- renames object members.+    Keys+  | -- | Traverse object member values (objects only, unlike 'Each').+    -- Arrays and scalars focus on nothing; use 'Each' or 'Ix' for arrays.+    Values+  | -- | The identity optic: focuses on the whole value unchanged.+    Id+  | -- | Sequence two optics: first focus where the left points,+    --   then within each target, focus where the right points.+    Compose Optic Optic+  | -- | Prism: focus on a JSON value of the given shape. Fails on+    -- mismatching values.+    Prism PrismKind+  | -- | Focus on any non-null JSON value. Fails on null.+    -- Matching-only (affine traversal, not a lawful prism).+    PrismJust+  | -- | Focus on the element at the given index of a JSON array (arrays+    -- only; objects and scalars focus on nothing). Out-of-bounds and+    -- negative indices focus on nothing.+    Ix Int+  | -- | Keep the focused value when the transformation holds of the+    -- sub-optic's focus: @filter o p@ focuses its input if @p@ maps+    -- some value focused by @o@ to true, and focuses nothing otherwise.+    -- Focusing is existential ('any'): one passing sub-value keeps the+    -- whole input. Affine traversal (zero or one of its input).+    Filter Optic Transformation+  deriving stock (Eq)++instance Show Optic where+  showsPrec d (Field name) =+    showParen (d > appPrec) $ showString "@" . showsPrec (appPrec + 1) name+  showsPrec _ Each = showString "each"+  showsPrec _ Keys = showString "keys"+  showsPrec _ Values = showString "values"+  showsPrec _ Id = showString "id"+  showsPrec d (Compose a b) =+    showParen (d > composePrec)+      $ showsPrec prec a+      . showString " . "+      . showsPrec prec b+    where+      composePrec :: Int = 5+      prec = composePrec + 1+  showsPrec _ (Prism kind) = showString (prismName kind)+  showsPrec _ PrismJust = showString "_Just"+  showsPrec _ (Ix i) = showString $ "ix " <> show i+  showsPrec d (Filter o t) =+    showParen (d > filterPrec)+      $ showString "filter "+      . showsArgs o t+    where+      filterPrec = appPrec+      -- Non-atoms take their own paren group per side, which reparses deterministically.+      showsArgs oo tt+        | isAtomOptic oo && isAtomTrans tt =+            showsPrec (filterPrec + 1) oo+              . showString " "+              . showsPrec (filterPrec + 1) tt+        | otherwise =+            showString "("+              . shows oo+              . showString ") ("+              . shows tt+              . showString ")"+      isAtomOptic (Compose _ _) = False+      isAtomOptic _ = True+      -- 'Trans.Compose' must stay qualified: bare 'Compose' is 'Optic.Compose' here.+      isAtomTrans (Trans.Compose _ _) = False+      isAtomTrans (Trans.Or _ _) = False+      isAtomTrans (Trans.And _ _) = False+      isAtomTrans (Trans.Xor _ _) = False+      isAtomTrans _ = True++-- | First-event predicate for each type prism; total over 'PrismKind'.+prismPredicate :: PrismKind -> JSONEvent -> Bool+prismPredicate PString (JSONString _) = True+prismPredicate PNumber (JSONNumber _) = True+prismPredicate PBool (JSONBool _) = True+prismPredicate PNull JSONNull = True+prismPredicate PArray JSONBeginArray = True+prismPredicate PObject JSONBeginObject = True+prismPredicate _ _ = False++-- | Compose with 'Id' elimination on either side ('Id' is the identity).+appendOptic :: Optic -> Optic -> Optic+appendOptic Id rest = rest+appendOptic step Id = step+appendOptic step rest = Compose step rest++instance Semigroup Optic where (<>) = appendOptic++instance Monoid Optic where mempty = Id++-- | Whether a suffix focuses the whole value starting at @event@.+focusesWhole :: Optic -> JSONEvent -> Bool+focusesWhole optic event = case optic of+  Id -> True+  Field _ -> False+  Each -> False+  Keys -> False+  Values -> False+  Ix _ -> False+  Prism kind -> prismPredicate kind event+  PrismJust -> event /= JSONNull+  Filter _ _ -> False+  Compose l r -> focusesWhole l event && focusesWhole r event++prismName :: PrismKind -> String+prismName PString = "_String"+prismName PNumber = "_Number"+prismName PBool = "_Bool"+prismName PNull = "_Null"+prismName PArray = "_Array"+prismName PObject = "_Object"
+ src/HQ/Optic/AST.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Optic.AST where++import HQ.Optic+import HQ.Optic.OpticType+import HQ.Transformation.TransformationType (ValueType (..))+import Relude hiding (Compose, id)++-- | Infer an optic's cardinality ('OpticType' lattice, combined with+-- '<>' over compositions). Total: every optic has a cardinality.+inferOpticType :: Optic -> OpticType+inferOpticType = go+  where+    go (Field _) = OpticAffineTraversal+    go Each = OpticTraversal+    go Keys = OpticTraversal+    go Values = OpticTraversal+    go Id = OpticLens+    go (Compose left right) = go left <> go right+    go (Ix _) = OpticAffineTraversal+    -- '_Just' is matching-only (its identity 'review' is not a section+    -- on 'Null'), so it is an affine traversal rather than a prism.+    go PrismJust = OpticAffineTraversal+    -- 'Filter' keeps its input zero or one times; the annotation of its+    -- sub-optic is irrelevant to its own cardinality.+    go (Filter _ _) = OpticAffineTraversal+    go (Prism _) = OpticPrism++-- | Infer the value type an optic focuses. Prisms (and 'Keys') pin+-- the type down; 'Field', 'Each', 'Values', 'Ix' and 'Id' focus+-- values of unknown shape, and 'Filter' keeps its input, so all of+-- those yield 'ValueAny'. Composition takes the right side: the+-- result values are whatever the rightmost selector focuses. Total,+-- and sound: a focus is always of the inferred type or nothing, so+-- only exact (non-'Any') mismatches are ever reported.+inferFocusType :: Optic -> ValueType+inferFocusType = go+  where+    go (Field _) = ValueAny+    go Each = ValueAny+    go Keys = ValueString+    go Values = ValueAny+    go Id = ValueAny+    go (Compose _ right) = go right+    go (Ix _) = ValueAny+    go PrismJust = ValueAny+    go (Filter _ _) = ValueAny+    go (Prism PString) = ValueString+    go (Prism PNumber) = ValueNumber+    go (Prism PBool) = ValueBool+    go (Prism PNull) = ValueNull+    go (Prism PArray) = ValueArray+    go (Prism PObject) = ValueObject
+ src/HQ/Optic/OpticType.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Optic.OpticType where++import Relude hiding (Compose, id)++-- | OpticType+--+-- +-----------+-----------+-----------+-----------+-----------++-- |           | Lens      | Prism     | Affine    | Traversal |+-- +===========+===========+===========+===========+===========++-- | Lens      | Lens      | Prism     | Affine    | Traversal |+-- +-----------+-----------+-----------+-----------+-----------++-- | Prism     | Prism     | Prism     | Affine    | Traversal |+-- +-----------+-----------+-----------+-----------+-----------++-- | Affine    | Affine    | Affine    | Affine    | Traversal |+-- +-----------+-----------+-----------+-----------+-----------++-- | Traversal | Traversal | Traversal | Traversal | Traversal |+-- +-----------+-----------+-----------+-----------+-----------++data OpticType = OpticLens | OpticPrism | OpticAffineTraversal | OpticTraversal+  deriving (Eq, Ord, Show, Bounded)++-- | Composition lattice: composing takes the 'max'.+-- Constructor order is the lattice order, so composition is 'max'.+instance Semigroup OpticType where (<>) = max++instance Monoid OpticType where mempty = minBound
+ src/HQ/Optic/Parser.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Optic.Parser where++import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)+import HQ.Optic+import HQ.Parser (Parser, keyword, lexeme, parens, parseTop, symbol)+import HQ.Transformation.Parser (atomParser)+import Relude hiding (Compose, filter, id, many, some)+import Text.Megaparsec+import Text.Megaparsec.Char (alphaNumChar, char)+import Text.Megaparsec.Char.Lexer (decimal)++parseOptic :: Text -> Either (ParseErrorBundle Text Void) Optic+parseOptic = parseTop "optic" opticParser++opticParser :: Parser Optic+opticParser = makeExprParser opticAtomParser [[InfixL (Compose <$ symbol ".")]]++opticAtomParser :: Parser Optic+opticAtomParser =+  choice+    [ fieldParser,+      eachParser,+      keysParser,+      valuesParser,+      filterParser,+      idParser,+      prismParser,+      ixParser,+      groupedOptic+    ]++-- | Redundant parentheses are tolerated around any optic atom.+groupedOptic :: Parser Optic+groupedOptic = parens opticParser++fieldParser :: Parser Optic+fieldParser = char '@' >> Field <$> identifier++identifier :: Parser Text+identifier = lexeme $ fromString <$> some (alphaNumChar <|> char '_' <|> char '-')++eachParser :: Parser Optic+eachParser = keyword "each" Each++keysParser :: Parser Optic+keysParser = keyword "keys" Keys++valuesParser :: Parser Optic+valuesParser = keyword "values" Values++-- | @filter OPTIC TRANSFORMATION@: two bare atoms, each optionally+-- parenthesized. Non-atoms take their own paren group+-- (@filter (each . @age) (== 30)@), which keeps the split+-- deterministic: a @.@ after a bare optic starts an outer+-- composition, and one shared group would force two parsers to+-- greedily share a token stream.+filterParser :: Parser Optic+filterParser = keyword "filter" () >> bare+  where+    bare = Filter <$> opticAtomParser <*> transArg+    transArg = atomParser++idParser :: Parser Optic+idParser = keyword "id" Id++prismParser :: Parser Optic+prismParser = char '_' *> prismNameParser++ixParser :: Parser Optic+ixParser = keyword "ix" () >> Ix <$> lexeme decimal++prismNameParser :: Parser Optic+prismNameParser =+  choice+    [ keyword "String" (Prism PString),+      keyword "Number" (Prism PNumber),+      keyword "Bool" (Prism PBool),+      keyword "Null" (Prism PNull),+      keyword "Array" (Prism PArray),+      keyword "Object" (Prism PObject),+      keyword "Just" PrismJust+    ]
+ src/HQ/Parser.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Parser where++import Relude hiding (many, some)+import Text.Megaparsec+import Text.Megaparsec.Char (alphaNumChar, char, spaceChar, string)+import Text.Megaparsec.Char.Lexer qualified as L++type Parser = Parsec Void Text++sc :: Parser ()+sc = L.space (void spaceChar) empty empty++parseTop :: String -> Parser a -> Text -> Either (ParseErrorBundle Text Void) a+parseTop name p = parse (sc *> p <* eof) name++symbol :: Text -> Parser Text+symbol = L.symbol sc++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++keyword :: Text -> a -> Parser a+keyword w v = lexeme (string w <* notFollowedBy (alphaNumChar <|> char '_' <|> char '-')) $> v++parens :: Parser a -> Parser a+parens p = lexeme (char '(') *> p <* lexeme (char ')')++brackets :: Parser a -> Parser a+brackets p = lexeme (char '[') *> p <* lexeme (char ']')++braces :: Parser a -> Parser a+braces p = lexeme (char '{') *> p <* lexeme (char '}')++comma :: Parser ()+comma = void $ lexeme (char ',')++colon :: Parser ()+colon = void $ lexeme (char ':')++commaSep :: Parser a -> Parser [a]+commaSep p = p `sepBy` comma
+ src/HQ/Query.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Query where++import HQ.Optic+import HQ.Optic.AST (inferFocusType)+import HQ.Transformation (Transformation)+import HQ.Transformation.AST+import HQ.Transformation.TransformationType (ValueType (..))+import Relude hiding (Compose, many, not, or, some, subtract)++data Query+  = Fold Optic+  | Preview Optic+  | -- | Apply a transformation to each of the focused values.+    Over Optic Transformation+  | Delete Optic+  deriving stock (Show, Eq)++getOptic :: Query -> Optic+getOptic (Fold optic) = optic+getOptic (Preview optic) = optic+getOptic (Over optic _) = optic+getOptic (Delete optic) = optic++data TypeError+  = InvalidTransformationType TransformationTypeError+  | -- | The focused values certainly reject the transformation: the+    -- optic focuses one type, the transformation needs another, and+    -- neither side is 'ValueAny'. Offenders kept for reporting.+    InvalidFocusType Optic Transformation ValueType ValueType+  deriving stock (Eq, Show)++renderTypeError :: TypeError -> Text+renderTypeError (InvalidTransformationType (InvalidDivideByZero t)) =+  "division by zero in " <> show t+renderTypeError (InvalidTransformationType (InvalidCompose t out inn)) =+  "transformation mismatch in "+    <> show t+    <> ": produces "+    <> valueTypeName out+    <> " but the next step expects "+    <> valueTypeName inn+renderTypeError (InvalidTransformationType (InvalidOr t out)) =+  renderBoolOp "or" t out+renderTypeError (InvalidTransformationType (InvalidAnd t out)) =+  renderBoolOp "and" t out+renderTypeError (InvalidTransformationType (InvalidXor t out)) =+  renderBoolOp "xor" t out+renderTypeError (InvalidFocusType optic t focus expected) =+  "type mismatch: transformation "+    <> show t+    <> " expects "+    <> valueTypeName expected+    <> " but the optic "+    <> show optic+    <> " focuses "+    <> valueTypeName focus+renderTypeError (InvalidTransformationType (InvalidFilter t out)) =+  "filter transformation "+    <> show t+    <> " must produce a boolean, but produces "+    <> valueTypeName out++-- | Render a boolean-connective mismatch: @or@/@and@/@xor@ share+-- everything but the connective's name.+renderBoolOp :: Text -> Transformation -> ValueType -> Text+renderBoolOp op t out =+  "transformation mismatch in "+    <> show t+    <> ": both sides of "+    <> op+    <> " must produce booleans, but a branch produces "+    <> valueTypeName out++valueTypeName :: ValueType -> Text+valueTypeName ValueObject = "object"+valueTypeName ValueArray = "array"+valueTypeName ValueString = "string"+valueTypeName ValueNumber = "number"+valueTypeName ValueBool = "boolean"+valueTypeName ValueNull = "null"+valueTypeName ValueAny = "any value"++-- | Check a query before running it: @filter@ booleans and 'Over'+-- composition types. Every query accepts any optic.+typecheckQuery :: Query -> Either TypeError Query+typecheckQuery q = checkOptic q >>= checkTransformation++checkOptic :: Query -> Either TypeError Query+checkOptic q = go (getOptic q) >> pure q+  where+    go :: Optic -> Either TypeError ()+    go (Filter o t) = checkPredicate o t >> go o+    go (Compose l r) = go l >> go r+    go _ = pure ()+    checkPredicate :: Optic -> Transformation -> Either TypeError ()+    checkPredicate o t = case inferTransformationType t of+      Left e -> Left (InvalidTransformationType e)+      Right tt+        | transformationOutput tt /= ValueBool ->+            Left+              $ InvalidTransformationType+              $ InvalidFilter t (transformationOutput tt)+        | otherwise -> checkFocus o t tt++-- | A transformation accepts focused values of unknown shape+-- ('ValueAny' either side); anything else must match exactly.+checkFocus ::+  Optic -> Transformation -> TransformationType -> Either TypeError ()+checkFocus optic t tt+  | focus == ValueAny || expected == ValueAny || focus == expected = pure ()+  | otherwise = Left (InvalidFocusType optic t focus expected)+  where+    focus = inferFocusType optic+    expected = transformationInput tt++checkTransformation :: Query -> Either TypeError Query+checkTransformation q@(Over optic transformation) =+  case inferTransformationType transformation of+    Left transformationTypeError ->+      Left $ InvalidTransformationType transformationTypeError+    Right tt -> checkFocus optic transformation tt >> pure q+checkTransformation q = pure q
+ src/HQ/Query/Parser.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Query.Parser where++import HQ.JSON.Parser (jsonValueParser)+import HQ.Optic.Parser (opticParser)+import HQ.Parser (Parser, keyword, parseTop)+import HQ.Query+import HQ.Transformation (Transformation (..))+import HQ.Transformation.Parser (transformationParser)+import Relude hiding (Const)+import Text.Megaparsec++parseQuery :: Text -> Either (ParseErrorBundle Text Void) Query+parseQuery = parseTop "query" queryParser++queryParser :: Parser Query+queryParser =+  foldParser <|> previewParser <|> overParser <|> deleteParser <|> setParser++-- | @set@ is @over@ with a constant.+setParser :: Parser Query+setParser = do+  keyword "set" () >> Over <$> opticParser <*> (Const <$> jsonValueParser)++deleteParser :: Parser Query+deleteParser = keyword "delete" () >> Delete <$> opticParser++overParser :: Parser Query+overParser = keyword "over" () >> Over <$> opticParser <*> transformationParser++foldParser :: Parser Query+foldParser = keyword "fold" () >> Fold <$> opticParser++previewParser :: Parser Query+previewParser = keyword "preview" () >> Preview <$> opticParser
+ src/HQ/Runner.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner+  ( executeRunnerAction,+    jsonRunner,+    foldDocuments,+    rewriteDocuments,+  )+where++import Control.Exception (evaluate, try)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Text qualified as T+import Data.Text.Encoding (Decoding (..), streamDecodeUtf8)+import Data.Text.IO (hPutStrLn)+import HQ.Early (Early, leave, runEarly)+import HQ.Error (HQError (..), renderHQError)+import HQ.JSON.Decoder (StreamIO, initialDecoder)+import HQ.JSON.Encoder (BSStream, EmitState, EncoderConfig (..), encode, initialEmitState)+import HQ.Optic (Optic)+import HQ.Query (Query (..))+import HQ.Runner.Cursor+import HQ.Runner.Error (RunnerError (..))+import HQ.Runner.Fold+import HQ.Runner.Rewrite+import HQ.Runner.Rewrite.Emit (RewriteContinuation, RewriteResult (..))+import HQ.Runner.Take+import Relude hiding (Compose, Const)+import Streaming (Of, Stream)+import Streaming.Prelude qualified as S+import System.IO (hSetBinaryMode)++data RunnerEnv = RunnerEnv+  { runnerEnvEarly :: Early HQError,+    runnerEnvQuery :: Query,+    runnerEnvInput :: StreamIO ByteString (),+    runnerEnvConfig :: EncoderConfig+  }++newtype RunnerF a = Runner (ReaderT RunnerEnv IO a)+  deriving newtype+    ( Functor,+      Applicative,+      Monad,+      MonadReader RunnerEnv+    )++type RunnerAction = RunnerF (BSStream IO ())++-- | Evaluate a runner action into an output byte‑stream without consuming it.+-- Useful for testing or when the caller wants to further process the+-- stream (e.g., piping to another command). It returns a lazy 'BSStream' that+-- can be consumed later. Errors are propagated via the 'Early' exceptions.+evalRunnerAction ::+  Early HQError ->+  RunnerAction ->+  Query ->+  EncoderConfig ->+  Handle ->+  IO (BSStream IO ())+evalRunnerAction early (Runner runner) query config handle = runReaderT runner env+  where+    env = RunnerEnv early query (streamHandle 1024 handle) config++-- | Run a query to stdout; errors go to stderr with a failing exit.+executeRunnerAction :: RunnerAction -> Query -> EncoderConfig -> Handle -> IO ()+executeRunnerAction runner query encConfig handle = do+  hSetBuffering stdout $ BlockBuffering Nothing+  hSetBinaryMode stdout True+  r <- runEarly $ \early -> do+    byteStream <- evalRunnerAction early runner query encConfig handle+    S.mapM_ write byteStream+  case r of+    Left e -> hPutStrLn stderr (renderHQError e) >> exitFailure+    Right v -> pure v+  where+    write = liftIO . LBS.hPut stdout++-- | Read 'ByteString' chunks lazily from a handle.+-- The chunk size defaults to 1024 bytes, which is a reasonable trade‑off for+-- typical inputs (around 100 MiB). The function yields a stream of ByteString+-- chunks until EOF.+streamHandle :: Int -> Handle -> StreamIO ByteString ()+streamHandle size handle = do+  chunk <- liftIO $ BS.hGetSome handle size+  if BS.null chunk+    then pure ()+    else S.yield chunk >> streamHandle size handle++-- | Run the JSON runner, producing a stream of encoded JSON documents.+jsonRunner :: RunnerAction+jsonRunner = do+  RunnerEnv {..} <- ask+  let cursor = Cursor [] initialDecoder (decodeUtf8Stream runnerEnvEarly runnerEnvInput)+      foldWith docs = void $ encode runnerEnvConfig 65536 docs+      rewriteWith rewriter optic =+        void+          $ rewriteDocuments+            runnerEnvEarly+            (runRewrite runnerEnvEarly rewriter optic runnerEnvConfig)+            cursor+            initialEmitState+  pure $ case runnerEnvQuery of+    Preview optic -> foldWith (takeFirstValue (runFold runnerEnvEarly optic cursor))+    Fold optic -> foldWith (foldDocuments runnerEnvEarly optic cursor)+    Over optic transformation -> rewriteWith (RewriteTransform transformation) optic+    Delete optic -> rewriteWith RewriteDelete optic++-- | Iterate over each top‑level document in the input stream.+-- The function abstracts the common pattern of fetching the next document,+-- projecting a cursor, and applying an action that may produce a new state.+-- It is used by both 'foldDocuments' and 'rewriteDocuments'.+forDocuments ::+  (Cursor -> IO (Maybe Cursor)) ->+  (s -> Cursor) ->+  (Cursor -> s -> Stream (Of e) IO s) ->+  s ->+  Stream (Of e) IO s+forDocuments next project act st = do+  mcur <- lift (next (project st))+  case mcur of+    Nothing -> pure st+    Just cur' -> act cur' st >>= forDocuments next project act++-- | Perform a fold over each top‑level JSON document.+-- The fold consumes the input cursor and yields the focused values as a+-- stream of events. It is used for queries like `fold` and `preview`.+foldDocuments :: Early HQError -> Optic -> Cursor -> EventStream Cursor+foldDocuments early optic =+  forDocuments (nextDocument early) id (\cur _ -> runFold early optic cur)++-- | Perform a rewrite over each top‑level JSON document.+-- The rewrite uses a continuation that can emit transformed JSON.+-- It threads an 'EmitState' (initially empty) across documents, resetting at each document boundary.+rewriteDocuments ::+  Early HQError ->+  RewriteContinuation ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+rewriteDocuments early action cur st =+  forDocuments (nextDocument early) rewriteCursor go (RewriteResult st cur)+  where+    go cur' (RewriteResult st' _) = action cur' st'++-- | Decode a stream of strict 'ByteString' chunks to 'Text',+-- handling UTF-8 errors. Invalid or truncated input aborts with a+-- runner error ('InvalidUtf8').+decodeUtf8Stream :: Early HQError -> StreamIO ByteString () -> StreamIO Text ()+decodeUtf8Stream early stream = case streamDecodeUtf8 mempty of+  Some _ _ cont -> go mempty cont stream+  where+    -- The continuation carries partial sequences internally: feed it+    -- new bytes only (re-feeding the carry would decode them twice).+    -- The returned carry is only inspected at end of input, where a+    -- non-empty remainder means truncation.+    go ::+      ByteString ->+      (ByteString -> Decoding) ->+      StreamIO ByteString () ->+      StreamIO Text ()+    go leftover cont str = do+      result <- lift $ S.next str+      case result of+        Left ()+          | BS.null leftover -> pure ()+          -- A non-empty carry is a truncated sequence: invalid, exactly+          -- as the old all-or-nothing decode reported it.+          | otherwise -> lift (leave early (HQRunnerError InvalidUtf8))+        Right (chunk, rest) -> do+          Some text leftover' cont' <- lift (decodeStep (cont chunk))+          unless (T.null text) $ S.yield text+          go leftover' cont' rest++    -- Step the incremental decoder strictly: it throws+    -- 'UnicodeException' on invalid input, mapped here to the+    -- runner's 'InvalidUtf8' (the same errors 'decodeUtf8'' reported).+    decodeStep :: Decoding -> IO Decoding+    decodeStep decoding = do+      result <- try (evaluate decoding) :: IO (Either UnicodeException Decoding)+      case result of+        Left _ -> leave early (HQRunnerError InvalidUtf8)+        Right dec' -> pure dec'
+ src/HQ/Runner/Cursor.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.Cursor where++import HQ.Early (Early, leave)+import HQ.JSON.Decoder+import HQ.JSON.Decoder.Skip+import HQ.JSON.Event (JSONEvent (..), matchingClose)+import HQ.Runner.Error (RunnerError (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming (Of, Stream)++-- | The house stream type: 'Stream' over 'IO'. Failures abort via+-- 'HQ.Early' exceptions instead of threading 'Either'. See 'StreamIO'.+type EventStream r = Stream (Of JSONEvent) IO r++-- | Input cursor: pushed-back events with the decoder and text+-- positioned after them.+data Cursor = Cursor+  { cursorBuffered :: [JSONEvent],+    cursorDecoder :: DecoderState,+    cursorText :: StreamIO Text ()+  }++-- | Interpret an optic against the JSON value at the cursor,+-- yielding the taken events and returning the advanced cursor.+type Continuation = Cursor -> EventStream Cursor++-- | One navigation step: the pulled event with the cursor positioned+-- after it.+data Step = Step {stepEvent :: JSONEvent, stepCursor :: Cursor}++-- | One object member step: the member key with the cursor positioned+-- after it.+data ObjectStep = ObjectStep {objectStepKey :: Text, objectStepCursor :: Cursor}++-- | Pull one event for navigation. Buffered events come first;+-- otherwise the decoder drives forward. Returns 'Nothing' at clean+-- end of input.+pullCursor :: Early HQError -> Cursor -> IO (Maybe Step)+pullCursor _ (Cursor (event : buffered) decoder text) =+  pure (Just (Step event (Cursor buffered decoder text)))+pullCursor early (Cursor [] decoder text) = do+  pulled <- pullEvent early decoder text+  case pulled of+    EndOfInput -> pure Nothing+    NextEvent (NextEmitted event decoder' rest) ->+      pure (Just (Step event (Cursor [] decoder' rest)))++-- | Push an event back for the continuation to see.+pushCursor :: JSONEvent -> Cursor -> Cursor+pushCursor event (Cursor buffered decoder text) =+  Cursor (event : buffered) decoder text++-- | Poll for the next top-level document at the cursor. Resets a+-- finished decoder over the remaining input and pushes the first event+-- back for the query to consume; 'Nothing' at clean end of input.+-- Call between top-level values only (empty buffer, balanced stack).+nextDocument :: Early HQError -> Cursor -> IO (Maybe Cursor)+nextDocument early cur@(Cursor buffered decoder text)+  | not (null buffered) || not (null (decoderStack decoder)) = pure (Just cur)+  | otherwise = do+      let cur' =+            Cursor [] (initialDecoder {decoderInput = decoderInput decoder}) text+      pulled <- pullCursor early cur'+      case pulled of+        Nothing -> pure Nothing+        Just (Step event rest) -> pure (Just (pushCursor event rest))++-- | Pull one event inside an object body: 'Left' rest on 'JSONEndObject',+-- 'Right' key and cursor after it on 'JSONObjectKey'. Throws+-- 'UnexpectedEndReadingObject' on end of input and 'InvalidObject' on+-- anything else. Shared by every object walk in folding and rewriting.+-- Inlined: runs once per member on every hot walk.+{-# INLINE expectObjectStep #-}+expectObjectStep :: Early HQError -> Cursor -> IO (Either Cursor ObjectStep)+expectObjectStep early input = do+  result <- pullCursor early input+  case result of+    Nothing -> leave early $ HQRunnerError UnexpectedEndReadingObject+    Just (Step JSONEndObject rest) -> pure (Left rest)+    Just (Step (JSONObjectKey key) rest) -> pure (Right (ObjectStep key rest))+    Just _ -> leave early $ HQRunnerError InvalidObject++-- | Pull one event inside an array body: 'Left' rest on 'JSONEndArray',+-- 'Right' event and cursor after it otherwise. Throws+-- 'UnexpectedEndReadingArray' on end of input. Shared by every array+-- walk in folding and rewriting.+-- Inlined: runs once per element on every hot walk.+{-# INLINE expectArrayStep #-}+expectArrayStep :: Early HQError -> Cursor -> IO (Either Cursor Step)+expectArrayStep early input = do+  result <- pullCursor early input+  case result of+    Nothing -> leave early $ HQRunnerError UnexpectedEndReadingArray+    Just (Step JSONEndArray rest) -> pure (Left rest)+    Just step' -> pure (Right step')++-- | Consume one complete value without yielding its events.+skipValue :: Early HQError -> Cursor -> EventStream Cursor+skipValue early = lift . skipValueE early++-- | 'skipValue' in 'IO'. Text-level skipping when the container+-- body is still ahead in the text (no replayed events); otherwise drain+-- event by event. Skipped regions never decode into events on the fast+-- path.+skipValueE :: Early HQError -> Cursor -> IO Cursor+skipValueE early input = do+  result <- pullCursor early input+  case result of+    Nothing -> leave early $ HQRunnerError UnexpectedEndOfInput+    Just (Step event (Cursor buffered decoder text)) ->+      skipEvent event buffered decoder text+  where+    skipEvent event buffered decoder text = case matchingClose event of+      Just closing+        | null buffered -> skipOpened event decoder text buffered+        | otherwise -> drainNested closing (Cursor buffered decoder text)+      Nothing -> case event of+        JSONEndArray -> leave early $ HQRunnerError UnexpectedEndOfArray+        JSONEndObject -> leave early $ HQRunnerError UnexpectedEndOfObject+        JSONObjectKey _ -> leave early $ HQRunnerError UnexpectedObjectKey+        _ -> pure (Cursor buffered decoder text)+    skipOpened event decoder text buffered = do+      (decoder', rest) <- skipContainerText early event decoder text+      pure (Cursor buffered decoder' rest)+    -- Event-by-event drain, without touching the text.+    drainValue :: Cursor -> IO Cursor+    drainValue stream = do+      result <- pullCursor early stream+      case result of+        Nothing -> leave early $ HQRunnerError UnexpectedEndOfInput+        Just (Step event rest) -> case matchingClose event of+          Just closing -> drainNested closing rest+          Nothing -> case event of+            JSONEndArray -> leave early $ HQRunnerError UnexpectedEndOfArray+            JSONEndObject -> leave early $ HQRunnerError UnexpectedEndOfObject+            JSONObjectKey _ -> leave early $ HQRunnerError UnexpectedObjectKey+            _ -> pure rest+    drainNested :: JSONEvent -> Cursor -> IO Cursor+    drainNested closing stream = do+      result <- pullCursor early stream+      case result of+        Nothing -> leave early $ HQRunnerError UnexpectedEndOfInput+        Just (Step event rest)+          | event == closing -> pure rest+          | otherwise -> case event of+              JSONObjectKey _+                | closing == JSONEndObject -> do+                    after <- drainValue rest+                    drainNested closing after+                | otherwise -> leave early $ HQRunnerError UnexpectedObjectKey+              _ -> do+                after <- drainValue (pushCursor event rest)+                drainNested closing after++-- | Skip an object member value at the text level, colon included.+skipMemberValue :: Early HQError -> Cursor -> EventStream Cursor+skipMemberValue early = lift . skipMemberValueE early++skipMemberValueE :: Early HQError -> Cursor -> IO Cursor+skipMemberValueE early (Cursor buffered decoder@DecoderState {..} text)+  | null buffered = do+      (SkipRest remainder rest) <-+        skipMemberValueText early decoderNestDepth decoderStack decoderInput text+      pure $ Cursor [] (finishValue decoder {decoderInput = remainder}) rest+  | otherwise = skipValueE early (Cursor buffered decoder text)
+ src/HQ/Runner/Error.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.Error where++import Relude hiding (Compose, Const)++data RunnerError+  = -- | The event or cursor stream ran dry where more was required.+    UnexpectedEndOfInput+  | UnexpectedEndOfArray+  | UnexpectedEndOfObject+  | UnexpectedObjectKey+  | -- | Structural failures while navigating or rewriting.+    InvalidObject+  | EmptyValue+  | ExpectedMemberValue+  | UnexpectedEndReadingObject+  | UnexpectedEndReadingArray+  | -- | Input is not valid UTF-8.+    InvalidUtf8+  | -- | Event-list materialization failures ('eventsToValue').+    TrailingEventsAfterValue+  | ExpectedJSONValue+  | ExpectedObjectKeyEvent++renderRunnerError :: RunnerError -> Text+renderRunnerError err = case err of+  UnexpectedEndOfInput -> "unexpected end of JSON input"+  UnexpectedEndOfArray -> "unexpected end of array"+  UnexpectedEndOfObject -> "unexpected end of object"+  UnexpectedObjectKey -> "unexpected object key"+  InvalidObject -> "invalid JSON object"+  EmptyValue -> "unexpected empty value"+  ExpectedMemberValue -> "unexpected end of input after object key"+  UnexpectedEndReadingObject -> "unexpected end of input while reading object"+  UnexpectedEndReadingArray -> "unexpected end of input while reading array"+  InvalidUtf8 -> "invalid UTF-8 input"+  TrailingEventsAfterValue -> "trailing events after a JSON value"+  ExpectedJSONValue -> "expected a JSON value"+  ExpectedObjectKeyEvent -> "expected an object key"
+ src/HQ/Runner/Fold.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.Fold where++import Data.Aeson (Value (..))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Vector qualified as Vector+import HQ.Early (Early, leave, orLeave)+import HQ.Error (HQError (..))+import HQ.JSON.Decoder (initialDecoder)+import HQ.JSON.Event+import HQ.Optic (Optic (..), PrismKind (..), prismPredicate)+import HQ.Runner.Cursor+import HQ.Runner.Error (RunnerError (..))+import HQ.Runner.Take (takeFirstValue, takeValue)+import HQ.Transformation (Transformation, runTransformation)+import HQ.Transformation.Error (TransformationError (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming (Of (..))+import Streaming.Prelude qualified as S++-- | Materialize the value at the cursor into events and a 'Value',+-- returning the value, its events and the cursor after it.+-- Shared by folding and rewriting so @filter@ gates and @over@+-- replacements agree on error mapping.+data Materialized = Materialized+  { materializedValue :: Value,+    materializedEvents :: NonEmpty JSONEvent,+    materializedCursor :: Cursor+  }++materializeValue :: Early HQError -> Cursor -> IO Materialized+materializeValue early cur = do+  events :> afterValue <- S.toList (takeValue early cur)+  ne <- case nonEmpty events of+    Nothing -> leave early $ HQRunnerError EmptyValue+    Just ne -> pure ne+  v <- orLeave early $ first HQRunnerError $ eventsToValue (toList ne)+  pure (Materialized v ne afterValue)++-- | Test a @filter@ gate, mapping failures to 'HQError'.+-- Shared by 'runFold' and 'runRewrite'.+gateValue :: Optic -> Transformation -> Value -> Either HQError Bool+gateValue o t v = first HQTransformationError $ evalFilterGate o t v++-- | Test a @filter@ gate on a streamed value, returning whether it is+-- kept plus replay/after cursors. Shared by 'runFold' and 'runRewrite'+-- so both agree on gating and cursor rebuild.+data GateResult = GateResult+  { gateKeep :: Bool,+    gateFirstEvent :: JSONEvent,+    gateReplay :: Cursor,+    gateAfter :: Cursor+  }++gateTake :: Early HQError -> Optic -> Transformation -> Cursor -> IO GateResult+gateTake early o t cur = do+  Materialized v ne@(firstEv :| _) afterValue <- materializeValue early cur+  keep <- orLeave early (gateValue o t v)+  let Cursor _ dec txt = afterValue+  pure (GateResult keep firstEv (Cursor (toList ne) dec txt) afterValue)++-- | Apply a transformation, mapping failures to 'HQError'.+-- Shared by rewriting (@over@) replacements.+applyTransformation :: Transformation -> Value -> Either HQError Value+applyTransformation t v =+  first HQTransformationError $ runTransformation t v++onEventOrEnd ::+  Early HQError -> Cursor -> (Step -> EventStream Cursor) -> EventStream Cursor+onEventOrEnd early input f = do+  result <- lift (pullCursor early input)+  case result of+    Nothing -> pure input+    Just step -> f step++-- | Match the next event against a table of opens; anything else is+-- skipped as a whole value. Unifies the open-or-skip preamble in+-- Fold (@runField@/@runEach@/@runKeys@/@runValues@/@runIndex@).+-- Inlined so the table specializes per call site.+{-# INLINE onOpenOrSkip #-}+onOpenOrSkip ::+  Early HQError ->+  Cursor ->+  [(JSONEvent, Cursor -> EventStream Cursor)] ->+  EventStream Cursor+onOpenOrSkip early input arms =+  onEventOrEnd early input $ \(Step event rest) ->+    case [handle | (open, handle) <- arms, open == event] of+      (handle : _) -> handle rest+      [] -> skipValue early (pushCursor event rest)++-- | Loop pulling member steps until the container ends; @body@ handles+-- each step, returning the cursor to continue from. Shared by+-- 'traverseObject' and 'traverseArray'. Inlined so @next@/@body@+-- specialize per walk; the 'INLINE's on the traverse wrappers and+-- step pullers dissolve the whole walk into each caller, leaving a+-- concrete single-type loop.+{-# INLINE walkMembers #-}+walkMembers ::+  (Cursor -> IO (Either Cursor s)) ->+  (s -> EventStream Cursor) ->+  Cursor ->+  EventStream Cursor+walkMembers next body = go+  where+    go stream = do+      step <- lift (next stream)+      case step of+        Left rest -> pure rest+        Right pair -> body pair >>= go++-- | Walk an object body step by step; @body@ handles each member key,+-- returning the cursor to continue from. Emits nothing, returns the+-- cursor after @JSONEndObject@.+-- Inlined so the step puller dissolves into the caller's walk loop.+{-# INLINE traverseObject #-}+traverseObject ::+  Early HQError ->+  Cursor ->+  (ObjectStep -> EventStream Cursor) ->+  EventStream Cursor+traverseObject early input body = walkMembers (expectObjectStep early) body input++-- | Walk an array body step by step; @body@ handles each element event,+-- returning the cursor to continue from.+-- Inlined so the step puller dissolves into the caller's walk loop.+{-# INLINE traverseArray #-}+traverseArray ::+  Early HQError -> Cursor -> (Step -> EventStream Cursor) -> EventStream Cursor+traverseArray early input body = walkMembers (expectArrayStep early) body input++-- | Consume the rest of an object body (all remaining members).+skipRestOfObject :: Early HQError -> Cursor -> EventStream Cursor+skipRestOfObject early input = traverseObject early input+  $ \(ObjectStep _ rest) -> skipMemberValue early rest++-- | Consume the rest of an array body (all remaining elements).+skipRestOfArray :: Early HQError -> Cursor -> EventStream Cursor+skipRestOfArray early input = traverseArray early input+  $ \(Step event rest) -> skipValue early (pushCursor event rest)++-- | Interpret an optic against the JSON value at the cursor.+--+-- The continuation receives the cursor positioned immediately after+-- the value currently being interpreted.+runFold :: Early HQError -> Optic -> Continuation+runFold early optic = run optic (takeValue early)+  where+    run :: Optic -> Continuation -> Continuation+    run opticF k input = case opticF of+      Id -> k input+      Field name -> runField name k input+      Each -> runEach k input+      Keys -> runKeys k input+      Values -> runValues k input+      Filter o t -> runFilter o t k input+      Compose left right -> run left (run right k) input+      Prism kind -> runScalar (prismPredicate kind) k input+      PrismJust -> runJust k input+      Ix i -> runIndex i k input++    runField :: Text -> Continuation -> Continuation+    runField name k input =+      onOpenOrSkip early input [(JSONBeginObject, findField name k)]++    findField :: Text -> Continuation -> Continuation+    findField name k = go+      where+        go stream = do+          step <- lift (expectObjectStep early stream)+          case step of+            Left rest -> pure rest+            Right (ObjectStep key rest)+              | key == name -> k rest >>= skipRestOfObject early+              | otherwise -> skipMemberValue early rest >>= go++    ----------------------------------------------------------------+    -- Each+    ----------------------------------------------------------------++    runEach :: Continuation -> Continuation+    runEach k input = onOpenOrSkip early input eventsWithCont+      where+        eventsWithCont =+          [ ( JSONBeginArray,+              \rest -> traverseArray early rest+                $ \(Step event rest') -> k (pushCursor event rest')+            ),+            ( JSONBeginObject,+              \rest -> traverseObject early rest $ k . objectStepCursor+            )+          ]++    ----------------------------------------------------------------+    -- Keys: object keys as strings (objects only)+    ----------------------------------------------------------------++    runKeys :: Continuation -> Continuation+    runKeys k input = onOpenOrSkip early input eventsWithCont+      where+        eventsWithCont =+          [ ( JSONBeginObject,+              \rest -> traverseObject early rest $ \(ObjectStep key rest') -> do+                _ <- k $ Cursor [JSONString key] initialDecoder $ pure ()+                skipMemberValue early rest'+            )+          ]++    ----------------------------------------------------------------+    -- Values: object member values only (arrays focus on nothing)+    ----------------------------------------------------------------++    runValues :: Continuation -> Continuation+    runValues k input = onOpenOrSkip early input eventsWithCont+      where+        eventsWithCont =+          [ ( JSONBeginObject,+              \rest -> traverseObject early rest $ k . objectStepCursor+            )+          ]++    ----------------------------------------------------------------+    -- Filter: keep the value when the predicate holds of the+    -- sub-optic's focus (existential over the focused values)+    ----------------------------------------------------------------++    runFilter :: Optic -> Transformation -> Continuation -> Continuation+    runFilter o t k input = onEventOrEnd early input $ \(Step event rest0) -> do+      GateResult keep _ replay rest <-+        lift (gateTake early o t (pushCursor event rest0))+      if keep then k replay else pure rest++    ----------------------------------------------------------------+    -- Scalar prisms+    ----------------------------------------------------------------++    runScalar :: (JSONEvent -> Bool) -> Continuation -> Continuation+    runScalar predicate k input =+      onEventOrEnd early input $ \(Step event rest) ->+        if predicate event+          then k (pushCursor event rest)+          else skipValue early (pushCursor event rest) -- not a match; consume anyway++    ----------------------------------------------------------------+    -- PrismJust+    ----------------------------------------------------------------++    runJust :: Continuation -> Continuation+    runJust k input = onEventOrEnd early input $ \case+      Step JSONNull rest -> pure rest+      Step event rest -> k (pushCursor event rest)++    ----------------------------------------------------------------+    -- Array index+    ----------------------------------------------------------------++    runIndex :: Int -> Continuation -> Continuation+    runIndex index k input =+      onOpenOrSkip early input [(JSONBeginArray, findIndex index)]+      where+        findIndex n stream+          | n < 0 = skipRestOfArray early stream+          | otherwise =+              lift (expectArrayStep early stream) >>= \case+                Left rest -> pure rest+                Right (Step event rest) -> case n of+                  0 -> k (pushCursor event rest) >>= skipRestOfArray early+                  _ -> skipValue early (pushCursor event rest) >>= findIndex (n - 1)++--------------------------------------------------------------------------------+-- Pure navigation: the same optic semantics over in-memory values.+--+-- Navigation here is total: absent members, out-of-bounds indices and+-- prism mismatches focus on nothing (mirroring the streaming runners'+-- skip behavior). Only @filter@ predicates are partial, and their+-- failures propagate.+--------------------------------------------------------------------------------++-- | Focus an optic on an in-memory value, collecting every focused+-- value. Used to evaluate @filter@ gates without re-driving the+-- streaming decoder.+focusMany :: Optic -> Value -> Either TransformationError [Value]+focusMany o v = case o of+  Field name -> pure (lookupField name v)+  Each -> pure (eachValues v)+  Keys -> pure (keyValues v)+  Values -> pure (objectValues v)+  Id -> pure [v]+  Compose l r -> do+    ls <- focusMany l v+    mconcat <$> traverse (focusMany r) ls+  Prism kind -> pure $ matchPrism kind v+  PrismJust -> pure $ matchJust v+  Ix i -> pure $ matchIndex i v+  Filter o' t -> do+    keep <- evalFilterGate o' t v+    pure [v | keep]++-- | Evaluate a @filter@ gate on an in-memory value: true when the+-- transformation maps some focused sub-value to true.+evalFilterGate ::+  Optic -> Transformation -> Value -> Either TransformationError Bool+evalFilterGate o t v = focusMany o v >>= go+  where+    go :: [Value] -> Either TransformationError Bool+    go [] = pure False+    go (w : ws) = do+      b <- testValue w+      if b then pure True else go ws+    testValue :: Value -> Either TransformationError Bool+    testValue w = case runTransformation t w of+      Left err -> Left err+      Right (Bool b) -> pure b+      Right _ -> Left FilterNotBoolean++-- | Object member lookup: missing members and non-objects focus on+-- nothing.+lookupField :: Text -> Value -> [Value]+lookupField name v = case v of+  Object o -> maybeToList (KeyMap.lookup (Key.fromText name) o)+  _ -> []++-- | Object member values only; arrays and scalars focus on nothing.+-- Arrays and scalars focus on nothing; use 'Each' for arrays.+objectValues :: Value -> [Value]+objectValues v = case v of+  Object o -> KeyMap.elems o+  _ -> []++-- | Array elements plus object member values.+eachValues :: Value -> [Value]+eachValues v = case v of+  Array a -> Vector.toList a+  Object _ -> objectValues v+  _ -> []++-- | Object keys as strings; arrays focus on nothing.+keyValues :: Value -> [Value]+keyValues v = case v of+  Object o -> map (String . Key.toText) (KeyMap.keys o)+  _ -> []++-- | Match a type prism against an in-memory value directly.+matchPrism :: PrismKind -> Value -> [Value]+matchPrism kind v = case kind of+  PString -> case v of s@(String _) -> [s]; _ -> []+  PNumber -> case v of n@(Number _) -> [n]; _ -> []+  PBool -> case v of b@(Bool _) -> [b]; _ -> []+  PNull -> case v of Null -> [v]; _ -> []+  PArray -> case v of a@(Array _) -> [a]; _ -> []+  PObject -> case v of o@(Object _) -> [o]; _ -> []++matchJust :: Value -> [Value]+matchJust v = case v of+  Null -> []+  _ -> [v]++matchIndex :: Int -> Value -> [Value]+matchIndex i v = case v of+  Array a -> maybeToList (a Vector.!? i)+  _ -> []++-- | Execute an optic, emitting at most one value: the first one it+-- selects.+--+-- The fold is short-circuited: once the first value has been emitted,+-- no further input is read from the source. This is library-level+-- first-match semantics over any optic; the @preview@ CLI command+-- exposes it directly (any optic accepted, first focus wins).+runPreview :: Early HQError -> Optic -> Continuation+runPreview early optic input =+  takeFirstValue (runFold early optic input) $> input
+ src/HQ/Runner/Rewrite.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.Rewrite where++import Data.Aeson (Value (..))+import HQ.Early (Early, leave, orLeave)+import HQ.Error (HQError (..))+import HQ.JSON.Encoder (BSStream, EmitState, EncoderConfig, emitChunk, flushEmit)+import HQ.JSON.Event+import HQ.Optic (Optic (..), focusesWhole, prismPredicate)+import HQ.Runner.Cursor+import HQ.Runner.Error (RunnerError (..))+import HQ.Runner.Fold+import HQ.Runner.Rewrite.Emit+import HQ.Transformation (Transformation (Const), runTransformation)+import HQ.Transformation.Error (TransformationError (..))+import Relude hiding (Compose, Const)++--------------------------------------------------------------------------------+-- Over and delete: document rewriting+--------------------------------------------------------------------------------++-- | What happens to a focused value: removed (@delete@) or rewritten+-- (@over@, including @set@ as @over@ with a constant).+data Rewriter = RewriteDelete | RewriteTransform Transformation+  deriving (Show, Eq)++data KeyAction = DropKey | KeepKey | RenameKey Text+  deriving (Show, Eq)++runDelete :: Early HQError -> Optic -> EncoderConfig -> RewriteContinuation+runDelete early = runRewrite early RewriteDelete++runOver ::+  Early HQError -> Optic -> Transformation -> EncoderConfig -> RewriteContinuation+runOver early optic transformation =+  runRewrite early (RewriteTransform transformation) optic++-- | Rewrite the document at the cursor, replacing or omitting focused+-- values in place; everything else passes through unchanged.+--+-- Each optic case below is a top-level worker taking its context+-- explicitly (rather than one @where@-closure over the whole query):+-- GHC gives every helper its own worker/wrapper and strictness, and+-- small leaves inline into their callers, instead of fusing all of+-- @over@/@delete@ into a single giant worker.+runRewrite ::+  Early HQError -> Rewriter -> Optic -> EncoderConfig -> RewriteContinuation+runRewrite early rewriter optic config cur0 st0 = do+  RewriteResult st' after <- rewriteRun early rewriter config optic cur0 st0+  st'' <- flushEmit st'+  pure (RewriteResult st'' after)++rewriteRun ::+  Early HQError -> Rewriter -> EncoderConfig -> Optic -> RewriteContinuation+rewriteRun early rewriter config step input st = case step of+  Id -> rewriteValue early rewriter config input st+  _ -> rewriteNavigate early rewriter config step Id input st++rewriteNavigate ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Optic ->+  Optic ->+  RewriteContinuation+rewriteNavigate early rewriter config step suffix input st = case step of+  Id -> rewriteRun early rewriter config suffix input st+  Compose left right ->+    rewriteNavigate early rewriter config left (right <> suffix) input st+  Field name -> rewriteField early rewriter config name suffix input st+  Each -> rewriteEach early rewriter config suffix input st+  Keys -> rewriteKeys early rewriter config suffix input st+  Values -> rewriteValues early rewriter config suffix input st+  Prism kind ->+    rewritePrism early rewriter config (prismPredicate kind) suffix input st+  PrismJust -> rewriteJust early rewriter config suffix input st+  Ix i -> rewriteIndex early rewriter config i suffix input st+  Filter o t -> rewriteFilter early rewriter config o t suffix input st++-- | Split a member-value suffix with a leading @filter@ step into+-- its gate and remainder, so a kept value deleted as a whole drops+-- its key too.+stripFilterGate :: Optic -> Maybe (Optic, Transformation, Optic)+stripFilterGate (Compose (Filter o t) rest') = Just (o, t, rest')+stripFilterGate (Filter o t) = Just (o, t, Id)+stripFilterGate _ = Nothing++rewriteValue ::+  Early HQError -> Rewriter -> EncoderConfig -> RewriteContinuation+rewriteValue early rewriter config input st = case rewriter of+  RewriteDelete -> RewriteResult st <$> lift (skipValueE early input)+  -- A constant replacement never reads the focused value: skip it+  -- at the text level instead of decoding it.+  RewriteTransform (Const value) -> do+    emitValueChunks config value st =<< lift (skipValueE early input)+  RewriteTransform t -> do+    Materialized v _ rest <- lift (materializeValue early input)+    value <- lift (orLeave early (applyTransformation t v))+    emitValueChunks config value st rest++-- | Emit a transformed value's events as chunks.+emitValueChunks ::+  EncoderConfig -> Value -> EmitState -> Cursor -> BSStream IO RewriteResult+emitValueChunks config value st cursor = go st (valueToEvents value)+  where+    go s [] = pure (RewriteResult s cursor)+    go s (event : events) = do+      s' <- emitChunk config event s+      go s' events++-- | Prism: value whose first event satisfies the predicate goes+-- through the suffix; everything else passes through unchanged.+rewritePrism ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  (JSONEvent -> Bool) ->+  Optic ->+  RewriteContinuation+rewritePrism early rewriter config predicate suffix input st =+  onEventOrEndChunks early input st $ \(Step event rest) ->+    if predicate event+      then rewriteRun early rewriter config suffix (pushCursor event rest) st+      else takeValueChunks early config (pushCursor event rest) st++-- | Prism on non-null: null passes through, anything else goes+-- through the suffix.+rewriteJust ::+  Early HQError -> Rewriter -> EncoderConfig -> Optic -> RewriteContinuation+rewriteJust early rewriter config suffix input st =+  onEventOrEndChunks early input st $ \case+    (Step JSONNull rest) -> do+      st' <- emitChunk config JSONNull st+      pure (RewriteResult st' rest)+    (Step event rest) ->+      rewriteRun early rewriter config suffix (pushCursor event rest) st++-- | Array index: rewrite the element at @index@, pass through the+-- rest of the array. Non-arrays pass through unchanged.+rewriteIndex ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Int ->+  Optic ->+  RewriteContinuation+rewriteIndex early rewriter config index suffix input st =+  onOpenOrSkipChunks early config input st eventsWithCont+  where+    eventsWithCont =+      [ ( JSONBeginArray,+          \rest s -> go index rest =<< emitChunk config JSONBeginArray s+        )+      ]++    go n stream s = do+      step <- lift (expectArrayStep early stream)+      case step of+        Left rest -> do+          s' <- emitChunk config JSONEndArray s+          pure (RewriteResult s' rest)+        Right (Step event rest)+          | n == 0 -> do+              RewriteResult s' after <- rewriteRun early rewriter config suffix (pushCursor event rest) s+              go (-1) after s'+          | otherwise -> do+              RewriteResult s' after <-+                takeValueChunks early config (pushCursor event rest) s+              go (n - 1) after s'++-- | Object field: rewrite the member named @name@ (dropping the key+-- too under @delete@ when the suffix lands on the value), pass+-- every other member through unchanged.+rewriteField ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Text ->+  Optic ->+  RewriteContinuation+rewriteField early rewriter config name suffix input st =+  onOpenOrSkipChunks early config input st eventsWithCont+  where+    eventsWithCont =+      [ ( JSONBeginObject,+          \rest s -> do+            st' <- emitChunk config JSONBeginObject s+            traverseObjectChunks early config rest st'+              $ \(ObjectStep key rest') s' ->+                if key == name+                  then rewriteOneMember early rewriter config suffix key rest' s'+                  else emitKeyAndTake early config key rest' s'+        )+      ]++-- | The @each@ traversal: rewrite every array element, or every+-- object member value. Non-containers pass through.+rewriteEach ::+  Early HQError -> Rewriter -> EncoderConfig -> Optic -> RewriteContinuation+rewriteEach early rewriter config suffix input st =+  onOpenOrSkipChunks early config input st eventsWithCont+  where+    eventsWithCont =+      [ ( JSONBeginArray,+          \rest s -> do+            st' <- emitChunk config JSONBeginArray s+            traverseArrayChunks early config rest st' $ \(Step event rest') s' ->+              rewriteRun early rewriter config suffix (pushCursor event rest') s'+        ),+        ( JSONBeginObject,+          \rest s -> do+            st' <- emitChunk config JSONBeginObject s+            traverseObjectChunks early config rest st' $ \(ObjectStep key rest') s' ->+              rewriteOneMember early rewriter config suffix key rest' s'+        )+      ]++-- | The @values@ traversal: rewrite every object member value.+-- Arrays and scalars pass through unchanged (unlike 'rewriteEach').+rewriteValues ::+  Early HQError -> Rewriter -> EncoderConfig -> Optic -> RewriteContinuation+rewriteValues early rewriter config suffix input st =+  onOpenOrSkipChunks early config input st eventsWithCont+  where+    eventsWithCont =+      [ ( JSONBeginObject,+          \rest s -> do+            st' <- emitChunk config JSONBeginObject s+            traverseObjectChunks early config rest st'+              $ \(ObjectStep key rest') s' ->+                rewriteOneMember early rewriter config suffix key rest' s'+        )+      ]++-- | The @filter@ optic: gate the focused value as a whole, running+-- the suffix on kept values and passing dropped values through+-- unchanged.+rewriteFilter ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Optic ->+  Transformation ->+  Optic ->+  RewriteContinuation+rewriteFilter early rewriter config o t suffix input st =+  onEventOrEndChunks early input st $ \(Step event rest) -> do+    GateResult keep _ valCursor _ <-+      lift $ gateTake early o t $ pushCursor event rest+    if keep+      then rewriteRun early rewriter config suffix valCursor st+      else takeValueChunks early config valCursor st++-- | The @keys@ traversal: rewrite object keys, leaving values alone.+-- Arrays and scalars pass through unchanged (@keys@ is objects-only).+rewriteKeys ::+  Early HQError -> Rewriter -> EncoderConfig -> Optic -> RewriteContinuation+rewriteKeys early rewriter config suffix input st =+  onOpenOrSkipChunks early config input st eventsWithCont+  where+    eventsWithCont =+      [ ( JSONBeginObject,+          \rest s -> do+            st' <- emitChunk config JSONBeginObject s+            traverseObjectChunks early config rest st'+              $ \(ObjectStep key rest') s' -> do+                action <- lift (rewriteKeyText early suffix rewriter key)+                applyKeyAction early config action key rest' s'+        )+      ]++applyKeyAction ::+  Early HQError ->+  EncoderConfig ->+  KeyAction ->+  Text ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+applyKeyAction early config action key rest s = case action of+  DropKey -> RewriteResult s <$> lift (skipValueE early rest)+  KeepKey -> emitKeyAndTake early config key rest s+  RenameKey newKey -> emitKeyAndTake early config newKey rest s++-- | Apply the remainder of a @keys@ optic plus the enclosing+-- 'Rewriter' to one object key. Keys are scalar strings, so the+-- suffix either focuses the key as a whole (checked with+-- 'focusesWhole', e.g. @Id@ or @_String@) or it matches nothing and+-- the key is kept.+rewriteKeyText :: Early HQError -> Optic -> Rewriter -> Text -> IO KeyAction+rewriteKeyText early suffix rw key = case rw of+  RewriteDelete+    | focusesWhole suffix (JSONString key) -> pure DropKey+    | otherwise -> pure KeepKey+  RewriteTransform t+    | focusesWhole suffix (JSONString key) ->+        case runTransformation t (String key) of+          Left err -> leave early $ HQTransformationError err+          Right (String next) ->+            pure (if next == key then KeepKey else RenameKey next)+          Right _ -> leave early $ HQTransformationError KeyNotString+    | otherwise -> pure KeepKey++-- | Rewrite one object member, returning the cursor after it.+-- The key survives unless a @delete@ lands on the member value as+-- a whole. A leading @filter@ step gates the value first: dropped+-- members pass through, and kept members deleted as a whole lose+-- their key too. The object walk itself is shared via+-- 'traverseObjectChunks'.+rewriteOneMember ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Optic ->+  Text ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+rewriteOneMember early rewriter config suffix key stream st = do+  result <- lift $ pullCursor early stream+  case result of+    Nothing -> lift $ leave early $ HQRunnerError ExpectedMemberValue+    Just (Step event rest) -> case stripFilterGate suffix of+      Just (o, t, rest') ->+        rewriteFilteredMember early rewriter config o t rest' key event rest st+      Nothing ->+        rewritePlainMember early rewriter config suffix key event rest st++rewriteFilteredMember ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Optic ->+  Transformation ->+  Optic ->+  Text ->+  JSONEvent ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+rewriteFilteredMember early rewriter config o t rest' key event rest st = do+  GateResult keep firstEv valCursor afterValue <-+    lift (gateTake early o t (pushCursor event rest))+  if not keep+    then emitKeyAndTake early config key valCursor st+    else case (rewriter, focusesWhole rest' firstEv) of+      (RewriteDelete, True) -> pure (RewriteResult st afterValue)+      _ -> do+        st' <- emitChunk config (JSONObjectKey key) st+        rewriteRun early rewriter config rest' valCursor st'++rewritePlainMember ::+  Early HQError ->+  Rewriter ->+  EncoderConfig ->+  Optic ->+  Text ->+  JSONEvent ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+rewritePlainMember early rewriter config suffix key event rest st =+  case rewriter of+    RewriteDelete+      | focusesWhole suffix event -> do+          after <- lift (skipValueE early (pushCursor event rest))+          pure (RewriteResult st after)+      | otherwise -> do+          st' <- emitChunk config (JSONObjectKey key) st+          rewriteRun early rewriter config suffix (pushCursor event rest) st'+    RewriteTransform _ -> do+      st' <- emitChunk config (JSONObjectKey key) st+      rewriteRun early rewriter config suffix (pushCursor event rest) st'
+ src/HQ/Runner/Rewrite/Emit.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Byte-stream take for the rewrite side: traversal that transcribes+-- values straight to output bytes.+module HQ.Runner.Rewrite.Emit where++import Control.Exception (try)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8Builder)+import HQ.Early (Early, leave)+import HQ.JSON.Decoder+import HQ.JSON.Decoder.Number (isNumberStart)+import HQ.JSON.Decoder.Skip+import HQ.JSON.Encoder+import HQ.JSON.Event (JSONEvent (..), matchingClose)+import HQ.Runner.Cursor+import HQ.Runner.Error (RunnerError (..))+import HQ.Runner.Take (pullOne, takeContainerGeneric)+import Relude hiding (Compose, id, many, some, state)++-- | Rewrite output: byte stream returning advanced emit state and cursor.+type RewriteContinuation = Cursor -> EmitState -> BSStream IO RewriteResult++-- | The rewrite pipeline's accumulator: emit state threaded through+-- byte emission alongside the cursor.+data RewriteResult = RewriteResult+  { rewriteEncoder :: EmitState,+    rewriteCursor :: Cursor+  }++-- | Pull one event; on end return unchanged, otherwise run the handler.+-- Byte-stream analogue of 'HQ.Runner.Cursor.onEventOrEnd'.+onEventOrEndChunks ::+  Early HQError ->+  Cursor ->+  EmitState ->+  (Step -> BSStream IO RewriteResult) ->+  BSStream IO RewriteResult+onEventOrEndChunks early input st f = do+  result <- lift (pullCursor early input)+  case result of+    Nothing -> pure (RewriteResult st input)+    Just pulled -> f pulled++-- | Match the next event against a table of opens; anything else is+-- passed through as a whole value. Byte-stream analogue of+-- 'HQ.Runner.Cursor.onOpenOrSkip'. Inlined so the table specializes+-- per call site.+{-# INLINE onOpenOrSkipChunks #-}+onOpenOrSkipChunks ::+  Early HQError ->+  EncoderConfig ->+  Cursor ->+  EmitState ->+  [(JSONEvent, Cursor -> EmitState -> BSStream IO RewriteResult)] ->+  BSStream IO RewriteResult+onOpenOrSkipChunks early config input st arms =+  onEventOrEndChunks early input st $ \(Step event rest) ->+    case [handle | (open, handle) <- arms, open == event] of+      (handle : _) -> handle rest st+      [] -> takeValueChunks early config (pushCursor event rest) st++-- | Loop pulling member steps until the container ends, emitting+-- @close@; @body@ handles each step, threading the encoder state.+-- Shared by 'traverseObjectChunks' and 'traverseArrayChunks': the+-- close emission is the only difference. Inlined so @close@/@next@/+-- @body@ specialize per walk; the 'INLINE's on the traverse wrappers+-- and step pullers below dissolve the whole walk into each caller,+-- leaving a concrete single-type loop (no per-element dictionary or+-- higher-order call).+{-# INLINE walkMembersChunks #-}+walkMembersChunks ::+  JSONEvent ->+  EncoderConfig ->+  (Cursor -> IO (Either Cursor s)) ->+  (s -> EmitState -> BSStream IO RewriteResult) ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+walkMembersChunks close config next body = go+  where+    go stream s = do+      step' <- lift (next stream)+      case step' of+        Left rest -> do+          s' <- emitChunk config close s+          pure (RewriteResult s' rest)+        Right pair -> do+          RewriteResult s' after <- body pair s+          go after s'++-- | Walk an object body, emitting @JSONEndObject@ at the end.+-- Caller must have emitted @JSONBeginObject@ already.+-- Inlined so the close tag and step puller dissolve into the+-- caller's 'walkMembersChunks' loop.+{-# INLINE traverseObjectChunks #-}+traverseObjectChunks ::+  Early HQError ->+  EncoderConfig ->+  Cursor ->+  EmitState ->+  (ObjectStep -> EmitState -> BSStream IO RewriteResult) ->+  BSStream IO RewriteResult+traverseObjectChunks early config input st body =+  walkMembersChunks JSONEndObject config (expectObjectStep early) body input st++-- | Walk an array body, emitting @JSONEndArray@ at the end.+{-# INLINE traverseArrayChunks #-}+traverseArrayChunks ::+  Early HQError ->+  EncoderConfig ->+  Cursor ->+  EmitState ->+  (Step -> EmitState -> BSStream IO RewriteResult) ->+  BSStream IO RewriteResult+traverseArrayChunks early config input st body =+  walkMembersChunks JSONEndArray config (expectArrayStep early) body input st++-- | Emit a key then passthrough its value; the 4x pattern in+-- @rewriteMember@/pairs/allKeys@.+emitKeyAndTake ::+  Early HQError ->+  EncoderConfig ->+  Text ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+emitKeyAndTake early config key rest s = do+  s' <- emitChunk config (JSONObjectKey key) s+  takeValueChunks early config rest s'++-- | Take one complete value, transcribing it straight to output bytes.+-- Strings and numbers take a verbatim raw path ('peekRawScalar'),+-- and so do whole containers in compact mode ('takeRawContainerChunks'+-- below): chunk-side only. The event-side take ('takeValue') always+-- decodes, so both paths must agree on value boundaries; the raw+-- scanners ('skipStringCollect'/'skipNumberCollect'/+-- 'skipContainerCollect') mirror the decoder ('consumeString'/+-- 'stepNumber'/structural loop) exactly, and the split/adversarial+-- tests cover the agreement. Change one side only with a test on+-- the other.+takeValueChunks ::+  Early HQError ->+  EncoderConfig ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+takeValueChunks early config cursor st = case peekRawScalar cursor of+  Just (RawString afterQuote, dec, txt) ->+    takeRawStringChunks early config afterQuote dec txt st+  Just (RawNumber atNumber, dec, txt) ->+    takeRawNumberChunks early config atNumber dec txt st+  Nothing -> do+    (Step event cursor') <- lift (pullOne early cursor)+    let slowPath = do+          st' <- emitChunk config event st+          case matchingClose event of+            Just closing -> takeContainerChunks early config closing cursor' st'+            Nothing -> case event of+              JSONEndArray -> lift (leave early $ HQRunnerError UnexpectedEndOfArray)+              JSONEndObject -> lift (leave early $ HQRunnerError UnexpectedEndOfObject)+              JSONObjectKey _ -> lift (leave early $ HQRunnerError UnexpectedObjectKey)+              _ -> pure (RewriteResult st' cursor')+    -- Wholesale containers bypass event decoding only when nothing is+    -- buffered (buffered replay has no source text to collect) and the+    -- output is compact (verbatim bytes are already canonical there;+    -- pretty output must be generated).+    case event of+      JSONBeginArray -> case cursor' of+        Cursor [] dec txt+          | outputStyle config == Compact ->+              takeRawContainerChunks early config JSONEndArray JSONBeginArray dec txt st+        _ -> slowPath+      JSONBeginObject -> case cursor' of+        Cursor [] dec txt+          | outputStyle config == Compact ->+              takeRawContainerChunks early config JSONEndObject JSONBeginObject dec txt st+        _ -> slowPath+      _ -> slowPath++-- | A peeked string or number value: payload after the quote / at the+-- first digit, pending colon already skipped.+data RawScalar = RawString Text | RawNumber Text++-- | Peek a string/number value; decline anything else (including+-- buffered replay cursors) so existing paths report errors.+-- Inlined: runs once per value on the chunk take path, and dissolving+-- it exposes the cursor/decoder deconstruction to the caller.+{-# INLINE peekRawScalar #-}+peekRawScalar :: Cursor -> Maybe (RawScalar, DecoderState, StreamIO Text ())+peekRawScalar cursor+  | null buf,+    Just start <- peekValue phase input,+    Just (c, rest) <- T.uncons start = case c of+      '"' -> Just (RawString rest, decoder, txt)+      _ | isNumberStart c -> Just (RawNumber start, decoder, txt)+      _ -> Nothing+  | otherwise = Nothing+  where+    Cursor buf decoder txt = cursor+    DecoderState {decoderInput = input, decoderPhase = phase} = decoder+    -- Member values hide behind their colon; anything else must already+    -- be in value position.+    peekValue DecoderPhaseValue inp = Just (T.dropWhile isWhitespace inp)+    peekValue DecoderPhaseObjectColon inp =+      case T.uncons (T.dropWhile isWhitespace inp) of+        Just (':', rest) -> Just (T.dropWhile isWhitespace rest)+        _ -> Nothing+    peekValue _ _ = Nothing++-- | Build the output bytes from a raw body. A single right-nested+-- fold: 'toLazyByteString' then streams in constant space, where+-- left-nested @acc <> piece@ accumulation retained ~150x the+-- collected size (measured on a 1.3 MB untouched array).+-- Inlined: runs once per verbatim body, fusing the fragment fold+-- with the consuming buffer append.+{-# INLINE buildFrags #-}+buildFrags :: RawBody -> Builder+buildFrags = foldl' (\acc t -> encodeUtf8Builder t <> acc) mempty . rawFrags++-- | Transcribe a peeked string value verbatim (escapes preserved,+-- quotes included in the fragments).+takeRawStringChunks ::+  Early HQError ->+  EncoderConfig ->+  Text ->+  DecoderState ->+  StreamIO Text () ->+  EmitState ->+  BSStream IO RewriteResult+takeRawStringChunks early config afterQuote dec txt st = do+  (Collected (SkipRest remainder rest) body) <- lift (skipStringCollect early afterQuote txt)+  st' <- emitRawBytes config (buildFrags body) (rawSize body) st+  pure (RewriteResult st' (Cursor [] (finishValue dec {decoderInput = remainder}) rest))++-- | Transcribe a peeked number value verbatim (no 'Scientific' roundtrip).+takeRawNumberChunks ::+  Early HQError ->+  EncoderConfig ->+  Text ->+  DecoderState ->+  StreamIO Text () ->+  EmitState ->+  BSStream IO RewriteResult+takeRawNumberChunks early config atNumber dec txt st = do+  (Collected (SkipRest remainder rest) body) <- lift (skipNumberCollect early atNumber txt)+  st' <- emitRawBytes config (buildFrags body) (rawSize body) st+  pure (RewriteResult st' (Cursor [] (finishValue dec {decoderInput = remainder}) rest))++-- | Transcribe a whole container value verbatim in bounded segments.+-- The cursor must be unbuffered with the decoder just past the opening+-- bracket (same precondition as walking it with 'takeContainerChunks';+-- the open event itself was already pulled). Separators wrap the whole+-- body exactly once ('emitRawOpen'/'emitRawTail'), so segment emission+-- composes byte-identically to one uninterrupted collect while each+-- segment stays under 'collectBudget'.+takeRawContainerChunks ::+  Early HQError ->+  EncoderConfig ->+  JSONEvent ->+  JSONEvent ->+  DecoderState ->+  StreamIO Text () ->+  EmitState ->+  BSStream IO RewriteResult+takeRawContainerChunks early config closing open dec txt st = case closing of+  JSONEndArray -> segmented ExpectValue+  JSONEndObject -> segmented ExpectKey+  -- Unreachable: callers pass literal closings. Collect nothing.+  _ -> pure (RewriteResult st (Cursor [] dec txt))+  where+    segmented expect = do+      stBracket <- emitRawOpen config open st+      let depth = decoderNestDepth dec+          base = shallower depth+      (RewriteResult stBody cur) <-+        collectLoop stBracket expect base depth (decoderStack dec) (decoderInput dec) txt+      st' <- emitRawTail config stBody+      pure (RewriteResult st' cur)+    -- Collect one budget-bounded segment, emit it verbatim, resume+    -- until the container completes. The resume state is exact loop+    -- state, so pausing is invisible downstream.+    collectLoop st0 exp0 base0 dep0 stk0 inp0 stream0 = do+      mseg <- liftIO $ try (collectExpect early mempty base0 dep0 stk0 exp0 inp0 stream0)+      case mseg of+        Right (Collected (SkipRest rest stream') body) -> do+          st' <- emitBuilder (buildFrags body) (rawSize body) st0+          pure (RewriteResult st' (Cursor [] (finishContainer dec rest) stream'))+        Left (CollectPaused body exp1 base1 dep1 stk1 inp1 stream1) -> do+          st' <- emitBuilder (buildFrags body) (rawSize body) st0+          collectLoop st' exp1 base1 dep1 stk1 inp1 stream1++-- | Take a container body, fusing decode and format per event with no+-- intermediate event stream. Thin wrapper over 'takeContainerGeneric'+-- with 'emitChunk' as the output action.+takeContainerChunks ::+  Early HQError ->+  EncoderConfig ->+  JSONEvent ->+  Cursor ->+  EmitState ->+  BSStream IO RewriteResult+takeContainerChunks early config closing cursor st = do+  (cur, st') <- takeContainerGeneric early closing cursor st (emitChunk config)+  pure (RewriteResult st' cur)+{-# INLINE takeContainerChunks #-}
+ src/HQ/Runner/Take.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.Take where++import Data.Text qualified as T+import HQ.Early (Early, leave)+import HQ.JSON.Decoder+import HQ.JSON.Decoder qualified as Decoder+import HQ.JSON.Event (JSONEvent (..), matchingClose)+import HQ.Runner.Cursor+import HQ.Runner.Error (RunnerError (..))+import Relude hiding (Compose, id, many, some, state)+import Streaming (Of, Stream)+import Streaming.Prelude qualified as S++-- | Pull a single event, with the advanced cursor.+pullOne :: Early HQError -> Cursor -> IO Step+pullOne early =+  pullCursor early+    >=> maybe (leave early $ HQRunnerError UnexpectedEndOfInput) pure++-- | True when the decoder still holds pending input that must be+-- stepped before pulling more text. Single name for the 4x+-- @not (T.null (decoderInput ...))@ guard.+hasPending :: DecoderState -> Bool+hasPending dec = not (T.null (decoderInput dec))++-- | Shared 'finish' decision for take loops: top-level exhaustion+-- means a truncated take here (contrast 'atEnd'/'finishEnd', where it+-- ends cleanly). Decided by 'classifyTerminal', like both drivers.+finishTakeEvent :: Early HQError -> DecoderState -> IO (JSONEvent, DecoderState)+finishTakeEvent early dec = case classifyTerminal dec of+  TerminalEnd -> leave early $ HQRunnerError UnexpectedEndOfInput+  TerminalError err -> leave early (HQDecodeError err)+  TerminalEmit (TerminalEmitted event dec') -> pure (event, dec')++-- | Stream the events of exactly one complete JSON value. Lazy: stops+-- pulling once the value is complete.+takeValue :: Early HQError -> Continuation+takeValue early cursor = do+  Step event cursor' <- lift (pullOne early cursor)+  S.yield event+  case matchingClose event of+    Just closing -> takeContainerFrom early closing cursor'+    Nothing -> case event of+      JSONEndArray -> lift (leave early $ HQRunnerError UnexpectedEndOfArray)+      JSONEndObject -> lift (leave early $ HQRunnerError UnexpectedEndOfObject)+      JSONObjectKey _ -> lift (leave early $ HQRunnerError UnexpectedObjectKey)+      _ -> pure cursor'++takeFirstValue :: EventStream r -> EventStream ()+takeFirstValue = go (0 :: Int)+  where+    go depth stream = do+      result <- lift (S.next stream)+      case result of+        Left _ -> pure ()+        Right (event, rest) -> do+          S.yield event+          case event of+            JSONBeginArray -> go (depth + 1) rest+            JSONBeginObject -> go (depth + 1) rest+            JSONEndArray+              | depth == 1 -> pure ()+              | otherwise -> go (depth - 1) rest+            JSONEndObject+              | depth == 1 -> pure ()+              | otherwise -> go (depth - 1) rest+            _+              | depth == 0 -> pure ()+              | otherwise -> go depth rest++-- | Take a container body event by event, driving the decoder directly.+-- Thin wrapper over 'takeContainerGeneric' with 'S.yield' as the output+-- action and no extra state.+takeContainerFrom :: Early HQError -> JSONEvent -> Cursor -> EventStream Cursor+takeContainerFrom early closing cursor = do+  (cur, _) <- takeContainerGeneric early closing cursor () outputOne+  pure cur+  where+    outputOne :: JSONEvent -> () -> EventStream ()+    outputOne event () = S.yield event+{-# INLINE takeContainerFrom #-}++-- | Single event-by-event container loop shared by the read side+-- ('takeContainerFrom', output = 'S.yield') and the rewrite side+-- ('takeContainerChunks' in "HQ.Runner.Rewrite.Emit", output =+-- 'emitChunk'): same decoder driving, same errors, same termination;+-- only the per-event output action and the threaded state differ. Both+-- callers inline it, exposing the concrete output action (verified by+-- benchmark; no 'SPECIALIZE' pragma, which is illegal here).+{-# INLINE takeContainerGeneric #-}+takeContainerGeneric ::+  forall e s.+  Early HQError ->+  JSONEvent ->+  Cursor ->+  s ->+  (JSONEvent -> s -> Stream (Of e) IO s) ->+  Stream (Of e) IO (Cursor, s)+takeContainerGeneric early closing cursor0 st0 outputOne = go cursor0 st0+  where+    go :: Cursor -> s -> Stream (Of e) IO (Cursor, s)+    go (Cursor buf dec txt) st = case buf of+      event : rest -> emit event (Cursor rest dec txt) st+      [] -> stepMore dec txt st+    -- Step while the decoder holds pending input: mid-value pauses+    -- (e.g. a high surrogate awaiting its low half) must be stepped,+    -- not finished. Only a truly drained decoder may pull more text.+    -- Mirrors 'pullMore' in "HQ.Runner.Cursor".+    stepMore :: DecoderState -> StreamIO Text () -> s -> Stream (Of e) IO (Cursor, s)+    stepMore dec txt st = case Decoder.step dec of+      Left err -> lift (leave early $ HQDecodeError err)+      Right (Emit event dec') -> emit event (Cursor [] dec' txt) st+      Right (NeedInput dec')+        | hasPending dec' -> stepMore dec' txt st+        | otherwise -> pullMore dec' txt st+      Right (Done _) -> lift (leave early $ HQRunnerError UnexpectedEndOfInput)+    pullMore :: DecoderState -> StreamIO Text () -> s -> Stream (Of e) IO (Cursor, s)+    pullMore dec txt st = do+      result <- lift (S.next txt)+      case result of+        Left () -> finishTake dec st+        Right (chunk, rest) -> case Decoder.feed chunk dec of+          Left err -> lift (leave early (HQDecodeError err))+          Right (Emit event dec') -> emit event (Cursor [] dec' rest) st+          Right (NeedInput dec') -> stepMore dec' rest st+          Right (Done _) -> lift (leave early $ HQRunnerError UnexpectedEndOfInput)+    -- Mirror terminal 'finish' policy: a value completed exactly at end+    -- of input still yields its final event; anything else ends the+    -- take the same way the event-stream takes did.+    finishTake :: DecoderState -> s -> Stream (Of e) IO (Cursor, s)+    finishTake dec st = do+      (event, dec') <- lift (finishTakeEvent early dec)+      emit event (Cursor [] dec' (pure ())) st+    emit :: JSONEvent -> Cursor -> s -> Stream (Of e) IO (Cursor, s)+    emit !event cur st = do+      st' <- outputOne event st+      if event == closing+        then pure (cur, st')+        else case matchingClose event of+          Just end -> nested end cur st'+          Nothing -> go cur st'+    nested :: JSONEvent -> Cursor -> s -> Stream (Of e) IO (Cursor, s)+    nested end cur st = do+      (cur', st') <- takeContainerGeneric early end cur st outputOne+      go cur' st'
+ src/HQ/Transformation.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | The transformation DSL over JSON values.+--+-- Transformations are structured as a tree of constructors that describe+-- how to rewrite a JSON value, e.g. @Equal 3 . Add 1@.+module HQ.Transformation where++import Data.Aeson (ToJSON, Value (..))+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Text (encodeToLazyText)+import Data.Bool qualified (not)+import Data.List qualified as List+import Data.Scientific (Scientific)+import Data.Text (strip, unpack)+import Data.Text qualified as T+import Data.Text.Lazy (toStrict)+import Data.Vector (Vector)+import Data.Vector qualified as V+import GHC.Show (ShowS, appPrec)+import HQ.Transformation.Error (TransformationError (..))+import Relude hiding (Compose, Const, and, isPrefixOf, length, many, not, or, reverse, some, subtract, toStrict, xor)+import Prelude (Show (showsPrec), showParen, showString)++-- | Transformation expressions over JSON values.+--+-- Transformations read the current JSON value and produce a new one:+-- numeric steps like 'Add' map numbers, string steps like 'ConcatString'+-- map strings, and 'Equal', 'Not' and 'Or' produce booleans. 'Compose'+-- composes two transformations right-to-left: @a . b@ applies @b@ first,+-- then applies @a@ over its result.+data Transformation+  = -- | @+ n@: add a number to the current value.+    Add Scientific+  | -- | @* n@: multiply the current value by a number.+    Multiply Scientific+  | -- | @- n@: subtract a number from the current value.+    Subtract Scientific+  | -- | @/ n@: divide the current value by a number.+    Divide Scientific+  | -- | @< n@: test whether the current number is less than @n@.+    Lt Scientific+  | -- | @<= n@: test whether the current number is at most @n@.+    Lte Scientific+  | -- | @++ s@: append a string to a string value.+    ConcatString Text+  | -- | @concat [..]@: append the given elements to an array value.+    ConcatArray [Value]+  | -- | @trim@: strip surrounding whitespace from a string value.+    Trim+  | -- | @replace a b@: replace occurrences of @a@ with @b@ in a string value.+    Replace Text Text+  | -- | @stripPrefix p@: remove the prefix @p@ from a string value, if present.+    StripPrefix Text+  | -- | @stripSuffix s@: remove the suffix @s@ from a string value, if present.+    StripSuffix Text+  | -- | @isPrefixOf p@: test whether a string value starts with @p@.+    IsPrefixOf Text+  | -- | @isSuffixOf s@: test whether a string value ends with @s@.+    IsSuffixOf Text+  | -- | @isInfixOf i@: test whether a string value contains @i@.+    IsInfixOf Text+  | -- | @isEmpty@: test whether an array value is empty.+    IsEmpty+  | -- | @length@: the length of an array value, as a number.+    ArrayLength+  | -- | @reverse@: reverse an array value.+    ArrayReverse+  | -- | @unique@: drop duplicate elements of an array value, keeping first occurrences.+    ArrayUnique+  | -- | @merge o@: shallow-merge the object operand @o@ into the+    -- current object value; @o@ wins member conflicts (like jq @+@).+    -- Nested objects are replaced wholesale, not merged.+    Merge (KeyMap.KeyMap Value)+  | -- | @deepMerge o@: recursively merge the object operand @o@ into+    -- the current object value (like jq @*@). Conflicting members+    -- that are both objects merge recursively; anything else takes+    -- the operand's value.+    DeepMerge (KeyMap.KeyMap Value)+  | -- | @sort@: sort the elements of an array value in canonical order+    -- (null, booleans, numbers, strings, arrays, objects). Stable:+    -- equal elements keep their input order.+    ArraySort+  | -- | @== v@ or @= v@: test the current value for equality with @v@.+    Equal Value+  | -- | @const v@: replace the current value with @v@, whatever it is.+    Const Value+  | -- | @not@: negate the current boolean value.+    Not+  | -- | @a or b@: boolean disjunction of two transformations.+    Or Transformation Transformation+  | -- | @a and b@: boolean conjunction of two transformations.+    And Transformation Transformation+  | -- | @a xor b@: boolean exclusive disjunction of two transformations.+    Xor Transformation Transformation+  | -- | @a . b@: apply @b@, then apply @a@ over its result.+    Compose Transformation Transformation+  deriving (Eq)++instance Show Transformation where+  showsPrec d (Add n) =+    showParen (d > appPrec) $ showString "+" . showsJson (Number n)+  showsPrec d (Multiply n) =+    showParen (d > appPrec) $ showString "*" . showsJson (Number n)+  showsPrec d (Subtract n) =+    showParen (d > appPrec) $ showString "-" . showsJson (Number n)+  showsPrec d (Divide n) =+    showParen (d > appPrec) $ showString "/" . showsJson (Number n)+  showsPrec d (Lt n) =+    showParen (d > appPrec) $ showString "<" . showsJson (Number n)+  showsPrec d (Lte n) =+    showParen (d > appPrec) $ showString "<=" . showsJson (Number n)+  showsPrec d (ConcatString s) =+    showParen (d > appPrec) $ showString "++ " . showsPrec (appPrec + 1) s+  showsPrec d (ConcatArray els) =+    showParen (d > appPrec) $ showString "concat " . showsJson els+  showsPrec _ Trim = showString "trim"+  showsPrec d (Replace a b) =+    showParen (d > appPrec)+      $ showString "replace "+      . showsPrec (appPrec + 1) a+      . showString " "+      . showsPrec (appPrec + 1) b+  showsPrec d (StripPrefix p) =+    showParen (d > appPrec) $ showString "stripPrefix " . showsPrec (appPrec + 1) p+  showsPrec d (StripSuffix s) =+    showParen (d > appPrec) $ showString "stripSuffix " . showsPrec (appPrec + 1) s+  showsPrec d (IsPrefixOf p) =+    showParen (d > appPrec) $ showString "isPrefixOf " . showsPrec (appPrec + 1) p+  showsPrec d (IsSuffixOf s) =+    showParen (d > appPrec) $ showString "isSuffixOf " . showsPrec (appPrec + 1) s+  showsPrec d (IsInfixOf i) =+    showParen (d > appPrec) $ showString "isInfixOf " . showsPrec (appPrec + 1) i+  showsPrec _ IsEmpty = showString "isEmpty"+  showsPrec _ ArrayLength = showString "length"+  showsPrec _ ArrayReverse = showString "reverse"+  showsPrec _ ArrayUnique = showString "unique"+  showsPrec d (Merge members) =+    showParen (d > appPrec) $ showString "merge " . showsJson (Object members)+  showsPrec d (DeepMerge members) =+    showParen (d > appPrec) $ showString "deepMerge " . showsJson (Object members)+  showsPrec _ ArraySort = showString "sort"+  showsPrec d (Equal v) =+    showParen (d > appPrec) $ showString "== " . showsJson v+  showsPrec d (Const v) =+    showParen (d > appPrec) $ showString "const " . showsJson v+  showsPrec _ Not = showString "not"+  showsPrec d (Or a b) =+    showParen (d > orPrec)+      $ showsPrec orPrec a+      . showString " or "+      . showsPrec (orPrec + 1) b+    where+      orPrec = 4+  showsPrec d (And a b) =+    showParen (d > andPrec)+      $ showsPrec andPrec a+      . showString " and "+      . showsPrec (andPrec + 1) b+    where+      andPrec = 6+  showsPrec d (Xor a b) =+    showParen (d > xorPrec)+      $ showsPrec xorPrec a+      . showString " xor "+      . showsPrec (xorPrec + 1) b+    where+      xorPrec = 5+  showsPrec d (Compose a b) =+    showParen (d > composePrec)+      $ showsPrec composePrec a+      . showString " . "+      . showsPrec (composePrec + 1) b+    where+      composePrec = 7++-- | Render an embedded JSON value in compact DSL syntax, e.g. @3@ or @[1,2]@.+showsJson :: (ToJSON a) => a -> ShowS+showsJson = showString . unpack . toStrict . encodeToLazyText++-- | Apply a transformation to a JSON value.+--+-- Every step is total over 'Value': a step that does not fit the current+-- value (for example adding to a string) fails with a description of the+-- expected value type.  Composition applies right-to-left, matching the+-- @a . b@ DSL syntax: @b@ runs first, then @a@ over its result.+runTransformation :: Transformation -> Value -> Either TransformationError Value+runTransformation step value = case step of+  Add n -> withNumber (Number . (+ n)) value+  Multiply n -> withNumber (Number . (* n)) value+  Subtract n -> withNumber (Number . (+ negate n)) value+  Divide n -> withNumber (Number . (/ n)) value+  Lt n -> withNumber (Bool . (< n)) value+  Lte n -> withNumber (Bool . (<= n)) value+  ConcatString suffix -> withString (String . (<> suffix)) value+  ConcatArray elements -> withArray (Array . (<> fromList elements)) value+  Trim -> withString (String . strip) value+  Replace needle replacement ->+    withString (String . T.replace needle replacement) value+  StripPrefix prefix ->+    withString (String . stripAffix T.stripPrefix prefix) value+  StripSuffix suffix ->+    withString (String . stripAffix T.stripSuffix suffix) value+  IsPrefixOf prefix -> withString (Bool . T.isPrefixOf prefix) value+  IsSuffixOf suffix -> withString (Bool . T.isSuffixOf suffix) value+  IsInfixOf infix_ -> withString (Bool . T.isInfixOf infix_) value+  IsEmpty -> withArray (Bool . V.null) value+  ArrayLength -> withArray (Number . fromIntegral . V.length) value+  ArrayReverse -> withArray (Array . V.reverse) value+  ArrayUnique -> withArray (Array . fromList . List.nub . toList) value+  Merge members -> withObject (Object . KeyMap.union members) value+  DeepMerge members -> withObject (\o -> Object (KeyMap.unionWith deepMergeValues o members)) value+  ArraySort -> withArray (Array . fromList . List.sortBy compareValues . toList) value+  Equal literal -> pure (Bool (value == literal))+  Const v -> pure v+  Not -> withBool (Bool . Data.Bool.not) value+  Or left right -> do+    result <- runTransformation left value+    case result of+      Bool b+        | b -> pure result+        | otherwise -> runTransformation right value+      _ -> Left OrBranchNotBoolean+  And left right -> do+    result <- runTransformation left value+    case result of+      Bool b+        | b -> runTransformation right value+        | otherwise -> pure result+      _ -> Left AndBranchNotBoolean+  Xor left right -> do+    l <- runTransformation left value+    r <- runTransformation right value+    case (l, r) of+      (Bool a, Bool b) -> pure (Bool (a /= b))+      _ -> Left XorBranchNotBoolean+  Compose left right -> runTransformation right value >>= runTransformation left+  where+    -- Eliminate one JSON shape: rebuild on match, fail with the+    -- shape's error otherwise. Every leaf transformation goes through+    -- here, so a new shape adds a projector, not a helper.+    with :: (Value -> Maybe a) -> TransformationError -> (a -> Value) -> Value -> Either TransformationError Value+    with project err build v = maybe (Left err) (pure . build) (project v)++    asNumber :: Value -> Maybe Scientific+    asNumber (Number n) = Just n+    asNumber _ = Nothing++    asString :: Value -> Maybe Text+    asString (String s) = Just s+    asString _ = Nothing++    -- Strip an affix when present, leaving the value unchanged otherwise.+    stripAffix :: (Text -> Text -> Maybe Text) -> Text -> Text -> Text+    stripAffix stripF affix s = fromMaybe s (stripF affix s)++    asArray :: Value -> Maybe (Vector Value)+    asArray (Array a) = Just a+    asArray _ = Nothing++    asObject :: Value -> Maybe (KeyMap.KeyMap Value)+    asObject (Object o) = Just o+    asObject _ = Nothing++    asBool :: Value -> Maybe Bool+    asBool (Bool b) = Just b+    asBool _ = Nothing++    -- Short names, kept as synonyms of 'with'.+    withNumber :: (Scientific -> Value) -> Value -> Either TransformationError Value+    withNumber = with asNumber ExpectedNumber++    withString :: (Text -> Value) -> Value -> Either TransformationError Value+    withString = with asString ExpectedString++    withArray :: (Vector Value -> Value) -> Value -> Either TransformationError Value+    withArray = with asArray ExpectedArray++    withObject :: (KeyMap.KeyMap Value -> Value) -> Value -> Either TransformationError Value+    withObject = with asObject ExpectedObject++    withBool :: (Bool -> Value) -> Value -> Either TransformationError Value+    withBool = with asBool ExpectedBoolean++-- | Recursive object merge with right-wins conflicts (like jq @*@):+-- members that are objects on both sides merge recursively, anything+-- else takes the replacement value.+deepMergeValues :: Value -> Value -> Value+deepMergeValues (Object current) (Object replacement) =+  Object (KeyMap.unionWith deepMergeValues current replacement)+deepMergeValues _ replacement = replacement++-- | Canonical ordering of JSON values, matching jq's @sort@:+-- null, then booleans, numbers, strings, arrays, objects. Numbers+-- compare numerically, strings lexicographically, arrays+-- element-wise (a proper prefix sorts first), objects by their+-- key/value pairs with keys in order. Total: any two values compare.+compareValues :: Value -> Value -> Ordering+compareValues x y = case compare (valueRank x) (valueRank y) of+  EQ -> compareSame x y+  other -> other+  where+    compareSame Null Null = EQ+    compareSame (Bool a) (Bool b) = compare a b+    compareSame (Number a) (Number b) = compare a b+    compareSame (String a) (String b) = compare a b+    compareSame (Array a) (Array b) =+      lexCompare compareValues (V.toList a) (V.toList b)+    compareSame (Object a) (Object b) =+      lexCompare comparePair (sorted a) (sorted b)+      where+        sorted = List.sortOn fst . KeyMap.toList+        comparePair (k1, v1) (k2, v2) = compare k1 k2 <> compareValues v1 v2+    compareSame a b = compare (valueRank a) (valueRank b)++-- | Lexicographic comparison; a proper prefix sorts first.+lexCompare :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering+lexCompare _ [] [] = EQ+lexCompare _ [] _ = LT+lexCompare _ _ [] = GT+lexCompare c (x : xs) (y : ys) = c x y <> lexCompare c xs ys++-- | Type rank for 'compareValues': jq's cross-type order.+valueRank :: Value -> Int+valueRank Null = 0+valueRank (Bool False) = 1+valueRank (Bool True) = 2+valueRank (Number _) = 3+valueRank (String _) = 4+valueRank (Array _) = 5+valueRank (Object _) = 6
+ src/HQ/Transformation/AST.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Transformation.AST+  ( inferTransformationType,+    TransformationType (..),+    TransformationTypeError (..),+  )+where++import Data.Aeson.Types (Value (..))+import HQ.Transformation+import HQ.Transformation.TransformationType+import Relude hiding (Compose, Const, many, not, or, some, subtract, toStrict)++-- | Mismatched 'Compose' steps, keeping the offender for reporting.+data TransformationTypeError+  = -- | Right output vs left input mismatch; offender kept for reporting.+    InvalidCompose Transformation ValueType ValueType+  | -- | An 'Or' branch does not produce a boolean; offender kept.+    InvalidOr Transformation ValueType+  | -- | An 'And' branch does not produce a boolean; offender kept.+    InvalidAnd Transformation ValueType+  | -- | A 'Xor' branch does not produce a boolean; offender kept.+    InvalidXor Transformation ValueType+  | -- | A @filter@ predicate does not produce a boolean; offender kept.+    InvalidFilter Transformation ValueType+  | -- | Division by zero; offender kept. Detected statically so it+    -- cannot explode mid-stream after partial output.+    InvalidDivideByZero Transformation+  deriving (Eq, Show)++-- | Infer a transformation's input/output types; 'Compose' steps must+-- line up (constants accept anything). Only the root type is ever+-- consumed, so no annotated tree is materialized.+inferTransformationType ::+  Transformation -> Either TransformationTypeError TransformationType+inferTransformationType = go+  where+    go (Add _) = pure $ TransformationType ValueNumber ValueNumber+    go (Multiply _) = pure $ TransformationType ValueNumber ValueNumber+    go (Subtract _) = pure $ TransformationType ValueNumber ValueNumber+    go (Divide n)+      | n == 0 = Left (InvalidDivideByZero (Divide n))+      | otherwise = pure $ TransformationType ValueNumber ValueNumber+    go (Lt _) = pure $ TransformationType ValueNumber ValueBool+    go (Lte _) = pure $ TransformationType ValueNumber ValueBool+    go (ConcatString _) = pure $ TransformationType ValueString ValueString+    go (ConcatArray _) = pure $ TransformationType ValueArray ValueArray+    go Trim = pure $ TransformationType ValueString ValueString+    go (Replace _ _) = pure $ TransformationType ValueString ValueString+    go (StripPrefix _) = pure $ TransformationType ValueString ValueString+    go (StripSuffix _) = pure $ TransformationType ValueString ValueString+    go (IsPrefixOf _) = pure $ TransformationType ValueString ValueBool+    go (IsSuffixOf _) = pure $ TransformationType ValueString ValueBool+    go (IsInfixOf _) = pure $ TransformationType ValueString ValueBool+    go IsEmpty = pure $ TransformationType ValueArray ValueBool+    go ArrayLength = pure $ TransformationType ValueArray ValueNumber+    go ArrayReverse = pure $ TransformationType ValueArray ValueArray+    go ArrayUnique = pure $ TransformationType ValueArray ValueArray+    go (Merge _) = pure $ TransformationType ValueObject ValueObject+    go (DeepMerge _) = pure $ TransformationType ValueObject ValueObject+    go ArraySort = pure $ TransformationType ValueArray ValueArray+    go (Equal _) = pure $ TransformationType ValueAny ValueBool+    go (Const v) = pure $ TransformationType ValueAny (valueType v)+    go Not = pure $ TransformationType ValueBool ValueBool+    go (Or left right) = boolPair Or InvalidOr left right+    go (And left right) = boolPair And InvalidAnd left right+    go (Xor left right) = boolPair Xor InvalidXor left right+    go (Compose left right) = do+      lt <- go left+      rt <- go right+      let conditions =+            [ transformationInput lt == ValueAny,+              transformationOutput rt == transformationInput lt+            ]+          inputType = transformationInput rt+          outputType = transformationOutput lt+      if getAny $ foldMap Any conditions+        then pure $ TransformationType inputType outputType+        else Left $ InvalidCompose (Compose left right) (transformationOutput rt) (transformationInput lt)++-- | Check a boolean connective: both branches must produce booleans;+-- the input type comes from the left branch.+boolPair ::+  (Transformation -> Transformation -> Transformation) ->+  (Transformation -> ValueType -> TransformationTypeError) ->+  Transformation ->+  Transformation ->+  Either TransformationTypeError TransformationType+boolPair ctor toErr left right = do+  lt <- inferTransformationType left+  rt <- inferTransformationType right+  case (transformationOutput lt, transformationOutput rt) of+    (ValueBool, ValueBool) ->+      pure $ TransformationType (transformationInput lt) ValueBool+    (ValueBool, other) ->+      Left $ toErr (ctor left right) other+    (other, _) ->+      Left $ toErr (ctor left right) other++-- | The 'ValueType' of an embedded JSON literal.+valueType :: Value -> ValueType+valueType (Object _) = ValueObject+valueType (Array _) = ValueArray+valueType (String _) = ValueString+valueType (Number _) = ValueNumber+valueType (Bool _) = ValueBool+valueType Null = ValueNull
+ src/HQ/Transformation/Error.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Transformation.Error where++import Relude hiding (Const, many, not, or, some, subtract, toStrict)++-- | A transformation failure: wrong value type, non-boolean @or@+-- branch, or violated runner contract (string keys, boolean gates).+data TransformationError+  = ExpectedNumber+  | ExpectedString+  | ExpectedArray+  | ExpectedObject+  | ExpectedBoolean+  | -- | A non-boolean branch of @or@.+    OrBranchNotBoolean+  | -- | A non-boolean left branch of @and@.+    AndBranchNotBoolean+  | -- | A non-boolean branch of @xor@.+    XorBranchNotBoolean+  | -- | A key rewrite yielding a non-string.+    KeyNotString+  | -- | A @filter@ predicate yielding a non-boolean.+    FilterNotBoolean++renderTransformationError :: TransformationError -> Text+renderTransformationError err = case err of+  ExpectedNumber -> "expected a number"+  ExpectedString -> "expected a string"+  ExpectedArray -> "expected an array"+  ExpectedObject -> "expected an object"+  ExpectedBoolean -> "expected a boolean"+  OrBranchNotBoolean -> "expected a boolean result from the left side of or"+  AndBranchNotBoolean -> "expected a boolean result from the left side of and"+  XorBranchNotBoolean -> "expected a boolean result from each side of xor"+  KeyNotString -> "key transformation must yield a string"+  FilterNotBoolean -> "filter transformation must produce a boolean"
+ src/HQ/Transformation/Parser.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Transformation.Parser where++import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)+import HQ.JSON.Parser (jsonArray, jsonNumber, jsonObject, jsonText, jsonValueParser)+import HQ.Parser (Parser, keyword, parens, parseTop, symbol)+import HQ.Transformation+import Relude hiding (Compose, Const, and, isPrefixOf, length, many, not, or, reverse, some, subtract, xor)+import Text.Megaparsec++-- | Parse a single transformation expression, e.g. @+1 . == 3@.+parseTransformation :: Text -> Either (ParseErrorBundle Text Void) Transformation+parseTransformation = parseTop "transformation" transformationParser++-- | Grammar, loosest to tightest: @or@, @xor@, @and@, @.@, atoms.+transformationParser :: Parser Transformation+transformationParser = makeExprParser atomParser table+  where+    table =+      [ [InfixL (Compose <$ symbol ".")],+        [InfixL (keyword "and" And <|> (And <$ symbol "&&"))],+        [InfixL (keyword "xor" Xor <|> (Xor <$ symbol "^^"))],+        [InfixL (keyword "or" Or <|> (Or <$ symbol "||"))]+      ]++atomParser :: Parser Transformation+atomParser =+  choice+    [ parenParser,+      constParser,+      equalParser,+      try strConcatParser,+      addParser,+      multiplyParser,+      subtractParser,+      divideParser,+      try lteParser,+      ltParser,+      try gteParser,+      gtParser,+      arrayConcatParser,+      trimParser,+      notParser,+      replaceParser,+      stripPrefixParser,+      stripSuffixParser,+      isPrefixOfParser,+      isSuffixOfParser,+      isInfixOfParser,+      isEmptyParser,+      lengthParser,+      reverseParser,+      uniqueParser,+      sortParser,+      mergeParser,+      deepMergeParser+    ]++parenParser :: Parser Transformation+parenParser = parens transformationParser++constParser :: Parser Transformation+constParser = Const <$> (keyword "const" () *> jsonValueParser)++equalParser :: Parser Transformation+equalParser = do+  void $ try (symbol "==") <|> symbol "="+  Equal <$> jsonValueParser++addParser :: Parser Transformation+addParser = prefixOp "+" jsonNumber Add++multiplyParser :: Parser Transformation+multiplyParser = prefixOp "*" jsonNumber Multiply++subtractParser :: Parser Transformation+subtractParser = prefixOp "-" jsonNumber Subtract++divideParser :: Parser Transformation+divideParser = prefixOp "/" jsonNumber Divide++ltParser :: Parser Transformation+ltParser = prefixOp "<" jsonNumber Lt++lteParser :: Parser Transformation+lteParser = prefixOp "<=" jsonNumber Lte++-- | @> v@ is sugar for @not . <= v@.+gtParser :: Parser Transformation+gtParser = prefixOp ">" jsonNumber (Compose Not . Lte)++-- | @>= v@ is sugar for @not . < v@.+gteParser :: Parser Transformation+gteParser = prefixOp ">=" jsonNumber (Compose Not . Lt)++strConcatParser :: Parser Transformation+strConcatParser = prefixOp "++" jsonText ConcatString++arrayConcatParser :: Parser Transformation+arrayConcatParser = prefixWordOp "concat" jsonArray ConcatArray++trimParser :: Parser Transformation+trimParser = keyword "trim" Trim++notParser :: Parser Transformation+notParser = keyword "not" Not++replaceParser :: Parser Transformation+replaceParser = Replace <$> (keyword "replace" () *> jsonText) <*> jsonText++stripPrefixParser :: Parser Transformation+stripPrefixParser = prefixWordOp "stripPrefix" jsonText StripPrefix++stripSuffixParser :: Parser Transformation+stripSuffixParser = prefixWordOp "stripSuffix" jsonText StripSuffix++isPrefixOfParser :: Parser Transformation+isPrefixOfParser = prefixWordOp "isPrefixOf" jsonText IsPrefixOf++isSuffixOfParser :: Parser Transformation+isSuffixOfParser = prefixWordOp "isSuffixOf" jsonText IsSuffixOf++isInfixOfParser :: Parser Transformation+isInfixOfParser = prefixWordOp "isInfixOf" jsonText IsInfixOf++isEmptyParser :: Parser Transformation+isEmptyParser = keyword "isEmpty" IsEmpty++lengthParser :: Parser Transformation+lengthParser = keyword "length" ArrayLength++reverseParser :: Parser Transformation+reverseParser = keyword "reverse" ArrayReverse++uniqueParser :: Parser Transformation+uniqueParser = keyword "unique" ArrayUnique++-- NOTE: 'sort' is a bare keyword with no prefix relations today, so it+-- needs no 'try'. If a longer 'sort...'-prefixed atom (e.g. @sortOn@)+-- is ever added, it must come first with 'try', like '++' vs '+'.+sortParser :: Parser Transformation+sortParser = keyword "sort" ArraySort++mergeParser :: Parser Transformation+mergeParser = prefixWordOp "merge" jsonObject Merge++deepMergeParser :: Parser Transformation+deepMergeParser = prefixWordOp "deepMerge" jsonObject DeepMerge++-- | Parse @OP operand@ and apply the constructor: shared shape of the+-- symbolic and single-operand parsers.+prefixOp :: Text -> Parser a -> (a -> Transformation) -> Parser Transformation+prefixOp op operand constr = constr <$> (symbol op *> operand)++-- | Word-operator variant of 'prefixOp': the operator must end on a+-- word boundary so @sortOn@/@concatenate@ don't lex as @sort@/@concat@+-- plus residue. Symbolic operators ('+', '++', '<='...) keep 'prefixOp'+-- since their operands ('+1', '"x"') may follow without a space.+prefixWordOp :: Text -> Parser a -> (a -> Transformation) -> Parser Transformation+prefixWordOp op operand constr = constr <$> (keyword op () *> operand)
+ src/HQ/Transformation/TransformationType.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Transformation.TransformationType where++import Relude hiding (Compose, id)++data ValueType+  = ValueObject+  | ValueArray+  | ValueString+  | ValueNumber+  | ValueBool+  | ValueNull+  | -- | Any value: the input type of a constant transformation, which+    -- accepts whatever value it is given.+    ValueAny+  deriving (Eq, Show)++-- | TransformationType of a transformation: its input and output value types.+data TransformationType = TransformationType+  { transformationInput :: ValueType,+    transformationOutput :: ValueType+  }+  deriving (Eq, Show)
+ test/HQ/CLISpec.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.CLISpec (spec) where++import Control.Exception (try)+import Data.Aeson (Value (..))+import HQ.CLI+import HQ.JSON.Encoder (EncodeStyle (..), Join (..), Raw (..))+import HQ.Optic (Optic (..))+import HQ.Query (Query (Delete, Fold, Over, Preview))+import HQ.Transformation hiding (Compose)+import Options.Applicative (ParserResult (..), defaultPrefs, execParserPure)+import Relude hiding (Compose, Const, id)+import System.Exit (ExitCode (..))+import Test.Syd++spec :: Spec+spec = do+  describe "command parsing" $ do+    let parseCLI :: [String] -> Either Text CLIOptions+        parseCLI args =+          case execParserPure defaultPrefs optParserInfo args of+            Success opts -> Right opts+            Failure _ -> Left "parse failure"+            CompletionInvoked _ -> Left "completion invoked"++    it "parses queries" $ forM_ queryCases $ \(args, expected) ->+      optQuery <$> parseCLI args `shouldBe` Right expected++    it "combines preview with compact"+      $ case parseCLI ["preview", "@name", "-c"] of+        Left err -> expectationFailure (toString err)+        Right opts -> do+          optQuery opts `shouldBe` Preview (Field "name")+          optCompact opts `shouldBe` Compact++    it "combines preview with raw and join" $ do+      case parseCLI ["preview", "@name", "-r", "-j"] of+        Left err -> expectationFailure (toString err)+        Right opts -> do+          optQuery opts `shouldBe` Preview (Field "name")+          optRaw opts `shouldBe` Raw+          optJoin opts `shouldBe` Join++    it "combines set with compact" $ do+      case parseCLI ["set", "@name", "\"bob\"", "-c"] of+        Left err -> expectationFailure (toString err)+        Right opts -> do+          optQuery opts `shouldBe` Over (Field "name") (Const (String "bob"))+          optCompact opts `shouldBe` Compact++  describe "withInput" $ do+    it "fails to process a non existent file" $ do+      -- 'withInput' reports the error itself and exits with failure;+      -- the handle body must never run.+      result <- try $ do+        withInput (Just "/nonexistent/hq-missing.json") $ const $ pure ()+      case result :: Either ExitCode () of+        Left code -> code `shouldNotBe` ExitSuccess+        Right () -> expectationFailure "expected the query to fail on an unopenable file"++queryCases :: [([String], Query)]+queryCases =+  [ (["preview", "@name"], Preview (Field "name")),+    (["preview", "each"], Preview Each),+    (["preview", "@a . @b"], Preview (Compose (Field "a") (Field "b"))),+    (["fold", "each"], Fold Each),+    (["set", "@name", "\"bob\""], Over (Field "name") (Const (String "bob"))),+    (["set", "each", "0"], Over Each (Const (Number 0))),+    ( ["set", "@users.each.@name", "\"anon\""],+      Over+        (Compose (Compose (Field "users") Each) (Field "name"))+        (Const (String "anon"))+    ),+    (["delete", "@name"], Delete (Field "name")),+    (["delete", "each"], Delete Each)+  ]
+ test/HQ/JSON/DecoderSpec.hs view
@@ -0,0 +1,835 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.JSON.DecoderSpec (spec) where++import Data.Scientific (fromFloatDigits)+import HQ.Early (runEarly)+import HQ.JSON.Decoder+import HQ.JSON.Event+import Relude hiding (Compose, id)+import Streaming.Prelude qualified as S+import Test.HQ (decodeChunks, decodeShown, drainCollect, malformedPullCorpus, runStreaming, splits, validPullCorpus)+import Test.Syd++spec :: Spec+spec = describe "HQ.JSON.Decoder" $ do+  scalarSpec+  stringSpec+  numberSpec+  objectSpec+  arraySpec+  nestedSpec+  incrementalSpec+  errorSpec+  streamingSpec+  adversarialSpec+  pullEventSpec++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++-- | Decode input that is guaranteed to be complete (all at once).+decodeComplete :: Text -> Either DecodeError [JSONEvent]+decodeComplete input = case feed input initialDecoder of+  Left err -> Left err+  Right result -> drainCollect result++-- | Decode text incrementally, feeding one character at a time.+decodeIncremental :: Text -> Either DecodeError [JSONEvent]+decodeIncremental input = go initialDecoder (toString input)+  where+    -- After all characters fed, drain remaining events and finalize+    go decoder [] = case step decoder of+      Left err -> Left err+      Right result -> drainCollect result+    go decoder (c : cs) = case feed (one c) decoder of+      Left err -> Left err+      Right (Emit event nextDec) -> fmap (event :) (go nextDec cs)+      Right (NeedInput nextDec) -> go nextDec cs+      Right (Done nextDec) -> go nextDec cs++-- | Assert a decode fails with an accepted error.+shouldFailWith :: Either DecodeError [JSONEvent] -> (DecodeError -> Bool) -> IO ()+shouldFailWith (Left err) p+  | p err = pure ()+  | otherwise = expectationFailure $ "Unexpected decode error: " <> show err+shouldFailWith (Right events) _ =+  expectationFailure $ "Expected decode error, got events: " <> show events++--------------------------------------------------------------------------------+-- Scalar values+--------------------------------------------------------------------------------++scalarSpec :: Spec+scalarSpec = describe "scalars" $ forM_ scalarCases $ \(label, input, expected) ->+  it label $ decodeComplete input `shouldBe` Right expected++scalarCases :: [(String, Text, [JSONEvent])]+scalarCases =+  [ ("parses null", "null", [JSONNull]),+    ("parses true", "true", [JSONBool True]),+    ("parses false", "false", [JSONBool False]),+    ("parses zero", "0", [JSONNumber 0]),+    ("parses positive integer", "42", [JSONNumber 42]),+    ("parses negative integer", "-42", [JSONNumber (-42)]),+    ("parses decimal", "3.14", [JSONNumber (fromFloatDigits (3.14 :: Double))]),+    ( "parses negative decimal",+      "-3.14",+      [JSONNumber (fromFloatDigits (-3.14 :: Double))]+    ),+    ("parses scientific notation", "1e10", [JSONNumber 10000000000]),+    ("parses scientific notation with exponent", "1.5e2", [JSONNumber 150]),+    ( "parses negative mantissa with unsigned exponent",+      "-1e5",+      [JSONNumber (-100000)]+    ),+    ("parses negative decimal with exponent", "-1.5e2", [JSONNumber (-150)]),+    ("parses empty string", "\"\"", [JSONString ""]),+    ("parses simple string", "\"hello\"", [JSONString "hello"]),+    ("parses string with spaces", "\"hello world\"", [JSONString "hello world"])+  ]++--------------------------------------------------------------------------------+-- String escaping+--------------------------------------------------------------------------------++stringSpec :: Spec+stringSpec = describe "string escape sequences" $ do+  forM_ stringCases $ \(label, input, expected) ->+    it label $ decodeComplete input `shouldBe` Right expected++  it "rejects invalid escape character"+    $ decodeComplete "\"hello\\xworld\""+    `shouldFailWith` (== InvalidEscape 'x')++stringCases :: [(String, Text, [JSONEvent])]+stringCases =+  [ ("parses escaped quote", "\"hello\\\"world\"", [JSONString "hello\"world"]),+    ( "parses escaped backslash",+      "\"hello\\\\world\"",+      [JSONString "hello\\world"]+    ),+    ("parses escaped newline", "\"hello\\nworld\"", [JSONString "hello\nworld"]),+    ("parses escaped tab", "\"hello\\tworld\"", [JSONString "hello\tworld"]),+    ( "parses escaped carriage return",+      "\"hello\\rworld\"",+      [JSONString "hello\rworld"]+    ),+    ( "parses escaped backspace",+      "\"hello\\bworld\"",+      [JSONString "hello\bworld"]+    ),+    ( "parses escaped form feed",+      "\"hello\\fworld\"",+      [JSONString "hello\fworld"]+    ),+    ( "parses escaped forward slash",+      "\"hello\\/world\"",+      [JSONString "hello/world"]+    ),+    ("parses unicode escape", "\"\\u0041\"", [JSONString "A"]),+    ("parses multi-byte unicode escape", "\"\\u00E9\"", [JSONString "\233"]),+    -- U+1D11E (Musical Symbol G Clef) = D834 DD1E+    ("parses surrogate pair", "\"\\uD834\\uDD1E\"", [JSONString "\119070"]),+    ( "does not consume a hex digit following a unicode escape",+      "\"\\u0026B\"",+      [JSONString "&B"]+    ),+    ( "does not consume a trailing hex letter",+      "\"\\u0041B\"",+      [JSONString "AB"]+    ),+    ( "parses string with multiple escapes",+      "\"line1\\nline2\\ttab\"",+      [JSONString "line1\nline2\ttab"]+    )+  ]++--------------------------------------------------------------------------------+-- Numbers+--------------------------------------------------------------------------------++numberSpec :: Spec+numberSpec = describe "number formats" $ do+  forM_ numberCases $ \(label, input, expected) ->+    it label $ decodeComplete input `shouldBe` Right expected++numberCases :: [(String, Text, [JSONEvent])]+numberCases =+  [ ("parses single digit", "5", [JSONNumber 5]),+    ("parses multiple digits", "123", [JSONNumber 123]),+    ("parses leading zero", "0", [JSONNumber 0]),+    ("parses negative zero", "-0", [JSONNumber 0]),+    ("parses with fractional part", "1.0", [JSONNumber 1]),+    ("parses with exponent E", "1E10", [JSONNumber 10000000000]),+    ("parses with exponent e", "1e10", [JSONNumber 10000000000]),+    ( "parses with negative exponent",+      "1e-2",+      [JSONNumber (fromFloatDigits (0.01 :: Double))]+    ),+    ("parses with positive exponent sign", "1e+2", [JSONNumber 100]),+    ( "parses large number",+      "99999999999999999999",+      [JSONNumber 99999999999999999999]+    ),+    ( "parses -1.5e-6",+      "-1.5e-6",+      [JSONNumber (fromFloatDigits ((-1.5e-6) :: Double))]+    ),+    ("parses 1.25", "1.25", [JSONNumber (fromFloatDigits (1.25 :: Double))]),+    ("parses 1E+10", "1E+10", [JSONNumber 10000000000])+  ]++--------------------------------------------------------------------------------+-- Objects+--------------------------------------------------------------------------------++objectSpec :: Spec+objectSpec = describe "objects" $ forM_ objectCases $ \(label, input, expected) ->+  it label $ decodeComplete input `shouldBe` Right expected++objectCases :: [(String, Text, [JSONEvent])]+objectCases =+  [ ("parses empty object", "{}", [JSONBeginObject, JSONEndObject]),+    ( "parses object with one field",+      "{\"name\":\"alice\"}",+      [JSONBeginObject, JSONObjectKey "name", JSONString "alice", JSONEndObject]+    ),+    ( "parses object with multiple fields",+      "{\"a\":1,\"b\":2}",+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONNumber 1,+        JSONObjectKey "b",+        JSONNumber 2,+        JSONEndObject+      ]+    ),+    ( "parses object with string value",+      "{\"key\":\"value\"}",+      [JSONBeginObject, JSONObjectKey "key", JSONString "value", JSONEndObject]+    ),+    ( "parses object with null value",+      "{\"x\":null}",+      [JSONBeginObject, JSONObjectKey "x", JSONNull, JSONEndObject]+    ),+    ( "parses object with boolean value",+      "{\"flag\":true}",+      [JSONBeginObject, JSONObjectKey "flag", JSONBool True, JSONEndObject]+    ),+    ( "parses object with number value",+      "{\"count\":42}",+      [JSONBeginObject, JSONObjectKey "count", JSONNumber 42, JSONEndObject]+    ),+    ( "parses object with whitespace",+      "{ \"name\" : \"alice\" }",+      [JSONBeginObject, JSONObjectKey "name", JSONString "alice", JSONEndObject]+    )+  ]++--------------------------------------------------------------------------------+-- Arrays+--------------------------------------------------------------------------------++arraySpec :: Spec+arraySpec = describe "arrays" $ forM_ arrayCases $ \(label, input, expected) ->+  it label $ decodeComplete input `shouldBe` Right expected++arrayCases :: [(String, Text, [JSONEvent])]+arrayCases =+  [ ("parses empty array", "[]", [JSONBeginArray, JSONEndArray]),+    ( "parses array with one element",+      "[1]",+      [JSONBeginArray, JSONNumber 1, JSONEndArray]+    ),+    ( "parses array with multiple elements",+      "[1,2,3]",+      [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray]+    ),+    ( "parses array with mixed types",+      "[1,\"hello\",true,null]",+      [ JSONBeginArray,+        JSONNumber 1,+        JSONString "hello",+        JSONBool True,+        JSONNull,+        JSONEndArray+      ]+    ),+    ( "parses array with whitespace",+      "[ 1 , 2 , 3 ]",+      [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray]+    ),+    ( "parses array of strings",+      "[\"a\",\"b\",\"c\"]",+      [JSONBeginArray, JSONString "a", JSONString "b", JSONString "c", JSONEndArray]+    ),+    ( "parses array of booleans",+      "[true,false,true]",+      [JSONBeginArray, JSONBool True, JSONBool False, JSONBool True, JSONEndArray]+    )+  ]++--------------------------------------------------------------------------------+-- Nested structures+--------------------------------------------------------------------------------++nestedSpec :: Spec+nestedSpec = describe "nested structures" $ do+  forM_ nestedCases $ \(label, input, expected) ->+    it label $ decodeComplete input `shouldBe` Right expected++  it "parses complex real-world-like structure" $ do+    let input = "{\"users\":[{\"name\":\"alice\",\"age\":30},{\"name\":\"bob\",\"age\":25}],\"count\":2}"+    case decodeComplete input of+      Left err -> expectationFailure $ "Parse error: " <> show err+      Right events -> do+        viaNonEmpty head events `shouldBe` Just JSONBeginObject+        length events `shouldSatisfy` (> 10)++nestedCases :: [(String, Text, [JSONEvent])]+nestedCases =+  [ ( "parses nested objects",+      "{\"a\":{\"b\":42}}",+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONBeginObject,+        JSONObjectKey "b",+        JSONNumber 42,+        JSONEndObject,+        JSONEndObject+      ]+    ),+    ( "parses nested arrays",+      "[[1,2],[3,4]]",+      [ JSONBeginArray,+        JSONBeginArray,+        JSONNumber 1,+        JSONNumber 2,+        JSONEndArray,+        JSONBeginArray,+        JSONNumber 3,+        JSONNumber 4,+        JSONEndArray,+        JSONEndArray+      ]+    ),+    ( "parses object containing array",+      "{\"items\":[1,2,3]}",+      [ JSONBeginObject,+        JSONObjectKey "items",+        JSONBeginArray,+        JSONNumber 1,+        JSONNumber 2,+        JSONNumber 3,+        JSONEndArray,+        JSONEndObject+      ]+    ),+    ( "parses array containing object",+      "[{\"a\":1}]",+      [ JSONBeginArray,+        JSONBeginObject,+        JSONObjectKey "a",+        JSONNumber 1,+        JSONEndObject,+        JSONEndArray+      ]+    ),+    ( "parses deeply nested structure",+      "{\"a\":{\"b\":{\"c\":\"deep\"}}}",+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONBeginObject,+        JSONObjectKey "b",+        JSONBeginObject,+        JSONObjectKey "c",+        JSONString "deep",+        JSONEndObject,+        JSONEndObject,+        JSONEndObject+      ]+    )+  ]++--------------------------------------------------------------------------------+-- Incremental parsing+--------------------------------------------------------------------------------++incrementalSpec :: Spec+incrementalSpec = describe "incremental parsing" $ do+  forM_ incrementalCases $ \(label, input, expected) ->+    it label $ decodeIncremental input `shouldBe` Right expected++  it "parses number incrementally across chunk boundary" $ do+    -- Number split across chunks: "4" then "2"+    case decodeChunks ["4", "2"] of+      Left err -> expectationFailure $ "Parse error: " <> show err+      Right events -> events `shouldBe` [JSONNumber 42]++  it "parses object across 3 chunks" $ do+    let expected =+          [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]+    case decodeChunks ["{\"a\":", "1", "}"] of+      Left err -> expectationFailure $ "Parse error: " <> show err+      Right events -> events `shouldBe` expected++incrementalCases :: [(String, Text, [JSONEvent])]+incrementalCases =+  [ ("parses scalar incrementally", "42", [JSONNumber 42]),+    ("parses string incrementally", "\"hi\"", [JSONString "hi"]),+    ( "parses object incrementally",+      "{\"a\":1}",+      [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]+    ),+    ( "parses array incrementally",+      "[1,2,3]",+      [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray]+    ),+    ( "parses nested incrementally",+      "[[1],[2]]",+      [ JSONBeginArray,+        JSONBeginArray,+        JSONNumber 1,+        JSONEndArray,+        JSONBeginArray,+        JSONNumber 2,+        JSONEndArray,+        JSONEndArray+      ]+    )+  ]++--------------------------------------------------------------------------------+-- Error handling+--------------------------------------------------------------------------------++errorSpec :: Spec+errorSpec = describe "error handling" $ forM_ errorCases $ \(label, input, p) ->+  it label $ decodeComplete input `shouldFailWith` p++errorCases :: [(String, Text, DecodeError -> Bool)]+errorCases =+  [ ("rejects empty input", "", (== UnexpectedEnd)),+    ("rejects incomplete object", "{\"a\":", (== UnexpectedEnd)),+    ("rejects trailing input", "42 extra", (== TrailingInput)),+    ("rejects trailing input after object", "{} {}", (== TrailingInput)),+    ( "rejects invalid keyword",+      "nul",+      \case+        InvalidKeyword _ -> True+        UnexpectedEnd -> True+        _ -> False+    ),+    ("rejects invalid character", "x", (== UnexpectedChar 'x')),+    ("rejects unmatched opening bracket", "[", (== UnexpectedEnd)),+    ( "rejects unmatched closing bracket",+      "]",+      \e ->+        e == UnexpectedChar ']' || e == UnexpectedEnd+    ),+    ("rejects missing colon in object", "{\"a\" 1}", (== ExpectedColon)),+    ("rejects missing comma in array", "[1 2]", (== ExpectedCommaOrEnd)),+    ("rejects invalid escape in string", "\"\\z\"", (== InvalidEscape 'z')),+    ("rejects invalid unicode escape", "\"\\uGGGG\"", (== InvalidUnicodeEscape)),+    ( "rejects invalid number --",+      "--",+      \case+        InvalidNumber _ -> True+        UnexpectedChar '-' -> True+        _ -> False+    )+  ]++--------------------------------------------------------------------------------+-- Streaming adapter+--------------------------------------------------------------------------------++streamingSpec :: Spec+streamingSpec = describe "streaming decode" $ do+  forM_ streamingCases $ \(label, chunks, expected) ->+    it label $ runStreaming chunks `shouldBe` expected++  forM_ streamingErrorChunks $ \chunks ->+    it ("rejects " <> show chunks) $ decodeChunks chunks `shouldSatisfy` isLeft++  it "reports trailing input after root value"+    $ decodeChunks ["42", " extra"]+    `shouldFailWith` (== TrailingInput)++streamingCases :: [(String, [Text], [JSONEvent])]+streamingCases =+  [ ("decodes a single chunk", ["42"], [JSONNumber 42]),+    ( "decodes multiple chunks",+      ["{", "\"a\"", ":", "1", "}"],+      [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]+    ),+    ("decodes empty stream", [], []),+    ("decodes scalar values", ["null"], [JSONNull]),+    ("decodes boolean", ["true"], [JSONBool True]),+    ("decodes string across chunks", ["\"hel", "lo\""], [JSONString "hello"]),+    ( "decodes array across chunks",+      ["[1,", "2,", "3]"],+      [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray]+    ),+    ( "decodes object across chunks",+      ["{\"a\":", "1}"],+      [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]+    ),+    ( "decodes nested structure across chunks",+      ["[[1],", "[2]]"],+      [ JSONBeginArray,+        JSONBeginArray,+        JSONNumber 1,+        JSONEndArray,+        JSONBeginArray,+        JSONNumber 2,+        JSONEndArray,+        JSONEndArray+      ]+    ),+    ( "decodes single-character chunks",+      ["[", "1", ",", "2", "]"],+      [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray]+    ),+    ( "decodes string literal across 5 chunks",+      ["\"", "he", "llo", " wor", "ld\""],+      [JSONString "hello world"]+    ),+    ( "decodes complex nested across many chunks",+      ["{\"arr\":[", "1,2],", "\"key\":\"val\"}"],+      [ JSONBeginObject,+        JSONObjectKey "arr",+        JSONBeginArray,+        JSONNumber 1,+        JSONNumber 2,+        JSONEndArray,+        JSONObjectKey "key",+        JSONString "val",+        JSONEndObject+      ]+    ),+    ( "parses surrogate pair across chunks",+      ["\"\\uD834", "\\uDD1E\""],+      [JSONString "\119070"]+    ),+    ( "parses unicode escape split across chunks followed by hex digit",+      ["\"\\u004", "1B\""],+      [JSONString "AB"]+    ),+    ( "parses object with unicode value",+      ["{\"k\":\"\\u0041\"}"],+      [JSONBeginObject, JSONObjectKey "k", JSONString "A", JSONEndObject]+    ),+    ( "parses nested arrays across many chunks",+      ["[[", "[", "1", "]", "]]"],+      [ JSONBeginArray,+        JSONBeginArray,+        JSONBeginArray,+        JSONNumber 1,+        JSONEndArray,+        JSONEndArray,+        JSONEndArray+      ]+    ),+    ( "parses escape sequences at chunk boundary",+      ["\"\\", "n\""],+      [JSONString "\n"]+    ),+    ( "parses deeply nested object across chunks",+      ["{\"a\":{\"b\":", "{\"", "c", "\":", "42}}}"],+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONBeginObject,+        JSONObjectKey "b",+        JSONBeginObject,+        JSONObjectKey "c",+        JSONNumber 42,+        JSONEndObject,+        JSONEndObject,+        JSONEndObject+      ]+    ),+    ("parses number 0 across chunks", ["0"], [JSONNumber 0]),+    ("parses number -42 across chunks", ["-4", "2"], [JSONNumber (-42)]),+    ( "parses fractional number across chunks",+      ["3.", "14"],+      [JSONNumber (fromFloatDigits (3.14 :: Double))]+    ),+    ( "parses exponent number across chunks",+      ["1e", "10"],+      [JSONNumber 10000000000]+    ),+    ("single whitespace stream is empty", [" "], []),+    ("multiple empty chunks then data", ["", "", "42"], [JSONNumber 42]),+    ("data then empty chunks", ["42", "", ""], [JSONNumber 42]),+    ("valid number 1e10 across chunks", ["1e", "10"], [JSONNumber 10000000000]),+    ( "valid number -1.5e-6 across chunks",+      ["-1.5e", "-6"],+      [JSONNumber (fromFloatDigits ((-1.5e-6) :: Double))]+    ),+    ( "nested object across chunks",+      ["{\"a\":{\"b\":", "1", "}}"],+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONBeginObject,+        JSONObjectKey "b",+        JSONNumber 1,+        JSONEndObject,+        JSONEndObject+      ]+    )+  ]++streamingErrorChunks :: [[Text]]+streamingErrorChunks =+  [["{invalid}"], ["{", "invalid}"], ["42", " ", "extra"], ["42", "extra"]]++--------------------------------------------------------------------------------+-- Adversarial tests: invalid numbers, surrogate pairs, error propagation+--------------------------------------------------------------------------------++adversarialSpec :: Spec+adversarialSpec = describe "malformed input" $ do+  -- ---- Invalid numbers ----+  describe "invalid numbers"+    $ forM_ invalidNumberCases+    $ \(label, input, p) ->+      it label $ decodeComplete input `shouldFailWith` p++  -- ---- Surrogate pair errors at EOF ----+  describe "surrogate pair errors"+    $ forM_ surrogateCases+    $ \(label, input, p) ->+      it label $ decodeComplete input `shouldFailWith` p++  -- ---- Error propagation in streaming (the key continueWith bug) ----+  describe "error propagation" $ do+    forM_ propagationChunks $ \chunks ->+      it ("propagates an error from " <> show chunks)+        $ decodeChunks chunks+        `shouldSatisfy` isLeft++    it "parses keyword true split across chunks"+      $ decodeChunks ["tru", "e"]+      `shouldBe` Right [JSONBool True]++    it "propagates string escape error at chunk boundary"+      $ decodeChunks ["\"\\", "z\""]+      `shouldFailWith` (== InvalidEscape 'z')++  -- ---- Empty and boundary ----+  describe "edge cases" $ do+    forM_ edgeCases $ \(label, input, expected) ->+      it label $ decodeComplete input `shouldBe` Right expected++    it "rejects unterminated input" $ forM_ unterminatedCases $ \input ->+      decodeComplete input `shouldFailWith` (== UnexpectedEnd)++    forM_ keywordCases $ \(label, input, p) ->+      it label $ decodeComplete input `shouldFailWith` p++    it "keyword null without delimiter at EOF" $ do+      decodeComplete "null" `shouldBe` Right [JSONNull]++    it "keyword null followed by space is valid" $ do+      decodeComplete "null " `shouldBe` Right [JSONNull]++    it "invalid escape in string at chunk boundary"+      $ decodeChunks ["\"\\", "x\""]+      `shouldFailWith` (== InvalidEscape 'x')++    it "incomplete high surrogate at EOF in streaming"+      $ decodeChunks ["\"\\uD834"]+      `shouldFailWith` (== InvalidSurrogatePair)++    it "high surrogate followed by non-low in streaming"+      $ decodeChunks ["\"\\uD834", "\\u0041\""]+      `shouldFailWith` (== InvalidSurrogatePair)++    it "rejects truncated numbers at chunk boundaries"+      $ forM_ [["1.", ""], ["1e", ""], ["1e+", ""]]+      $ \chunks ->+        decodeChunks chunks+          `shouldFailWith` (\e -> isInvalidNumber e || e == UnexpectedEnd)++edgeCases :: [(String, Text, [JSONEvent])]+edgeCases =+  [ ( "deeply nested empty arrays",+      "[[[[]]]]",+      [ JSONBeginArray,+        JSONBeginArray,+        JSONBeginArray,+        JSONBeginArray,+        JSONEndArray,+        JSONEndArray,+        JSONEndArray,+        JSONEndArray+      ]+    ),+    ( "all scalar types in array",+      "[null,true,false,0,1.5,\"x\"]",+      [ JSONBeginArray,+        JSONNull,+        JSONBool True,+        JSONBool False,+        JSONNumber 0,+        JSONNumber (fromFloatDigits (1.5 :: Double)),+        JSONString "x",+        JSONEndArray+      ]+    ),+    ( "empty object value",+      "{\"a\":{}}",+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONBeginObject,+        JSONEndObject,+        JSONEndObject+      ]+    ),+    ( "empty array value",+      "{\"a\":[]}",+      [ JSONBeginObject,+        JSONObjectKey "a",+        JSONBeginArray,+        JSONEndArray,+        JSONEndObject+      ]+    )+  ]++unterminatedCases :: [Text]+unterminatedCases =+  [ "\"hello",+    "\"hello\\",+    "\"\\u00",+    "{\"a\":1",+    "[1,2"+  ]++keywordCases :: [(String, Text, DecodeError -> Bool)]+keywordCases =+  [ ("keyword null followed by digit is invalid", "null0", isInvalidKeyword),+    ("keyword true followed by letter is invalid", "truex", isInvalidKeyword),+    ( "keyword false followed by brace is invalid",+      "false}",+      \e -> isInvalidKeyword e || e == TrailingInput+    )+  ]++isInvalidKeyword :: DecodeError -> Bool+isInvalidKeyword (InvalidKeyword _) = True+isInvalidKeyword _ = False++invalidNumberCases :: [(String, Text, DecodeError -> Bool)]+invalidNumberCases =+  [ ( "rejects +1 (leading plus)",+      "+1",+      \e -> e == UnexpectedChar '+' || isInvalidNumber e+    ),+    ("rejects 01 (leading zero)", "01", isInvalidNumber),+    ( "rejects 1. (trailing dot)",+      "1.",+      \e -> isInvalidNumber e || e == UnexpectedEnd+    ),+    ( "rejects 1e (trailing exponent)",+      "1e",+      \e -> isInvalidNumber e || e == UnexpectedEnd+    ),+    ( "rejects 1e+ (trailing exponent sign)",+      "1e+",+      \e -> isInvalidNumber e || e == UnexpectedEnd+    ),+    ( "rejects - (just a sign)",+      "-",+      \e -> isInvalidNumber e || e == UnexpectedEnd+    ),+    ( "rejects 1--2 (double negative)",+      "1--2",+      \e -> isInvalidNumber e || e == UnexpectedChar '-'+    ),+    ( "rejects 1.2.3 (double dot)",+      "1.2.3",+      \e -> isInvalidNumber e || e == UnexpectedChar '.'+    ),+    ( "rejects -. (sign + dot only)",+      "-.",+      \e -> isInvalidNumber e || e == UnexpectedChar '.'+    ),+    ( "rejects 1e--2 (double exponent sign)",+      "1e--2",+      \e -> isInvalidNumber e || e == UnexpectedChar '-'+    )+  ]++surrogateCases :: [(String, Text, DecodeError -> Bool)]+surrogateCases =+  [ ( "rejects incomplete high surrogate at EOF",+      "\"\\uD834",+      \e -> e == InvalidSurrogatePair || e == UnexpectedEnd+    ),+    ( "rejects high surrogate followed by non-low-surrogate",+      "\"\\uD834\\u0041\"",+      (== InvalidSurrogatePair)+    ),+    ("rejects lone low surrogate", "\"\\uDC00\"", (== InvalidSurrogatePair)),+    ( "rejects incomplete low surrogate escape at EOF",+      "\"\\uD834\\u",+      \e -> e == InvalidSurrogatePair || e == InvalidUnicodeEscape || e == UnexpectedEnd+    ),+    ( "rejects high surrogate followed by invalid unicode",+      "\"\\uD834\\uGGGG\"",+      \e -> e == InvalidSurrogatePair || e == InvalidUnicodeEscape+    )+  ]++propagationChunks :: [[Text]]+propagationChunks =+  [ ["{\"foo\": @}}"],+    ["{\"a\":", "@}"],+    ["{\"a\":@", "}"],+    ["[[[", "@]]]"],+    ["[1,", "@2]"]+  ]++isInvalidNumber :: DecodeError -> Bool+isInvalidNumber (InvalidNumber _) = True+isInvalidNumber _ = False++--------------------------------------------------------------------------------+-- pullEvent (single-event pulls agree with streaming decode)+--------------------------------------------------------------------------------++-- | Pull every event through pullEvent.+pullAllChunks :: [Text] -> IO (Either Text [JSONEvent])+pullAllChunks chunks = do+  result <- runEarly (\early -> collect early initialDecoder stream)+  pure (first renderHQError result)+  where+    stream :: StreamIO Text ()+    stream = S.each chunks+    collect early decoder text = do+      pulled <- pullEvent early decoder text+      case pulled of+        EndOfInput -> pure []+        NextEvent (NextEmitted event decoder' rest) ->+          (event :) <$> collect early decoder' rest++pullEventSpec :: Spec+pullEventSpec = describe "pullEvent" $ do+  it "agrees with streaming decode on valid inputs under every split" $ do+    forM_ validPullCorpus $ \input ->+      forM_ (splits input) $ \chunks -> do+        pulled <- pullAllChunks chunks+        pulled `shouldBe` decodeShown chunks++  it "agrees with streaming decode on malformed inputs under every split" $ do+    forM_ malformedPullCorpus $ \input ->+      forM_ (splits input) $ \chunks -> do+        pulled <- pullAllChunks chunks+        pulled `shouldBe` decodeShown chunks
+ test/HQ/JSON/EncoderSpec.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.JSON.EncoderSpec (spec) where++import Data.Text qualified as T+import HQ.JSON.Encoder+import HQ.JSON.Event (JSONEvent (..))+import Relude hiding (Compose, id)+import Streaming (Of (..))+import Streaming.Prelude qualified as S+import Test.HQ (decodeChunks)+import Test.Syd++spec :: Spec+spec = describe "HQ.JSON.Encoder" $ do+  encodeSpec+  encodePrettySpec+  valueOptionsSpec+  roundtripSpec++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++-- | Encode events to a single Text value using compact style, without+-- separators between top-level values.+encodeEvents :: [JSONEvent] -> Text+encodeEvents = encodeEventsWith $ EncoderConfig Compact $ ValueOptions NoRaw Join++-- | Encode events with the given 'EncoderConfig' to a single Text+-- value.+encodeEventsWith :: EncoderConfig -> [JSONEvent] -> Text+encodeEventsWith encConfig events = runIdentity $ do+  result <- S.toList (encode encConfig 32 (S.each events))+  case result of+    chunks :> _ -> pure $ decodeUtf8 $ mconcat chunks++--------------------------------------------------------------------------------+-- encode+--------------------------------------------------------------------------------++encodeSpec :: Spec+encodeSpec = describe "encode" $ forM_ encodeCases $ \(label, events, expected) ->+  it label $ encodeEvents events `shouldBe` expected++encodeCases :: [(String, [JSONEvent], Text)]+encodeCases =+  [ ("encodes null", [JSONNull], "null"),+    ("encodes true", [JSONBool True], "true"),+    ("encodes false", [JSONBool False], "false"),+    ("encodes number", [JSONNumber 42], "42"),+    ("encodes string", [JSONString "hello"], "\"hello\""),+    ("encodes empty object", [JSONBeginObject, JSONEndObject], "{}"),+    ("encodes object with one field", [JSONBeginObject, JSONObjectKey "name", JSONString "alice", JSONEndObject], "{\"name\":\"alice\"}"),+    ("encodes object with multiple fields", [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONObjectKey "b", JSONNumber 2, JSONEndObject], "{\"a\":1,\"b\":2}"),+    ("encodes empty array", [JSONBeginArray, JSONEndArray], "[]"),+    ("encodes array with one element", [JSONBeginArray, JSONNumber 1, JSONEndArray], "[1]"),+    ("encodes array with multiple elements", [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray], "[1,2,3]"),+    ("encodes array of strings", [JSONBeginArray, JSONString "a", JSONString "b", JSONEndArray], "[\"a\",\"b\"]"),+    ("encodes nested objects", [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "b", JSONNumber 1, JSONEndObject, JSONEndObject], "{\"a\":{\"b\":1}}"),+    ("encodes nested arrays", [JSONBeginArray, JSONBeginArray, JSONNumber 1, JSONEndArray, JSONBeginArray, JSONNumber 2, JSONEndArray, JSONEndArray], "[[1],[2]]"),+    ("encodes object containing array", [JSONBeginObject, JSONObjectKey "items", JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray, JSONEndObject], "{\"items\":[1,2]}"),+    ("encodes array containing object", [JSONBeginArray, JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject, JSONEndArray], "[{\"a\":1}]"),+    ("encodes complex structure", [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "name", JSONString "alice", JSONObjectKey "age", JSONNumber 30, JSONEndObject, JSONBeginObject, JSONObjectKey "name", JSONString "bob", JSONObjectKey "age", JSONNumber 25, JSONEndObject, JSONEndArray, JSONObjectKey "count", JSONNumber 2, JSONEndObject], "{\"users\":[{\"name\":\"alice\",\"age\":30},{\"name\":\"bob\",\"age\":25}],\"count\":2}")+  ]++--------------------------------------------------------------------------------+-- pretty encode+--------------------------------------------------------------------------------++encodePrettySpec :: Spec+encodePrettySpec = describe "pretty encode" $ do+  let prettyConfig = EncoderConfig (Pretty 2) $ ValueOptions NoRaw Join+  let compactConfig = EncoderConfig Compact $ ValueOptions NoRaw Join++  describe "scalars are identical in compact and pretty" $ do+    let scalarCases =+          [ ("null", [JSONNull], "null"),+            ("true", [JSONBool True], "true"),+            ("false", [JSONBool False], "false"),+            ("42", [JSONNumber 42], "42"),+            ("1.5", [JSONNumber 1.5], "1.5"),+            ("\"hello\"", [JSONString "hello"], "\"hello\"")+          ]+    forM_ scalarCases $ \(label, events, expected) ->+      it label $ do+        encodeEventsWith compactConfig events `shouldBe` expected+        encodeEventsWith prettyConfig events `shouldBe` expected++  describe "empty containers stay compact" $ do+    forM_ emptyContainerCases $ \(label, events, expected) ->+      it label $ encodeEventsWith prettyConfig events `shouldBe` expected++  describe "single-element containers" $ do+    forM_ singleElementCases $ \(label, events, expected) ->+      it label $ encodeEventsWith prettyConfig events `shouldBe` expected++  describe "multiple elements" $ do+    forM_ multipleElementCases $ \(label, events, expected) ->+      it label $ encodeEventsWith prettyConfig events `shouldBe` expected++  describe "nested structures" $ do+    forM_ nestedCases $ \(label, events, expected) ->+      it label $ encodeEventsWith prettyConfig events `shouldBe` expected++  describe "string escaping is preserved" $ do+    it "special characters encode identically with surrounding formatting" $ do+      let events =+            [ JSONBeginArray,+              JSONString "quote\" backslash\\ newline\n return\r tab\t bell\b formfeed\f control\x01 snowman☃ snow❄",+              JSONEndArray+            ]+      encodeEvents events+        `shouldBe` "[\"quote\\\" backslash\\\\ newline\\n return\\r tab\\t bell\\b formfeed\\f control\\u0001 snowman☃ snow❄\"]"+      encodeEventsWith prettyConfig events+        `shouldBe` "[\n  \"quote\\\" backslash\\\\ newline\\n return\\r tab\\t bell\\b formfeed\\f control\\u0001 snowman☃ snow❄\"\n]"+    it "pretty output decodes back to the same events" $ do+      let events =+            [ JSONBeginArray,+              JSONString "tab\tyes\nline2\r\n\"quoted\"\\and 日本語☃\x07",+              JSONNumber (-1.5e-3),+              JSONEndArray+            ]+          encoded = encodeEventsWith prettyConfig events+      case decodeChunks [encoded] of+        Left err -> expectationFailure $ "Re-decode failed: " <> show err+        Right evts' -> evts' `shouldBe` events++  describe "chunk sizes do not affect pretty output" $ do+    let events =+          [ JSONBeginObject,+            JSONObjectKey "users",+            JSONBeginArray,+            JSONBeginObject,+            JSONObjectKey "name",+            JSONString "alice",+            JSONObjectKey "age",+            JSONNumber 30,+            JSONEndObject,+            JSONBeginObject,+            JSONObjectKey "name",+            JSONString "bob",+            JSONObjectKey "age",+            JSONNumber 25,+            JSONEndObject,+            JSONEndArray,+            JSONObjectKey "tags",+            JSONBeginArray,+            JSONString "a\"b",+            JSONNull,+            JSONEndArray,+            JSONEndObject+          ]+        expected = encodeEventsWith prettyConfig events+    forM_ [1, 2, 3, 5, 8, 16, 24, 40] $ \cSize ->+      it ("chunk size " <> show cSize) $ do+        let concatenated = runIdentity $ do+              result <- S.toList (encode prettyConfig cSize (S.each events))+              case result of+                chunks :> _ -> pure $ decodeUtf8 $ mconcat chunks+        concatenated `shouldBe` expected+        case decodeChunks [concatenated] of+          Left err -> expectationFailure $ "Re-decode failed at chunk size " <> show cSize <> ": " <> show err+          Right evts' -> evts' `shouldBe` events++  describe "roundtrip through pretty encoding" $ do+    let prettyRoundtripCases =+          [ ("empty object", "{}"),+            ("empty array", "[]"),+            ("object", "{\"name\":\"Alice\"}"),+            ("array", "[1,2,3]"),+            ("nested", "{\"users\":[{\"name\":\"alice\"},{\"name\":\"bob\"}]}"),+            ("mixed array", "[1,true,null,\"x\",-2.5]"),+            ("escapes", "\"a\\nb\\\"c\\\\d\""),+            ("unicode", "\"日本語☃\""),+            ("number with exponent", "1e10"),+            ("negative exponent", "1e-2")+          ]+    forM_ prettyRoundtripCases $ \(label, input) ->+      it ("pretty roundtrips " <> label) $ prettyRoundtrip input++emptyContainerCases :: [(String, [JSONEvent], Text)]+emptyContainerCases =+  [ ("empty object", [JSONBeginObject, JSONEndObject], "{}"),+    ("empty array", [JSONBeginArray, JSONEndArray], "[]"),+    ("empty containers nested in non-empty containers", [JSONBeginObject, JSONObjectKey "a", JSONBeginArray, JSONEndArray, JSONObjectKey "b", JSONBeginObject, JSONEndObject, JSONEndObject], "{\n  \"a\": [],\n  \"b\": {}\n}"),+    ("empty arrays nested in an array", [JSONBeginArray, JSONBeginArray, JSONEndArray, JSONBeginArray, JSONEndArray, JSONEndArray], "[\n  [],\n  []\n]")+  ]++singleElementCases :: [(String, [JSONEvent], Text)]+singleElementCases =+  [ ("object", [JSONBeginObject, JSONObjectKey "name", JSONString "Alice", JSONEndObject], "{\n  \"name\": \"Alice\"\n}"),+    ("array", [JSONBeginArray, JSONNumber 42, JSONEndArray], "[\n  42\n]")+  ]++multipleElementCases :: [(String, [JSONEvent], Text)]+multipleElementCases =+  [ ("object with multiple fields", [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONObjectKey "b", JSONNumber 2, JSONEndObject], "{\n  \"a\": 1,\n  \"b\": 2\n}"),+    ("array with multiple elements", [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray], "[\n  1,\n  2,\n  3\n]")+  ]++nestedCases :: [(String, [JSONEvent], Text)]+nestedCases =+  [ ("object in object", [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "b", JSONNumber 1, JSONEndObject, JSONEndObject], "{\n  \"a\": {\n    \"b\": 1\n  }\n}"),+    ("array in array", [JSONBeginArray, JSONBeginArray, JSONNumber 1, JSONEndArray, JSONEndArray], "[\n  [\n    1\n  ]\n]"),+    ("array in object", [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray, JSONEndObject], "{\n  \"users\": [\n    1,\n    2\n  ]\n}"),+    ("object in array", [JSONBeginArray, JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject, JSONEndArray], "[\n  {\n    \"a\": 1\n  }\n]"),+    ("deeply nested", [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "b", JSONBeginArray, JSONBeginObject, JSONObjectKey "c", JSONNumber 1, JSONEndObject, JSONEndArray, JSONEndObject, JSONEndObject], "{\n  \"a\": {\n    \"b\": [\n      {\n        \"c\": 1\n      }\n    ]\n  }\n}"),+    ("complex structure", [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "name", JSONString "alice", JSONObjectKey "age", JSONNumber 30, JSONEndObject, JSONBeginObject, JSONObjectKey "name", JSONString "bob", JSONObjectKey "age", JSONNumber 25, JSONEndObject, JSONEndArray, JSONObjectKey "count", JSONNumber 2, JSONEndObject], "{\n  \"users\": [\n    {\n      \"name\": \"alice\",\n      \"age\": 30\n    },\n    {\n      \"name\": \"bob\",\n      \"age\": 25\n    }\n  ],\n  \"count\": 2\n}"),+    ("mixed types in array", [JSONBeginArray, JSONNumber 1, JSONString "hello", JSONBool True, JSONNull, JSONEndArray], "[\n  1,\n  \"hello\",\n  true,\n  null\n]")+  ]++--------------------------------------------------------------------------------+-- value output options+--------------------------------------------------------------------------------++valueOptionsSpec :: Spec+valueOptionsSpec = describe "value output options" $ do+  describe "newline separation" $ do+    let encConfig = EncoderConfig Compact $ ValueOptions NoRaw NoJoin+    forM_ newlineCases $ \(label, events, expected) ->+      it label $ encodeEventsWith encConfig events `shouldBe` expected+    it "applies pretty formatting inside each value" $ do+      encodeEventsWith+        (EncoderConfig (Pretty 2) $ ValueOptions NoRaw NoJoin)+        [ JSONBeginObject,+          JSONObjectKey "a",+          JSONNumber 1,+          JSONEndObject,+          JSONString "x"+        ]+      `shouldBe` "{\n  \"a\": 1\n}\n\"x\"\n"+    it "matches plain encode with separation disabled" $ do+      let events =+            [ JSONBeginObject,+              JSONObjectKey "a",+              JSONNumber 1,+              JSONEndObject,+              JSONString "x"+            ]+      encodeEventsWith (EncoderConfig Compact $ ValueOptions NoRaw Join) events+        `shouldBe` encodeEvents events++    it "output is independent of chunk size" $ do+      let events =+            [ JSONBeginObject,+              JSONObjectKey "a",+              JSONNumber 1,+              JSONEndObject,+              JSONString "x",+              JSONBeginArray,+              JSONNumber 2,+              JSONEndArray+            ]+          expected = encodeEventsWith encConfig events+      forM_ [1, 2, 3, 5, 8, 16] $ \flushSize -> do+        let concatenated = runIdentity $ do+              result <- S.toList (encode encConfig flushSize (S.each events))+              case result of+                chunks :> _ -> pure $ decodeUtf8 $ mconcat chunks+        concatenated `shouldBe` expected+    it "every line decodes back to the original events" $ do+      let events =+            [ JSONBeginObject,+              JSONObjectKey "a",+              JSONNumber 1,+              JSONEndObject,+              JSONString "x",+              JSONBeginArray,+              JSONNumber 2,+              JSONEndArray+            ]+          encoded = encodeEventsWith encConfig events+          lines' = filter (not . T.null) (T.splitOn "\n" encoded)+          decodedLines = map (fromRight [] . decodeChunks . pure) lines'+      mconcat decodedLines `shouldBe` events++  describe "raw string output"+    $ forM_ rawCases+    $ \(label, config, events, expected) ->+      it label $ encodeEventsWith config events `shouldBe` expected++--------------------------------------------------------------------------------+-- Roundtrip: encode . decode produces the same text+--------------------------------------------------------------------------------++newlineCases :: [(String, [JSONEvent], Text)]+newlineCases =+  [ ("produces nothing for an empty stream", [], ""),+    ("terminates a single scalar with a newline", [JSONNumber 1], "1\n"),+    ("places multiple scalars on separate lines", [JSONNumber 1, JSONString "a", JSONBool True, JSONNull], "1\n\"a\"\ntrue\nnull\n"),+    ("places container values on separate lines", [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject, JSONBeginArray, JSONNumber 2, JSONEndArray], "{\"a\":1}\n[2]\n"),+    ("keeps a nested container inside one value", [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "b", JSONNumber 1, JSONEndObject, JSONEndObject, JSONNumber 2], "{\"a\":{\"b\":1}}\n2\n"),+    ("emits empty containers as single-line values", [JSONBeginObject, JSONEndObject, JSONBeginArray, JSONEndArray], "{}\n[]\n")+  ]++rawCases :: [(String, EncoderConfig, [JSONEvent], Text)]+rawCases =+  [ ("renders a top-level string without quotes or escapes", EncoderConfig Compact $ ValueOptions Raw Join, [JSONString "a\"b\n雪"], "a\"b\n雪"),+    ("keeps strings inside containers quoted", EncoderConfig Compact $ ValueOptions Raw Join, [JSONBeginArray, JSONString "x\\y", JSONEndArray], "[\"x\\\\y\"]"),+    ("keeps object keys quoted", EncoderConfig Compact $ ValueOptions Raw Join, [JSONBeginObject, JSONObjectKey "k\"", JSONString "v", JSONEndObject], "{\"k\\\"\":\"v\"}"),+    ("combines raw strings with newline separation", EncoderConfig Compact $ ValueOptions Raw NoJoin, [JSONString "one", JSONString "two", JSONNumber 3], "one\ntwo\n3\n"),+    ("combines raw strings with joining", EncoderConfig Compact $ ValueOptions Raw Join, [JSONString "one", JSONString "two", JSONNumber 3], "onetwo3")+  ]++roundtripSpec :: Spec+roundtripSpec = describe "roundtrip (encode . decode)" $ do+  forM_ roundtripCases $ \(label, input) ->+    it ("roundtrips " <> label) $ roundtrip input++roundtripCases :: [(String, Text)]+roundtripCases =+  [ ("null", "null"),+    ("true", "true"),+    ("false", "false"),+    ("number", "42"),+    ("negative number", "-3.14"),+    ("empty string", "\"\""),+    ("simple string", "\"hello\""),+    ("string with escapes", "\"hello\\nworld\""),+    ("empty object", "{}"),+    ("object with one field", "{\"name\":\"alice\"}"),+    ("object with multiple fields", "{\"a\":1,\"b\":2}"),+    ("empty array", "[]"),+    ("array with one element", "[1]"),+    ("array with multiple elements", "[1,2,3]"),+    ("array of strings", "[\"a\",\"b\",\"c\"]"),+    ("nested objects", "{\"a\":{\"b\":42}}"),+    ("nested arrays", "[[1,2],[3,4]]"),+    ("object containing array", "{\"items\":[1,2,3]}"),+    ("array containing object", "[{\"a\":1}]"),+    ("mixed types in array", "[1,\"hello\",true,null]"),+    ("deeply nested", "{\"a\":{\"b\":{\"c\":\"deep\"}}}"),+    ("complex structure", "{\"users\":[{\"name\":\"alice\",\"age\":30},{\"name\":\"bob\",\"age\":25}],\"count\":2}"),+    ("string with special escapes", "\"tab\\there\\nnewline\\rret\""),+    ("string with unicode escape", "\"\\u0041\""),+    ("number with exponent", "1e10"),+    ("number with negative exponent", "1e-2"),+    ("zero", "0")+  ]++-- | Verify that encoding with 'Pretty 2' and decoding again yields the+-- same events as decoding the compact input, i.e. that pretty-printing+-- only changes whitespace.+prettyRoundtrip :: Text -> IO ()+prettyRoundtrip input = case decodeChunks [input] of+  Left err -> expectationFailure $ "Decode failed: " <> show err+  Right events -> do+    let encoded = encodeEventsWith encConfig events+        redecoded = decodeChunks [encoded]+    case redecoded of+      Left err -> expectationFailure $ "Re-decode failed: " <> show err+      Right events' -> events `shouldBe` events'+  where+    encConfig = EncoderConfig (Pretty 2) $ ValueOptions NoRaw Join++-- | Verify that encode . decode produces the same events (wrapped in Either).+roundtrip :: Text -> IO ()+roundtrip input = case decodeChunks [input] of+  Left err -> expectationFailure $ "Decode failed: " <> show err+  Right events -> do+    let encoded = encodeEvents events+        redecoded = decodeChunks [encoded]+    case redecoded of+      Left err -> expectationFailure $ "Re-decode failed: " <> show err+      Right events' -> events `shouldBe` events'
+ test/HQ/JSON/ParserSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.JSON.ParserSpec (spec) where++import Data.Aeson (Value (..))+import Data.Aeson.Key (fromText)+import Data.Aeson.KeyMap qualified as KeyMap+import HQ.JSON.Event (JSONEvent (..))+import HQ.JSON.Parser (parseValue, parseValueEvents)+import Relude hiding (Compose, id)+import Test.HQ (decodeChunks)+import Test.Syd++spec :: Spec+spec = describe "HQ.JSON.Parser" $ do+  parseValueSpec+  parseValueEventsSpec++--------------------------------------------------------------------------------+-- parseValue+--------------------------------------------------------------------------------++parseValueSpec :: Spec+parseValueSpec = describe "parseValue" $ do+  it "parses values" $ forM_ valueCases $ \(input, expected) ->+    parseValue input `shouldBe` Right expected++  it "rejects invalid input" $ forM_ invalidCases $ \input ->+    parseValue input `shouldSatisfy` isLeft++valueCases :: [(Text, Value)]+valueCases =+  [ ("42", Number 42),+    ("-7", Number (-7)),+    ("0.5", Number 0.5),+    ("1e10", Number 1e10),+    ("-2.5e-3", Number (-2.5e-3)),+    ("\"\\\"\\\\\\/\\b\\f\\n\\r\\t\"", String "\"\\/\b\f\n\r\t"),+    ("\"caf\\u00e9\"", String "café"),+    ("\"\\uD83D\\uDE00\"", String "\x1F600"),+    ("{\"k\\u0041\":1}", Object (KeyMap.fromList [(fromText "kA", Number 1)]))+  ]++invalidCases :: [Text]+invalidCases =+  [ "one",+    "\"\\x\"",+    "\"\\uD83D\"",+    "\"\\uDE00\"",+    "\"\\uD83Dx\"",+    "\"a\SOHb\""+  ]++--------------------------------------------------------------------------------+-- parseValueEvents+--------------------------------------------------------------------------------++-- | Parse a value to events, or fail the test with the error message.+parseEventsOrFail :: Text -> IO [JSONEvent]+parseEventsOrFail input = case parseValueEvents input of+  Left err -> expectationFailure (toString err) >> pure []+  Right events -> pure events++parseValueEventsSpec :: Spec+parseValueEventsSpec = describe "parseValueEvents" $ do+  it "preserves object member order" $ do+    events <- parseEventsOrFail "{\"b\":1,\"a\":2}"+    events+      `shouldBe` [ JSONBeginObject,+                   JSONObjectKey "b",+                   JSONNumber 1,+                   JSONObjectKey "a",+                   JSONNumber 2,+                   JSONEndObject+                 ]++  it "produces the same events as the streaming decoder" $ do+    let input = "{\"users\":[{\"name\":\"alice\",\"age\":30}],\"count\":2}"+    case (parseValueEvents input, decodeChunks [input]) of+      (Left err, _) -> expectationFailure (toString err)+      (_, Left err) -> expectationFailure (show err)+      (Right events, Right decoded) -> events `shouldBe` decoded++  it "converts scalars, arrays and nested containers" $ do+    events <- parseEventsOrFail "[1,\"x\",true,null,{\"k\":[]}]"+    events+      `shouldBe` [ JSONBeginArray,+                   JSONNumber 1,+                   JSONString "x",+                   JSONBool True,+                   JSONNull,+                   JSONBeginObject,+                   JSONObjectKey "k",+                   JSONBeginArray,+                   JSONEndArray,+                   JSONEndObject,+                   JSONEndArray+                 ]++  it "rejects trailing input"+    $ parseValueEvents "[1,2] x"+    `shouldSatisfy` isLeft++  it "rejects malformed input"+    $ parseValueEvents "{\"a\":}"+    `shouldSatisfy` isLeft++  it "agrees with the streaming decoder on escapes" $ do+    let input = "{\"k\\u0041\":\"a\\tb\\/c\\uD83D\\uDE00\"}"+    case (parseValueEvents input, decodeChunks [input]) of+      (Left err, _) -> expectationFailure (toString err)+      (_, Left err) -> expectationFailure (show err)+      (Right events, Right decoded) -> events `shouldBe` decoded
+ test/HQ/OpticSpec.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.OpticSpec (spec) where++import Data.Aeson (Value (..))+import HQ.Optic+import HQ.Optic.AST (inferFocusType, inferOpticType)+import HQ.Optic.OpticType (OpticType (..))+import HQ.Optic.Parser (parseOptic)+import HQ.Transformation hiding (Compose)+import HQ.Transformation.TransformationType (ValueType (..))+import Relude hiding (Compose, filter, id, not)+import Test.Syd++-- | The cardinality of an optic, inferred directly.+opticTypeOf :: Optic -> OpticType+opticTypeOf = inferOpticType++-- | The focused value type of an optic, inferred directly.+opticFocusOf :: Optic -> ValueType+opticFocusOf = inferFocusType++-- | Parse 'show' output back (replaces the former 'Read Optic' orphan,+-- which lived in the library only for this check).+readOptic :: String -> Maybe Optic+readOptic str = case parseOptic (fromString str) of+  Left _ -> Nothing+  Right v -> Just v++spec :: Spec+spec = describe "HQ.Optic" $ do+  it "show and read are inverses" $ do+    -- NOTE: 'field' is excluded: its 'Show' quotes the name (@"a")+    -- while the parser accepts bare identifiers (@a), so fields never+    -- round-tripped (pre-existing mismatch, unrelated to this change).+    let optics =+          [ Id,+            Each,+            Keys,+            Values,+            Ix 0,+            Ix 1,+            Ix 3,+            Prism PString,+            Compose Each Keys,+            Compose Keys (Prism PString),+            Compose Values Keys,+            Filter Each (Equal (Number 1)),+            Filter (Ix 0) Not,+            Filter (Compose Each (Ix 0)) (Equal (Number 1))+          ]+    forM_ optics $ \optic -> readOptic (show optic) `shouldBe` Just optic++  it "ix equality compares indices" $ do+    Ix 0 `shouldBe` Ix 0+    (Ix 0 == Ix 1) `shouldBe` False++  describe "inferOpticType classifications" $ do+    it "classifies optics" $ forM_ opticTypeCases $ \(optic, expected) ->+      opticTypeOf optic `shouldBe` expected++  describe "appendOptic monoid" $ do+    it "combines optics" $ forM_ appendCases $ \(l, r, expected) ->+      appendOptic l r `shouldBe` expected++    it "satisfies the monoid identity laws" $ do+      (mempty :: Optic) `shouldBe` Id+      (Each <> Field "a") `shouldBe` Compose Each (Field "a")+      (Field "a" <> Id) `shouldBe` Field "a"+      (Id <> Field "a") `shouldBe` Field "a"++    it "agrees on cardinality across reassociation" $ do+      let l = Field "a"+          c = Each+          r = Ix 0+      opticTypeOf ((l <> c) <> r) `shouldBe` opticTypeOf (l <> (c <> r))++  describe "inferFocusType classifications" $ do+    it "infers focus types" $ forM_ focusCases $ \(optic, expected) ->+      opticFocusOf optic `shouldBe` expected++opticTypeCases :: [(Optic, OpticType)]+opticTypeCases =+  [ (Id, OpticLens),+    (Field "a", OpticAffineTraversal),+    (Ix 0, OpticAffineTraversal),+    (Prism PString, OpticPrism),+    (Prism PNull, OpticPrism),+    (PrismJust, OpticAffineTraversal),+    (Each, OpticTraversal),+    (Keys, OpticTraversal),+    (Values, OpticTraversal),+    (Compose (Field "a") Each, OpticTraversal),+    (Compose (Field "a") (Ix 0), OpticAffineTraversal),+    (Compose (Prism PString) PrismJust, OpticAffineTraversal),+    (Filter (Field "a") (Equal (Number 1)), OpticAffineTraversal),+    (Compose Each (Filter (Field "a") (Equal (Number 1))), OpticTraversal)+  ]++appendCases :: [(Optic, Optic, Optic)]+appendCases =+  [ (Id, Field "a", Field "a"),+    (Field "a", Id, Field "a"),+    (Id, Id, Id),+    (Each, Field "a", Compose Each (Field "a"))+  ]++focusCases :: [(Optic, ValueType)]+focusCases =+  [ (Field "a", ValueAny),+    (Each, ValueAny),+    (Values, ValueAny),+    (Id, ValueAny),+    (Ix 0, ValueAny),+    (PrismJust, ValueAny),+    (Filter (Field "a") (Equal (Number 1)), ValueAny),+    (Prism PString, ValueString),+    (Prism PNumber, ValueNumber),+    (Prism PBool, ValueBool),+    (Prism PNull, ValueNull),+    (Prism PArray, ValueArray),+    (Prism PObject, ValueObject),+    (Keys, ValueString),+    (Compose Each (Prism PNumber), ValueNumber),+    (Compose (Field "a") (Field "b"), ValueAny)+  ]
+ test/HQ/Query/ParserSpec.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Query.ParserSpec (spec) where++import Data.Aeson (Value (..))+import HQ.Optic+import HQ.Query (Query (..))+import HQ.Query.Parser (parseQuery)+import HQ.Transformation hiding (Compose)+import HQ.Transformation qualified as T+import Relude hiding (Compose, Const)+import Test.Syd++spec :: Spec+spec = describe "HQ.Query.Parser" $ do+  it "parses queries" $ forM_ happyCases $ \(input, expected) ->+    parseQuery input `shouldBe` Right expected++  it "rejects invalid queries" $ forM_ rejectCases $ \input ->+    parseQuery input `shouldSatisfy` isLeft++happyCases :: [(Text, Query)]+happyCases =+  [ ("fold @foo", Fold (Field "foo")),+    ("fold each", Fold Each),+    ("fold @foo.each.@bar", Fold (Compose (Compose (Field "foo") Each) (Field "bar"))),+    ("preview @foo.each", Preview (Compose (Field "foo") Each)),+    ("preview each.@foo", Preview (Compose Each (Field "foo"))),+    ("preview @name", Preview (Field "name")),+    ("fold @my_field", Fold (Field "my_field")),+    ("preview @field123", Preview (Field "field123")),+    ("preview @foo_bar_1", Preview (Field "foo_bar_1")),+    ("fold id", Fold Id),+    ("preview id.@foo", Preview (Compose Id (Field "foo"))),+    ("fold keys", Fold Keys),+    ("fold values", Fold Values),+    ("preview @obj.keys", Preview (Compose (Field "obj") Keys)),+    ("preview keys._String", Preview (Compose Keys (Prism PString))),+    ("fold values.@x", Fold (Compose Values (Field "x"))),+    ("fold ix 10", Fold (Ix 10)),+    ("fold filter @age == 30", Fold (Filter (Field "age") (Equal (Number 30)))),+    ("fold @users.filter (each . @age) (== 30)", Fold (Compose (Field "users") (Filter (Compose Each (Field "age")) (Equal (Number 30))))),+    ("over each.filter @age == 30 +1", Over (Compose Each (Filter (Field "age") (Equal (Number 30)))) (Add 1)),+    ("fold (@foo)", Fold (Field "foo")),+    ("fold ((@foo))", Fold (Field "foo")),+    ("fold (@foo . @bar)", Fold (Compose (Field "foo") (Field "bar"))),+    ("fold filter (@age) (== 30)", Fold (Filter (Field "age") (Equal (Number 30)))),+    ("over keys trim", Over Keys Trim),+    ("delete values", Delete Values),+    ("  preview @foo  ", Preview (Field "foo")),+    ("preview @foo . @bar", Preview (Compose (Field "foo") (Field "bar"))),+    ("preview@foo", Preview (Field "foo")),+    ("\tpreview\t@foo\t", Preview (Field "foo")),+    ("fold _String", Fold (Prism PString)),+    ("fold _Number", Fold (Prism PNumber)),+    ("fold _Bool", Fold (Prism PBool)),+    ("fold _Null", Fold (Prism PNull)),+    ("fold _Array", Fold (Prism PArray)),+    ("fold _Object", Fold (Prism PObject)),+    ("fold _Just", Fold PrismJust),+    ("fold each._String", Fold (Compose Each (Prism PString))),+    ("fold @data._Number", Fold (Compose (Field "data") (Prism PNumber))),+    ("fold _Array.ix 0", Fold (Compose (Prism PArray) (Ix 0))),+    ("over @foo +1", Over (Field "foo") (Add 1)),+    ("over each trim", Over Each Trim),+    ("over @foo.each +1", Over (Compose (Field "foo") Each) (Add 1)),+    ("over @n +1 . == 3", Over (Field "n") (T.Compose (Add 1) (Equal (Number 3)))),+    ("over @title ++\"!\"", Over (Field "title") (ConcatString "!")),+    ("over@foo+1", Over (Field "foo") (Add 1)),+    ("set @name \"bob\"", Over (Field "name") (Const (String "bob"))),+    ("set each 0", Over Each (Const (Number 0))),+    ("set @users.each.@name \"anon\"", Over (Compose (Compose (Field "users") Each) (Field "name")) (Const (String "anon")))+  ]++rejectCases :: [Text]+rejectCases =+  [ "fold @users.filter (each . @age == 30)",+    "fold @users.filter (each . @age, == 30)",+    "fold ()",+    "",+    "unknown @foo",+    "fold",+    "fold foo",+    "fold @",+    "folder @foo",+    "fold eachx",+    "fold ix0",+    "over @foo"+  ]
+ test/HQ/QuerySpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.QuerySpec (spec) where++import Data.Aeson (Value (..))+import HQ.Optic+import HQ.Query+import HQ.Transformation hiding (Compose)+import HQ.Transformation qualified as T+import HQ.Transformation.AST (TransformationTypeError (..))+import HQ.Transformation.TransformationType (ValueType (..))+import Relude hiding (Compose, filter, id, or)+import Test.Syd++spec :: Spec+spec = describe "HQ.Query" $ do+  describe "typecheckQuery" $ do+    it "accepts well-typed queries" $ forM_ acceptCases $ \q ->+      typecheckQuery q `shouldBe` Right q++    it "rejects focus mismatches" $ forM_ focusCases $ \(q, focus, expected) ->+      case typecheckQuery q of+        Left (InvalidFocusType _ _ focus' expected') -> do+          focus' `shouldBe` focus+          expected' `shouldBe` expected+        Left err -> expectationFailure $ "wrong error: " <> show err+        Right _ -> expectationFailure "expected a type error"++    it "rejects transformation mismatches" $ forM_ transformationCases $ \(q, expected) ->+      case typecheckQuery q of+        Left (InvalidTransformationType err) -> err `shouldBe` expected+        Left err -> expectationFailure $ "wrong error: " <> show err+        Right _ -> expectationFailure "expected a type error"++acceptCases :: [Query]+acceptCases =+  [ Fold (Field "name"),+    Preview (Field "name"),+    Preview (Prism PString),+    Preview Id,+    Preview Each,+    Preview (Compose Each (Field "x")),+    Preview (Compose Each (Filter (Field "age") (Equal (Number 29)))),+    Over (Compose Each (Prism PNumber)) (Add 1),+    Over (Field "age") (Add 1),+    Delete (Ix 0),+    Fold Keys,+    Over Each (T.Compose (Equal (Number 1)) Trim),+    Fold (Filter (Field "a") (Equal (Number 1))),+    Preview (Filter (Field "a") (Equal (Number 1)))+  ]++focusCases :: [(Query, ValueType, ValueType)]+focusCases =+  [ (Over (Compose Each (Prism PNumber)) (ConcatString "!"), ValueNumber, ValueString),+    (Fold (Filter (Prism PNumber) (IsPrefixOf "a")), ValueNumber, ValueString)+  ]++transformationCases :: [(Query, TransformationTypeError)]+transformationCases =+  [ (Over Each (T.Compose (Add 1) (Equal (Number 3))), InvalidCompose (T.Compose (Add 1) (Equal (Number 3))) ValueBool ValueNumber),+    (Over Each (Or (Add 1) (Equal (Number 2))), InvalidOr (Or (Add 1) (Equal (Number 2))) ValueNumber),+    (Fold (Filter (Field "a") (Add 1)), InvalidFilter (Add 1) ValueNumber),+    (Fold (Filter (Field "a") (T.Compose (Add 1) (Equal (Number 3)))), InvalidCompose (T.Compose (Add 1) (Equal (Number 3))) ValueBool ValueNumber),+    (Fold (Filter (Compose Each (Filter (Field "b") (Add 2))) (Equal (Number 1))), InvalidFilter (Add 2) ValueNumber)+  ]
+ test/HQ/Runner/FoldSpec.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.FoldSpec (spec) where++import HQ.Early (Early, runEarly)+import HQ.Error (HQError (..), renderHQError)+import HQ.JSON.Decoder (StreamIO, initialDecoder)+import HQ.JSON.Event (JSONEvent (..), valueToEvents)+import HQ.JSON.Parser (parseValue)+import HQ.Optic (Optic)+import HQ.Optic.Parser (parseOptic)+import HQ.Runner (foldDocuments)+import HQ.Runner.Cursor (Cursor (..), EventStream)+import HQ.Runner.Fold (focusMany, runFold, runPreview)+import HQ.Transformation.Error (renderTransformationError)+import Relude hiding (Compose, id, many, not, or, some, subtract, toStrict)+import Streaming.Prelude qualified as S+import Test.HQ (splits)+import Test.Syd++spec :: Spec+spec = describe "HQ.Runner.Fold" $ do+  eachArraySpec+  eachObjectSpec+  eachCompositionSpec+  keysSpec+  valuesSpec+  ixSpec+  filterSpec+  differentialSpec+  fieldSpec+  idSpec+  previewSpec+  chunkedFoldSpec+  multiDocumentSpec++-- | Run an optic runner against chunked JSON text and collect output+-- events. Every fold/preview harness shares it; they differ only in+-- the runner and the chunks. Runs in IO because the streaming decoder+-- and cursor use IO internally.+runOnChunks :: (Early HQError -> Cursor -> EventStream Cursor) -> [Text] -> IO (Either Text [JSONEvent])+runOnChunks action chunks = do+  result <- runEarly (\early -> S.toList_ $ action early cursor)+  pure (first renderHQError result)+  where+    textStream :: StreamIO Text ()+    textStream = S.each chunks+    cursor = Cursor [] initialDecoder textStream++-- | Run a fold optic against a JSON text input and collect output events.+runFoldTest :: Optic -> Text -> IO (Either Text [JSONEvent])+runFoldTest optic input = runOnChunks (`runFold` optic) [input]++-- | Parse an optic string and run it against JSON input.+runQueryTest :: Text -> Text -> IO (Either Text [JSONEvent])+runQueryTest opticStr jsonInput = case parseOptic opticStr of+  Left err -> pure (Left (show err))+  Right optic -> runFoldTest optic jsonInput++-- | Run a preview optic against a JSON text input and collect the+-- (at most one) output value's events.+runPreviewTest :: Optic -> Text -> IO (Either Text [JSONEvent])+runPreviewTest optic input = runOnChunks (`runPreview` optic) [input]++-- | Parse an optic string and preview it against JSON input.+runQueryPreviewTest :: Text -> Text -> IO (Either Text [JSONEvent])+runQueryPreviewTest opticStr jsonInput = case parseOptic opticStr of+  Left err -> pure (Left (show err))+  Right optic -> runPreviewTest optic jsonInput++-- | Run a fold optic against chunked JSON text.+runFoldChunks :: Optic -> [Text] -> IO (Either Text [JSONEvent])+runFoldChunks optic = runOnChunks (`runFold` optic)++-- | Run a preview optic against chunked JSON text.+runPreviewChunks :: Optic -> [Text] -> IO (Either Text [JSONEvent])+runPreviewChunks optic = runOnChunks (`runPreview` optic)++-- | Parse an optic string and preview it against chunked JSON input.+runQueryPreviewChunks :: Text -> [Text] -> IO (Either Text [JSONEvent])+runQueryPreviewChunks opticStr chunks = case parseOptic opticStr of+  Left err -> pure (Left (show err))+  Right optic -> runPreviewChunks optic chunks++-- | Run a fold optic over every top-level document across text chunks.+runFoldDocumentsTest :: Optic -> [Text] -> IO (Either Text [JSONEvent])+runFoldDocumentsTest optic = runOnChunks (`foldDocuments` optic)++-- | Parse an optic string and run it over every top-level document.+runQueryDocumentsTest :: Text -> [Text] -> IO (Either Text [JSONEvent])+runQueryDocumentsTest opticStr chunks = case parseOptic opticStr of+  Left err -> pure (Left (show err))+  Right optic -> runFoldDocumentsTest optic chunks++--------------------------------------------------------------------------------+-- preview+--------------------------------------------------------------------------------++previewSpec :: Spec+previewSpec = describe "preview" $ forM_ previewCases $ \(label, optic, doc, expected) ->+  it label $ runQueryPreviewTest optic doc `shouldReturn` expected++previewCases :: [(String, Text, Text, Either Text [JSONEvent])]+previewCases =+  [ ("returns a field value", "@name", "{\"name\":\"alice\",\"age\":30}", Right [JSONString "alice"]),+    ("returns nothing when the field is missing", "@name", "{\"age\":30}", Right []),+    ("returns nothing for non-object input", "@name", "42", Right []),+    ("returns the first element of an array", "each", "[1,2,3]", Right [JSONNumber 1]),+    ("returns the first object value", "each", "{\"a\":1,\"b\":2}", Right [JSONNumber 1]),+    ("returns nothing for an empty array", "each", "[]", Right []),+    ("returns the first composed match", "each . @name", "[{\"name\":\"alice\"},{\"name\":\"bob\"}]", Right [JSONString "alice"]),+    -- NOTE: spaces around the outer '.' are load-bearing here;+    -- '== 30.@age' would lex '30.' as a number prefix.+    ("returns the first match through a filter", "each.filter @age == 30 . @age", "[{\"age\":20},{\"age\":30}]", Right [JSONNumber 30]),+    ("returns the first array element with ix 0", "ix 0", "[10,20]", Right [JSONNumber 10]),+    ("returns nothing when ix 0 finds no element", "ix 0", "[]", Right []),+    ("returns the proper array element with ix", "ix 0", "[0,1,2,3]", Right [JSONNumber 0]),+    ("returns the last array element with ix", "ix 3", "[0,1,2,3]", Right [JSONNumber 3]),+    ("returns nothing when ix finds no element", "ix 0", "[]", Right []),+    ("returns nothing when ix is out of bounds", "ix 4", "[0,1,2,3]", Right []),+    ("matches a string prism", "_String", "\"hello\"", Right [JSONString "hello"]),+    ("returns nothing when a prism does not match", "_String", "42", Right []),+    ("returns a whole container value", "@obj", "{\"obj\":{\"a\":1},\"next\":2}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]),+    ("returns the whole input for id", "id", "[1,2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray]),+    ("stops reading input after the first match", "each", "[1, 2,,]", Right [JSONNumber 1])+  ]++--------------------------------------------------------------------------------+-- keys+--------------------------------------------------------------------------------++keysSpec :: Spec+keysSpec = describe "keys" $ do+  forM_ keysCases $ \(label, optic, doc, expected) ->+    it label $ runQueryTest optic doc `shouldReturn` expected+  forM_ keysPreviewCases $ \(label, optic, doc, expected) ->+    it label $ runQueryPreviewTest optic doc `shouldReturn` expected++keysCases :: [(String, Text, Text, Either Text [JSONEvent])]+keysCases =+  [ ("yields object keys as strings", "keys", "{\"a\":1,\"b\":2}", Right [JSONString "a", JSONString "b"]),+    ("yields nothing for arrays", "keys", "[10,20,30]", Right []),+    ("yields nothing for empty containers", "keys", "{}", Right []),+    ("yields nothing for empty arrays", "keys", "[]", Right []),+    ("yields nothing for number scalars", "keys", "42", Right []),+    ("yields nothing for string scalars", "keys", "\"x\"", Right []),+    ("composes keys with a matching prism", "keys . _String", "{\"a\":1}", Right [JSONString "a"]),+    ("composes keys with a mismatched prism", "keys . _Number", "{\"a\":1}", Right []),+    ("composes keys after a field", "@obj . keys", "{\"obj\":{\"a\":1}}", Right [JSONString "a"])+  ]++keysPreviewCases :: [(String, Text, Text, Either Text [JSONEvent])]+keysPreviewCases =+  [ ("previews the first key", "keys", "{\"a\":1,\"b\":2}", Right [JSONString "a"]),+    ("previews nothing for arrays", "keys", "[10,20]", Right [])+  ]++--------------------------------------------------------------------------------+-- values (objects only)+--------------------------------------------------------------------------------++valuesSpec :: Spec+valuesSpec = describe "values" $ do+  forM_ valuesCases $ \(label, optic, doc, expected) ->+    it label $ runQueryTest optic doc `shouldReturn` expected+  forM_ valuesPreviewCases $ \(label, optic, doc, expected) ->+    it label $ runQueryPreviewTest optic doc `shouldReturn` expected++valuesCases :: [(String, Text, Text, Either Text [JSONEvent])]+valuesCases =+  [ ("yields object values", "values", "{\"a\":1,\"b\":2}", Right [JSONNumber 1, JSONNumber 2]),+    ("yields nothing for arrays", "values", "[1,2,3]", Right []),+    ("yields nothing for empty objects", "values", "{}", Right []),+    ("yields nothing for scalars", "values", "42", Right []),+    ("yields nested containers whole", "values", "{\"a\":{\"b\":1}}", Right [JSONBeginObject, JSONObjectKey "b", JSONNumber 1, JSONEndObject]),+    ("composes with a field", "values . @x", "{\"a\":{\"x\":1},\"b\":{\"x\":2}}", Right [JSONNumber 1, JSONNumber 2]),+    ("returns empty when the field is missing in all values", "values . @x", "{\"a\":1}", Right [])+  ]++valuesPreviewCases :: [(String, Text, Text, Either Text [JSONEvent])]+valuesPreviewCases =+  [ ("previews the first value", "values", "{\"a\":1,\"b\":2}", Right [JSONNumber 1]),+    ("previews nothing for arrays", "values", "[1,2]", Right [])+  ]++--------------------------------------------------------------------------------+-- ix+--------------------------------------------------------------------------------++ixSpec :: Spec+ixSpec = describe "ix" $ forM_ ixCases $ \(label, optic, doc, expected) ->+  it label $ runQueryTest optic doc `shouldReturn` expected++ixCases :: [(String, Text, Text, Either Text [JSONEvent])]+ixCases =+  [ ("yields the first element", "ix 0", "[7,8]", Right [JSONNumber 7]),+    ("yields the second element", "ix 1", "[7,8]", Right [JSONNumber 8]),+    ("yields nothing when out of bounds", "ix 5", "[1,2]", Right []),+    ("yields nothing for objects", "ix 0", "{\"a\":1}", Right []),+    ("yields nothing for scalars", "ix 0", "42", Right [])+  ]++--------------------------------------------------------------------------------+-- filter+--------------------------------------------------------------------------------++filterSpec :: Spec+filterSpec = describe "filter" $ do+  forM_ filterCases $ \(label, optic, doc, expected) ->+    it label $ runQueryTest optic doc `shouldReturn` expected+  forM_ filterPreviewCases $ \(label, optic, doc, expected) ->+    it label $ runQueryPreviewTest optic doc `shouldReturn` expected++filterCases :: [(String, Text, Text, Either Text [JSONEvent])]+filterCases =+  [ ("keeps array elements when the test holds", "each . filter @age == 30", "[{\"age\":30},{\"age\":20}]", Right [JSONBeginObject, JSONObjectKey "age", JSONNumber 30, JSONEndObject]),+    ("keeps the whole value on any match", "filter each == 1", "[1,2,1]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 1, JSONEndArray]),+    ("drops values when nothing matches", "each . filter @age == 30", "[{\"age\":20}]", Right []),+    ("drops values with a missing focus", "filter @age == 30", "{\"b\":1}", Right []),+    ("filters matching scalars", "filter id == 1", "1", Right [JSONNumber 1]),+    ("filters mismatched scalars", "filter id == 1", "2", Right []),+    ("composes after a filter", "each . filter @age == 30 . @name", "[{\"age\":30,\"name\":\"a\"},{\"age\":20,\"name\":\"b\"}]", Right [JSONString "a"]),+    ("keeps nested filtered values", "filter (filter @a == 1) (== {\"a\":1})", "{\"a\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]),+    ("fails when the predicate does not fit", "each . filter @a +1", "[{\"a\":\"x\"}]", Left "expected a number"),+    ("fails when the predicate is not boolean", "each . filter @a +1", "[{\"a\":1}]", Left "filter transformation must produce a boolean"),+    ("skips replayed containers looking for later members", "filter @a == 1 . @zzz", "{\"a\":1,\"big\":[1,2,3]}", Right [])+  ]++filterPreviewCases :: [(String, Text, Text, Either Text [JSONEvent])]+filterPreviewCases =+  [ ("previews the first kept value", "each . filter @age == 30", "[{\"age\":20},{\"age\":30}]", Right [JSONBeginObject, JSONObjectKey "age", JSONNumber 30, JSONEndObject])+  ]++--------------------------------------------------------------------------------+-- pure vs streaming folds+--------------------------------------------------------------------------------++-- | The pure navigator ('focusMany') must agree with the streaming+-- fold as multisets: object member order differs (document order vs+-- key map order), and duplicate keys would collapse, so inputs have+-- unique keys and events compare order-insensitively.+differentialSpec :: Spec+differentialSpec = describe "pure vs streaming folds" $ do+  it "focusMany agrees with runFold as multisets" $ do+    forM_ differentialOptics $ \opticStr ->+      forM_ differentialDocs $ \doc ->+        case (parseOptic opticStr, parseValue doc) of+          (Right optic, Right value) -> do+            actual <- runFoldTest optic doc+            let expected = first renderTransformationError (concatMap valueToEvents <$> focusMany optic value)+            (sortOn (show :: JSONEvent -> String) <$> actual)+              `shouldBe` (sortOn (show :: JSONEvent -> String) <$> expected)+          (Left err, _) -> expectationFailure $ "bad optic: " <> show err+          (_, Left err) -> expectationFailure $ "bad doc: " <> show err++differentialOptics :: [Text]+differentialOptics =+  [ "id",+    "each",+    "keys",+    "values",+    "@a",+    "@missing",+    "ix 0",+    "ix 2",+    "_String",+    "_Number",+    "_Just",+    "_Null",+    "each . @x",+    "@a . each",+    "filter @a == 1",+    "filter (each . @x) (== 2)",+    "each . filter @b == 2"+  ]++differentialDocs :: [Text]+differentialDocs =+  [ "42",+    "\"hi\"",+    "true",+    "null",+    "[]",+    "[1,\"a\",true]",+    "{}",+    "{\"a\":1,\"b\":[2,3]}",+    "{\"a\":{\"x\":1},\"b\":2}",+    "[[1,2],[3]]"+  ]++--------------------------------------------------------------------------------+-- field+--------------------------------------------------------------------------------++fieldSpec :: Spec+fieldSpec = describe "field" $ forM_ fieldCases $ \(label, optic, doc, expected) ->+  it label $ runQueryTest optic doc `shouldReturn` expected++fieldCases :: [(String, Text, Text, Either Text [JSONEvent])]+fieldCases =+  [ ("extracts a field from an object", "@name", "{\"name\":\"alice\"}", Right [JSONString "alice"]),+    ("returns empty when field is missing", "@name", "{\"age\":30}", Right []),+    ("returns empty for non-object input", "@name", "42", Right [])+  ]++--------------------------------------------------------------------------------+-- id+--------------------------------------------------------------------------------++idSpec :: Spec+idSpec = describe "id" $ forM_ idCases $ \(label, optic, doc, expected) ->+  it label $ runQueryTest optic doc `shouldReturn` expected++idCases :: [(String, Text, Text, Either Text [JSONEvent])]+idCases =+  [ ("returns the input value unchanged", "id", "42", Right [JSONNumber 42]),+    ("returns a string value unchanged", "id", "\"hello\"", Right [JSONString "hello"])+  ]++--------------------------------------------------------------------------------+-- each on arrays+--------------------------------------------------------------------------------++eachArraySpec :: Spec+eachArraySpec = describe "each on arrays" $ forM_ eachArrayCases $ \(label, optic, doc, expected) ->+  it label $ runQueryTest optic doc `shouldReturn` expected++eachArrayCases :: [(String, Text, Text, Either Text [JSONEvent])]+eachArrayCases =+  [ ("yields each element of a numeric array", "each", "[1,2,3]", Right [JSONNumber 1, JSONNumber 2, JSONNumber 3]),+    ("yields each element of a string array", "each", "[\"a\",\"b\",\"c\"]", Right [JSONString "a", JSONString "b", JSONString "c"]),+    ("yields a single-element array", "each", "[42]", Right [JSONNumber 42]),+    ("yields nothing for an empty array", "each", "[]", Right []),+    ("yields nothing for non-container input", "each", "42", Right []),+    ("yields nested array elements", "each", "[[1,2],[3]]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray, JSONBeginArray, JSONNumber 3, JSONEndArray])+  ]++--------------------------------------------------------------------------------+-- each on objects+--------------------------------------------------------------------------------++eachObjectSpec :: Spec+eachObjectSpec = describe "each on objects" $ forM_ eachObjectCases $ \(label, optic, doc, expected) ->+  it label $ runQueryTest optic doc `shouldReturn` expected++eachObjectCases :: [(String, Text, Text, Either Text [JSONEvent])]+eachObjectCases =+  [ ("yields each value of an object", "each", "{\"a\":1,\"b\":2}", Right [JSONNumber 1, JSONNumber 2]),+    ("yields nothing for an empty object", "each", "{}", Right [])+  ]++--------------------------------------------------------------------------------+-- each composed with field+--------------------------------------------------------------------------------++eachCompositionSpec :: Spec+eachCompositionSpec = describe "each . field composition" $ forM_ eachCompositionCases $ \(label, optic, doc, expected) ->+  it label $ runQueryTest optic doc `shouldReturn` expected++eachCompositionCases :: [(String, Text, Text, Either Text [JSONEvent])]+eachCompositionCases =+  [ ("extracts field from each array element", "each . @name", "[{\"name\":\"alice\"},{\"name\":\"bob\"}]", Right [JSONString "alice", JSONString "bob"]),+    ("extracts field from each object value", "each . @x", "{\"a\":{\"x\":1},\"b\":{\"x\":2}}", Right [JSONNumber 1, JSONNumber 2]),+    ("returns empty when field is missing in some elements", "each . @name", "[{\"name\":\"alice\"},{\"age\":30}]", Right [JSONString "alice"]),+    ("returns empty when field missing in all elements", "each . @name", "[{\"a\":1},{\"b\":2}]", Right []),+    ("extracts field from each element with multiple fields", "each . @id", "[{\"name\":\"alice\",\"id\":\"1\"},{\"name\":\"bob\",\"id\":\"2\"}]", Right [JSONString "1", JSONString "2"]),+    ("field . each distributes field then each", "@items . each", "{\"items\":[1,2,3]}", Right [JSONNumber 1, JSONNumber 2, JSONNumber 3]),+    ("each . each flattens nested arrays", "each . each", "[[1,2],[3,4]]", Right [JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONNumber 4])+  ]++chunkedFoldSpec :: Spec+chunkedFoldSpec = describe "chunked input" $ do+  it "folds agree with whole-input runs under every split" $ do+    forM_ foldChunkCases $ \(opticStr, doc) ->+      case parseOptic opticStr of+        Left err -> expectationFailure $ "bad optic: " <> show err+        Right optic -> do+          expected <- runFoldTest optic doc+          forM_ (splits doc) $ \chunks -> do+            actual <- runFoldChunks optic chunks+            actual `shouldBe` expected++  it "preview never touches invalid tails under any split" $ do+    forM_ (splits "[1, 2,,]") $ \chunks -> do+      actual <- runQueryPreviewChunks "each" chunks+      actual `shouldBe` Right [JSONNumber 1]++  it "malformed inputs fail the same chunked as whole" $ do+    forM_ malformedChunkCases $ \(opticStr, doc) -> do+      expected <- runQueryTest opticStr doc+      case parseOptic opticStr of+        Left err -> expectationFailure $ "bad optic: " <> show err+        Right optic ->+          forM_ (splits doc) $ \chunks -> do+            actual <- runFoldChunks optic chunks+            actual `shouldBe` expected++foldChunkCases :: [(Text, Text)]+foldChunkCases =+  [ ("each . @name", "[{\"name\":\"alice\"},{\"age\":30}]"),+    ("@users.each.@name", "{\"users\":[{\"name\":\"a\",\"age\":1},{\"name\":\"b\"}]}"),+    ("each", "[[1,2],[3]]"),+    ("@a", "{\"a\":{\"b\":[1,2]},\"c\":3}"),+    ("@missing", "{\"a\":1}"),+    ("ix 2", "[1,2,3,4]"),+    ("each . each", "[[1,2],[3,4]]"),+    ("@a.@b", "{\"a\":{\"b\":[1,{\"c\":2}]}}"),+    ("keys", "{\"a\":1,\"b\":2}"),+    ("keys", "[10,20,30]"),+    ("keys . _String", "{\"a\":1}"),+    ("values", "{\"a\":1,\"b\":2}"),+    ("values . @x", "{\"a\":{\"x\":1},\"b\":2}"),+    ("ix 0", "{\"a\":1}"),+    ("each . filter @age == 30", "[{\"age\":30},{\"age\":20}]"),+    ("filter each == 1", "[1,2,1]"),+    ("each . filter @age == 30 . @name", "[{\"age\":30,\"name\":\"a\"}]"),+    -- Surrogate pairs inside containers: the take loops must step+    -- mid-value pauses (high surrogate) instead of finishing early.+    ("id", "[\"\\uD83D\\uDE00\"]"),+    ("id", "{\"u\":\"caf\\u00e9 \\uD83D\\uDE00\",\"s\":\"a/b\"}"),+    ("each", "[\"\\uD83D\\uDE00\",\"x\"]")+  ]++malformedChunkCases :: [(Text, Text)]+malformedChunkCases =+  [ ("@b", "{\"a\":1,\"b\":tru}"),+    ("@a", "{\"a\":1,\"b\":tru}"),+    ("each", "[1,,2]"),+    ("@a", "{\"a\":01}"),+    ("keys", "[1,,2]"),+    ("values", "{\"a\":tru}"),+    ("filter @a == 1", "{\"a\":1,\"b\":tru}"),+    ("id", "[\"\\uD83D\"]"),+    ("id", "[\"\\uD83D\\uxyz\"]")+  ]++multiDocumentSpec :: Spec+multiDocumentSpec = describe "multiple documents" $ do+  forM_ multiDocumentCases $ \(label, optic, chunks, expected) ->+    it label $ runQueryDocumentsTest optic chunks `shouldReturn` expected++  it "previews only the first document" $ do+    runQueryPreviewTest "@a" "{\"a\":1} {\"a\":2}"+      `shouldReturn` Right [JSONNumber 1]++multiDocumentCases :: [(String, Text, [Text], Either Text [JSONEvent])]+multiDocumentCases =+  [ ("folds the same field across documents", "@a", ["{\"a\":1} {\"a\":2}"], Right [JSONNumber 1, JSONNumber 2]),+    ("skips documents without a match", "@a", ["{\"a\":1} {\"b\":2} [3]"], Right [JSONNumber 1]),+    ("continues across chunk splits at document boundaries", "@a", ["{\"a\":1} {\"a", "\":2}"], Right [JSONNumber 1, JSONNumber 2]),+    ("fails on trailing garbage", "@a", ["{\"a\":1} garbage"], Left "unexpected character 'g' in JSON input"),+    ("yields nothing for empty input", "@a", [], Right []),+    ("yields nothing for whitespace-only input", "@a", ["  \n "], Right [])+  ]
+ test/HQ/Runner/RewriteSpec.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Runner.RewriteSpec (spec) where++import Data.Aeson (Value (..))+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text qualified as T+import HQ.Early (Early, runEarly)+import HQ.Error (HQError (..), renderHQError)+import HQ.JSON.Decoder (StreamIO, initialDecoder)+import HQ.JSON.Encoder+import HQ.JSON.Event (JSONEvent (..), eventsToValue)+import HQ.JSON.Parser (parseValueEvents)+import HQ.Optic (Optic)+import HQ.Optic.Parser (parseOptic)+import HQ.Runner (rewriteDocuments)+import HQ.Runner.Cursor (Cursor (..))+import HQ.Runner.Rewrite (runDelete, runOver)+import HQ.Runner.Rewrite.Emit (RewriteContinuation)+import HQ.Transformation+import Relude hiding (Compose, Const, and, id, length, many, not, or, reverse, some, subtract, toStrict)+import Streaming (Of (..))+import Streaming.Prelude qualified as S+import Test.HQ (splits)+import Test.Syd++spec :: Spec+spec = describe "HQ.Runner.Rewrite" $ do+  setSpec+  deleteSpec+  overSpec+  keysRewriteSpec+  valuesRewriteSpec+  ixRewriteSpec+  filterRewriteSpec+  chunkedRewriteSpec+  compactContainerSpec+  multiDocumentRewriteSpec++-- | Encoder config for rewrite tests: pretty output, matching the+-- production default.+testConfig :: EncoderConfig+testConfig = EncoderConfig (Pretty 2) (ValueOptions NoRaw NoJoin)++-- | Encoder config exercising the compact fast paths (raw scalar and+-- container capture) in Take. Same value options as 'testConfig',+-- only the style differs.+compactTestConfig :: EncoderConfig+compactTestConfig = EncoderConfig Compact (ValueOptions NoRaw NoJoin)++-- | Whole-container passthrough values: nested objects/arrays with+-- strings (escapes, unicode), numbers, keywords, empties and+-- significant whitespace (dropped by compact capture).+containerCorpus :: [Text]+containerCorpus =+  [ "{\"a\":{\"b\":[1,\"x\",true,null]},\"c\":{}}",+    "{\"a\":[{\"b\":[{\"c\":[]}]}]}",+    "[{\"k\":\"v\\\"q\",\"n\":-12.5e2,\"t\":true,\"f\":false,\"z\":null,\"e\":{},\"s\":\"a\\u00e9\\n\"}]",+    "{ \"a\" : [1, 2] }",+    "{\"deep\":{\"deeper\":{\"deepest\":[[[[1]]]]}}}",+    "[[],{},[{}],{\"a\":[]}]"+  ]++malformedContainerCorpus :: [Text]+malformedContainerCorpus =+  [ "{\"a\":[1,2}",+    "{\"a\":1",+    "[1,,2]",+    "[1 2]",+    "{\"a\" 1}",+    "{\"a\":\"\\x\"}",+    "{\"a\":nul}",+    "{\"a\":01}"+  ]++-- | Compact container capture must agree with the event path+-- (pretty config): same queries, same documents, every chunk split.+-- The pretty runs decode and re-encode event by event; the compact+-- runs capture whole containers verbatim.+compactContainerSpec :: Spec+compactContainerSpec = describe "compact container capture" $ do+  it "over agrees with the event path under every split" $ do+    forM_ overContainerCases $ \(opticStr, transformation, doc) ->+      case parseOptic opticStr of+        Left err -> expectationFailure $ "bad optic: " <> show err+        Right optic -> do+          expected <- runRewriteChunks (\early -> runOver early optic transformation testConfig) [doc]+          forM_ (splits doc) $ \chunks -> do+            actual <- runRewriteChunks (\early -> runOver early optic transformation compactTestConfig) chunks+            actual `shouldBe` expected+  it "delete agrees with the event path under every split" $ do+    forM_ deleteContainerCases $ \(opticStr, doc) ->+      case parseOptic opticStr of+        Left err -> expectationFailure $ "bad optic: " <> show err+        Right optic -> do+          expected <- runRewriteChunks (\early -> runDelete early optic testConfig) [doc]+          forM_ (splits doc) $ \chunks -> do+            actual <- runRewriteChunks (\early -> runDelete early optic compactTestConfig) chunks+            actual `shouldBe` expected+  it "fails exactly where the event path fails" $ do+    Right testOptic <- pure (parseOptic "@a")+    forM_ malformedContainerCorpus $ \doc -> do+      forM_ (splits doc) $ \chunks -> do+        pretty <- runRewriteChunks (\early -> runDelete early testOptic testConfig) chunks+        compact <- runRewriteChunks (\early -> runDelete early testOptic compactTestConfig) chunks+        pretty `shouldSatisfy` isLeft+        compact `shouldBe` pretty+  it "normalizes insignificant whitespace like the event path" $ do+    Right optic <- pure (parseOptic "@b")+    runRewriteDocumentsTest (\early -> runDelete early optic compactTestConfig) ["{ \"a\" : [1, 2] }"]+      `shouldReturn` Right "{\"a\":[1,2]}\n"+  where+    overContainerCases :: [(Text, Transformation, Text)]+    overContainerCases =+      [ ("@a", Add 1, "{\"a\":1,\"nested\":{\"x\":[1,2],\"y\":{}}}"),+        ("@a", Add 1, "{ \"a\" : 1, \"spaced\" : [1, 2] }"),+        ("each.@n", Add 1, "[{\"n\":1,\"keep\":{\"deep\":[true,null]}},{\"n\":2}]")+      ]+    deleteContainerCases :: [(Text, Text)]+    deleteContainerCases =+      [ ("@x", "{\"x\":1,\"keep\":{\"deep\":[1,{\"y\":2}]}}"),+        ("@a", "{\"a\":1,\"nested\":{\"x\":[1,2],\"y\":{}}}")+      ]+        <> [("@x", doc) | doc <- containerCorpus]++-- | Run a document-rewriting query (set/delete), reparse its output+-- bytes back to events, and collect them. Reparsing through the+-- independent pure parser keeps every existing event expectation+-- valid while the rewrite pipeline emits chunks.+runRewriteTest :: (Early HQError -> RewriteContinuation) -> Text -> IO (Either Text [JSONEvent])+runRewriteTest mkRun input = runRewriteChunks mkRun [input]++-- | Run a document-rewriting query against chunked JSON text.+runRewriteChunks :: (Early HQError -> RewriteContinuation) -> [Text] -> IO (Either Text [JSONEvent])+runRewriteChunks mkRun chunks = do+  result <-+    runEarly+      ( \early -> do+          (byteChunks :> _) <- S.toList (mkRun early cursor initialEmitState)+          pure (decodeUtf8 (mconcat byteChunks))+      )+  case first renderHQError result of+    Left err -> pure (Left err)+    Right text+      -- No output bytes means no values (e.g. deleting the whole+      -- document): nothing to reparse.+      | T.null (T.strip text) -> pure (Right [])+      | otherwise -> case parseValueEvents text of+          Left err -> pure (Left err)+          Right events -> pure (Right events)+  where+    textStream :: StreamIO Text ()+    textStream = S.each chunks+    cursor = Cursor [] initialDecoder textStream++-- | Parse an optic string and run the continuation, mapping optic+-- syntax errors like any other failure.+withOptic :: Text -> (Optic -> IO (Either Text [JSONEvent])) -> IO (Either Text [JSONEvent])+withOptic opticStr f = case parseOptic opticStr of+  Left err -> pure (Left (show err))+  Right optic -> f optic++-- | Parse an optic string and a replacement value, run @set@ against+-- JSON input, and collect the rewritten document's events.+--+-- @set@ is @over@ with a constant transformation, so the harness drives+-- 'runOver' with 'Const'.+runSetTest :: Text -> Text -> Text -> IO (Either Text [JSONEvent])+runSetTest opticStr valueStr jsonInput = withOptic opticStr $ \optic ->+  case parseValueEvents valueStr of+    Left err -> pure (Left err)+    Right events -> case eventsToValue events of+      Left err -> pure (Left (renderHQError (HQRunnerError err)))+      Right value ->+        runRewriteTest (\early -> runOver early optic (Const value) testConfig) jsonInput++-- | Parse an optic string and run @delete@ against JSON input,+-- collecting the rewritten document's events.+runDeleteTest :: Text -> Text -> IO (Either Text [JSONEvent])+runDeleteTest opticStr jsonInput = withOptic opticStr $ \optic ->+  runRewriteTest (\early -> runDelete early optic testConfig) jsonInput++-- | Parse an optic string and a transformation, run @over@ against JSON+-- input, and collect the rewritten document's events.+runOverTest :: Text -> Transformation -> Text -> IO (Either Text [JSONEvent])+runOverTest opticStr transformation jsonInput = withOptic opticStr $ \optic ->+  runRewriteTest (\early -> runOver early optic transformation testConfig) jsonInput++--------------------------------------------------------------------------------+-- set+--------------------------------------------------------------------------------++setSpec :: Spec+setSpec = describe "set" $ forM_ setCases $ \(label, optic, value, doc, expected) ->+  it label $ runSetTest optic value doc `shouldReturn` expected++setCases :: [(String, Text, Text, Text, Either Text [JSONEvent])]+setCases =+  [ ("replaces a field value", "@name", "\"bob\"", "{\"name\":\"alice\",\"age\":30}", Right [JSONBeginObject, JSONObjectKey "name", JSONString "bob", JSONObjectKey "age", JSONNumber 30, JSONEndObject]),+    ("leaves the document unchanged when the field is missing", "@name", "5", "{\"age\":30}", Right [JSONBeginObject, JSONObjectKey "age", JSONNumber 30, JSONEndObject]),+    ("leaves non-object input unchanged", "@name", "5", "[1,2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray]),+    ("replaces every array element", "each", "0", "[1,2,3]", Right [JSONBeginArray, JSONNumber 0, JSONNumber 0, JSONNumber 0, JSONEndArray]),+    ("replaces every object value", "each", "true", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONObjectKey "a", JSONBool True, JSONObjectKey "b", JSONBool True, JSONEndObject]),+    ("leaves an empty array unchanged", "each", "0", "[]", Right [JSONBeginArray, JSONEndArray]),+    ("leaves an empty object unchanged", "each", "0", "{}", Right [JSONBeginObject, JSONEndObject]),+    ("replaces only strings with a prism", "each . _String", "\"x\"", "[1,\"a\",true]", Right [JSONBeginArray, JSONNumber 1, JSONString "x", JSONBool True, JSONEndArray]),+    ("passes non-matching values through unchanged", "_String", "\"x\"", "5", Right [JSONNumber 5]),+    ("replaces fields in a composed traversal", "@users.each.@name", "\"anon\"", "{\"users\":[{\"name\":\"a\",\"age\":1},{\"name\":\"b\"}]}", Right [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "name", JSONString "anon", JSONObjectKey "age", JSONNumber 1, JSONEndObject, JSONBeginObject, JSONObjectKey "name", JSONString "anon", JSONEndObject, JSONEndArray, JSONEndObject]),+    ("keeps members unchanged when the composed target is missing", "@users.each.@name", "\"anon\"", "{\"users\":[{\"age\":1}]}", Right [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "age", JSONNumber 1, JSONEndObject, JSONEndArray, JSONEndObject]),+    ("replaces the first array element", "ix 0", "9", "[[1,2],[3]]", Right [JSONBeginArray, JSONNumber 9, JSONBeginArray, JSONNumber 3, JSONEndArray, JSONEndArray]),+    ("replaces the second array element", "ix 1", "9", "[1,[2,3]]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 9, JSONEndArray]),+    ("replaces the whole document with id", "id", "5", "[1,2]", Right [JSONNumber 5]),+    ("replaces the whole document with a compound value", "id", "{\"x\":1}", "5", Right [JSONBeginObject, JSONObjectKey "x", JSONNumber 1, JSONEndObject]),+    ("replaces a nested container value wholesale", "@a", "5", "{\"a\":{\"b\":[1,2]},\"c\":3}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 5, JSONObjectKey "c", JSONNumber 3, JSONEndObject]),+    ("replaces an array with an array prism", "_Array", "[9]", "[1,2]", Right [JSONBeginArray, JSONNumber 9, JSONEndArray])+  ]++--------------------------------------------------------------------------------+-- delete+--------------------------------------------------------------------------------++deleteSpec :: Spec+deleteSpec = describe "delete" $ forM_ deleteCases $ \(label, optic, doc, expected) ->+  it label $ runDeleteTest optic doc `shouldReturn` expected++deleteCases :: [(String, Text, Text, Either Text [JSONEvent])]+deleteCases =+  [ ("removes a field", "@name", "{\"name\":\"alice\",\"age\":30}", Right [JSONBeginObject, JSONObjectKey "age", JSONNumber 30, JSONEndObject]),+    ("leaves the document unchanged when the field is missing", "@name", "{\"age\":30}", Right [JSONBeginObject, JSONObjectKey "age", JSONNumber 30, JSONEndObject]),+    ("leaves non-object input unchanged", "@name", "[1,2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray]),+    ("removes every array element", "each", "[1,2,3]", Right [JSONBeginArray, JSONEndArray]),+    ("removes every object member", "each", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONEndObject]),+    ("leaves an empty array unchanged", "each", "[]", Right [JSONBeginArray, JSONEndArray]),+    ("leaves an empty object unchanged", "each", "{}", Right [JSONBeginObject, JSONEndObject]),+    ("removes only strings with a prism", "each . _String", "[1,\"a\",2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray]),+    ("removes object members whose whole value matches a prism", "each . _Number", "{\"a\":1,\"b\":\"x\"}", Right [JSONBeginObject, JSONObjectKey "b", JSONString "x", JSONEndObject]),+    ("removes the first array element", "ix 0", "[10,20]", Right [JSONBeginArray, JSONNumber 20, JSONEndArray]),+    ("removes a member whose value is targeted by a composed optic", "@a._String", "{\"a\":\"x\",\"b\":\"y\"}", Right [JSONBeginObject, JSONObjectKey "b", JSONString "y", JSONEndObject]),+    ("keeps a member whose value does not match the composed prism", "@a._String", "{\"a\":5,\"b\":\"y\"}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 5, JSONObjectKey "b", JSONString "y", JSONEndObject]),+    ("removes composed fields but keeps the container", "@users.each.@name", "{\"users\":[{\"name\":\"a\",\"age\":1},{\"age\":2}]}", Right [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "age", JSONNumber 1, JSONEndObject, JSONBeginObject, JSONObjectKey "age", JSONNumber 2, JSONEndObject, JSONEndArray, JSONEndObject]),+    ("removes the whole document with id", "id", "[1,2]", Right []),+    ("leaves a value alone when the composed optic does not reach it", "@a.@b", "{\"a\":{\"c\":1},\"b\":2}", Right [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "c", JSONNumber 1, JSONEndObject, JSONObjectKey "b", JSONNumber 2, JSONEndObject])+  ]++-------------------------------------------------------------------------------+-- over+-------------------------------------------------------------------------------++overSpec :: Spec+overSpec = describe "over" $ forM_ overCases $ \(label, optic, t, doc, expected) ->+  it label $ runOverTest optic t doc `shouldReturn` expected++overCases :: [(String, Text, Transformation, Text, Either Text [JSONEvent])]+overCases =+  [ ("adds to every array element", "each", Add 1, "[1,2,3]", Right [JSONBeginArray, JSONNumber 2, JSONNumber 3, JSONNumber 4, JSONEndArray]),+    ("adds to a field value", "@age", Add 1, "{\"name\":\"alice\",\"age\":30}", Right [JSONBeginObject, JSONObjectKey "name", JSONString "alice", JSONObjectKey "age", JSONNumber 31, JSONEndObject]),+    ("appends to string values", "each . _String", ConcatString "!", "[1,\"a\",\"b\"]", Right [JSONBeginArray, JSONNumber 1, JSONString "a!", JSONString "b!", JSONEndArray]),+    ("trims string values", "each . _String", Trim, "[\"  hi  \",5]", Right [JSONBeginArray, JSONString "hi", JSONNumber 5, JSONEndArray]),+    ("replaces substrings in string values", "@name", Replace "a" "e", "{\"name\":\"alice\"}", Right [JSONBeginObject, JSONObjectKey "name", JSONString "elice", JSONEndObject]),+    ("maps values to booleans", "each", Equal (Number 1), "[1,2,1]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONBool True, JSONEndArray]),+    ("negates boolean values", "each . _Bool", Not, "[true,false]", Right [JSONBeginArray, JSONBool False, JSONBool True, JSONEndArray]),+    ("disjoins two transformations with or", "each", Or (Equal (Number 1)) (Equal (Number 3)), "[1,2,3]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONBool True, JSONEndArray]),+    ("conjoins two transformations with and", "each", And (Equal (Number 1)) (Equal (Number 1)), "[1,2]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONEndArray]),+    ("conjoins to true when both branches hold", "each", And (IsPrefixOf "a") (IsSuffixOf "c"), "[\"abc\",\"ab\"]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONEndArray]),+    -- The right branch would fail on a number; a false left branch+    -- must return False without running it.+    ("short-circuits and on false", "each", And (Equal (Number 2)) Not, "[1]", Right [JSONBeginArray, JSONBool False, JSONEndArray]),+    ("exclusive-disjoins two transformations with Xor", "each", Xor (IsPrefixOf "a") (IsSuffixOf "a"), "[\"a\",\"ab\",\"ba\",\"b\"]", Right [JSONBeginArray, JSONBool False, JSONBool True, JSONBool True, JSONBool False, JSONEndArray]),+    ("fails and with a non-boolean left branch", "each", And (Add 1) (Equal (Number 1)), "[0]", Left "expected a boolean result from the left side of and"),+    ("fails Xor with a non-boolean branch", "each", Xor (Equal (Number 1)) (Add 1), "[1]", Left "expected a boolean result from each side of xor"),+    ("composes transformations right-to-left", "each", Compose (Equal (Number 3)) (Add 1), "[1,2,3]", Right [JSONBeginArray, JSONBool False, JSONBool True, JSONBool False, JSONEndArray]),+    ("rewrites values focused by a composed optic", "@users.each.@age", Add 1, "{\"users\":[{\"age\":1},{\"age\":2}]}", Right [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "age", JSONNumber 2, JSONEndObject, JSONBeginObject, JSONObjectKey "age", JSONNumber 3, JSONEndObject, JSONEndArray, JSONEndObject]),+    ("replaces the whole document with id", "id", Equal (Number 1), "[1,2]", Right [JSONBool False]),+    ("fails when the transformation does not fit the value", "each", Add 1, "[\"a\",1]", Left "expected a number"),+    ("strips a matching prefix", "each", StripPrefix "pre", "[\"prefix\",\"pre\",\"other\"]", Right [JSONBeginArray, JSONString "fix", JSONString "", JSONString "other", JSONEndArray]),+    ("strips a matching suffix", "each", StripSuffix ".json", "[\"a.json\",\"json\"]", Right [JSONBeginArray, JSONString "a", JSONString "json", JSONEndArray]),+    ("tests prefix membership", "each", IsPrefixOf "pre", "[\"prefix\",\"other\"]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONEndArray]),+    ("tests suffix membership", "each", IsSuffixOf ".json", "[\"a.json\",\"other\"]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONEndArray]),+    ("tests infix membership", "each", IsInfixOf "fix", "[\"prefix\",\"other\"]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONEndArray]),+    ("tests array emptiness", "each", IsEmpty, "[[],[1]]", Right [JSONBeginArray, JSONBool True, JSONBool False, JSONEndArray]),+    ("computes array lengths", "each", ArrayLength, "[[1,2],[]]", Right [JSONBeginArray, JSONNumber 2, JSONNumber 0, JSONEndArray]),+    ("reverses arrays", "each", ArrayReverse, "[[1,2,3]]", Right [JSONBeginArray, JSONBeginArray, JSONNumber 3, JSONNumber 2, JSONNumber 1, JSONEndArray, JSONEndArray]),+    ("drops duplicate array elements", "each", ArrayUnique, "[[1,1,2,1]]", Right [JSONBeginArray, JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray, JSONEndArray]),+    ("sorts array elements", "each", ArraySort, "[[3,1,2]]", Right [JSONBeginArray, JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray, JSONEndArray]),+    ("fails sort on scalar elements", "each", ArraySort, "[\"b\",1,true,null]", Left "expected an array"),+    ("sorts mixed values by type rank", "each", ArraySort, "[[\"b\",1,true,null]]", Right [JSONBeginArray, JSONBeginArray, JSONNull, JSONBool True, JSONNumber 1, JSONString "b", JSONEndArray, JSONEndArray]),+    ("sorts nested arrays lexicographically", "each", ArraySort, "[[[2],[1],[1,2]]]", Right [JSONBeginArray, JSONBeginArray, JSONBeginArray, JSONNumber 1, JSONEndArray, JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray, JSONBeginArray, JSONNumber 2, JSONEndArray, JSONEndArray, JSONEndArray]),+    ("fails sort on non-arrays", "each", ArraySort, "[1]", Left "expected an array"),+    ("shallow-merges objects with right-wins conflicts", "id", Merge (KeyMap.fromList [("a", Object (KeyMap.fromList [("y", Number 2)])), ("b", Number 5)]), "{\"a\":{\"x\":1},\"b\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "y", JSONNumber 2, JSONEndObject, JSONObjectKey "b", JSONNumber 5, JSONEndObject]),+    ("deep-merges nested objects recursively", "id", DeepMerge (KeyMap.fromList [("a", Object (KeyMap.fromList [("y", Number 2)])), ("b", Number 5)]), "{\"a\":{\"x\":1},\"b\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONBeginObject, JSONObjectKey "x", JSONNumber 1, JSONObjectKey "y", JSONNumber 2, JSONEndObject, JSONObjectKey "b", JSONNumber 5, JSONEndObject]),+    ("replaces conflicting scalars on deepMerge", "id", DeepMerge (KeyMap.fromList [("a", Number 5)]), "{\"a\":{\"x\":1}}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 5, JSONEndObject]),+    ("fails merge on non-objects", "id", Merge (KeyMap.fromList [("b", Number 1)]), "[1]", Left "expected an object"),+    ("fails stripPrefix on numbers", "each", StripPrefix "a", "[1]", Left "expected a string"),+    ("fails length on strings", "each", ArrayLength, "[\"a\"]", Left "expected an array")+  ]++-------------------------------------------------------------------------------+-- keys rewrite (object key renaming; array indices are read-only)+-------------------------------------------------------------------------------++keysRewriteSpec :: Spec+keysRewriteSpec = describe "keys rewrite" $ do+  forM_ keysOverCases $ \(label, optic, t, doc, expected) ->+    it label $ runOverTest optic t doc `shouldReturn` expected+  forM_ keysSetCases $ \(label, optic, value, doc, expected) ->+    it label $ runSetTest optic value doc `shouldReturn` expected+  forM_ keysDeleteCases $ \(label, optic, doc, expected) ->+    it label $ runDeleteTest optic doc `shouldReturn` expected++keysOverCases :: [(String, Text, Transformation, Text, Either Text [JSONEvent])]+keysOverCases =+  [ ("renames every key", "keys", ConcatString "!", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONObjectKey "a!", JSONNumber 1, JSONObjectKey "b!", JSONNumber 2, JSONEndObject]),+    ("trims keys", "keys", Trim, "{\" a \":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]),+    ("renames through a composed string prism", "keys . _String", ConcatString "!", "{\"a\":1}", Right [JSONBeginObject, JSONObjectKey "a!", JSONNumber 1, JSONEndObject]),+    ("leaves keys alone when the prism does not match", "keys . _Number", Add 1, "{\"a\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]),+    ("leaves arrays unchanged", "keys", ConcatString "!", "[1,2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray]),+    ("fails when the transformation does not fit keys", "keys", Add 1, "{\"a\":1}", Left "expected a number")+  ]++keysSetCases :: [(String, Text, Text, Text, Either Text [JSONEvent])]+keysSetCases =+  [ ("sets every key to a constant", "keys", "\"k\"", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONObjectKey "k", JSONNumber 1, JSONObjectKey "k", JSONNumber 2, JSONEndObject]),+    ("fails when the replacement is not a string", "keys", "5", "{\"a\":1}", Left "key transformation must yield a string")+  ]++keysDeleteCases :: [(String, Text, Text, Either Text [JSONEvent])]+keysDeleteCases =+  [ ("removes every member", "keys", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONEndObject]),+    ("removes every member through a matching prism", "keys . _String", "{\"a\":1}", Right [JSONBeginObject, JSONEndObject]),+    ("keeps members when the prism does not match", "keys . _Number", "{\"a\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject]),+    ("leaves arrays unchanged on delete", "keys", "[1,2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray])+  ]++-------------------------------------------------------------------------------+-- values rewrite (objects only)+-------------------------------------------------------------------------------++valuesRewriteSpec :: Spec+valuesRewriteSpec = describe "values rewrite" $ do+  forM_ valuesOverCases $ \(label, optic, t, doc, expected) ->+    it label $ runOverTest optic t doc `shouldReturn` expected+  forM_ valuesSetCases $ \(label, optic, value, doc, expected) ->+    it label $ runSetTest optic value doc `shouldReturn` expected+  forM_ valuesDeleteCases $ \(label, optic, doc, expected) ->+    it label $ runDeleteTest optic doc `shouldReturn` expected++valuesOverCases :: [(String, Text, Transformation, Text, Either Text [JSONEvent])]+valuesOverCases =+  [ ("adds to every object value", "values", Add 1, "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 2, JSONObjectKey "b", JSONNumber 3, JSONEndObject]),+    ("leaves arrays unchanged", "values", Add 1, "[1,2,3]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONNumber 3, JSONEndArray]),+    ("rewrites values focused by a composed prism", "values . _Number", Add 1, "{\"a\":1,\"b\":\"x\"}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 2, JSONObjectKey "b", JSONString "x", JSONEndObject])+  ]++valuesSetCases :: [(String, Text, Text, Text, Either Text [JSONEvent])]+valuesSetCases =+  [ ("sets every object value", "values", "0", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 0, JSONObjectKey "b", JSONNumber 0, JSONEndObject])+  ]++valuesDeleteCases :: [(String, Text, Text, Either Text [JSONEvent])]+valuesDeleteCases =+  [ ("removes every member", "values", "{\"a\":1,\"b\":2}", Right [JSONBeginObject, JSONEndObject]),+    ("leaves arrays unchanged on delete", "values", "[1,2]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 2, JSONEndArray])+  ]++-------------------------------------------------------------------------------+-- ix rewrite (arrays only)+-------------------------------------------------------------------------------++ixRewriteSpec :: Spec+ixRewriteSpec = describe "ix rewrite" $ do+  forM_ ixOverCases $ \(label, optic, t, doc, expected) ->+    it label $ runOverTest optic t doc `shouldReturn` expected+  forM_ ixDeleteCases $ \(label, optic, doc, expected) ->+    it label $ runDeleteTest optic doc `shouldReturn` expected++ixOverCases :: [(String, Text, Transformation, Text, Either Text [JSONEvent])]+ixOverCases =+  [ ("adds to the indexed element", "ix 1", Add 10, "[1,2,3]", Right [JSONBeginArray, JSONNumber 1, JSONNumber 12, JSONNumber 3, JSONEndArray]),+    ("leaves objects unchanged", "ix 0", Add 1, "{\"a\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject])+  ]++ixDeleteCases :: [(String, Text, Text, Either Text [JSONEvent])]+ixDeleteCases =+  [ ("leaves objects unchanged on delete", "ix 0", "{\"a\":1}", Right [JSONBeginObject, JSONObjectKey "a", JSONNumber 1, JSONEndObject])+  ]++-------------------------------------------------------------------------------+-- filter rewrite+-------------------------------------------------------------------------------++filterRewriteSpec :: Spec+filterRewriteSpec = describe "filter rewrite" $ do+  forM_ filterOverCases $ \(label, optic, t, doc, expected) ->+    it label $ runOverTest optic t doc `shouldReturn` expected+  forM_ filterSetCases $ \(label, optic, value, doc, expected) ->+    it label $ runSetTest optic value doc `shouldReturn` expected+  forM_ filterDeleteCases $ \(label, optic, doc, expected) ->+    it label $ runDeleteTest optic doc `shouldReturn` expected++filterOverCases :: [(String, Text, Transformation, Text, Either Text [JSONEvent])]+filterOverCases =+  [ ("replaces kept values", "each . filter @age == 30", Const (Number 0), "[{\"age\":30},{\"age\":20}]", Right [JSONBeginArray, JSONNumber 0, JSONBeginObject, JSONObjectKey "age", JSONNumber 20, JSONEndObject, JSONEndArray]),+    ("rewrites through a filter into kept values", "each . filter @age == 30 . @score", Add 100, "[{\"age\":30,\"score\":1},{\"age\":20,\"score\":2}]", Right [JSONBeginArray, JSONBeginObject, JSONObjectKey "age", JSONNumber 30, JSONObjectKey "score", JSONNumber 101, JSONEndObject, JSONBeginObject, JSONObjectKey "age", JSONNumber 20, JSONObjectKey "score", JSONNumber 2, JSONEndObject, JSONEndArray]),+    ("fails when the predicate does not fit", "each . filter @a +1", Const (Number 0), "[{\"a\":\"x\"}]", Left "expected a number"),+    ("fails when the predicate is not boolean", "each . filter @a +1", Const (Number 0), "[{\"a\":1}]", Left "filter transformation must produce a boolean")+  ]++filterSetCases :: [(String, Text, Text, Text, Either Text [JSONEvent])]+filterSetCases =+  [ ("sets kept values", "each . filter @age == 30", "0", "[{\"age\":30},{\"age\":20}]", Right [JSONBeginArray, JSONNumber 0, JSONBeginObject, JSONObjectKey "age", JSONNumber 20, JSONEndObject, JSONEndArray])+  ]++filterDeleteCases :: [(String, Text, Text, Either Text [JSONEvent])]+filterDeleteCases =+  [ ("removes kept elements", "each . filter @age == 30", "[{\"age\":30},{\"age\":20}]", Right [JSONBeginArray, JSONBeginObject, JSONObjectKey "age", JSONNumber 20, JSONEndObject, JSONEndArray]),+    ("removes kept members but keeps the container", "@users . each . filter @age == 30", "{\"users\":[{\"age\":30},{\"age\":20}],\"b\":2}", Right [JSONBeginObject, JSONObjectKey "users", JSONBeginArray, JSONBeginObject, JSONObjectKey "age", JSONNumber 20, JSONEndObject, JSONEndArray, JSONObjectKey "b", JSONNumber 2, JSONEndObject]),+    ("removes the whole member when the gate keeps it", "@users . filter (each) (== 1)", "{\"users\":[1],\"b\":2}", Right [JSONBeginObject, JSONObjectKey "b", JSONNumber 2, JSONEndObject]),+    ("removes the whole document when the gate keeps it", "filter @age == 30", "{\"age\":30}", Right []),+    ("leaves the document unchanged when the gate drops it", "filter @age == 30", "{\"age\":20}", Right [JSONBeginObject, JSONObjectKey "age", JSONNumber 20, JSONEndObject])+  ]++chunkedRewriteSpec :: Spec+chunkedRewriteSpec = describe "chunked input" $ do+  it "rewrites agree with whole-input runs under every split" $ do+    forM_ overChunkCases $ \(opticStr, transformation, doc) -> do+      expected <- runOverTest opticStr transformation doc+      case parseOptic opticStr of+        Left err -> expectationFailure $ "bad optic: " <> show err+        Right optic ->+          forM_ (splits doc) $ \chunks -> do+            actual <- runRewriteChunks (\early -> runOver early optic transformation testConfig) chunks+            actual `shouldBe` expected++  it "deletes agree with whole-input runs under every split" $ do+    forM_ deleteChunkCases $ \(opticStr, doc) ->+      case parseOptic opticStr of+        Left err -> expectationFailure $ "bad optic: " <> show err+        Right optic -> do+          expected <- runDeleteTest opticStr doc+          forM_ (splits doc) $ \chunks -> do+            actual <- runRewriteChunks (\early -> runDelete early optic testConfig) chunks+            actual `shouldBe` expected++overChunkCases :: [(Text, Transformation, Text)]+overChunkCases =+  [ ("@users.each.@age", Add 1, "{\"users\":[{\"age\":1},{\"age\":2}]}"),+    ("each", Add 1, "[1,2,3]"),+    ("each . _String", ConcatString "!", "[1,\"a\",\"b\"]"),+    ("keys", ConcatString "!", "{\"a\":1,\"b\":2}"),+    ("values", Add 1, "{\"a\":1,\"b\":2}"),+    ("ix 1", Add 1, "[1,2,3]"),+    ("each . filter @age == 30", Const (Number 0), "[{\"age\":30},{\"age\":20}]")+  ]++deleteChunkCases :: [(Text, Text)]+deleteChunkCases =+  [ ("@users.each.@name", "{\"users\":[{\"name\":\"a\",\"age\":1},{\"age\":2}]}"),+    ("each", "[1,2,3]"),+    ("@a", "{\"a\":{\"b\":[1,2]},\"c\":3}"),+    ("keys", "{\"a\":1,\"b\":2}"),+    ("values", "{\"a\":1,\"b\":2}"),+    ("each . filter @age == 30", "[{\"age\":30},{\"age\":20}]")+  ]++-- | Run a rewrite continuation over every top-level document and+-- collect the raw output bytes. Multi-document output is not a single+-- value, so unlike 'runRewriteChunks' this does not reparse to events.+runRewriteDocumentsTest :: (Early HQError -> RewriteContinuation) -> [Text] -> IO (Either Text Text)+runRewriteDocumentsTest mkRun chunks = do+  result <-+    runEarly+      ( \early -> do+          (byteChunks :> _) <- S.toList (rewriteDocuments early (mkRun early) cursor initialEmitState)+          pure (decodeUtf8 (mconcat byteChunks))+      )+  pure (first renderHQError result)+  where+    textStream :: StreamIO Text ()+    textStream = S.each chunks+    cursor = Cursor [] initialDecoder textStream++multiDocumentRewriteSpec :: Spec+multiDocumentRewriteSpec = describe "multiple documents" $ do+  it "rewrites the same field across documents" $ do+    Right optic <- pure (parseOptic "@a")+    runRewriteDocumentsTest (\early -> runOver early optic (Add 1) testConfig) ["{\"a\":1} {\"a\":2}"]+      `shouldReturn` Right "{\n  \"a\": 2\n}\n{\n  \"a\": 3\n}\n"++  it "deletes across documents" $ do+    Right optic <- pure (parseOptic "@x")+    runRewriteDocumentsTest (\early -> runDelete early optic testConfig) ["{\"a\":1,\"x\":0} {\"b\":2}"]+      `shouldReturn` Right "{\n  \"a\": 1\n}\n{\n  \"b\": 2\n}\n"++  it "continues across chunk splits at document boundaries" $ do+    Right optic <- pure (parseOptic "@a")+    runRewriteDocumentsTest (\early -> runOver early optic (Add 1) testConfig) ["{\"a\":1} {\"a", "\":2}"]+      `shouldReturn` Right "{\n  \"a\": 2\n}\n{\n  \"a\": 3\n}\n"++  it "fails on trailing garbage" $ do+    Right optic <- pure (parseOptic "@a")+    runRewriteDocumentsTest (\early -> runOver early optic (Add 1) testConfig) ["{\"a\":0} garbage"]+      `shouldReturn` Left "unexpected character 'g' in JSON input"
+ test/HQ/Transformation/ASTSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Transformation.ASTSpec (spec) where++import Data.Aeson (Value (..))+import Data.Aeson.KeyMap qualified as KeyMap+import HQ.Transformation+import HQ.Transformation.AST+import HQ.Transformation.TransformationType+import Relude hiding (Compose, Const, and, isPrefixOf, length, not, or, reverse, subtract, xor)+import Test.Syd++spec :: Spec+spec = describe "HQ.Transformation.AST" $ do+  describe "inferTransformationType" $ do+    it "tags well-typed transformations" $ forM_ happyCases $ \(t, expected) ->+      inferTransformationType t `shouldBe` Right expected++    it "rejects ill-typed transformations" $ forM_ errorCases $ \(t, expected) ->+      inferTransformationType t `shouldBe` Left expected++    it "reports the failing composition in DSL syntax" $ do+      case inferTransformationType (Compose (Add 1) (Equal (Number 3))) of+        Left (InvalidCompose t _ _) -> show t `shouldBe` ("+1 . == 3" :: String)+        Left err -> expectationFailure $ "wrong error: " <> show err+        Right _ -> expectationFailure "expected an InvalidCompose"++    it "renders and/xor precedence without redundant parens" $ do+      show (Or (And (Equal (Number 1)) (Equal (Number 1))) (Equal (Number 3)))+        `shouldBe` ("== 1 and == 1 or == 3" :: String)+      show (And (Equal (Number 1)) (Or (Equal (Number 2)) (Equal (Number 3))))+        `shouldBe` ("== 1 and (== 2 or == 3)" :: String)+      show (Xor (And (Equal (Number 1)) (Equal (Number 2))) (Equal (Number 3)))+        `shouldBe` ("== 1 and == 2 xor == 3" :: String)++happyCases :: [(Transformation, TransformationType)]+happyCases =+  [ (Add 1, TransformationType ValueNumber ValueNumber),+    (Lt 1, TransformationType ValueNumber ValueBool),+    (Lte 1, TransformationType ValueNumber ValueBool),+    (ConcatString " x", TransformationType ValueString ValueString),+    (StripPrefix "pre", TransformationType ValueString ValueString),+    (StripSuffix "suf", TransformationType ValueString ValueString),+    (IsPrefixOf "pre", TransformationType ValueString ValueBool),+    (IsSuffixOf "suf", TransformationType ValueString ValueBool),+    (IsInfixOf "fix", TransformationType ValueString ValueBool),+    (IsEmpty, TransformationType ValueArray ValueBool),+    (ArrayLength, TransformationType ValueArray ValueNumber),+    (ArrayReverse, TransformationType ValueArray ValueArray),+    (ArrayUnique, TransformationType ValueArray ValueArray),+    (ArraySort, TransformationType ValueArray ValueArray),+    (Merge (KeyMap.fromList [("b", Number 1)]), TransformationType ValueObject ValueObject),+    (DeepMerge (KeyMap.fromList [("b", Number 1)]), TransformationType ValueObject ValueObject),+    (Const (Number 3), TransformationType ValueAny ValueNumber),+    (Compose (Const (Number 3)) (Add 1), TransformationType ValueNumber ValueNumber),+    (Compose (Add 1) (Const (Number 3)), TransformationType ValueAny ValueNumber),+    (Compose (Add 1) (Multiply 2), TransformationType ValueNumber ValueNumber),+    (Compose Not (Equal (Number 1)), TransformationType ValueAny ValueBool),+    (Or (Equal (Number 1)) (Equal (Number 2)), TransformationType ValueAny ValueBool),+    (And (Equal (Number 1)) (Equal (Number 1)), TransformationType ValueAny ValueBool),+    (Xor (Equal (Number 1)) (Equal (Number 2)), TransformationType ValueAny ValueBool),+    (Compose (Equal (Number 1)) Trim, TransformationType ValueString ValueBool),+    (Compose IsEmpty ArrayReverse, TransformationType ValueArray ValueBool)+  ]++errorCases :: [(Transformation, TransformationTypeError)]+errorCases =+  [ (Divide 0, InvalidDivideByZero (Divide 0)),+    (Compose (Add 1) (Const (String "x")), InvalidCompose (Compose (Add 1) (Const (String "x"))) ValueString ValueNumber),+    (Or (Add 1) (Equal (Number 2)), InvalidOr (Or (Add 1) (Equal (Number 2))) ValueNumber),+    (Or (Equal (Number 1)) (Add 2), InvalidOr (Or (Equal (Number 1)) (Add 2)) ValueNumber),+    (And (Add 1) (Equal (Number 2)), InvalidAnd (And (Add 1) (Equal (Number 2))) ValueNumber),+    (Xor (Equal (Number 1)) (Add 2), InvalidXor (Xor (Equal (Number 1)) (Add 2)) ValueNumber),+    (Compose (Add 1) (Equal (Number 3)), InvalidCompose (Compose (Add 1) (Equal (Number 3))) ValueBool ValueNumber),+    (Compose (ConcatString " x") (Add 1), InvalidCompose (Compose (ConcatString " x") (Add 1)) ValueNumber ValueString),+    (Compose (StripPrefix "a") ArrayLength, InvalidCompose (Compose (StripPrefix "a") ArrayLength) ValueNumber ValueString)+  ]
+ test/HQ/Transformation/ParserSpec.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HQ.Transformation.ParserSpec (spec) where++import Data.Aeson (Value (..))+import Data.Aeson.KeyMap qualified as KeyMap+import HQ.Transformation+import HQ.Transformation.Parser (parseTransformation)+import Relude hiding (Compose, Const, many, some)+import Test.Syd++spec :: Spec+spec = describe "HQ.Transformation.Parser" $ do+  it "parses arithmetic" $ forM_ arithmeticCases $ \(input, expected) ->+    parseTransformation input `shouldBe` Right expected++  it "parses strings and arrays" $ forM_ stringArrayCases $ \(input, expected) ->+    parseTransformation input `shouldBe` Right expected++  it "parses affixes and predicates" $ forM_ affixCases $ \(input, expected) ->+    parseTransformation input `shouldBe` Right expected++  it "parses constants" $ forM_ constantCases $ \(input, expected) ->+    parseTransformation input `shouldBe` Right expected++  it "parses booleans" $ forM_ booleanCases $ \(input, expected) ->+    parseTransformation input `shouldBe` Right expected++  it "parses composition and precedence" $ forM_ compositionCases $ \(input, expected) ->+    parseTransformation input `shouldBe` Right expected++  it "rejects invalid expressions" $ forM_ errorCases $ \input ->+    parseTransformation input `shouldSatisfy` isLeft++arithmeticCases :: [(Text, Transformation)]+arithmeticCases =+  [ ("+1", Add 1),+    ("*2", Multiply 2),+    ("-5", Subtract 5),+    ("/4", Divide 4),+    ("+0.5", Add 0.5),+    ("<5", Lt 5),+    ("<=5", Lte 5),+    (">5", Compose Not (Lte 5)),+    (">=5", Compose Not (Lt 5)),+    ("*1e10", Multiply 1e10)+  ]++stringArrayCases :: [(Text, Transformation)]+stringArrayCases =+  [ ("++ \" world\"", ConcatString " world"),+    ("concat [1,2]", ConcatArray [Number 1, Number 2]),+    ("trim", Trim),+    ("replace \"ab\" \"bc\"", Replace "ab" "bc"),+    ("concat[1,2]", ConcatArray [Number 1, Number 2])+  ]++affixCases :: [(Text, Transformation)]+affixCases =+  [ ("stripPrefix \"pre\"", StripPrefix "pre"),+    ("stripSuffix \"suf\"", StripSuffix "suf"),+    ("isPrefixOf \"pre\"", IsPrefixOf "pre"),+    ("isSuffixOf \"suf\"", IsSuffixOf "suf"),+    ("isInfixOf \"fix\"", IsInfixOf "fix"),+    ("isEmpty", IsEmpty),+    ("length", ArrayLength),+    ("reverse", ArrayReverse),+    ("unique", ArrayUnique),+    ("sort", ArraySort),+    ("merge {\"b\": 1}", Merge (KeyMap.fromList [("b", Number 1)])),+    ("deepMerge {\"a\": {\"y\": 2}}", DeepMerge (KeyMap.fromList [("a", Object (KeyMap.fromList [("y", Number 2)]))])),+    ("stripPrefix \"a\" . trim", Compose (StripPrefix "a") Trim)+  ]++constantCases :: [(Text, Transformation)]+constantCases =+  [ ("const 3", Const (Number 3)),+    ("const \"x\"", Const (String "x")),+    ("const 3 . +1", Compose (Const (Number 3)) (Add 1))+  ]++booleanCases :: [(Text, Transformation)]+booleanCases =+  [ ("== 3", Equal (Number 3)),+    ("= \"x\"", Equal (String "x")),+    ("not", Not),+    ("== 1 . not", Compose (Equal (Number 1)) Not),+    ("not . == 1", Compose Not (Equal (Number 1))),+    ("== 1 or == 2", Or (Equal (Number 1)) (Equal (Number 2))),+    ("== 1 || == 2", Or (Equal (Number 1)) (Equal (Number 2))),+    ("== 1 and == 1", And (Equal (Number 1)) (Equal (Number 1))),+    ("== 1 && == 1", And (Equal (Number 1)) (Equal (Number 1))),+    ("== 1 xor == 2", Xor (Equal (Number 1)) (Equal (Number 2))),+    ("== 1 ^^ == 2", Xor (Equal (Number 1)) (Equal (Number 2))),+    ("== 1 and == 1 or == 3", Or (And (Equal (Number 1)) (Equal (Number 1))) (Equal (Number 3))),+    ("== 1 or == 2 xor == 2", Or (Equal (Number 1)) (Xor (Equal (Number 2)) (Equal (Number 2)))),+    ("== 1 xor == 2 and == 2", Xor (Equal (Number 1)) (And (Equal (Number 2)) (Equal (Number 2))))+  ]++compositionCases :: [(Text, Transformation)]+compositionCases =+  [ ("+1 . trim", Compose (Add 1) Trim),+    ("+1 . == 3", Compose (Add 1) (Equal (Number 3))),+    ("+1 . == 3 or == 4", Or (Compose (Add 1) (Equal (Number 3))) (Equal (Number 4))),+    ("not . == 1 . == 3", Compose (Compose Not (Equal (Number 1))) (Equal (Number 3))),+    ("(== 1 or == 2) . == 3", Compose (Or (Equal (Number 1)) (Equal (Number 2))) (Equal (Number 3))),+    ("not . (== 1 or == 2)", Compose Not (Or (Equal (Number 1)) (Equal (Number 2))))+  ]++errorCases :: [Text]+errorCases =+  [ "merge [1]",+    "",+    "5",+    "+",+    "blah",+    "+ \"x\"",+    "replace 1 2",+    "stripPrefix 1",+    "isEmpty \"x\"",+    "concat 3",+    "trim xyz",+    "not == 1",+    "!",+    "const1",+    "sortOn",+    "android",+    "== 1 orange == 2"+  ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/HQ.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Shared helpers for the @hq@ test suite.+module Test.HQ+  ( decodeChunks,+    runStreaming,+    drainCollect,+    splits,+    validPullCorpus,+    malformedPullCorpus,+    decodeShown,+  )+where++import Data.Text qualified as T+import HQ.Error (HQError (..), renderHQError)+import HQ.JSON.Decoder (DecodeError (..), DecoderResult (..), DecoderState (..), decodeTexts, finish, step)+import HQ.JSON.Event (JSONEvent)+import Relude hiding (Compose, id)++-- | Stream text chunks through the decode function.+decodeChunks :: [Text] -> Either DecodeError [JSONEvent]+decodeChunks = decodeTexts++-- | Helper to run a streaming decode and check the result.+runStreaming :: [Text] -> [JSONEvent]+runStreaming chunks = case decodeChunks chunks of+  Left _err -> []+  Right events -> events++-- | Drain events from a decoder result by repeatedly calling step,+-- then finalize with finish. Steps while input remains, and only calls+-- finish on a drained decoder: finish discards decoderInput, and+-- stepping an empty-input decoder that returns NeedInput would loop+-- forever.+drainCollect :: DecoderResult -> Either DecodeError [JSONEvent]+drainCollect (Emit event next) = case step next of+  Left err -> Left err+  Right result -> fmap (event :) (drainCollect result)+drainCollect (Done _) = Right []+drainCollect (NeedInput next)+  -- There is still unconsumed input; step it rather than calling finish+  -- (finish discards decoderInput, which would lose surrogate pairs,+  -- keywords, and numbers that span across the last feed boundary).+  | not (T.null (decoderInput next)) = case step next of+      Left err -> Left err+      Right result -> drainCollect result+  | otherwise = case finish next of+      Right (Emit event next') -> case step next' of+        Left err' -> Left err'+        Right result' -> fmap (event :) (drainCollect result')+      Right (Done _) -> Right []+      Right (NeedInput _) -> Left UnexpectedEnd+      Left err -> Left err++-- | Chunkings under which an input is decoded: whole, every two-way+-- split, and one-character chunks for short inputs.+splits :: Text -> [[Text]]+splits input+  | T.null input = [[input]]+  | otherwise =+      [input]+        : [[T.take n input, T.drop n input] | n <- [1 .. T.length input - 1]]+          ++ [[T.singleton c | c <- toString input] | T.length input <= 24]++-- | Streaming decode with errors shown, for differential testing.+-- Errors are rendered for the CLI boundary ('renderHQError') so both+-- drives compare the messages users actually see.+decodeShown :: [Text] -> Either Text [JSONEvent]+decodeShown chunks = case decodeChunks chunks of+  Left err -> Left (renderHQError (HQDecodeError err))+  Right events -> Right events++--------------------------------------------------------------------------------+-- Shared corpus+--------------------------------------------------------------------------------++validPullCorpus :: [Text]+validPullCorpus =+  [ "42",+    "-42",+    "0",+    "3.14",+    "-3.14",+    "0.15",+    "1e10",+    "1E10",+    "1e-2",+    "1e+2",+    "1.5e2",+    "-1.5e-6",+    "-1e5",+    "null",+    "true",+    "false",+    "\"\"",+    "\"hello\"",+    "\"a\\\"b\\\\c\\/\\b\\f\\n\\r\\t\"",+    "\"\\u00e9\"",+    "\"\\ud83d\\ude00\"",+    "[\"\\ud83d\\ude00\"]",+    "{\"u\":\"\\ud83d\\ude00\"}",+    "[]",+    "[1,2,3]",+    "[1,\"a\",true,null]",+    "{}",+    "{\"a\":1,\"b\":[2,3]}",+    " {\"a\" : [1, 2] } ",+    "",+    "   "+  ]++malformedPullCorpus :: [Text]+malformedPullCorpus =+  [ "\"abc",+    "{\"a\":1",+    "[1,2",+    "12a",+    "\"\\x\"",+    "\"\\u00z1\"",+    "\"\\ud83d\"",+    "\"\\ud83dX\"",+    "01",+    "1e",+    "1e+",+    "{\"a\" 1}",+    "[1,,2]",+    "[1 2]",+    "{,}",+    "nul",+    "-",+    "--1"+  ]