diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2022 damianfral + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,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) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Main (main) where + +import HQ.CLI (runCLI) +import Relude + +main :: IO () +main = runCLI diff --git a/docs/LANG.md b/docs/LANG.md new file mode 100644 --- /dev/null +++ b/docs/LANG.md @@ -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' +``` diff --git a/hq-json.cabal b/hq-json.cabal new file mode 100644 --- /dev/null +++ b/hq-json.cabal @@ -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 +maintainer: damianfral +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 diff --git a/src/HQ/CLI.hs b/src/HQ/CLI.hs new file mode 100644 --- /dev/null +++ b/src/HQ/CLI.hs @@ -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 diff --git a/src/HQ/Early.hs b/src/HQ/Early.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Early.hs @@ -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 diff --git a/src/HQ/Error.hs b/src/HQ/Error.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Error.hs @@ -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 diff --git a/src/HQ/JSON/Decoder.hs b/src/HQ/JSON/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder.hs @@ -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 ())) diff --git a/src/HQ/JSON/Decoder/Core.hs b/src/HQ/JSON/Decoder/Core.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder/Core.hs @@ -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 diff --git a/src/HQ/JSON/Decoder/Error.hs b/src/HQ/JSON/Decoder/Error.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder/Error.hs @@ -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" diff --git a/src/HQ/JSON/Decoder/Keyword.hs b/src/HQ/JSON/Decoder/Keyword.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder/Keyword.hs @@ -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 diff --git a/src/HQ/JSON/Decoder/Number.hs b/src/HQ/JSON/Decoder/Number.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder/Number.hs @@ -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) diff --git a/src/HQ/JSON/Decoder/Skip.hs b/src/HQ/JSON/Decoder/Skip.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder/Skip.hs @@ -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 #-} diff --git a/src/HQ/JSON/Decoder/String.hs b/src/HQ/JSON/Decoder/String.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Decoder/String.hs @@ -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 diff --git a/src/HQ/JSON/Encoder.hs b/src/HQ/JSON/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Encoder.hs @@ -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 diff --git a/src/HQ/JSON/Event.hs b/src/HQ/JSON/Event.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Event.hs @@ -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 diff --git a/src/HQ/JSON/Parser.hs b/src/HQ/JSON/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HQ/JSON/Parser.hs @@ -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 diff --git a/src/HQ/Optic.hs b/src/HQ/Optic.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Optic.hs @@ -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" diff --git a/src/HQ/Optic/AST.hs b/src/HQ/Optic/AST.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Optic/AST.hs @@ -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 diff --git a/src/HQ/Optic/OpticType.hs b/src/HQ/Optic/OpticType.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Optic/OpticType.hs @@ -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 diff --git a/src/HQ/Optic/Parser.hs b/src/HQ/Optic/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Optic/Parser.hs @@ -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 + ] diff --git a/src/HQ/Parser.hs b/src/HQ/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Parser.hs @@ -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 diff --git a/src/HQ/Query.hs b/src/HQ/Query.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Query.hs @@ -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 diff --git a/src/HQ/Query/Parser.hs b/src/HQ/Query/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Query/Parser.hs @@ -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 diff --git a/src/HQ/Runner.hs b/src/HQ/Runner.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner.hs @@ -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' diff --git a/src/HQ/Runner/Cursor.hs b/src/HQ/Runner/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner/Cursor.hs @@ -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) diff --git a/src/HQ/Runner/Error.hs b/src/HQ/Runner/Error.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner/Error.hs @@ -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" diff --git a/src/HQ/Runner/Fold.hs b/src/HQ/Runner/Fold.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner/Fold.hs @@ -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 diff --git a/src/HQ/Runner/Rewrite.hs b/src/HQ/Runner/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner/Rewrite.hs @@ -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' diff --git a/src/HQ/Runner/Rewrite/Emit.hs b/src/HQ/Runner/Rewrite/Emit.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner/Rewrite/Emit.hs @@ -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 #-} diff --git a/src/HQ/Runner/Take.hs b/src/HQ/Runner/Take.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Runner/Take.hs @@ -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' diff --git a/src/HQ/Transformation.hs b/src/HQ/Transformation.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Transformation.hs @@ -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 diff --git a/src/HQ/Transformation/AST.hs b/src/HQ/Transformation/AST.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Transformation/AST.hs @@ -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 diff --git a/src/HQ/Transformation/Error.hs b/src/HQ/Transformation/Error.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Transformation/Error.hs @@ -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" diff --git a/src/HQ/Transformation/Parser.hs b/src/HQ/Transformation/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Transformation/Parser.hs @@ -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) diff --git a/src/HQ/Transformation/TransformationType.hs b/src/HQ/Transformation/TransformationType.hs new file mode 100644 --- /dev/null +++ b/src/HQ/Transformation/TransformationType.hs @@ -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) diff --git a/test/HQ/CLISpec.hs b/test/HQ/CLISpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/CLISpec.hs @@ -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) + ] diff --git a/test/HQ/JSON/DecoderSpec.hs b/test/HQ/JSON/DecoderSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/JSON/DecoderSpec.hs @@ -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 diff --git a/test/HQ/JSON/EncoderSpec.hs b/test/HQ/JSON/EncoderSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/JSON/EncoderSpec.hs @@ -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' diff --git a/test/HQ/JSON/ParserSpec.hs b/test/HQ/JSON/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/JSON/ParserSpec.hs @@ -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 diff --git a/test/HQ/OpticSpec.hs b/test/HQ/OpticSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/OpticSpec.hs @@ -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) + ] diff --git a/test/HQ/Query/ParserSpec.hs b/test/HQ/Query/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/Query/ParserSpec.hs @@ -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" + ] diff --git a/test/HQ/QuerySpec.hs b/test/HQ/QuerySpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/QuerySpec.hs @@ -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) + ] diff --git a/test/HQ/Runner/FoldSpec.hs b/test/HQ/Runner/FoldSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/Runner/FoldSpec.hs @@ -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 []) + ] diff --git a/test/HQ/Runner/RewriteSpec.hs b/test/HQ/Runner/RewriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/Runner/RewriteSpec.hs @@ -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" diff --git a/test/HQ/Transformation/ASTSpec.hs b/test/HQ/Transformation/ASTSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/Transformation/ASTSpec.hs @@ -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) + ] diff --git a/test/HQ/Transformation/ParserSpec.hs b/test/HQ/Transformation/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/Transformation/ParserSpec.hs @@ -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" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/HQ.hs b/test/Test/HQ.hs new file mode 100644 --- /dev/null +++ b/test/Test/HQ.hs @@ -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" + ]