diff --git a/Makefile b/Makefile index ae1e5ab..5fd6ef5 100644 --- a/Makefile +++ b/Makefile @@ -184,6 +184,10 @@ bench: ## Run benchmarks bench-parser: ## Run parser-only benchmark $(DUNE) exec benchmarks/bench_parser.exe +.PHONY: bench-execution +bench-execution: ## Compare prepared execution with the interpreter in-process + $(DUNE) exec --root . --profile=release benchmarks/bench_execution.exe + .PHONY: release release: ## Create a new release (usage: make release VERSION=1.2.3) @if [ -z "$(VERSION)" ]; then \ diff --git a/README.md b/README.md index c1ab4ec..27203bf 100644 --- a/README.md +++ b/README.md @@ -148,6 +148,7 @@ Arguments: Options: -r, --raw-output Output strings without quotes + --stream-output Flush each result as it is produced --no-color Disable colored output --repl Start interactive REPL mode -v, --verbose Show verbose output including deprecation warnings @@ -156,6 +157,24 @@ Options: --help Print help ``` +By default, all output is written at once after the query succeeds, and an +error shares stdout with any results. With `--stream-output`, each result is +flushed to stdout as it is produced. If a later result or input tail fails, +earlier output on stdout remains, the error is written to stderr instead, and +the process exits with status 1. Successful output is identical in both modes; +a query with no results prints one empty line. This flag has no effect in REPL +mode. + +Both modes execute complete items before EOF for supported root or direct +root-member iteration; without `--stream-output` the results are held until the +query has succeeded. Collection barriers, unsupported queries and `--debug` +validate the complete JSON input first. After a query error, callbacks stop and input validation continues. +A later input error wins. Invalid JSON also takes precedence over an invalid query. +The debug AST prints only after valid EOF. +For supported queries that start with a root object key, file, inline, and stdin +input can retain only the selected value while validating the rest. Other queries +retain the complete input. The JavaScript string entry remains validation-first. + ## Contributing Contributions are welcome! See the [development setup](#development) below to get started. diff --git a/benchmarks/README.md b/benchmarks/README.md index aee0e8e..d5bd46e 100644 --- a/benchmarks/README.md +++ b/benchmarks/README.md @@ -26,6 +26,175 @@ MIN_RUNS=3 WARMUP=1 ./benchmarks/bench.sh The benchmark suite uses [hyperfine](https://github.com/sharkdp/hyperfine) for accurate, statistical benchmarking with warmup runs and multiple iterations. +## Compare prepared execution and one-shot library calls + +Run the in-process execution benchmark with the project's opam dependencies installed: + +```bash +make bench-execution + +# Override the default operation counts for a longer run. +opam exec -- dune exec --root . --profile=release benchmarks/bench_execution.exe -- \ + --iterations 10000 --warmup 1000 --samples 7 +``` + +If no opam switch is selected, prefix either command with `OPAMSWITCH=`. +Use the same compiler, release profile, GC settings, and idle machine when comparing runs. +The output records the OCaml version, word size, OS type, key GC settings, queries, and operation counts. It prints prepared-execution and one-shot library tables for the same workloads, then prepared-sink, input-inclusive, and first-result comparisons. Run from the repository root so the first-result table can read `benchmarks/big.json`. + +### Prepared execution + +For this table, each workload parses its query and JSON once and calls `Execution.prepare` once. +Before any timing, the benchmark requires the expected backend, checks the interpreter result against a fixed expected result, and compares the complete prepared result with `Interpreter.execute`. +Structural equality checks result order, nested values, and numeric constructors, rather than only a checksum or result count. +A mismatch, error, halt, or wrong backend stops the run with a nonzero exit status. + +| Workload | Expected backend | Input and result | Prepared operations/sample | One-shot operations/sample | +|---|---|---|---:|---:| +| `deep_scalar_chain` | Compiled | Nested field/index chain returning `42` | 100,000 | 5,000 | +| `scalar_predicate` | Compiled | Integer arithmetic, comparison, and boolean predicate returning `true` | 50,000 | 5,000 | +| `iterator_select_field` | Compiled | 128 objects, mixed passing/failing predicates, 25 ordered integer results | 2,000 | 2,000 | +| `map_transform` | Compiled | 128 objects transformed into one array of 128 integers | 2,000 | 2,000 | +| `fallback_length` | Interpreted | `.root.groups \| length` returning `2`. Unsupported `length` forces whole-query fallback. | 100,000 | 5,000 | + +Both tables use 1,000 warmup operations per path and workload, then five paired samples with alternating path order. +`--iterations` overrides the per-workload operation counts in both tables. `--warmup` and `--samples` override their respective defaults. All counts must be positive. +Each operation executes the whole query and materializes its full result list. +The timed loop calls an opaque function and stores each opaque result in a shared sink so the compiler cannot remove the work. +Full result checks also run after warmup and at each sample endpoint, outside timing. + +The table reports median elapsed nanoseconds per operation and median allocated bytes per operation for prepared `Execution.execute` (`E`) and `Interpreter.execute` (`I`). +`Time delta` and `Alloc delta` are `(E / I - 1) * 100`. Positive values show a regression in that run. +There is no performance pass/fail threshold. + +### One-shot library calls + +The second table measures the work that `Core.run` performs on each call: + +- Candidate (`C`) calls the real `Core.run`: parse the query, prepare an execution plan, execute it, render every result, and join the strings with newlines. +- Reference (`R`) follows the former `Core.run` path: call `Core.parse`, call `Interpreter.execute`, render every result with `Json.to_string_pretty`, and join the strings with newlines. It does not prepare a plan. + +Both paths use `debug=false`, `colorize=false`, `verbose=false`, `raw=false`, and `summarize=false`. +They receive the same already parsed `Json.t` used by the prepared comparison. **JSON parsing, process startup, and stdout are excluded.** Query parsing, per-call preparation on the candidate path, execution, and rendering are included. +The default one-shot counts are capped at 5,000 operations per sample to limit run time. + +Before either table is timed, the benchmark compares complete `Ok string` or `Error string` results, including whitespace and error text. +For each workload, the reference string must also equal the rendered fixed expected result. +Two additional untimed checks compare parse and runtime errors and require an `Error` result. +The benchmark repeats complete result checks after warmup and at each sample endpoint, outside timing. +A mismatch stops the run with a nonzero exit status. + +The one-shot table reports median `C ns/op`, `R ns/op`, `C B/op`, and `R B/op`. +Its deltas are `(C / R - 1) * 100`, with positive values showing regressions and no performance threshold. +Use this table to assess preparation cost on the library call path. Prepared-plan gains alone do not show whether one-shot calls improve. + +### Prepared result sink + +The third table runs `.[]` over 16,384 integers, from 1 through 16,384, using one prepared compiled plan and one input built before timing: + +- Fold (`F`) calls `Execution.fold` into an integer checksum of 134,225,920. +- List (`L`) calls `Execution.execute` and keeps its complete result list. It does not compute a checksum during timing. + +This comparison isolates final result-list allocation on a large output stream. Both paths still include the compiled iterator's work and allocation. Fold includes the scalar callback. **Parsing, plan preparation, input generation, rendering, and stdout are excluded.** The input remains a complete in-memory JSON array. This is not a streaming JSON parser or a peak-memory measurement. + +Before timing, the benchmark requires the compiled backend, checks the full collected list against the fixture, and checks the fold checksum. It repeats these checks after warmup and each sample, outside timing. Unexpected values, errors, halts, or checksums stop the run. The checksum is a consumption check, not a full proof of fold result order. + +This workload defaults to 100 operations per sample and 10 warmup operations per path. `--iterations` and `--warmup` can reduce these counts, but this table caps them at 100 and 10. It uses the requested `--samples` count, with alternating path order and the same timer and allocation counters as the other tables. + +The table reports median `F ns/op`, `L ns/op`, `F B/op`, and `L B/op`. Deltas are `(F / L - 1) * 100`. Negative values mean less time or allocation for fold. There is no performance threshold. + +### Input-inclusive selective reader + +The fourth table compares two paths from the same generated JSON string to the complete rendered result: + +- Candidate (`C`) calls `Core.run_input` with a `Core.String` source. +- Reference (`R`) calls `Json.parse_string`, then the existing `Core.run` on the parsed value. + +Both timed paths include query parsing, JSON parsing and validation, preparation, execution, and rendering. Both use `debug=false`, `colorize=false`, `verbose=false`, `raw=false`, and `summarize=false`. Payload generation and result checks are outside timing. + +Each valid object has a small `"keep":{"value":42}` member and a `discard` member containing 64 nested arrays of 256 integers, from 0 through 16,383. The early and late payloads contain the same members in opposite order. The output records their byte length. + +| Workload | Query | Position and expected result | +|---|---|---| +| `input_early_keep` | `.keep.value` | `keep` first, before the large discarded member. Returns `42`. | +| `input_late_keep` | `.keep.value` | `keep` last, after the large discarded member. Returns `42`. | +| `input_full_fallback` | `length` | Early payload with a full-input interpreted query. Returns `2`. | + +**Every input byte is validated.** Selection only avoids retaining or materializing discarded containers after an early matched root key. The late-selected case must parse the large member before finding `keep`, so it exposes the position-dependent cost. The fallback control requires the complete object. The source String itself remains retained in all cases. Allocated bytes per operation measure allocation volume, not retained memory or peak RSS. + +Before timing, the benchmark checks each backend, requires the reference to equal the rendered fixed expected result, and compares the exact candidate and reference `Ok string` or `Error string` results. It repeats exact result checks after each path's warmup and at every sample endpoint. These checks are outside timing. A mismatch stops the run. + +Each case defaults to 100 operations per sample and 10 warmup operations per path. `--iterations` and `--warmup` can reduce these counts, but this table caps them at 100 and 10. It uses the requested sample count, alternating path order, and the existing timer and allocation counters. + +The table reports median `C ns/op`, `R ns/op`, `C B/op`, and `R B/op`. Deltas are `(C / R - 1) * 100`. Compare the early and late rows to report position effects, and use the fallback row to assess full-input overhead. There is no hard performance pass threshold. + +### First rendered result + +The `event_member_first` row reads `benchmarks/big.json` before timing and wraps its array as `{"rows":,"tail":0}`. The query is `.rows[] | .id`. It compares the first emitted result of `Core.run_input_iter` (`S`) with the complete return of `Core.run_input` (`A`), both on the same retained `Core.String` source. + +Before timing, the benchmark requires a compiled plan and a `Member_items ("rows", ...)` cut through `Execution.For_test.stream_cut`. It collects the iterator's complete rendered output array and the atomic call's rendered string, requires their joined forms to match, and requires the first output to be `1`. + +Each paired sample makes one fresh call per path and alternates their order. `--samples` sets the number of pairs. `--warmup` is capped at three calls per path. `--iterations` does not apply to this table. Immediately before each call, the benchmark runs `Gc.full_major ()`, reads `Gc.allocated_bytes ()`, and reads `Unix.gettimeofday ()`. For `S`, the first emit callback records elapsed nanoseconds and allocated bytes before it checks the result, then the call continues to EOF and checks every rendered output, its order, and the final count against the expected array. For `A`, the measurement stops when `Core.run_input` returns, and the result is checked against the expected string. An error or mismatch fails the run. + +The measurement includes query parsing and preparation, JSON parsing, execution, and rendering. `S` measures time to the first complete child; `A` parses, validates, executes, and renders the complete document before returning. Fixture load and generation, process startup, stdout, and result checks are excluded. The source string and expected output remain retained. This measures library call latency, not the first byte observed from a CLI process. + +The row reports medians for `S first ns`, `A complete ns`, `S first B`, and `A complete B`, followed by time delta, allocation delta, and samples. Deltas are `(S / A - 1) * 100`. **B is allocation volume to the reported endpoint, not peak RSS or total allocation through EOF.** There is no performance threshold. + +### Measure observed CLI peak RSS on Linux + +Use a separate fresh-process measurement for peak RSS. Run this procedure from the repository root on Linux with GNU `/usr/bin/time`. Build once, create the wrapped fixture once, then alternate the two CLI modes across repeated pairs: + +```bash +opam exec --switch=query-json-ocaml-5.5-beta1 -- \ + dune build --root . --profile=release cli/cli.exe + +binary="$PWD/_build/default/cli/cli.exe" +results=$(mktemp -d) +{ + printf '{"rows":' + cat benchmarks/big.json + printf ',"tail":0}' +} > "$results/member.json" + +"$binary" --no-color '.rows[] | .id' "$results/member.json" > "$results/default.out" +"$binary" --no-color --stream-output '.rows[] | .id' "$results/member.json" > "$results/ready.out" +cmp "$results/default.out" "$results/ready.out" || exit 1 + +for pair in 1 2 3 4 5 6 7 8 9 10; do + if [ $((pair % 2)) -eq 1 ]; then + modes='ready default' + else + modes='default ready' + fi + for mode in $modes; do + if [ "$mode" = ready ]; then + /usr/bin/time -v -o "$results/$pair-$mode.time" \ + "$binary" --no-color --stream-output '.rows[] | .id' "$results/member.json" > /dev/null || exit 1 + else + /usr/bin/time -v -o "$results/$pair-$mode.time" \ + "$binary" --no-color '.rows[] | .id' "$results/member.json" > /dev/null || exit 1 + fi + done +done +printf 'Reports: %s\n' "$results" +``` + +Read `Maximum resident set size (kbytes)` from each report. Calculate a median separately for each mode across all ten runs. For an even count, average the two middle sorted values. Keep the individual values and report their range. Repeat the paired series on an idle machine before drawing conclusions. Record the fixture byte count, platform, OCaml version, build profile, GC settings, and commands with the results. + +Each timed command starts a fresh CLI process, reads the same file, and sends stdout to `/dev/null`. These measurements include startup, parsing, execution, rendering, and output handling. Default mode collects output atomically. Ready mode flushes each output, so this comparison also includes different result collection and output handling costs. It does not isolate only the underlying streaming-versus-atomic execution path. + +Report these values as **observed max RSS for this fixture/platform**. They do not establish bounded or constant memory. Complete children, retained member prefixes, runtime heap sizing, and rendering can affect RSS. This procedure is separate from the allocation-volume and first-callback table. It has no pass/fail threshold. + +### Measurement limits + +- The prepared-execution and prepared-sink tables exclude query parsing, preparation, and rendering. The one-shot, input-inclusive, and first-result tables include them. The input-inclusive and first-result tables include JSON parsing. First-result timing ends at the first callback for the streamed path (`S`), before result checks; for the atomic path (`A`) it ends when the call returns, after full validation, execution, and rendering. All tables exclude fixture generation, result checks, startup, and stdout. None measures end-to-end CLI latency. +- Allocation uses the difference between `Gc.allocated_bytes` readings. It includes minor- and major-heap allocations without counting promotion twice. It is allocation volume, not retained memory or peak RSS. +- `Gc.full_major ()` runs before each sample, outside timing. Collections triggered during execution remain in the measurement. The loop, sink store, and small fixed timer/counter overhead are included and are not subtracted. +- Elapsed time uses `Unix.gettimeofday`, matching the existing parser benchmark without adding dependencies. This wall clock can change. Non-positive durations fail the run, but positive clock jumps and scheduling noise can still distort results. Nanoseconds are converted from seconds, not clock resolution. The first-result table measures one call per sample rather than a batch. +- Medians and alternating order reduce noise but do not supply confidence intervals. Repeat runs before drawing conclusions, especially for small fallback differences. CPU frequency, system load, compiler version, and GC settings affect results. +- These deterministic fixtures time successful integer/boolean execution and fallback paths. Error checks are untimed. They do not measure errors, effects, halt behavior, large numbers, arbitrary JSON shapes, every supported query, peak streaming memory, or other rendering options. Use the execution tests for broader correctness coverage. +- The one-shot reference copies the former `Core.run` behavior. Review it if parsing, error handling, or rendering changes. The candidate calls `Core.run` directly so its measured preparation cost cannot drift from that library entry point. + ## GC Pressure / OCaml Compactor Benchmark `bench_gc_pressure` is an in-process benchmark for comparing OCaml runtime GC and compaction behavior. It is intended for testing runtime branches such as [`new_compactor`](https://github.com/sadiqj/ocaml/tree/new_compactor), where CLI wall-clock benchmarks hide the compactor signal behind process startup, parsing, and I/O noise. diff --git a/benchmarks/bench_execution.ml b/benchmarks/bench_execution.ml new file mode 100644 index 0000000..0c1d349 --- /dev/null +++ b/benchmarks/bench_execution.ml @@ -0,0 +1,727 @@ +type workload = { + name : string; + query : string; + payload : string; + backend : Execution.For_test.backend; + iterations : int; + expected : Json.t list; +} + +type 'a prepared = { + workload : workload; + reference : 'a; + execution : unit -> 'a; + interpreter : unit -> 'a; +} + +type measurement = { ns : float; bytes : float } + +let rows = 128 + +let array_payload = + "[" + ^ String.concat "," + (List.init rows (fun i -> + Printf.sprintf {|{"id":%d,"score":%d,"active":%b}|} i (i mod 100) + (i mod 2 = 0) + ) + ) + ^ "]" + +let deep_payload = + {|{"root":{"groups":[{}, + {"members":[{"profile":{"stats":{"scores":[ + {"value":3},{"value":7},{"value":42} + ]}}}]}]}}|} + +let workloads = + [ + { + name = "deep_scalar_chain"; + query = ".root.groups[1].members[0].profile.stats.scores[2].value"; + payload = deep_payload; + backend = Execution.For_test.Compiled; + iterations = 100_000; + expected = [ `Int 42 ]; + }; + { + name = "scalar_predicate"; + query = ".price * .quantity + .fee > .limit and .active"; + payload = {|{"price":17,"quantity":4,"fee":3,"limit":60,"active":true}|}; + backend = Execution.For_test.Compiled; + iterations = 50_000; + expected = [ `Bool true ]; + }; + { + name = "iterator_select_field"; + query = ".[] | select(.active and .score >= 50) | .id"; + payload = array_payload; + backend = Execution.For_test.Compiled; + iterations = 2_000; + expected = List.init 25 (fun i -> `Int (50 + (2 * i))); + }; + { + name = "map_transform"; + query = "map(.score * 2 + .id)"; + payload = array_payload; + backend = Execution.For_test.Compiled; + iterations = 2_000; + expected = + [ `List (List.init rows (fun i -> `Int ((i mod 100 * 2) + i))) ]; + }; + { + name = "fallback_length"; + query = ".root.groups | length"; + payload = deep_payload; + backend = Execution.For_test.Interpreted; + iterations = 100_000; + expected = [ `Int64 2L ]; + }; + ] + +let backend_name = function + | Execution.For_test.Compiled -> + "compiled" + | Execution.For_test.Interpreted -> + "fallback" + +let rec describe_json : Json.t -> string = function + | `Int n -> + Printf.sprintf "Int(%d)" n + | `Int64 n -> + Printf.sprintf "Int64(%Ld)" n + | `List values -> + "[" ^ String.concat "; " (List.map describe_json values) ^ "]" + | value -> + Json.to_string value + +let describe_result : Interpreter.execute_result -> string = function + | Ok values -> + "Ok " ^ describe_json (`List values) + | Error message -> + "Error " ^ message + | Halt code -> + Printf.sprintf "Halt %d" code + +let check_result name expected actual = + (* Structural equality preserves result order and numeric constructors. These + fixtures use finite integers and booleans, so NaN equality is not needed. *) + if actual <> expected then + failwith + (Printf.sprintf "%s: result mismatch\nexpected: %s\nactual: %s" name + (describe_result expected) (describe_result actual) + ) + +let render results = + results + |> List.map (Json.to_string_pretty ~colorize:false ~summarize:false ~raw:false) + |> String.concat "\n" + +let one_shot_candidate query json = + Core.run ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false query json + +(* Keep this path aligned with Core.run before it started preparing plans. *) +let former_core_run ?(debug = false) ?(colorize = true) ?(verbose = false) + ?(raw = false) ?(summarize = false) query json = + match Core.parse ~debug ~colorize query with + | Error error -> + Error error + | Ok expr -> ( + match Interpreter.execute ~colorize ~verbose expr json with + | Ok results -> + Ok + (results + |> List.map (Json.to_string_pretty ~colorize ~summarize ~raw) + |> String.concat "\n" + ) + | Error error -> + Error error + | Halt code -> + exit code + ) + +let one_shot_reference query json = + former_core_run ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false query json + +let check_string_result name expected actual = + let describe = function + | Ok output -> + Printf.sprintf "Ok %S" output + | Error error -> + Printf.sprintf "Error %S" error + in + if actual <> expected then + failwith + (Printf.sprintf "%s: one-shot result mismatch\nexpected: %s\nactual: %s" + name (describe expected) (describe actual) + ) + +let check_one_shot_errors () = + List.iter + (fun (name, query, json) -> + let reference = one_shot_reference query json in + ( match reference with + | Error _ -> + () + | Ok _ -> + failwith (name ^ ": expected an error") + ); + check_string_result name reference (one_shot_candidate query json) + ) + [ ("parse error", "[", `Null); ("runtime error", ".missing", `Assoc []) ] + +let prepare workload = + let expr = + match Core.parse ~debug:false ~colorize:false workload.query with + | Ok expr -> + expr + | Error message -> + failwith (workload.name ^ ": query parse error: " ^ message) + in + let json = + match Json.parse_string workload.payload with + | Ok json -> + json + | Error message -> + failwith (workload.name ^ ": JSON parse error: " ^ message) + in + let plan = Execution.prepare expr in + let actual_backend = Execution.For_test.backend plan in + if actual_backend <> workload.backend then + failwith + (Printf.sprintf "%s: expected %s backend, got %s" workload.name + (backend_name workload.backend) + (backend_name actual_backend) + ); + let execution () = + Execution.execute ~colorize:false ~verbose:false plan json + in + let interpreter () = + Interpreter.execute ~colorize:false ~verbose:false expr json + in + let reference = interpreter () in + check_result + (workload.name ^ " fixture") + (Interpreter.Ok workload.expected) reference; + check_result workload.name reference (execution ()); + let prepared = { workload; reference; execution; interpreter } in + let execution () = one_shot_candidate workload.query json in + let interpreter () = one_shot_reference workload.query json in + let reference = interpreter () in + check_string_result + (workload.name ^ " fixture") + (Ok (render workload.expected)) + reference; + check_string_result workload.name reference (execution ()); + let one_shot = + { + workload = { workload with iterations = min 5_000 workload.iterations }; + reference; + execution; + interpreter; + } + in + (prepared, one_shot) + +let repeat sink iterations run = + let run = Sys.opaque_identity run in + for _ = 1 to iterations do + sink := Sys.opaque_identity (run ()) + done + +let measure ~check ~empty sink iterations run = + sink := empty; + Gc.full_major (); + let before = Gc.allocated_bytes () in + let start = Unix.gettimeofday () in + repeat sink iterations run; + let elapsed = Unix.gettimeofday () -. start in + let allocated = Gc.allocated_bytes () -. before in + check !sink; + if elapsed <= 0.0 then + failwith + "Non-positive elapsed time. Increase --iterations or check the clock."; + let count = Float.of_int iterations in + { ns = elapsed *. 1e9 /. count; bytes = allocated /. count } + +let median values = + let sorted = Array.of_list values in + Array.sort Float.compare sorted; + let n = Array.length sorted in + if n mod 2 = 0 then + (sorted.((n / 2) - 1) +. sorted.(n / 2)) /. 2.0 + else + sorted.(n / 2) + +let summarize results = + { + ns = median (List.map (fun r -> r.ns) results); + bytes = median (List.map (fun r -> r.bytes) results); + } + +let parse_args () = + let iterations = ref None in + let warmup = ref 1_000 in + let samples = ref 5 in + let positive flag set n = + if n <= 0 then raise (Arg.Bad (flag ^ " requires a positive integer")); + set n + in + Arg.parse + [ + ( "--iterations", + Arg.Int (positive "--iterations" (fun n -> iterations := Some n)), + "N Override operations per sample (sink/input capped at 100; \ + first-result unaffected)" + ); + ( "--warmup", + Arg.Int (positive "--warmup" (fun n -> warmup := n)), + "N Warmup operations per path (default 1000; sink/input capped at 10; \ + first-result at 3)" + ); + ( "--samples", + Arg.Int (positive "--samples" (fun n -> samples := n)), + "N Paired samples per workload (default 5)" + ); + ] + (fun arg -> raise (Arg.Bad ("Unexpected argument: " ^ arg))) + "bench_execution [--iterations N] [--warmup N] [--samples N]"; + (!iterations, !warmup, !samples) + +let bench ~check ~empty ~iterations ~warmup ~samples prepared = + let iterations = + Option.value iterations ~default:prepared.workload.iterations + in + let sink = ref empty in + repeat sink warmup prepared.execution; + check prepared.workload.name prepared.reference !sink; + repeat sink warmup prepared.interpreter; + check prepared.workload.name prepared.reference !sink; + let execution = ref [] in + let interpreter = ref [] in + let sample run results = + results := + measure + ~check:(check prepared.workload.name prepared.reference) + ~empty sink iterations run + :: !results + in + for i = 1 to samples do + if i mod 2 = 1 then begin + sample prepared.execution execution; + sample prepared.interpreter interpreter + end else begin + sample prepared.interpreter interpreter; + sample prepared.execution execution + end + done; + let execution = summarize !execution in + let interpreter = summarize !interpreter in + Printf.printf + "%-23s %-8s %8d %12.1f %12.1f %10.1f %10.1f %+9.1f%% %+9.1f%%\n%!" + prepared.workload.name + (backend_name prepared.workload.backend) + iterations execution.ns interpreter.ns execution.bytes interpreter.bytes + (((execution.ns /. interpreter.ns) -. 1.0) *. 100.0) + (((execution.bytes /. interpreter.bytes) -. 1.0) *. 100.0) + +let bench_sink ~iterations ~warmup ~samples = + let rows = 16_384 in + let iterations = min 100 (Option.value iterations ~default:100) in + let warmup = min 10 warmup in + let values = List.init rows (fun i -> `Int (i + 1)) in + let input = `List values in + let expr = + match Core.parse ~debug:false ~colorize:false ".[]" with + | Ok expr -> + expr + | Error message -> + failwith message + in + let plan = Execution.prepare expr in + if Execution.For_test.backend plan <> Execution.For_test.Compiled then + failwith "large_stream_sink: expected compiled backend"; + let collect () = + Execution.execute ~colorize:false ~verbose:false plan input + in + let fold () = + Execution.fold ~colorize:false ~verbose:false ~init:0 + ~f:(fun sum -> function + | `Int n -> + sum + n + | _ -> + failwith "large_stream_sink: expected integer" + ) + plan input + in + let check_list = check_result "large_stream_sink" (Interpreter.Ok values) in + let check_fold = function + | Execution.Completed sum when sum = rows * (rows + 1) / 2 -> + () + | Execution.Completed sum -> + failwith (Printf.sprintf "large_stream_sink: unexpected checksum %d" sum) + | Execution.Failed message -> + failwith ("large_stream_sink: " ^ message) + | Execution.Halted code -> + failwith (Printf.sprintf "large_stream_sink: unexpected halt %d" code) + in + check_list (collect ()); + check_fold (fold ()); + let list_sink = ref (Interpreter.Ok []) in + let fold_sink = ref (Execution.Completed 0) in + repeat list_sink warmup collect; + check_list !list_sink; + repeat fold_sink warmup fold; + check_fold !fold_sink; + let collected = ref [] in + let folded = ref [] in + let sample_list () = + collected := + measure ~check:check_list ~empty:(Interpreter.Ok []) list_sink iterations + collect + :: !collected; + list_sink := Interpreter.Ok [] + in + let sample_fold () = + folded := + measure ~check:check_fold ~empty:(Execution.Completed 0) fold_sink + iterations fold + :: !folded + in + list_sink := Interpreter.Ok []; + for i = 1 to samples do + if i mod 2 = 1 then begin + sample_fold (); + sample_list () + end else begin + sample_list (); + sample_fold () + end + done; + let folded = summarize !folded in + let collected = summarize !collected in + Printf.printf + "\n\ + Prepared sink: F = Execution.fold checksum; L = Execution.execute list.\n\ + Query: .[]; %d integers; checksum %d; %d warmup operations per path.\n\ + Parsing, preparation, rendering, and result checks excluded.\n\n" + rows + (rows * (rows + 1) / 2) + warmup; + Printf.printf "%-23s %-8s %8s %12s %12s %10s %10s %10s %10s\n%!" "Workload" + "Backend" "Ops/sample" "F ns/op" "L ns/op" "F B/op" "L B/op" "Time delta" + "Alloc delta"; + Printf.printf + "%-23s %-8s %8d %12.1f %12.1f %10.1f %10.1f %+9.1f%% %+9.1f%%\n%!" + "large_stream_sink" "compiled" iterations folded.ns collected.ns + folded.bytes collected.bytes + (((folded.ns /. collected.ns) -. 1.0) *. 100.0) + (((folded.bytes /. collected.bytes) -. 1.0) *. 100.0) + +let bench_input ~iterations ~warmup ~samples = + let groups = 64 in + let width = 256 in + let discarded = + {|"discard":{"nested":[|} + ^ String.concat "," + (List.init groups (fun group -> + "[" + ^ String.concat "," + (List.init width (fun i -> string_of_int ((group * width) + i))) + ^ "]" + ) + ) + ^ "]}" + in + let keep = {|"keep":{"value":42}|} in + let early = "{" ^ keep ^ "," ^ discarded ^ "}" in + let late = "{" ^ discarded ^ "," ^ keep ^ "}" in + let iterations = min 100 (Option.value iterations ~default:100) in + let warmup = min 10 warmup in + let prepare_input (name, query, payload, backend, expected) = + let workload = { name; query; payload; backend; iterations; expected } in + let expr = + match Core.parse ~debug:false ~colorize:false query with + | Ok expr -> + expr + | Error message -> + failwith (name ^ ": query parse error: " ^ message) + in + if Execution.For_test.backend (Execution.prepare expr) <> backend then + failwith (name ^ ": unexpected backend"); + let execution () = + Core.run_input ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false query (Core.String payload) + in + let interpreter () = + match Json.parse_string payload with + | Ok json -> + one_shot_candidate query json + | Error message -> + Error message + in + let reference = interpreter () in + check_string_result (name ^ " fixture") (Ok (render expected)) reference; + check_string_result name reference (execution ()); + { workload; reference; execution; interpreter } + in + let prepared = + List.map prepare_input + [ + ( "input_early_keep", + ".keep.value", + early, + Execution.For_test.Compiled, + [ `Int 42 ] + ); + ( "input_late_keep", + ".keep.value", + late, + Execution.For_test.Compiled, + [ `Int 42 ] + ); + ( "input_full_fallback", + "length", + early, + Execution.For_test.Interpreted, + [ `Int64 2L ] + ); + ] + in + Printf.printf + "\n\ + Input-inclusive: C = Core.run_input (String); R = Json.parse_string + \ + Core.run.\n\ + %d nested arrays of %d integers; %d payload bytes; %d warmup operations \ + per path.\n\ + Early/late query: .keep.value; full-input fallback control: length.\n\ + Includes query parsing, JSON parsing/validation, preparation, execution, \ + and rendering.\n\ + Payload generation and result checks excluded; every input byte is \ + validated.\n\ + Selection avoids discarded container materialization only after a matched \ + root key.\n\ + String input remains retained; B/op is allocation volume, not peak RSS.\n" + groups width (String.length early) warmup; + Printf.printf "\n%-23s %-8s %8s %12s %12s %10s %10s %10s %10s\n%!" "Workload" + "Backend" "Ops/sample" "C ns/op" "R ns/op" "C B/op" "R B/op" "Time delta" + "Alloc delta"; + List.iter + (bench ~check:check_string_result ~empty:(Ok "") ~iterations:None ~warmup + ~samples + ) + prepared + +let bench_first_result ~warmup ~samples = + let name = "event_member_first" in + let query = ".rows[] | .id" in + let payload = + {|{"rows":|} + ^ In_channel.with_open_bin "benchmarks/big.json" In_channel.input_all + ^ {|,"tail":0}|} + in + let input = Core.String payload in + let expr = + match Core.parse ~debug:false ~colorize:false query with + | Ok expr -> + expr + | Error message -> + failwith (name ^ ": " ^ message) + in + let plan = Execution.prepare expr in + if Execution.For_test.backend plan <> Execution.For_test.Compiled then + failwith (name ^ ": expected compiled backend"); + ( match Execution.For_test.stream_cut plan with + | Some (Execution.For_test.Member_items ("rows", _)) -> + () + | _ -> + failwith (name ^ ": expected Member_items rows cut") + ); + let check_status = function + | Ok _ -> + () + | Error message -> + failwith (name ^ ": " ^ message) + in + let collect () = + let outputs = ref [] in + Core.run_input_iter ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false + ~emit:(fun value -> outputs := value :: !outputs) + query input + |> check_status; + Array.of_list (List.rev !outputs) + in + let expected = collect () in + let expected_atomic = + match + Core.run_input ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false query input + with + | Ok result -> + result + | Error message -> + failwith (name ^ ": " ^ message) + in + if String.concat "\n" (Array.to_list expected) <> expected_atomic then + failwith (name ^ ": streamed output does not match atomic output"); + if Array.length expected = 0 || expected.(0) <> "1" then + failwith (name ^ ": expected first rendered output 1"); + let measure_first_streamed () = + let index = ref 0 in + let first = ref None in + let before = ref 0.0 in + let start = ref 0.0 in + let emit value = + ( match !first with + | None -> + let ns = (Unix.gettimeofday () -. !start) *. 1e9 in + let bytes = Gc.allocated_bytes () -. !before in + first := Some { ns; bytes } + | Some _ -> + () + ); + if !index >= Array.length expected || value <> expected.(!index) then + failwith (Printf.sprintf "%s: output mismatch at index %d" name !index); + incr index + in + Gc.full_major (); + before := Gc.allocated_bytes (); + start := Unix.gettimeofday (); + Core.run_input_iter ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false ~emit query input + |> check_status; + if !index <> Array.length expected then + failwith (name ^ ": incomplete output"); + match !first with + | Some measurement when measurement.ns > 0.0 -> + measurement + | _ -> + failwith (name ^ ": missing first result or non-positive elapsed time") + in + let measure_complete_atomic () = + Gc.full_major (); + let before = Gc.allocated_bytes () in + let start = Unix.gettimeofday () in + let result = + Core.run_input ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false query input + in + let ns = (Unix.gettimeofday () -. start) *. 1e9 in + let bytes = Gc.allocated_bytes () -. before in + ( match result with + | Ok value when value = expected_atomic -> + () + | Ok _ -> + failwith (name ^ ": atomic output mismatch") + | Error message -> + failwith (name ^ ": " ^ message) + ); + if ns <= 0.0 then failwith (name ^ ": non-positive elapsed time"); + { ns; bytes } + in + let warmup = min 3 warmup in + for _ = 1 to warmup do + ignore (measure_first_streamed ()); + ignore (measure_complete_atomic ()) + done; + let streamed = ref [] in + let atomic = ref [] in + for i = 1 to samples do + if i mod 2 = 1 then begin + streamed := measure_first_streamed () :: !streamed; + atomic := measure_complete_atomic () :: !atomic + end else begin + atomic := measure_complete_atomic () :: !atomic; + streamed := measure_first_streamed () :: !streamed + end + done; + let streamed = summarize !streamed in + let atomic = summarize !atomic in + Printf.printf + "\n\ + First rendered result: S = first Core.run_input_iter result; A = complete \ + Core.run_input result.\n\ + Fixture: benchmarks/big.json wrapped as {\"rows\":,\"tail\":0}; \ + query: %s.\n\ + Compiled Member_items rows cut; %d input bytes; %d outputs; first output 1.\n\ + One fresh call per path per paired sample, both over the same retained \ + Core.String.\n\ + %d warmup calls per path; alternating sample order; --iterations does not \ + apply.\n\ + Includes query parse/prepare, JSON parsing, execution, rendering. S \ + measures time to the first complete child; A measures time to the \ + complete rendered result.\n\ + Excludes fixture load/generation, process startup, stdout; source string \ + stays retained.\n\ + S records time/allocation at its first callback, before result checking, \ + then continues to EOF and checks every output. A records time/allocation \ + when the call returns, then checks the result.\n\ + B is allocation volume, not peak RSS. No performance threshold.\n\n" + query (String.length payload) (Array.length expected) warmup; + Printf.printf "%-23s %12s %12s %12s %12s %10s %10s %7s\n%!" "Workload" + "S first ns" "A complete ns" "S first B" "A complete B" "Time delta" + "Alloc delta" "Samples"; + Printf.printf "%-23s %12.1f %12.1f %12.1f %12.1f %+9.1f%% %+9.1f%% %7d\n%!" + name streamed.ns atomic.ns streamed.bytes atomic.bytes + (((streamed.ns /. atomic.ns) -. 1.0) *. 100.0) + (((streamed.bytes /. atomic.bytes) -. 1.0) *. 100.0) + samples + +let () = + let iterations, warmup, samples = parse_args () in + let prepared, one_shot = List.split (List.map prepare workloads) in + check_one_shot_errors (); + let gc = Gc.get () in + Printf.printf + "Execution benchmark: OCaml %s, %d-bit, %s\n\ + GC: minor_heap_size=%d words, space_overhead=%d, allocation_policy=%d\n\ + %d workloads verified in both modes before timing; array fixtures contain \ + %d rows.\n\ + One-shot parse/runtime error checks passed (not timed).\n\ + %d paired samples, %d warmup operations per path in the first two tables; \ + medians below.\n\ + Clock: Unix.gettimeofday.\n\ + Deltas = (candidate / reference - 1) * 100; positive means slower / more \ + allocation.\n\n" + Sys.ocaml_version Sys.word_size Sys.os_type gc.minor_heap_size + gc.space_overhead gc.allocation_policy (List.length prepared) rows samples + warmup; + List.iter + (fun p -> Printf.printf "%s: %s\n" p.workload.name p.workload.query) + prepared; + Printf.printf + "\n\ + Prepared execution: E = prepared Execution; I = Interpreter.\n\ + Query/JSON parsing, preparation, rendering, startup, and stdout excluded.\n"; + Printf.printf "\n%-23s %-8s %8s %12s %12s %10s %10s %10s %10s\n%!" "Workload" + "Backend" "Ops/sample" "E ns/op" "I ns/op" "E B/op" "I B/op" "Time delta" + "Alloc delta"; + List.iter + (bench ~check:check_result ~empty:(Interpreter.Ok []) ~iterations ~warmup + ~samples + ) + prepared; + Printf.printf + "\n\ + One-shot library: C = Core.run; R = former parse/interpret/render path.\n\ + Includes query parsing, per-call preparation (C only), execution, and \ + rendering.\n\ + Already parsed JSON; JSON parsing, startup, and stdout excluded.\n\ + Options: debug=false, colorize=false, verbose=false, raw=false, \ + summarize=false.\n"; + Printf.printf "\n%-23s %-8s %8s %12s %12s %10s %10s %10s %10s\n%!" "Workload" + "Backend" "Ops/sample" "C ns/op" "R ns/op" "C B/op" "R B/op" "Time delta" + "Alloc delta"; + List.iter + (bench ~check:check_string_result ~empty:(Ok "") ~iterations ~warmup + ~samples + ) + one_shot; + bench_sink ~iterations ~warmup ~samples; + bench_input ~iterations ~warmup ~samples; + bench_first_result ~warmup ~samples; + Printf.printf + "\nAll result checks passed, including warmup and sample endpoints.\n" diff --git a/benchmarks/dune b/benchmarks/dune index 6d67a3d..6ab65ac 100644 --- a/benchmarks/dune +++ b/benchmarks/dune @@ -5,3 +5,7 @@ (executable (name bench_gc_pressure) (libraries query-json.core unix)) + +(executable + (name bench_execution) + (libraries query-json.core unix)) diff --git a/cli/cli.ml b/cli/cli.ml index 7d84329..31399d4 100644 --- a/cli/cli.ml +++ b/cli/cli.ml @@ -15,6 +15,13 @@ end let print_error_message ~colorize:_ str = print_endline (Console_style.enter 1 ^ str ^ Console_style.enter 1) +(* --stream-output can leave already-flushed results on stdout, so the + terminal error must go to stderr with a failing exit code instead of + sharing stdout with the results it followed. *) +let exit_with_stream_error str = + prerr_endline (Console_style.enter 1 ^ str ^ Console_style.enter 1); + Stdlib.exit 1 + let usage ?(colorize = true) () = let t = Console_style.make ~colorize in [ @@ -27,6 +34,8 @@ let usage ?(colorize = true) () = Console_style.indent 3 ^ "-r, --raw-output: Output raw strings, not JSON texts"; Console_style.indent 3 + ^ "--stream-output: Flush each result as it is produced"; + Console_style.indent 3 ^ "-n, --null-input: Run filter with null as input (no input read)"; Console_style.indent 3 ^ "-v, --verbose: Activate verbossity"; Console_style.indent 3 ^ "-d, --debug: Print AST"; @@ -62,8 +71,6 @@ let repl_usage ?(colorize = true) () = |> String.concat (Console_style.enter 1) |> print_endline -let ( let* ) = Result.bind - (* When JSON is piped via stdin (e.g., `cat data.json | query-json --repl`), stdin is consumed by the JSON parser. The REPL then needs stdin for interactive keyboard input, but it's exhausted/closed from the pipe. This function reconnects stdin to /dev/tty (the controlling terminal), @@ -78,7 +85,7 @@ let reconnect_stdin_to_tty () = with Unix.Unix_error _ -> false let execution position_0 position_1 verbose debug no_color raw_output null_input - repl functions = + stream_output repl functions = let colorize = not no_color in if Option.is_some functions then match functions with @@ -170,25 +177,43 @@ let execution position_0 position_1 verbose debug no_color raw_output null_input | None -> usage () | Some query -> ( - let output = - let* json = - if null_input then - Ok `Null - else - match position_1 with - | Some f when Sys.file_exists f -> - Json.parse_file f - | Some s -> - Json.parse_string s - | None -> - Json.parse_channel (Unix.in_channel_of_descr Unix.stdin) - in - Core.run ~debug ~colorize ~verbose ~raw:raw_output ~summarize:false - query json + let input = + if null_input then + Core.Value `Null + else + match position_1 with + | Some f when Sys.file_exists f -> + Core.File f + | Some s -> + Core.String s + | None -> + Core.Channel (Unix.in_channel_of_descr Unix.stdin) in - match output with - | Ok results -> - print_endline results + (* One line per result in both modes. --stream-output flushes each line + as it is produced; the default holds every line until the query has + succeeded, so stdout stays all-or-nothing. *) + let held = Buffer.create 4096 in + let emit line = + if stream_output then ( + output_string stdout line; + output_char stdout '\n'; + flush stdout + ) else ( + Buffer.add_string held line; + Buffer.add_char held '\n' + ) + in + match + Core.run_input_iter ~debug ~colorize ~verbose ~raw:raw_output + ~summarize:false ~emit query input + with + | Ok 0 -> + (* no results still end the output with one line break *) + print_newline () + | Ok _ -> + print_string (Buffer.contents held) + | Error err when stream_output -> + exit_with_stream_error err | Error err -> print_error_message ~colorize err ) @@ -212,6 +237,13 @@ let () = value & flag & info [ "r"; "raw-output" ] ~doc:"Output raw strings, not JSON texts" in + let stream_output = + value & flag + & info [ "stream-output" ] + ~doc: + "Flush each result as it is produced. Earlier results remain if a \ + later result or input tail fails. Has no effect in REPL mode." + in let null_input = value & flag & info [ "n"; "null-input" ] @@ -233,7 +265,7 @@ let () = let term = let open Cmdliner.Term in const execution $ query $ json $ verbose $ debug $ color $ raw_output - $ null_input $ repl $ functions + $ null_input $ stream_output $ repl $ functions in let info = Cmdliner.Cmd.info "query-json" ~version:Info.version diff --git a/cli/test/basic.t b/cli/test/basic.t index e6f46dd..f5a5b45 100644 --- a/cli/test/basic.t +++ b/cli/test/basic.t @@ -62,3 +62,46 @@ raw output with string containing escape sequences $ printf '{"message": "Hello\\nWorld\\t!"}' | query-json --no-color -r '.message' Hello World ! + +stream output for multiple results + + $ query-json --no-color --stream-output '.[]' '[1,2,3]' + 1 + 2 + 3 + +empty stream output still writes one LF + + $ query-json --no-color --stream-output 'empty' 'null' | od -An -tx1 + 0a + +raw stream output preserves empty strings and embedded newlines + + $ query-json --no-color --stream-output -r '.[]' '["","a\nb","","\n",""]' | od -An -tx1 + 0a 61 0a 62 0a 0a 0a 0a 0a + +successful output bytes match default mode, including raw edge cases + + $ for options in '' '-r'; do + > for json in '[]' '[1,2,3]' '[""]' '["\n"]' '["","a\nb","","\n",""]'; do + > query-json --no-color $options '.[]' "$json" > default.out + > query-json --no-color --stream-output $options '.[]' "$json" > stream.out + > cmp default.out stream.out || exit 1 + > done + > done + +stream output keeps the prefix on stdout and sends the late error to stderr + + $ query-json --no-color --stream-output '.[] | .value' '[{"value":1},{"value":2},{}]' 2>&1 | sed '/^$/d' + 1 + 2 + error[key_not_found]: Key 'value' not found in object + in: {} + hint: Use .value? for optional access + +default output remains atomic on the same late error + + $ query-json --no-color '.[] | .value' '[{"value":1},{"value":2},{}]' | sed '/^$/d' + error[key_not_found]: Key 'value' not found in object + in: {} + hint: Use .value? for optional access diff --git a/cli/test/dune b/cli/test/dune index 1ffa966..cd98790 100644 --- a/cli/test/dune +++ b/cli/test/dune @@ -1,3 +1,17 @@ +(executable + (name stream_probe) + (enabled_if + (<> %{os_type} "Win32")) + (libraries unix runtime_events)) + (cram (alias runtest) + (applies_to basic errors functions null) (deps %{bin:query-json} ./mock.json)) + +(cram + (alias runtest) + (applies_to source) + (enabled_if + (<> %{os_type} "Win32")) + (deps %{bin:query-json} ./mock.json ./stream_probe.exe)) diff --git a/cli/test/source.t b/cli/test/source.t new file mode 100644 index 0000000..4cd1a08 --- /dev/null +++ b/cli/test/source.t @@ -0,0 +1,148 @@ +Root and member cuts drain both residual outputs while the input pipe stays open. + + $ ./stream_probe.exe "$(command -v query-json)" + root: before EOF "1\n11\n"; final "1\n11\n2\n12\n"; exit 0 + member: before EOF "1\n11\n"; final "1\n11\n2\n12\n"; exit 0 + raw: before EOF "\n"; final "\n\n"; exit 0 + +Selected and fallback queries give the same bytes for string, file, and channel input. + + $ json='{"keep":[{"value":1},{"value":2}],"discard":[3,4]}' + $ printf '%s' "$json" > source.json + $ printf '1\n2\n' > expected.out + $ for mode in '' '--stream-output'; do + > for query in '.keep[] | .value' 'fn chosen: .keep[] | .value; chosen'; do + > query-json --no-color $mode "$query" "$json" > string.out + > query-json --no-color $mode "$query" source.json > file.out + > query-json --no-color $mode "$query" < source.json > channel.out + > cmp expected.out string.out || exit 1 + > cmp expected.out file.out || exit 1 + > cmp expected.out channel.out || exit 1 + > done + > done + +An existing filename takes precedence over inline JSON. + + $ printf '{"keep":42}' > null + $ query-json --no-color '.keep' null + 42 + +Null input skips invalid inline and channel input in both output modes. + + $ for mode in '' '--stream-output'; do + > query-json --no-color $mode --null-input '.' '{' < source.json + > done + null + null + +Raw and empty selected results preserve output bytes in both modes and backends. + + $ for json in '{"keep":[]}' '{"keep":[""]}' '{"keep":["","a\nb","","\n",""]}'; do + > for raw in '' '-r'; do + > query-json --no-color $raw 'fn chosen: .keep[]; chosen' "$json" > expected.out + > for mode in '' '--stream-output'; do + > query-json --no-color $mode $raw '.keep[]' "$json" > selected.out + > cmp expected.out selected.out || exit 1 + > done + > done + > done + +Invalid JSON wins over an invalid query for every source and output mode. +Debug output must not appear. + + $ json='{"keep":[1,2],"discard":[}' + $ printf '%s' "$json" > invalid.json + $ query-json --no-color '.' "$json" > input-error.out + $ cat input-error.out + + JSON parse error: Line 1, bytes 25-26: + Invalid token '}' + + $ for mode in '' '--stream-output'; do + > query-json --no-color --debug $mode '[' "$json" > string.out 2>&1 + > query-json --no-color --debug $mode '[' invalid.json > file.out 2>&1 + > query-json --no-color --debug $mode '[' < invalid.json > channel.out 2>&1 + > cmp input-error.out string.out || exit 1 + > cmp input-error.out file.out || exit 1 + > cmp input-error.out channel.out || exit 1 + > done + +Valid input returns the saved query error in both modes. + + $ query-json --no-color --debug '[' source.json + + error[parse_error]: unexpected token, got end of input + --> [ + ^ + + $ query-json --no-color --debug --stream-output '[' source.json 2>&1 + + error[parse_error]: unexpected token, got end of input + --> [ + ^ + + [1] + + + +Debug prints the original AST once before execution, even when input is selected. + + $ query-json --no-color --debug '.keep[]' '{"keep":[1,2],"discard":[9]}' + (Pipe ((Key "keep"), (Index []))) + 1 + 2 + $ query-json --no-color --debug --stream-output '.keep[]' '{"keep":[1,2],"discard":[9]}' + (Pipe ((Key "keep"), (Index []))) + 1 + 2 + +Selected input remains atomic by default on a late execution error. + + $ query-json --no-color '.keep[] | .value' '{"keep":[{"value":1},{}],"discard":true}' | sed '/^$/d' + error[key_not_found]: Key 'value' not found in object + in: {} + hint: Use .value? for optional access + +Streamed selected input keeps results on stdout and sends the late error to stderr. + + $ query-json --no-color --stream-output '.keep[] | .value' '{"keep":[{"value":1},{}],"discard":true}' 2>&1 | sed '/^$/d' + 1 + error[key_not_found]: Key 'value' not found in object + in: {} + hint: Use .value? for optional access + +Fallback execution has the same atomic and streamed errors. + + $ for mode in '' '--stream-output'; do + > json='{"keep":[{"value":1},{}],"discard":true}' + > query-json --no-color $mode '.keep[] | .value' "$json" > selected.out 2>&1 + > query-json --no-color $mode 'fn chosen: .keep[] | .value; chosen' "$json" > fallback.out 2>&1 + > cmp selected.out fallback.out || exit 1 + > done + +Halt preserves its exit code and the output policy of each mode. + + $ query-json --no-color '1, halt_error(7), 2' 'null' + [7] + $ query-json --no-color --stream-output '1, halt_error(7), 2' 'null' + 1 + [7] + +Malformed discarded values and trailing bytes fail before AST or result output. +Their errors match full-input parsing, including when the query is invalid. + + $ for json in '{"keep":[1,2],"discard":[}' '{"keep":[1,2],"discard":"\q"}' '{"keep":[1,2],"discard":"\uD800"}' '{"keep":[1,2],"discard":1e}' '{"keep":[1,2]} trailing'; do + > printf '%s' "$json" > invalid.json + > query-json --no-color '.' "$json" > input-error.out + > grep -q 'JSON parse error:' input-error.out || exit 1 + > for mode in '' '--stream-output'; do + > for query in '.keep[]' 'fn chosen: .keep[]; chosen' '['; do + > query-json --no-color --debug $mode "$query" "$json" > string.out 2>&1 + > query-json --no-color --debug $mode "$query" invalid.json > file.out 2>&1 + > query-json --no-color --debug $mode "$query" < invalid.json > channel.out 2>&1 + > cmp input-error.out string.out || exit 1 + > cmp input-error.out file.out || exit 1 + > cmp input-error.out channel.out || exit 1 + > done + > done + > done diff --git a/cli/test/stream_probe.ml b/cli/test/stream_probe.ml new file mode 100644 index 0000000..9cf9424 --- /dev/null +++ b/cli/test/stream_probe.ml @@ -0,0 +1,202 @@ +let now () = + Runtime_events.Timestamp.get_current () + |> Runtime_events.Timestamp.to_int64 |> Int64.to_float + |> fun ns -> ns /. 1e9 + +let deadline () = now () +. 30.0 + +let remaining until = + let seconds = until -. now () in + if seconds <= 0.0 then failwith "thirty-second deadline expired"; + seconds + +let rec ready until reads writes = + let seconds = remaining until in + match Unix.select reads writes [] seconds with + | [], [], [] -> + ready until reads writes + | _ -> + () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> + ready until reads writes + +let write_all until fd text = + let rec loop offset = + if offset < String.length text then begin + ready until [] [ fd ]; + match + Unix.write_substring fd text offset (String.length text - offset) + with + | 0 -> + failwith "zero-byte pipe write" + | count -> + loop (offset + count) + | exception + Unix.Unix_error ((Unix.EINTR | Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) + -> + loop offset + end + in + loop 0 + +let rec read until fd bytes = + ready until [ fd ] []; + match Unix.read fd bytes 0 (Bytes.length bytes) with + | count -> + count + | exception + Unix.Unix_error ((Unix.EINTR | Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) -> + read until fd bytes + +let rec pause until = + let seconds = min 0.01 (remaining until) in + match Unix.select [] [] [] seconds with + | _ -> + () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> + pause until + +let rec poll until pid = + ignore (remaining until); + match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ -> + None + | _, status -> + Some status + | exception Unix.Unix_error (Unix.EINTR, _, _) -> + poll until pid + +let rec reap until pid = + match poll until pid with + | Some status -> + status + | None -> + pause until; + reap until pid + +let terminate until pid = + match poll until pid with + | Some status -> + status + | None -> + ( try Unix.kill pid Sys.sigkill + with Unix.Unix_error (Unix.ESRCH, _, _) -> () + ); + reap until pid + +let probe binary name raw query prefix tail expected_prefix expected = + let descriptors = ref [] in + let child = ref None in + let output = Buffer.create 32 in + let pipe () = + let r, w = Unix.pipe ~cloexec:true () in + descriptors := r :: w :: !descriptors; + (r, w) + in + let close fd = + if List.mem fd !descriptors then begin + descriptors := List.filter (( <> ) fd) !descriptors; + Unix.close fd + end + in + let cleanup () = + List.iter + (fun fd -> try close fd with Unix.Unix_error _ -> ()) + !descriptors; + match !child with + | None -> + () + | Some pid -> ( + let until = deadline () in + try + ignore (terminate until pid); + child := None + with exn -> + Printf.eprintf "%s cleanup: %s\n%!" name (Printexc.to_string exn) + ) + in + try + Fun.protect ~finally:cleanup (fun () -> + let input_read, input_write = pipe () in + let output_read, output_write = pipe () in + let arguments = + if raw then + [| binary; "--no-color"; "--stream-output"; "-r"; query |] + else + [| binary; "--no-color"; "--stream-output"; query |] + in + let pid = + Unix.create_process binary arguments input_read output_write + Unix.stderr + in + child := Some pid; + close input_read; + close output_write; + let until = deadline () in + write_all until input_write prefix; + let bytes = Bytes.create 64 in + let rec before_eof () = + let count = read until output_read bytes in + if count = 0 then failwith "stdout closed before the input tail"; + Buffer.add_subbytes output bytes 0 count; + let actual = Buffer.contents output in + if not (String.starts_with ~prefix:actual expected_prefix) then + failwith (Printf.sprintf "unexpected prefix %S" actual); + if actual <> expected_prefix then before_eof () + in + before_eof (); + ( match poll until pid with + | Some _ -> + child := None; + failwith "CLI exited before the input tail" + | None -> + () + ); + let first = Buffer.contents output in + let until = deadline () in + write_all until input_write tail; + close input_write; + let rec to_eof () = + let count = read until output_read bytes in + if count <> 0 then begin + Buffer.add_subbytes output bytes 0 count; + if not (String.starts_with ~prefix:(Buffer.contents output) expected) + then + failwith "unexpected final output"; + to_eof () + end + in + to_eof (); + let actual = Buffer.contents output in + if actual <> expected then failwith "incomplete final output"; + let status = reap until pid in + child := None; + ( match status with + | Unix.WEXITED 0 -> + () + | Unix.WEXITED code -> + failwith (Printf.sprintf "CLI exited %d" code) + | Unix.WSIGNALED signal -> + failwith (Printf.sprintf "CLI signal %d" signal) + | Unix.WSTOPPED signal -> + failwith (Printf.sprintf "CLI stopped %d" signal) + ); + Printf.printf "%s: before EOF %S; final %S; exit 0\n%!" name first + actual + ) + with exn -> + failwith + (Printf.sprintf "%s: %s; stdout %S" name (Printexc.to_string exn) + (Buffer.contents output) + ) + +let () = + if Array.length Sys.argv <> 2 then + failwith "usage: stream_probe QUERY_JSON_PATH"; + if not Sys.win32 then Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + let binary = Sys.argv.(1) in + probe binary "root" false ".[] | (., . + 10)" "[1," "2]" "1\n11\n" + "1\n11\n2\n12\n"; + probe binary "member" false ".rows[] | (., . + 10)" {|{"rows":[1,|} + {|2],"tail":0}|} "1\n11\n" "1\n11\n2\n12\n"; + probe binary "raw" true {|.[] | ""|} "[1," "2]" "\n" "\n\n" diff --git a/js/Js.ml b/js/Js.ml index 4f8a367..b21d31c 100644 --- a/js/Js.ml +++ b/js/Js.ml @@ -1,10 +1,6 @@ let run query input = - match Json.parse_string input with - | Ok json -> - Core.run ~debug:false ~colorize:false ~verbose:false ~raw:false - ~summarize:false query json - | Error err -> - Error err + Core.run_input ~debug:false ~colorize:false ~verbose:false ~raw:false + ~summarize:false query (Core.String input) let arity_to_js (arity : Language.arity) = match arity with diff --git a/source/Core.ml b/source/Core.ml index a5a84be..a4c963b 100644 --- a/source/Core.ml +++ b/source/Core.ml @@ -38,7 +38,8 @@ let run ?(debug = false) ?(colorize = true) ?(verbose = false) ?(raw = false) ?(summarize = false) query json = match parse ~debug ~colorize query with | Ok runtime -> ( - match Interpreter.execute ~colorize ~verbose runtime json with + let plan = Execution.prepare runtime in + match Execution.execute ~colorize ~verbose plan json with | Ok results -> Ok (results @@ -52,3 +53,105 @@ let run ?(debug = false) ?(colorize = true) ?(verbose = false) ?(raw = false) ) | Error err -> Error err + +let run_iter ?(debug = false) ?(colorize = true) ?(verbose = false) + ?(raw = false) ?(summarize = false) ~emit query json = + match parse ~debug ~colorize query with + | Ok runtime -> ( + let plan = Execution.prepare runtime in + match + Execution.fold ~colorize ~verbose ~init:0 + ~f:(fun count value -> + emit (Json.to_string_pretty ~colorize ~summarize ~raw value); + count + 1 + ) + plan json + with + | Completed count -> + Ok count + | Failed err -> + Error err + | Halted code -> + exit code + ) + | Error err -> + Error err + +type input = Json.Input.source = + | String of string + | File of string + | Channel of in_channel + | Value of Json.t + +let load_input ~debug ~colorize query input = + match parse ~debug:false ~colorize query with + | Ok runtime -> ( + let plan = Execution.prepare runtime in + match Execution.load plan input with + | Ok loaded -> + if debug then print_endline (Ast.show_expression runtime); + Ok loaded + | Error err -> + Error err + ) + | Error query_error -> ( + match Json.Input.read ~select:None input with + | Ok _ -> + Error query_error + | Error err -> + Error err + ) + +let run_input ?(debug = false) ?(colorize = true) ?(verbose = false) + ?(raw = false) ?(summarize = false) query input = + match load_input ~debug ~colorize query input with + | Ok loaded -> ( + match Execution.execute_loaded ~colorize ~verbose loaded with + | Ok results -> + Ok + (results + |> List.map (Json.to_string_pretty ~colorize ~summarize ~raw) + |> String.concat "\n" + ) + | Error err -> + Error err + | Halt code -> + exit code + ) + | Error err -> + Error err + +let run_input_iter ?(debug = false) ?(colorize = true) ?(verbose = false) + ?(raw = false) ?(summarize = false) ~emit query input = + let f count value = + emit (Json.to_string_pretty ~colorize ~summarize ~raw value); + count + 1 + in + let result = + if debug then + match load_input ~debug ~colorize query input with + | Ok loaded -> + Execution.fold_loaded ~colorize ~verbose ~init:0 ~f loaded + | Error error -> + Execution.Failed error + else + match parse ~debug:false ~colorize query with + | Ok runtime -> + Execution.fold_source ~colorize ~verbose ~init:0 ~f + (Execution.prepare runtime) + input + | Error query_error -> ( + match Json.Input.read ~select:None input with + | Ok _ -> + Execution.Failed query_error + | Error error -> + Execution.Failed error + ) + in + match result with + | Completed count -> + Ok count + | Failed err -> + Error err + | Halted code -> + exit code diff --git a/source/Core.mli b/source/Core.mli index c0bc0af..0eb2af1 100644 --- a/source/Core.mli +++ b/source/Core.mli @@ -11,3 +11,59 @@ val run : string -> Json.t -> (string, string) result + +val run_iter : + ?debug:bool -> + ?colorize:bool -> + ?verbose:bool -> + ?raw:bool -> + ?summarize:bool -> + emit:(string -> unit) -> + string -> + Json.t -> + (int, string) result +(** Parse and prepare once, then call [emit] once per rendered result without + separators, and return how many results were emitted. A late error can + follow earlier calls to [emit]. Exceptions raised by [emit] escape + unchanged. A halt exits as in [run]. *) + +type input = Json.Input.source = + | String of string + | File of string + | Channel of in_channel + | Value of Json.t + +val run_input : + ?debug:bool -> + ?colorize:bool -> + ?verbose:bool -> + ?raw:bool -> + ?summarize:bool -> + string -> + input -> + (string, string) result +(** Read and validate the complete input before reporting query errors, printing + the debug AST, or executing. Retain selected input when the plan permits it. + Render results atomically as in [run]. *) + +val run_input_iter : + ?debug:bool -> + ?colorize:bool -> + ?verbose:bool -> + ?raw:bool -> + ?summarize:bool -> + emit:(string -> unit) -> + string -> + input -> + (int, string) result +(** Call [emit] once per rendered result and return how many results were + emitted. Can emit before EOF for eligible compiled queries. Barriers and + interpreted queries still validate first, as in [run_input]. [debug=true] + always validates first and prints the AST only after valid EOF. Invalid + queries also validate the full input, with input errors taking precedence. + + A query failure or halt stops callbacks and validates the remaining input. A + later input error wins. Otherwise the query error returns or the halt exits + as in [run]. Earlier output can precede a query or input error. Callback + exceptions escape unchanged, including their backtrace. Owned files close on + every exit. Borrowed channels remain open. *) diff --git a/source/Execution.ml b/source/Execution.ml new file mode 100644 index 0000000..737d45c --- /dev/null +++ b/source/Execution.ml @@ -0,0 +1,447 @@ +type one = + | Identity + | Literal of Ast.literal + | Key of string + | Index of int + | Pipe_one of one * one + | Operation of one * Ast.op * one + | List of plan option + | Map of plan + +and many = + | Empty + | Iterate + | Indices of int list + | Pipe of plan * plan + | Comma of plan * plan + | Select of plan + +and plan = One of one | Many of many + +type t = Plan of plan | Fallback of Ast.expression +type loaded = Loaded of t * Json.t +type 'a fold_result = Completed of 'a | Failed of string | Halted of int + +let ( let* ) = Option.bind + +let pipe_plan left right = + match (left, right) with + | One left, One right -> + One (Pipe_one (left, right)) + | _ -> + Many (Pipe (left, right)) + +let rec compile = function + | Ast.Identity -> + Some (One Identity) + | Ast.Literal literal -> + Some (One (Literal literal)) + | Ast.Key key -> + Some (One (Key key)) + | Ast.Index [] -> + Some (Many Iterate) + | Ast.Index [ index ] -> + Some (One (Index index)) + | Ast.Index indices -> + Some (Many (Indices indices)) + | Ast.Fn0 Empty -> + Some (Many Empty) + | Ast.Pipe (left, right) -> + let* left = compile left in + let* right = compile right in + Some (pipe_plan left right) + | Ast.Comma (left, right) -> + let* left = compile left in + let* right = compile right in + Some (Many (Comma (left, right))) + | Ast.List None -> + Some (One (List None)) + | Ast.List (Some expr) -> + let* plan = compile expr in + Some (One (List (Some plan))) + | Ast.Operation (left, op, right) -> ( + let* left = compile left in + let* right = compile right in + match (left, right) with + | One left, One right -> + Some (One (Operation (left, op, right))) + | _ -> + None + ) + | Ast.Fn1 (With_expr (Map, expr)) -> + let* plan = compile expr in + Some (One (Map plan)) + | Ast.Fn1 (With_expr (Select, expr)) -> + let* plan = compile expr in + Some (Many (Select plan)) + | _ -> + None + +let prepare expr = + match compile expr with Some plan -> Plan plan | None -> Fallback expr + +type stream_head = Root | Member of string +type stream_cut = Root_items of plan | Member_items of string * plan + +let direct_member = function + | Key member | Pipe_one (Identity, Key member) -> + Some member + | _ -> + None + +let rec split_stream_head = function + | Many Iterate -> + Some (Root, None) + | Many (Pipe (One Identity, Many Iterate)) -> + Some (Root, None) + | Many (Pipe (One left, Many Iterate)) -> + let* member = direct_member left in + Some (Member member, None) + | Many (Pipe (left, right)) -> + let* head, residual = split_stream_head left in + let residual = + match residual with None -> right | Some left -> pipe_plan left right + in + Some (head, Some residual) + | _ -> + None + +let stream_cut = function + | Fallback _ -> + None + | Plan plan -> + let* head, residual = split_stream_head plan in + let residual = Option.value residual ~default:(One Identity) in + Some + ( match head with + | Root -> + Root_items residual + | Member member -> + Member_items (member, residual) + ) + +module For_test = struct + type backend = Compiled | Interpreted + + let backend = function Plan _ -> Compiled | Fallback _ -> Interpreted + + type stream_cut = Root_items of t | Member_items of string * t + + let stream_cut query = + match stream_cut query with + | None -> + None + | Some (Root_items residual) -> + Some (Root_items (Plan residual)) + | Some (Member_items (member, residual)) -> + Some (Member_items (member, Plan residual)) +end + +let rec leading_key_one = function + | Key key -> + Some (key, Identity) + | Pipe_one (left, right) -> + let* key, left = leading_key_one left in + Some (key, Pipe_one (left, right)) + | _ -> + None + +let rec leading_key = function + | One one -> + let* key, one = leading_key_one one in + Some (key, One one) + | Many (Pipe (left, right)) -> + let* key, left = leading_key left in + Some (key, Many (Pipe (left, right))) + | _ -> + None + +let load query source = + let select, residual = + match query with + | Plan plan -> ( + match leading_key plan with + | Some (key, residual) -> + (Some key, Plan residual) + | None -> + (None, query) + ) + | Fallback _ -> + (None, query) + in + Result.map + (function + | Json.Input.Whole json -> + Loaded (query, json) + | Json.Input.Selected json -> + Loaded (residual, json) + ) + (Json.Input.read ~select source) + +type cursor = unit -> Json.t option + +let once eval : cursor = + let pending = ref true in + fun () -> + if !pending then begin + pending := false; + Some (eval ()) + end else + None + +(* Opening a branch must not evaluate it before earlier branches are drained. *) +let delayed open_cursor : cursor = + let current = ref None in + fun () -> + let next = + match !current with + | Some next -> + next + | None -> + let next = open_cursor () in + current := Some next; + next + in + next () + +let of_seq seq : cursor = + let rest = ref seq in + fun () -> + match !rest () with + | Seq.Nil -> + None + | Seq.Cons (value, tail) -> + rest := tail; + Some value + +let rec eval_one ~colorize plan json = + match plan with + | Identity -> + json + | Literal literal -> + Runtime.literal literal + | Key key -> + Runtime.member key json + | Index index -> + Runtime.index ~colorize index json + | Pipe_one (left, right) -> + let value = eval_one ~colorize left json in + eval_one ~colorize right value + | Operation (left, op, right) -> + let left = eval_one ~colorize left json in + let right = eval_one ~colorize right json in + Runtime.Operators.apply ~colorize op left right + | List None -> + `List [] + | List (Some plan) -> + `List (collect ~colorize plan json) + | Map (One plan) -> + let items = Runtime.map_inputs ~colorize json in + `List (List.map (eval_one ~colorize plan) items) + | Map plan -> + let items = Runtime.map_inputs ~colorize json in + let results = + List.fold_left + (fun acc item -> List.rev_append (collect ~colorize plan item) acc) + [] items + in + `List (List.rev results) + +and collect ~colorize plan json = + match plan with + | One plan -> + [ eval_one ~colorize plan json ] + | Many _ -> + let next = open_cursor ~colorize plan json in + let rec drain acc = + match next () with + | None -> + List.rev acc + | Some value -> + drain (value :: acc) + in + drain [] + +and open_cursor ~colorize plan json : cursor = + match plan with + | One plan -> + once (fun () -> eval_one ~colorize plan json) + | Many Empty -> + fun () -> None + | Many Iterate -> + delayed (fun () -> of_seq (Runtime.iterator ~colorize json)) + | Many (Indices indices) -> ( + let rest = ref indices in + fun () -> + match !rest with + | [] -> + None + | index :: tail -> + rest := tail; + Some (Runtime.index ~colorize index json) + ) + | Many (Comma (left, right)) -> + let left = open_cursor ~colorize left json in + let right = open_cursor ~colorize right json in + let in_left = ref true in + fun () -> + if !in_left then ( + match left () with + | Some _ as value -> + value + | None -> + in_left := false; + right () + ) else + right () + | Many (Pipe (One left, right)) -> + delayed (fun () -> + let value = eval_one ~colorize left json in + open_cursor ~colorize right value + ) + | Many (Pipe (left, One right)) -> + let left = open_cursor ~colorize left json in + fun () -> Option.map (eval_one ~colorize right) (left ()) + | Many (Pipe (left, right)) -> + let left = open_cursor ~colorize left json in + let active = ref (fun () -> None) in + let rec next () = + match !active () with + | Some _ as value -> + value + | None -> ( + match left () with + | None -> + None + | Some value -> + active := open_cursor ~colorize right value; + next () + ) + in + next + | Many (Select (One conditional)) -> + let pending = ref true in + fun () -> + if !pending then begin + pending := false; + let value = eval_one ~colorize conditional json in + if Runtime.Operators.is_truthy value then + Some json + else + None + end else + None + | Many (Select conditional) -> + let conditional = open_cursor ~colorize conditional json in + let rec next () = + match conditional () with + | None -> + None + | Some value -> + if Runtime.Operators.is_truthy value then + Some json + else + next () + in + next + +let fold ~colorize ~verbose ?env ~init ~f query json = + match query with + | Fallback expr -> ( + match Interpreter.fold ~colorize ~verbose ?env ~init ~f expr json with + | Completed acc -> + Completed acc + | Failed error -> + Failed error + | Halted code -> + Halted code + ) + | Plan plan -> + let next = open_cursor ~colorize plan json in + let pull () = + match next () with + | value -> + Ok value + | effect Runtime.Runtime_error.Fail err, _ -> + Error (Runtime.Runtime_error.format ~colorize err) + | exception exn -> + Error (Printexc.to_string exn) + in + let rec drain acc = + match pull () with + | Ok None -> + Completed acc + | Ok (Some value) -> + (drain [@tailcall]) (f acc value) + | Error error -> + Failed error + in + drain init + +let execute ~colorize ~verbose ?env query json : Interpreter.execute_result = + match query with + | Fallback expr -> + Interpreter.execute ~colorize ~verbose ?env expr json + | Plan _ -> ( + match + fold ~colorize ~verbose ?env ~init:[] + ~f:(fun acc value -> value :: acc) + query json + with + | Completed values -> + Ok (List.rev values) + | Failed error -> + Error error + | Halted code -> + Halt code + ) + +let execute_loaded ~colorize ~verbose ?env (Loaded (query, json)) = + execute ~colorize ~verbose ?env query json + +let fold_loaded ~colorize ~verbose ?env ~init ~f (Loaded (query, json)) = + fold ~colorize ~verbose ?env ~init ~f query json + +let fold_source ~colorize ~verbose ?env ~init ~f query source = + match stream_cut query with + | None -> ( + match load query source with + | Ok loaded -> + fold_loaded ~colorize ~verbose ?env ~init ~f loaded + | Error error -> + Failed error + ) + | Some cut -> ( + let at, residual = + match cut with + | Root_items residual -> + (Json.Input.Root, residual) + | Member_items (member, residual) -> + (Json.Input.Member member, residual) + in + let step state item = + let result = + match state with + | Completed acc -> + fold ~colorize ~verbose ?env ~init:acc ~f (Plan residual) item + | Failed _ | Halted _ -> + state + in + match result with + | Completed _ -> + Json.Input.Continue result + | Failed _ | Halted _ -> + Json.Input.Validate_rest result + in + match Json.Input.fold_items ~at ~init:(Completed init) ~f:step source with + | Error error -> + Failed error + | Ok (Folded result) -> + result + | Ok (Materialized (Whole json)) -> + fold ~colorize ~verbose ?env ~init ~f query json + | Ok (Materialized (Selected json)) -> + fold ~colorize ~verbose ?env ~init ~f + (Plan (pipe_plan (Many Iterate) residual)) + json + ) diff --git a/source/Execution.mli b/source/Execution.mli new file mode 100644 index 0000000..94e3afc --- /dev/null +++ b/source/Execution.mli @@ -0,0 +1,90 @@ +type t +type loaded +type 'a fold_result = Completed of 'a | Failed of string | Halted of int + +val prepare : Ast.expression -> t +(** Select a backend for the complete expression without evaluating it. Plans + are immutable and can be reused after success or failure. *) + +module For_test : sig + type backend = Compiled | Interpreted + + val backend : t -> backend + (** The path [prepare] chose. Tests and benchmarks assert it so a case meant + for the compiled path cannot pass through the fallback. *) + + type stream_cut = private Root_items of t | Member_items of string * t + + val stream_cut : t -> stream_cut option +end + +val load : t -> Json.Input.source -> (loaded, string) result +(** Bind a query to immutable input, selecting one unconditional leading root + key when possible. Whole input retains the original query; selected input + uses the remaining plan. Input is read once, without retry. *) + +val fold : + colorize:bool -> + verbose:bool -> + ?env:(string * Json.t) list -> + init:'a -> + f:('a -> Json.t -> 'a) -> + t -> + Json.t -> + 'a fold_result +(** Fold top-level results in order without collecting the final result list, + for either backend. Nested expressions can still collect intermediate + results. A late failure or halt can follow earlier calls to [f]. Exceptions + raised by [f] escape unchanged. Each call owns its evaluation state. *) + +val execute : + colorize:bool -> + verbose:bool -> + ?env:(string * Json.t) list -> + t -> + Json.t -> + Interpreter.execute_result +(** Each call owns its pull state. An error discards all results from that call; + compiled errors never cause an interpreter retry. *) + +val execute_loaded : + colorize:bool -> + verbose:bool -> + ?env:(string * Json.t) list -> + loaded -> + Interpreter.execute_result +(** Execute bound input with fresh evaluation state on each call. *) + +val fold_loaded : + colorize:bool -> + verbose:bool -> + ?env:(string * Json.t) list -> + init:'a -> + f:('a -> Json.t -> 'a) -> + loaded -> + 'a fold_result +(** Fold bound input with the ordering and callback behavior of [fold]. Each + call owns its evaluation state, including after failure or halt. *) + +val fold_source : + colorize:bool -> + verbose:bool -> + ?env:(string * Json.t) list -> + init:'a -> + f:('a -> Json.t -> 'a) -> + t -> + Json.Input.source -> + 'a fold_result +(** Permits early results only for proven compiled item cuts. Other plans use + [load] and [fold_loaded]. Each complete child is fully evaluated before + reading the next child. + + A query failure or halt stops callbacks and saves the terminal result while + the remaining input is validated. A later input error wins. Otherwise the + saved result returns. Earlier callbacks can precede an input error. + Materialized input executes the original query, or iteration and the + residual plan for a selected scalar. Input is never retried. + + Callback exceptions escape unchanged, including their backtrace. + [Json.Input] closes owned files on every exit and leaves borrowed channels + open. Prepared plans remain reusable. *) diff --git a/source/Interpreter.ml b/source/Interpreter.ml index 8f7d005..2d5c255 100644 --- a/source/Interpreter.ml +++ b/source/Interpreter.ml @@ -1,169 +1,7 @@ open Ast -module Runtime_error : sig - type t - type _ Effect.t += Fail : t -> unit Effect.t - - val to_json : t -> Json.t - val kind_string : t -> string - val message : t -> string - val value : t -> Json.t option - val suggestion : t -> string option - val key_not_found : key:string -> value:Json.t -> 'a - val null_access : key:string -> value:Json.t -> 'a - val type_mismatch : value:Json.t -> ?suggestion:string -> string -> 'a - val index_out_of_bounds : index:int -> length:int -> value:Json.t -> 'a - val empty_array : string -> 'a - val invalid_argument : fn:string -> expected:string -> found:string -> 'a - val undefined_function : name:string -> 'a - val empty_result : op:string -> ?suggestion:string -> unit -> 'a - val assertion_error : value:Json.t -> string -> 'a - val custom : kind:string -> value:Json.t -> string -> 'a -end = struct - type error_kind = - | Key_not_found - | Null_access - | Type_mismatch - | Index_out_of_bounds - | Empty_array - | Undefined_function - | Empty_result - | Assertion_error - | Invalid_argument - | Custom of string - - let error_kind_to_string = function - | Key_not_found -> - "key_not_found" - | Null_access -> - "null_access" - | Type_mismatch -> - "type_mismatch" - | Index_out_of_bounds -> - "index_out_of_bounds" - | Empty_array -> - "empty_array" - | Undefined_function -> - "undefined_function" - | Empty_result -> - "empty_result" - | Assertion_error -> - "assertion_error" - | Invalid_argument -> - "invalid_argument" - | Custom s -> - s - - type t = { - kind : error_kind; - message : string; - value : Json.t option; - suggestion : string option; - } - - type _ Effect.t += Fail : t -> unit Effect.t - - let to_json { kind; message; value; suggestion } : Json.t = - let fields = - [ - ("kind", `String (error_kind_to_string kind)); - ("message", `String message); - ] - in - let fields = - match value with Some v -> fields @ [ ("value", v) ] | None -> fields - in - let fields = - match suggestion with - | Some s -> - fields @ [ ("suggestion", `String s) ] - | None -> - fields - in - `Assoc fields - - let kind_string err = error_kind_to_string err.kind - let message err = err.message - let value err = err.value - let suggestion err = err.suggestion - - let fail ~kind ?value ?suggestion message = - Effect.perform (Fail { kind; message; value; suggestion }); - assert false - - let key_not_found ~key ~value = - let suggestion = - match value with - | `Assoc assoc -> ( - let keys = List.map fst assoc in - let hyphenated_match = - List.find_opt - (fun k -> - let key_len = String.length key in - String.length k > key_len - && String.sub k 0 key_len = key - && String.get k key_len = '-' - ) - keys - in - match hyphenated_match with - | Some hk -> - Printf.sprintf - "Did you mean \"%s\"? Use .[\"...\"] or .\"...\" for keys with \ - hyphens" - hk - | None -> - "Use ." ^ key ^ "? for optional access" - ) - | _ -> - "Use ." ^ key ^ "? for optional access" - in - fail ~kind:Key_not_found ~value ~suggestion - ("Key '" ^ key ^ "' not found in object") - - let null_access ~key ~value = - fail ~kind:Null_access ~value ("Cannot access key '" ^ key ^ "' on null") - - let type_mismatch ~value ?suggestion message = - fail ~kind:Type_mismatch ~value ?suggestion message - - let index_out_of_bounds ~index ~length ~value = - fail ~kind:Index_out_of_bounds ~value - ~suggestion:("Use .[" ^ Int.to_string index ^ "]? for optional access") - ("Index " ^ Int.to_string index ^ " out of bounds (array has " - ^ Int.to_string length ^ " elements)" - ) - - let empty_array op = - fail ~kind:Empty_array - ~suggestion:("Use " ^ op ^ "? for optional access") - (op ^ ": empty array") - - let invalid_argument ~fn ~expected ~found = - fail ~kind:Invalid_argument - (Printf.sprintf "`%s`: expected %s, found %s" fn expected found) - - let undefined_function ~name = - fail ~kind:Undefined_function - ~suggestion:"check function name or define it with 'fn'" - ("undefined function: `" ^ name ^ "`") - - let empty_result ~op ?suggestion () = - let suggestion = - match suggestion with - | Some s -> - Some s - | None -> - Some ("Use " ^ op ^ "? for optional access") - in - fail ~kind:Empty_result ?suggestion (op ^ ": empty expression result") - - let assertion_error ~value message = - fail ~kind:Assertion_error ~value - ~suggestion:"Check the condition in your assert() call" message - - let custom ~kind ~value message = fail ~kind:(Custom kind) ~value message -end +module Runtime_error = Runtime.Runtime_error +module Operators = Runtime.Operators type _ Effect.t += | Yield : Json.t -> unit Effect.t @@ -332,375 +170,7 @@ let rec substitute_params (params : string list) (args : expression list) Apply (name, List.map sub call_args) let fail_invalid_type ~ctx op (json : Json.t) = - let type_desc = - match json with - | `List _ | `Assoc _ -> - "an " ^ Json.type_of json - | `String _ -> - "a " ^ Json.type_of json - | `Bool _ -> - "a boolean" - | `Float _ | `Int _ | `Int64 _ | `Big_int _ | `Decimal _ -> - "a number" - | `Null -> - "null" - in - let t = Console_style.make ~colorize:ctx.colorize in - Runtime_error.type_mismatch ~value:json - ("Cannot apply " - ^ Console_style.single_quotes (t.bold op) - ^ " to " ^ type_desc - ) - -module Operators = struct - let not (json : Json.t) = - match json with `Bool false | `Null -> `Bool true | _ -> `Bool false - - let to_float = function - | `Float f -> - Some f - | `Int n -> - Some (Float.of_int n) - | `Int64 n -> - Some (Int64.to_float n) - | `Big_int z -> - Some (Z.to_float z) - | `Decimal (d : Json.decimal) -> - Some (Json.Decimal.to_float d) - | _ -> - None - - let exact_decimal_of_json = function - | `Int n -> - Some (Json.Decimal.of_integer (Z.of_int n)) - | `Int64 n -> - Some (Json.Decimal.of_integer (Z.of_int64 n)) - | `Big_int z -> - Some (Json.Decimal.of_integer z) - | `Decimal (d : Json.decimal) -> - Some d - | _ -> - None - - let z_int_min = Z.of_int Int.min_int - let z_int_max = Z.of_int Int.max_int - let z_int64_min = Z.of_int64 Int64.min_int - let z_int64_max = Z.of_int64 Int64.max_int - - let json_of_integer_z z = - if Z.compare z z_int_min >= 0 && Z.compare z z_int_max <= 0 then - `Int (Z.to_int z) - else if Z.compare z z_int64_min >= 0 && Z.compare z z_int64_max <= 0 then - `Int64 (Z.to_int64 z) - else - `Big_int z - - let json_of_decimal (d : Json.decimal) = - if d.scale = 0 then - json_of_integer_z d.coeff - else - `Decimal d - - let add_exact l r = Json.Decimal.add l r |> json_of_decimal - let sub_exact l r = Json.Decimal.sub l r |> json_of_decimal - let mul_exact l r = Json.Decimal.mul l r |> json_of_decimal - - let add ~ctx str (left : Json.t) (right : Json.t) : Json.t = - match (left, right) with - | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), - ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> - add_exact - (Option.get (exact_decimal_of_json l)) - (Option.get (exact_decimal_of_json r)) - | `Float l, `Float r -> - `Float (l +. r) - | `Int l, `Float r -> - `Float (Int.to_float l +. r) - | `Float l, `Int r -> - `Float (l +. Int.to_float r) - | `Int64 l, `Float r -> - `Float (Int64.to_float l +. r) - | `Float l, `Int64 r -> - `Float (l +. Int64.to_float r) - | `Decimal l, `Float r -> - `Float (Json.Decimal.to_float l +. r) - | `Float l, `Decimal r -> - `Float (l +. Json.Decimal.to_float r) - | `Big_int l, `Float r -> - `Float (Z.to_float l +. r) - | `Float l, `Big_int r -> - `Float (l +. Z.to_float r) - | `String l, `String r -> - `String (l ^ r) - | `Assoc l_entries, `Assoc r_entries -> - (* right side wins for duplicate keys (override, not merge) *) - let updated_l = - List.map - (fun (k, v) -> - match List.assoc_opt k r_entries with - | Some v' -> - (k, v') - | None -> - (k, v) - ) - l_entries - in - (* then add new keys from r that weren't in l *) - let new_keys = - List.filter - (fun (k, _) -> Stdlib.not (List.mem_assoc k l_entries)) - r_entries - in - `Assoc (updated_l @ new_keys) - | `List l, `List r -> - `List (l @ r) - | `Null, r -> - Runtime_error.type_mismatch ~value:r - ~suggestion:"Use (.x ?? 0) for explicit null handling" - ("Cannot add null to " ^ Json.type_of r) - | l, `Null -> - Runtime_error.type_mismatch ~value:l - ~suggestion:"Use (.x ?? 0) for explicit null handling" - ("Cannot add " ^ Json.type_of l ^ " to null") - | _ -> - fail_invalid_type ~ctx str left - - let apply_float_operation ~ctx str fn (left : Json.t) (right : Json.t) = - match (to_float left, to_float right) with - | Some l, Some r -> - `Float (fn l r) - | _ -> - fail_invalid_type ~ctx str left - - let compare ~ctx:_ str int_fn (left : Json.t) (right : Json.t) = - match (left, right) with - | ( (`Int _ | `Int64 _ | `Big_int _ | `Float _ | `Decimal _), - (`Int _ | `Int64 _ | `Big_int _ | `Float _ | `Decimal _) ) -> - `Bool (int_fn (Json.compare left right) 0) - | _ -> - Runtime_error.invalid_argument ~fn:str ~expected:"numbers" - ~found:(Json.type_of left ^ " and " ^ Json.type_of right) - - let gt ~ctx = compare ~ctx ">" ( > ) - let gte ~ctx = compare ~ctx ">=" ( >= ) - let lt ~ctx = compare ~ctx "<" ( < ) - let lte ~ctx = compare ~ctx "<=" ( <= ) - - let is_truthy (json : Json.t) : bool = - (* in jq, false and null are falsy, everything else is truthy *) - match json with - | `Bool false | `Null -> - false - | _ -> - true - - let and_ ~ctx:_ (left : Json.t) (right : Json.t) : Json.t = - `Bool (is_truthy left && is_truthy right) - - let or_ ~ctx:_ (left : Json.t) (right : Json.t) : Json.t = - `Bool (is_truthy left || is_truthy right) - - let equal l r = `Bool (Json.equal l r) - let not_equal l r = `Bool (Stdlib.not (Json.equal l r)) - let add ~ctx = add ~ctx "+" - - let subtract ~ctx (left : Json.t) (right : Json.t) : Json.t = - match (left, right) with - | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), - ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> - sub_exact - (Option.get (exact_decimal_of_json l)) - (Option.get (exact_decimal_of_json r)) - | `Float l, `Float r -> - `Float (l -. r) - | `Int l, `Float r -> - `Float (Int.to_float l -. r) - | `Float l, `Int r -> - `Float (l -. Int.to_float r) - | `Int64 l, `Float r -> - `Float (Int64.to_float l -. r) - | `Float l, `Int64 r -> - `Float (l -. Int64.to_float r) - | `Decimal l, `Float r -> - `Float (Json.Decimal.to_float l -. r) - | `Float l, `Decimal r -> - `Float (l -. Json.Decimal.to_float r) - | `Big_int l, `Float r -> - `Float (Z.to_float l -. r) - | `Float l, `Big_int r -> - `Float (l -. Z.to_float r) - | `List l, `List r -> - let in_r x = List.exists (fun y -> Json.equal x y) r in - `List (List.filter (fun x -> Stdlib.not (in_r x)) l) - | _ -> - fail_invalid_type ~ctx "-" left - - let rec deep_merge (left : Json.t) (right : Json.t) : Json.t = - match (left, right) with - | `Assoc l_entries, `Assoc r_entries -> - (* preserve key order: update existing keys from l with recursive merge from r *) - let updated_l = - List.map - (fun (k, v) -> - match List.assoc_opt k r_entries with - | Some r_val -> - (k, deep_merge v r_val) - | None -> - (k, v) - ) - l_entries - in - (* add new keys from r that weren't in l *) - let new_keys = - List.filter - (fun (k, _) -> Stdlib.not (List.mem_assoc k l_entries)) - r_entries - in - `Assoc (updated_l @ new_keys) - | _, r -> - r - - let multiply ~ctx (left : Json.t) (right : Json.t) : Json.t = - match (left, right) with - | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), - ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> - mul_exact - (Option.get (exact_decimal_of_json l)) - (Option.get (exact_decimal_of_json r)) - | `Float l, `Float r -> - `Float (l *. r) - | `Int l, `Float r -> - `Float (Int.to_float l *. r) - | `Float l, `Int r -> - `Float (l *. Int.to_float r) - | `Int64 l, `Float r -> - `Float (Int64.to_float l *. r) - | `Float l, `Int64 r -> - `Float (l *. Int64.to_float r) - | `Decimal l, `Float r -> - `Float (Json.Decimal.to_float l *. r) - | `Float l, `Decimal r -> - `Float (l *. Json.Decimal.to_float r) - | `Big_int l, `Float r -> - `Float (Z.to_float l *. r) - | `Float l, `Big_int r -> - `Float (l *. Z.to_float r) - | `String s, `Int n -> - if n <= 0 then - `String "" - else - `String (String.concat "" (List.init n (fun _ -> s))) - | `String s, `Int64 n -> - let count = Int64.to_int n in - if count <= 0 then - `String "" - else - `String (String.concat "" (List.init count (fun _ -> s))) - | `String s, `Float f -> - let count = Int.of_float f in - if count <= 0 then - `String "" - else - `String (String.concat "" (List.init count (fun _ -> s))) - | `String s, `Decimal d -> - let count = Int.of_float (Json.Decimal.to_float d) in - if count <= 0 then - `String "" - else - `String (String.concat "" (List.init count (fun _ -> s))) - | `Assoc _, `Assoc _ -> - deep_merge left right - | `Null, r | r, `Null -> - r - | _ -> - fail_invalid_type ~ctx "*" left - - let is_zero_divisor (json : Json.t) = - match json with - | `Int 0 | `Int64 0L -> - true - | `Float f -> - f = 0.0 - | `Big_int z -> - Z.equal z Z.zero - | `Decimal (d : Json.decimal) -> - Z.equal d.coeff Z.zero - | _ -> - false - - let divide ~ctx (left : Json.t) (right : Json.t) : Json.t = - if is_zero_divisor right then - Runtime_error.invalid_argument ~fn:"divide" ~expected:"non-zero divisor" - ~found:"zero"; - match (left, right) with - | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), - ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> ( - let ld = Option.get (exact_decimal_of_json l) in - let rd = Option.get (exact_decimal_of_json r) in - let exact = Json.Decimal.div_exact_or_none ld rd in - match exact with - | Some d -> - json_of_decimal d - | None -> - `Float (Json.Decimal.to_float ld /. Json.Decimal.to_float rd) - ) - | `Float l, `Float r -> - `Float (l /. r) - | `Int l, `Float r -> - `Float (Int.to_float l /. r) - | `Float l, `Int r -> - `Float (l /. Int.to_float r) - | `Int64 l, `Float r -> - `Float (Int64.to_float l /. r) - | `Float l, `Int64 r -> - `Float (l /. Int64.to_float r) - | `Decimal l, `Float r -> - `Float (Json.Decimal.to_float l /. r) - | `Float l, `Decimal r -> - `Float (l /. Json.Decimal.to_float r) - | `String s, `String delim -> - `List - (Re.split_delim (Re.compile (Re.str delim)) s - |> List.map (fun part -> `String part) - ) - | _ -> - fail_invalid_type ~ctx "/" left - - let modulo ~ctx (left : Json.t) (right : Json.t) : Json.t = - match (left, right) with - | `Big_int l, `Big_int r -> - `Big_int (Z.rem l r) - | `Big_int l, `Int r -> - `Big_int (Z.rem l (Z.of_int r)) - | `Int l, `Big_int r -> - `Big_int (Z.rem (Z.of_int l) r) - | `Big_int l, `Int64 r -> - `Big_int (Z.rem l (Z.of_int64 r)) - | `Int64 l, `Big_int r -> - `Big_int (Z.rem (Z.of_int64 l) r) - | `Big_int l, `Float r -> - `Float (mod_float (Z.to_float l) r) - | `Float l, `Big_int r -> - `Float (mod_float l (Z.to_float r)) - | `Int64 l, `Int64 r -> - `Int64 (Int64.rem l r) - | `Int64 l, `Int r -> - `Int64 (Int64.rem l (Int64.of_int r)) - | `Int l, `Int64 r -> - `Int64 (Int64.rem (Int64.of_int l) r) - | `Int l, `Int r -> - `Int (l mod r) - | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), - ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> - let ld = Option.get (exact_decimal_of_json l) in - let rd = Option.get (exact_decimal_of_json r) in - if ld.scale = 0 && rd.scale = 0 then - json_of_integer_z (Z.rem ld.coeff rd.coeff) - else - apply_float_operation ~ctx "%" mod_float left right - | _ -> - apply_float_operation ~ctx "%" mod_float left right -end + Runtime.fail_invalid_type ~colorize:ctx.colorize op json module Search = struct let string_first haystack needle = @@ -1259,22 +729,6 @@ let stderr json = Printf.eprintf "%s\n%!" str; yield json -let json_number_of_ast_number = function - | Ast.Integer s -> ( - match int_of_string_opt s with - | Some i -> - `Int i - | None -> ( - match Int64.of_string_opt s with - | Some i -> - `Int64 i - | None -> - `Big_int (Z.of_string s) - ) - ) - | Ast.Decimal s -> - `Decimal (Json.Decimal.of_lexeme_exn s) - let int_of_ast_number = function | Ast.Integer s -> ( match int_of_string_opt s with @@ -2021,56 +1475,19 @@ let join_sep ~ctx sep json = | _ -> fail_invalid_type ~ctx "join" json -let member ~ctx:_ (key : string) (json : Json.t) = - match json with - | `Assoc assoc -> ( - match List.assoc_opt key assoc with - | Some value -> - value - | None -> - Runtime_error.key_not_found ~key ~value:json - ) - | `Null -> - Runtime_error.null_access ~key ~value:json - | _ -> - Runtime_error.type_mismatch ~value:json - ("Cannot index " ^ Json.type_of json ^ " with string \"" ^ key ^ "\"") +let member ~ctx:_ key json = Runtime.member key json let iterator ~ctx (json : Json.t) = - match json with - | `List [] -> - () - | `List items -> - yield_many items - | `Assoc obj -> - List.iter (fun (_, x) -> yield x) obj - | _ -> - fail_invalid_type ~ctx "[]" json + Seq.iter yield (Runtime.iterator ~colorize:ctx.colorize json) -let rec index ~ctx (indices : int list) (json : Json.t) = +let index ~ctx (indices : int list) (json : Json.t) = match indices with | [] -> iterator ~ctx json - | [ value ] -> ( - match json with - | `List list -> - let len = List.length list in - let actual_index = - if value < 0 then - len + value - else - value - in - if actual_index >= 0 && actual_index < len then - yield (List.nth list actual_index) - else - Runtime_error.index_out_of_bounds ~index:value ~length:len - ~value:json - | _ -> - fail_invalid_type ~ctx ("[" ^ Int.to_string value ^ "]") json - ) | multiple -> - List.iter (fun idx -> index ~ctx [ idx ] json) multiple + List.iter + (fun idx -> yield (Runtime.index ~colorize:ctx.colorize idx json)) + multiple let slice ~ctx (start : int option) (finish : int option) (json : Json.t) = let start = @@ -2142,17 +1559,8 @@ let rec interp ~ctx expression json : unit = interp_fn1 ~ctx fn1 json | Fn2 (f, e1, e2) -> interp_fn2 ~ctx f e1 e2 json - | Literal literal -> ( - match literal with - | Bool b -> - yield (`Bool b) - | Number n -> - yield (json_number_of_ast_number n) - | String s -> - yield (`String s) - | Null -> - yield `Null - ) + | Literal literal -> + yield (Runtime.literal literal) | Variable name -> variable ~ctx name | Env_var name -> ( @@ -2831,35 +2239,7 @@ and pipe ~ctx left right json = ~then_:(fun json -> interp ~ctx right json) and operation ~ctx left_expr right_expr op json = - let apply_op l_val r_val = - match op with - | Add -> - Operators.add ~ctx l_val r_val - | Subtract -> - Operators.subtract ~ctx l_val r_val - | Multiply -> - Operators.multiply ~ctx l_val r_val - | Divide -> - Operators.divide ~ctx l_val r_val - | Modulo -> - Operators.modulo ~ctx l_val r_val - | Greater_than -> - Operators.gt ~ctx l_val r_val - | Greater_than_or_equal -> - Operators.gte ~ctx l_val r_val - | Less_than -> - Operators.lt ~ctx l_val r_val - | Less_than_or_equal -> - Operators.lte ~ctx l_val r_val - | Equal -> - Operators.equal l_val r_val - | Not_equal -> - Operators.not_equal l_val r_val - | And -> - Operators.and_ ~ctx l_val r_val - | Or -> - Operators.or_ ~ctx l_val r_val - in + let apply_op = Operators.apply ~colorize:ctx.colorize op in on_yield (fun () -> interp ~ctx left_expr json) ~then_:(fun l_val -> @@ -2869,16 +2249,9 @@ and operation ~ctx left_expr right_expr op json = ) and map ~ctx (expr : expression) (json : Json.t) = - match json with - | `List list when List.length list > 0 -> - let collected = - List.concat_map (fun item -> collect ~ctx expr item) list - in - yield (`List collected) - | `List _ -> - yield (`List []) - | _ -> - fail_invalid_type ~ctx "map" json + let items = Runtime.map_inputs ~colorize:ctx.colorize json in + let collected = List.concat_map (fun item -> collect ~ctx expr item) items in + yield (`List collected) and map_values ~ctx (expr : expression) (json : Json.t) = match json with @@ -3803,7 +3176,7 @@ and add_array ~ctx json = yield `Null | `List (first :: rest) -> let sum = - List.fold_left (fun acc el -> Operators.add ~ctx acc el) first rest + List.fold_left (Operators.add ~colorize:ctx.colorize) first rest in yield sum | _ -> @@ -3814,7 +3187,9 @@ and add_expr ~ctx expr json = | [] -> yield `Null | first :: rest -> - let sum = List.fold_left (Operators.add ~ctx) first rest in + let sum = + List.fold_left (Operators.add ~colorize:ctx.colorize) first rest + in yield sum and to_uppercase ~ctx json = @@ -5027,24 +4402,41 @@ and paths_to ~ctx cond_expr json = type execute_result = Ok of Json.t list | Error of string | Halt of int +type 'a fold_result = Completed of 'a | Failed of string | Halted of int + +let fold ~colorize ~verbose ?(env = []) ~init ~f expr json = + let ctx = { colorize; verbose; env; fns = [] } in + let acc = ref init in + match interp ~ctx expr json with + | () -> + Completed !acc + | effect Yield value, k -> + (* Handler clauses run outside the interpreter's exception handlers. *) + acc := f !acc value; + Effect.Deep.continue k () + | effect Runtime_error.Fail err, _ -> + Failed (Runtime_error.format ~colorize err) + | effect User_error value, _ -> + let message = Json.to_string value in + let qerr = Error.runtime_error ~kind:"user_error" ~message ~value () in + Failed (Error.format ~colorize qerr) + | effect Break, _ -> + let err = + Error.context_error ~message:"break used outside of loop context" + in + Failed (Error.format ~colorize err) + | effect Halt exit_code, _ -> + Halted exit_code + | exception e -> + Failed (Printexc.to_string e) + let execute ~colorize ~verbose ?(env = []) expr json = let ctx = { colorize; verbose; env; fns = [] } in - let format_error (err : Runtime_error.t) = - let qerr = - Error.runtime_error - ~kind:(Runtime_error.kind_string err) - ~message:(Runtime_error.message err) - ?value:(Runtime_error.value err) - ?suggestion:(Runtime_error.suggestion err) - () - in - Error.format ~colorize qerr - in match collect ~ctx expr json with | results -> Ok results | effect Runtime_error.Fail err, _ -> - Error (format_error err) + Error (Runtime_error.format ~colorize err) | effect User_error value, _ -> let message = Json.to_string value in let qerr = Error.runtime_error ~kind:"user_error" ~message ~value () in diff --git a/source/Interpreter.mli b/source/Interpreter.mli index 510330b..e6c9cab 100644 --- a/source/Interpreter.mli +++ b/source/Interpreter.mli @@ -1,5 +1,22 @@ type execute_result = Ok of Json.t list | Error of string | Halt of int +type 'a fold_result = Completed of 'a | Failed of string | Halted of int + +val fold : + colorize:bool -> + verbose:bool -> + ?env:(string * Json.t) list -> + init:'a -> + f:('a -> Json.t -> 'a) -> + Ast.expression -> + Json.t -> + 'a fold_result +(** Call [f] once per top-level yield, in order, without collecting the final + result list. Nested expressions can still collect intermediate results. + Errors and halts match [execute], but earlier calls to [f] remain visible. + Exceptions from [f] escape unchanged. Each call owns its evaluation state. +*) + val execute : colorize:bool -> verbose:bool -> diff --git a/source/Runtime.ml b/source/Runtime.ml new file mode 100644 index 0000000..e1f7533 --- /dev/null +++ b/source/Runtime.ml @@ -0,0 +1,606 @@ +open Ast + +module Runtime_error = struct + type error_kind = + | Key_not_found + | Null_access + | Type_mismatch + | Index_out_of_bounds + | Empty_array + | Undefined_function + | Empty_result + | Assertion_error + | Invalid_argument + | Custom of string + + let error_kind_to_string = function + | Key_not_found -> + "key_not_found" + | Null_access -> + "null_access" + | Type_mismatch -> + "type_mismatch" + | Index_out_of_bounds -> + "index_out_of_bounds" + | Empty_array -> + "empty_array" + | Undefined_function -> + "undefined_function" + | Empty_result -> + "empty_result" + | Assertion_error -> + "assertion_error" + | Invalid_argument -> + "invalid_argument" + | Custom s -> + s + + type t = { + kind : error_kind; + message : string; + value : Json.t option; + suggestion : string option; + } + + type _ Effect.t += Fail : t -> unit Effect.t + + let to_json { kind; message; value; suggestion } : Json.t = + let fields = + [ + ("kind", `String (error_kind_to_string kind)); + ("message", `String message); + ] + in + let fields = + match value with Some v -> fields @ [ ("value", v) ] | None -> fields + in + let fields = + match suggestion with + | Some s -> + fields @ [ ("suggestion", `String s) ] + | None -> + fields + in + `Assoc fields + + let kind_string err = error_kind_to_string err.kind + let message err = err.message + let value err = err.value + let suggestion err = err.suggestion + + let fail ~kind ?value ?suggestion message = + Effect.perform (Fail { kind; message; value; suggestion }); + assert false + + let key_not_found ~key ~value = + let suggestion = + match value with + | `Assoc assoc -> ( + let keys = List.map fst assoc in + let hyphenated_match = + List.find_opt + (fun k -> + let key_len = String.length key in + String.length k > key_len + && String.sub k 0 key_len = key + && String.get k key_len = '-' + ) + keys + in + match hyphenated_match with + | Some hk -> + Printf.sprintf + "Did you mean \"%s\"? Use .[\"...\"] or .\"...\" for keys with \ + hyphens" + hk + | None -> + "Use ." ^ key ^ "? for optional access" + ) + | _ -> + "Use ." ^ key ^ "? for optional access" + in + fail ~kind:Key_not_found ~value ~suggestion + ("Key '" ^ key ^ "' not found in object") + + let null_access ~key ~value = + fail ~kind:Null_access ~value ("Cannot access key '" ^ key ^ "' on null") + + let type_mismatch ~value ?suggestion message = + fail ~kind:Type_mismatch ~value ?suggestion message + + let index_out_of_bounds ~index ~length ~value = + fail ~kind:Index_out_of_bounds ~value + ~suggestion:("Use .[" ^ Int.to_string index ^ "]? for optional access") + ("Index " ^ Int.to_string index ^ " out of bounds (array has " + ^ Int.to_string length ^ " elements)" + ) + + let empty_array op = + fail ~kind:Empty_array + ~suggestion:("Use " ^ op ^ "? for optional access") + (op ^ ": empty array") + + let invalid_argument ~fn ~expected ~found = + fail ~kind:Invalid_argument + (Printf.sprintf "`%s`: expected %s, found %s" fn expected found) + + let undefined_function ~name = + fail ~kind:Undefined_function + ~suggestion:"check function name or define it with 'fn'" + ("undefined function: `" ^ name ^ "`") + + let empty_result ~op ?suggestion () = + let suggestion = + match suggestion with + | Some s -> + Some s + | None -> + Some ("Use " ^ op ^ "? for optional access") + in + fail ~kind:Empty_result ?suggestion (op ^ ": empty expression result") + + let assertion_error ~value message = + fail ~kind:Assertion_error ~value + ~suggestion:"Check the condition in your assert() call" message + + let custom ~kind ~value message = fail ~kind:(Custom kind) ~value message + + let format ~colorize err = + let qerr = + Error.runtime_error ~kind:(kind_string err) ~message:(message err) + ?value:(value err) ?suggestion:(suggestion err) () + in + Error.format ~colorize qerr +end + +let fail_invalid_type ~colorize op (json : Json.t) = + let type_desc = + match json with + | `List _ | `Assoc _ -> + "an " ^ Json.type_of json + | `String _ -> + "a " ^ Json.type_of json + | `Bool _ -> + "a boolean" + | `Float _ | `Int _ | `Int64 _ | `Big_int _ | `Decimal _ -> + "a number" + | `Null -> + "null" + in + let t = Console_style.make ~colorize in + Runtime_error.type_mismatch ~value:json + ("Cannot apply " + ^ Console_style.single_quotes (t.bold op) + ^ " to " ^ type_desc + ) + +module Operators = struct + let not (json : Json.t) = + match json with `Bool false | `Null -> `Bool true | _ -> `Bool false + + let to_float = function + | `Float f -> + Some f + | `Int n -> + Some (Float.of_int n) + | `Int64 n -> + Some (Int64.to_float n) + | `Big_int z -> + Some (Z.to_float z) + | `Decimal (d : Json.decimal) -> + Some (Json.Decimal.to_float d) + | _ -> + None + + let exact_decimal_of_json = function + | `Int n -> + Some (Json.Decimal.of_integer (Z.of_int n)) + | `Int64 n -> + Some (Json.Decimal.of_integer (Z.of_int64 n)) + | `Big_int z -> + Some (Json.Decimal.of_integer z) + | `Decimal (d : Json.decimal) -> + Some d + | _ -> + None + + let z_int_min = Z.of_int Int.min_int + let z_int_max = Z.of_int Int.max_int + let z_int64_min = Z.of_int64 Int64.min_int + let z_int64_max = Z.of_int64 Int64.max_int + + let json_of_integer_z z = + if Z.compare z z_int_min >= 0 && Z.compare z z_int_max <= 0 then + `Int (Z.to_int z) + else if Z.compare z z_int64_min >= 0 && Z.compare z z_int64_max <= 0 then + `Int64 (Z.to_int64 z) + else + `Big_int z + + let json_of_decimal (d : Json.decimal) = + if d.scale = 0 then + json_of_integer_z d.coeff + else + `Decimal d + + let add_exact l r = Json.Decimal.add l r |> json_of_decimal + let sub_exact l r = Json.Decimal.sub l r |> json_of_decimal + let mul_exact l r = Json.Decimal.mul l r |> json_of_decimal + + let add ~colorize str (left : Json.t) (right : Json.t) : Json.t = + match (left, right) with + | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), + ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> + add_exact + (Option.get (exact_decimal_of_json l)) + (Option.get (exact_decimal_of_json r)) + | `Float l, `Float r -> + `Float (l +. r) + | `Int l, `Float r -> + `Float (Int.to_float l +. r) + | `Float l, `Int r -> + `Float (l +. Int.to_float r) + | `Int64 l, `Float r -> + `Float (Int64.to_float l +. r) + | `Float l, `Int64 r -> + `Float (l +. Int64.to_float r) + | `Decimal l, `Float r -> + `Float (Json.Decimal.to_float l +. r) + | `Float l, `Decimal r -> + `Float (l +. Json.Decimal.to_float r) + | `Big_int l, `Float r -> + `Float (Z.to_float l +. r) + | `Float l, `Big_int r -> + `Float (l +. Z.to_float r) + | `String l, `String r -> + `String (l ^ r) + | `Assoc l_entries, `Assoc r_entries -> + let updated_l = + List.map + (fun (k, v) -> + match List.assoc_opt k r_entries with + | Some v' -> + (k, v') + | None -> + (k, v) + ) + l_entries + in + let new_keys = + List.filter + (fun (k, _) -> Stdlib.not (List.mem_assoc k l_entries)) + r_entries + in + `Assoc (updated_l @ new_keys) + | `List l, `List r -> + `List (l @ r) + | `Null, r -> + Runtime_error.type_mismatch ~value:r + ~suggestion:"Use (.x ?? 0) for explicit null handling" + ("Cannot add null to " ^ Json.type_of r) + | l, `Null -> + Runtime_error.type_mismatch ~value:l + ~suggestion:"Use (.x ?? 0) for explicit null handling" + ("Cannot add " ^ Json.type_of l ^ " to null") + | _ -> + fail_invalid_type ~colorize str left + + let apply_float_operation ~colorize str fn (left : Json.t) (right : Json.t) = + match (to_float left, to_float right) with + | Some l, Some r -> + `Float (fn l r) + | _ -> + fail_invalid_type ~colorize str left + + let compare str int_fn (left : Json.t) (right : Json.t) = + match (left, right) with + | ( (`Int _ | `Int64 _ | `Big_int _ | `Float _ | `Decimal _), + (`Int _ | `Int64 _ | `Big_int _ | `Float _ | `Decimal _) ) -> + `Bool (int_fn (Json.compare left right) 0) + | _ -> + Runtime_error.invalid_argument ~fn:str ~expected:"numbers" + ~found:(Json.type_of left ^ " and " ^ Json.type_of right) + + let is_truthy (json : Json.t) : bool = + match json with `Bool false | `Null -> false | _ -> true + + let add ~colorize = add ~colorize "+" + + let subtract ~colorize (left : Json.t) (right : Json.t) : Json.t = + match (left, right) with + | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), + ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> + sub_exact + (Option.get (exact_decimal_of_json l)) + (Option.get (exact_decimal_of_json r)) + | `Float l, `Float r -> + `Float (l -. r) + | `Int l, `Float r -> + `Float (Int.to_float l -. r) + | `Float l, `Int r -> + `Float (l -. Int.to_float r) + | `Int64 l, `Float r -> + `Float (Int64.to_float l -. r) + | `Float l, `Int64 r -> + `Float (l -. Int64.to_float r) + | `Decimal l, `Float r -> + `Float (Json.Decimal.to_float l -. r) + | `Float l, `Decimal r -> + `Float (l -. Json.Decimal.to_float r) + | `Big_int l, `Float r -> + `Float (Z.to_float l -. r) + | `Float l, `Big_int r -> + `Float (l -. Z.to_float r) + | `List l, `List r -> + let in_r x = List.exists (fun y -> Json.equal x y) r in + `List (List.filter (fun x -> Stdlib.not (in_r x)) l) + | _ -> + fail_invalid_type ~colorize "-" left + + let rec deep_merge (left : Json.t) (right : Json.t) : Json.t = + match (left, right) with + | `Assoc l_entries, `Assoc r_entries -> + let updated_l = + List.map + (fun (k, v) -> + match List.assoc_opt k r_entries with + | Some r_val -> + (k, deep_merge v r_val) + | None -> + (k, v) + ) + l_entries + in + let new_keys = + List.filter + (fun (k, _) -> Stdlib.not (List.mem_assoc k l_entries)) + r_entries + in + `Assoc (updated_l @ new_keys) + | _, r -> + r + + let multiply ~colorize (left : Json.t) (right : Json.t) : Json.t = + match (left, right) with + | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), + ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> + mul_exact + (Option.get (exact_decimal_of_json l)) + (Option.get (exact_decimal_of_json r)) + | `Float l, `Float r -> + `Float (l *. r) + | `Int l, `Float r -> + `Float (Int.to_float l *. r) + | `Float l, `Int r -> + `Float (l *. Int.to_float r) + | `Int64 l, `Float r -> + `Float (Int64.to_float l *. r) + | `Float l, `Int64 r -> + `Float (l *. Int64.to_float r) + | `Decimal l, `Float r -> + `Float (Json.Decimal.to_float l *. r) + | `Float l, `Decimal r -> + `Float (l *. Json.Decimal.to_float r) + | `Big_int l, `Float r -> + `Float (Z.to_float l *. r) + | `Float l, `Big_int r -> + `Float (l *. Z.to_float r) + | `String s, `Int n -> + if n <= 0 then + `String "" + else + `String (String.concat "" (List.init n (fun _ -> s))) + | `String s, `Int64 n -> + let count = Int64.to_int n in + if count <= 0 then + `String "" + else + `String (String.concat "" (List.init count (fun _ -> s))) + | `String s, `Float f -> + let count = Int.of_float f in + if count <= 0 then + `String "" + else + `String (String.concat "" (List.init count (fun _ -> s))) + | `String s, `Decimal d -> + let count = Int.of_float (Json.Decimal.to_float d) in + if count <= 0 then + `String "" + else + `String (String.concat "" (List.init count (fun _ -> s))) + | `Assoc _, `Assoc _ -> + deep_merge left right + | `Null, r | r, `Null -> + r + | _ -> + fail_invalid_type ~colorize "*" left + + let is_zero_divisor (json : Json.t) = + match json with + | `Int 0 | `Int64 0L -> + true + | `Float f -> + f = 0.0 + | `Big_int z -> + Z.equal z Z.zero + | `Decimal (d : Json.decimal) -> + Z.equal d.coeff Z.zero + | _ -> + false + + let divide ~colorize (left : Json.t) (right : Json.t) : Json.t = + if is_zero_divisor right then + Runtime_error.invalid_argument ~fn:"divide" ~expected:"non-zero divisor" + ~found:"zero"; + match (left, right) with + | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), + ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> ( + let ld = Option.get (exact_decimal_of_json l) in + let rd = Option.get (exact_decimal_of_json r) in + let exact = Json.Decimal.div_exact_or_none ld rd in + match exact with + | Some d -> + json_of_decimal d + | None -> + `Float (Json.Decimal.to_float ld /. Json.Decimal.to_float rd) + ) + | `Float l, `Float r -> + `Float (l /. r) + | `Int l, `Float r -> + `Float (Int.to_float l /. r) + | `Float l, `Int r -> + `Float (l /. Int.to_float r) + | `Int64 l, `Float r -> + `Float (Int64.to_float l /. r) + | `Float l, `Int64 r -> + `Float (l /. Int64.to_float r) + | `Decimal l, `Float r -> + `Float (Json.Decimal.to_float l /. r) + | `Float l, `Decimal r -> + `Float (l /. Json.Decimal.to_float r) + | `String s, `String delim -> + `List + (Re.split_delim (Re.compile (Re.str delim)) s + |> List.map (fun part -> `String part) + ) + | _ -> + fail_invalid_type ~colorize "/" left + + let modulo ~colorize (left : Json.t) (right : Json.t) : Json.t = + match (left, right) with + | `Big_int l, `Big_int r -> + `Big_int (Z.rem l r) + | `Big_int l, `Int r -> + `Big_int (Z.rem l (Z.of_int r)) + | `Int l, `Big_int r -> + `Big_int (Z.rem (Z.of_int l) r) + | `Big_int l, `Int64 r -> + `Big_int (Z.rem l (Z.of_int64 r)) + | `Int64 l, `Big_int r -> + `Big_int (Z.rem (Z.of_int64 l) r) + | `Big_int l, `Float r -> + `Float (mod_float (Z.to_float l) r) + | `Float l, `Big_int r -> + `Float (mod_float l (Z.to_float r)) + | `Int64 l, `Int64 r -> + `Int64 (Int64.rem l r) + | `Int64 l, `Int r -> + `Int64 (Int64.rem l (Int64.of_int r)) + | `Int l, `Int64 r -> + `Int64 (Int64.rem (Int64.of_int l) r) + | `Int l, `Int r -> + `Int (l mod r) + | ( ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as l), + ((`Int _ | `Int64 _ | `Big_int _ | `Decimal _) as r) ) -> + let ld = Option.get (exact_decimal_of_json l) in + let rd = Option.get (exact_decimal_of_json r) in + if ld.scale = 0 && rd.scale = 0 then + json_of_integer_z (Z.rem ld.coeff rd.coeff) + else + apply_float_operation ~colorize "%" mod_float left right + | _ -> + apply_float_operation ~colorize "%" mod_float left right + + let apply ~colorize (op : Ast.op) left right = + match op with + | Add -> + add ~colorize left right + | Subtract -> + subtract ~colorize left right + | Multiply -> + multiply ~colorize left right + | Divide -> + divide ~colorize left right + | Modulo -> + modulo ~colorize left right + | Greater_than -> + compare ">" ( > ) left right + | Greater_than_or_equal -> + compare ">=" ( >= ) left right + | Less_than -> + compare "<" ( < ) left right + | Less_than_or_equal -> + compare "<=" ( <= ) left right + | Equal -> + `Bool (Json.equal left right) + | Not_equal -> + `Bool (Stdlib.not (Json.equal left right)) + | And -> + `Bool (is_truthy left && is_truthy right) + | Or -> + `Bool (is_truthy left || is_truthy right) +end + +let json_number_of_ast_number = function + | Ast.Integer s -> ( + match int_of_string_opt s with + | Some i -> + `Int i + | None -> ( + match Int64.of_string_opt s with + | Some i -> + `Int64 i + | None -> + `Big_int (Z.of_string s) + ) + ) + | Ast.Decimal s -> + `Decimal (Json.Decimal.of_lexeme_exn s) + +let literal = function + | Bool b -> + `Bool b + | Number n -> + json_number_of_ast_number n + | String s -> + `String s + | Null -> + `Null + +let member (key : string) (json : Json.t) = + match json with + | `Assoc assoc -> ( + match List.assoc_opt key assoc with + | Some value -> + value + | None -> + Runtime_error.key_not_found ~key ~value:json + ) + | `Null -> + Runtime_error.null_access ~key ~value:json + | _ -> + Runtime_error.type_mismatch ~value:json + ("Cannot index " ^ Json.type_of json ^ " with string \"" ^ key ^ "\"") + +let iterator ~colorize (json : Json.t) = + match json with + | `List items -> + List.to_seq items + | `Assoc obj -> + Seq.map snd (List.to_seq obj) + | _ -> + fail_invalid_type ~colorize "[]" json + +let index ~colorize value (json : Json.t) = + match json with + | `List list -> + let len = List.length list in + let actual_index = + if value < 0 then + len + value + else + value + in + if actual_index >= 0 && actual_index < len then + List.nth list actual_index + else + Runtime_error.index_out_of_bounds ~index:value ~length:len ~value:json + | _ -> + fail_invalid_type ~colorize ("[" ^ Int.to_string value ^ "]") json + +let map_inputs ~colorize (json : Json.t) = + match json with + | `List items -> + items + | _ -> + fail_invalid_type ~colorize "map" json diff --git a/source/Runtime.mli b/source/Runtime.mli new file mode 100644 index 0000000..904245e --- /dev/null +++ b/source/Runtime.mli @@ -0,0 +1,38 @@ +module Runtime_error : sig + type t + type _ Effect.t += Fail : t -> unit Effect.t + + val to_json : t -> Json.t + val kind_string : t -> string + val message : t -> string + val value : t -> Json.t option + val suggestion : t -> string option + val format : colorize:bool -> t -> string + val key_not_found : key:string -> value:Json.t -> 'a + val null_access : key:string -> value:Json.t -> 'a + val type_mismatch : value:Json.t -> ?suggestion:string -> string -> 'a + val index_out_of_bounds : index:int -> length:int -> value:Json.t -> 'a + val empty_array : string -> 'a + val invalid_argument : fn:string -> expected:string -> found:string -> 'a + val undefined_function : name:string -> 'a + val empty_result : op:string -> ?suggestion:string -> unit -> 'a + val assertion_error : value:Json.t -> string -> 'a + val custom : kind:string -> value:Json.t -> string -> 'a +end + +val fail_invalid_type : colorize:bool -> string -> Json.t -> 'a + +module Operators : sig + val not : Json.t -> Json.t + val is_truthy : Json.t -> bool + val json_of_integer_z : Z.t -> Json.t + val json_of_decimal : Json.decimal -> Json.t + val add : colorize:bool -> Json.t -> Json.t -> Json.t + val apply : colorize:bool -> Ast.op -> Json.t -> Json.t -> Json.t +end + +val literal : Ast.literal -> Json.t +val member : string -> Json.t -> Json.t +val iterator : colorize:bool -> Json.t -> Json.t Seq.t +val index : colorize:bool -> int -> Json.t -> Json.t +val map_inputs : colorize:bool -> Json.t -> Json.t list diff --git a/source/dune b/source/dune index e4072bc..3ffd1b6 100644 --- a/source/dune +++ b/source/dune @@ -2,6 +2,7 @@ (name Core) (wrapped false) (public_name query-json.core) + (private_modules Runtime) (libraries json sedlex re unix zarith query-json.console-style) (preprocess (pps ppx_deriving.show sedlex.ppx)) diff --git a/source/jotason/Read.mli b/source/jotason/Read.mli index 4db5583..63f24dc 100644 --- a/source/jotason/Read.mli +++ b/source/jotason/Read.mli @@ -9,3 +9,44 @@ val from_file : ?buf:Buffer.t -> ?fname:string -> ?lnum:int -> string -> t val parse_string : string -> (t, string) result val parse_file : string -> (t, string) result val parse_channel : in_channel -> (t, string) result + +module Input : sig + type source = + | String of string + | File of string + | Channel of in_channel + | Value of t + + type selection = Whole of t | Selected of t + + type item_location = Root | Member of string + type 'a step = Continue of 'a | Validate_rest of 'a + type 'a items_result = Folded of 'a | Materialized of selection + + val read : select:string option -> source -> (selection, string) result + (** Select the first matching root object member, after validating the entire + input. [select = None] uses the full parser and returns [Whole]. Missing + members and other roots return [Whole]. [Value] returns [Whole] without + parsing. Files are closed; channels remain open. *) + + val fold_items : + at:item_location -> + init:'a -> + f:('a -> t -> 'a step) -> + source -> + ('a items_result, string) result + (** Fold complete immediate array elements or object values in source order, + including duplicate fields. [Member key] uses the first matching direct + root member. Each child's comma or closing delimiter is consumed before + [f] runs. Empty containers return [Folded init]. + + Unsuitable targets return [Materialized] without calling [f]: [Selected] + for a scalar matching member, [Whole] for a missing member or unsuitable + root. [Value] uses the same rules without parsing. + + [Validate_rest state] stops callbacks but validates the remaining document + and EOF before returning [Folded state]. A later input error returns + [Error]. Earlier callbacks can precede an input error. Callback exceptions + escape with their identity and backtrace. Files close on every exit; + borrowed channels remain open, with possible read-ahead. *) +end diff --git a/source/jotason/Read.mll b/source/jotason/Read.mll index bcdcc76..a84942e 100644 --- a/source/jotason/Read.mll +++ b/source/jotason/Read.mll @@ -347,7 +347,15 @@ and read_array_sep v = parse | _ { long_error "Expected ',' or ']' but found" v lexbuf } | eof { custom_error "Unexpected end of input" v lexbuf } +and read_array_start = parse + | '[' { true } + | "" { false } + (* Object structure *) +and read_object_start = parse + | '{' { true } + | "" { false } + and read_object_end = parse | '}' { raise Common.End_of_object } | "" { () } @@ -527,15 +535,11 @@ and read_abstract_fields read_key read_field init_acc v = parse (* Skip rules - for ignoring field values *) and skip_json v = parse - | "true" | "false" | "null" | "NaN" | "Infinity" | "-Infinity" { () } - | '"' { finish_skip_stringlit v lexbuf } - | '-'? positive_int { () } - | float { () } | '{' { try read_space v lexbuf; read_object_end lexbuf; - skip_ident v lexbuf; + ignore (read_ident v lexbuf); read_space v lexbuf; read_colon v lexbuf; read_space v lexbuf; @@ -544,7 +548,7 @@ and skip_json v = parse read_space v lexbuf; read_object_sep v lexbuf; read_space v lexbuf; - skip_ident v lexbuf; + ignore (read_ident v lexbuf); read_space v lexbuf; read_colon v lexbuf; read_space v lexbuf; @@ -571,19 +575,7 @@ and skip_json v = parse | "/*" { finish_comment v lexbuf; skip_json v lexbuf } | "\n" { newline v lexbuf; skip_json v lexbuf } | space { skip_json v lexbuf } - | eof { custom_error "Unexpected end of input" v lexbuf } - | _ { long_error "Invalid token" v lexbuf } - -and finish_skip_stringlit v = parse - | ('\\' (['"' '\\' '/' 'b' 'f' 'n' 'r' 't'] | 'u' hex hex hex hex) | [^'"' '\\'])* '"' { () } - | _ { long_error "Invalid string literal" v lexbuf } - | eof { custom_error "Unexpected end of input" v lexbuf } - -and skip_ident v = parse - | '"' { finish_skip_stringlit v lexbuf } - | ident { () } - | _ { long_error "Expected string or identifier but found" v lexbuf } - | eof { custom_error "Unexpected end of input" v lexbuf } + | "" { ignore (read_json v lexbuf) } (* Buffer rules - for capturing deferred values *) and buffer_json v = parse @@ -764,16 +756,19 @@ and finish_buffer_comment v = parse from_lexbuf v lexbuf with Common.End_of_input -> Common.json_error "Blank input data" - let from_file ?buf ?fname ?lnum file = + let with_file read file = let ic = open_in file in try - let x = from_channel ?buf ?fname ?lnum ic in + let x = read ic in close_in ic; x with e -> close_in_noerr ic; raise e + let from_file ?buf ?fname ?lnum file = + with_file (from_channel ?buf ?fname ?lnum) file + exception Finally of exn * exn let seq_from_lexbuf v ?(fin = fun () -> ()) lexbuf = @@ -827,21 +822,254 @@ and finish_buffer_comment v = parse exception Json_error = Common.Json_error (* Result-based parsing wrappers *) - let parse_string str = - try Ok (from_string str) + let parse_with_error context read input = + try Ok (read input) with | Common.Json_error msg -> Error ("JSON parse error: " ^ msg) - | e -> Error (Printexc.to_string e ^ " There was an error reading the string") + | e -> Error (Printexc.to_string e ^ " There was an error reading " ^ context) + + let parse_string str = + parse_with_error "the string" from_string str let parse_file file = - try Ok (from_file file) - with - | Common.Json_error msg -> Error ("JSON parse error: " ^ msg) - | e -> Error (Printexc.to_string e ^ " There was an error reading the file") + parse_with_error "the file" from_file file let parse_channel channel = - try Ok (from_channel channel) - with - | Common.Json_error msg -> Error ("JSON parse error: " ^ msg) - | e -> Error (Printexc.to_string e ^ " There was an error reading from standard input") + parse_with_error "from standard input" from_channel channel + + module Input = struct + type source = String of string | File of string | Channel of in_channel | Value of t + type selection = Whole of t | Selected of t + type item_location = Root | Member of string + type 'a step = Continue of 'a | Validate_rest of 'a + type 'a items_result = Folded of 'a | Materialized of selection + + type position = First | Next | Tail | Done + type cursor = { next : unit -> t option; drain : unit -> unit } + type probe = Items of cursor | Ready of selection + + let array_closed read = + try read (); false with Common.End_of_array -> true + + let object_closed read = + try read (); false with Common.End_of_object -> true + + let read_key v lexbuf = + let name = read_ident v lexbuf in + read_space v lexbuf; + read_colon v lexbuf; + read_space v lexbuf; + name + + let container_cursor v lexbuf ~is_object ~after = + let position = ref First in + let at_end () = + if is_object then object_closed (fun () -> read_object_end lexbuf) + else array_closed (fun () -> read_array_end lexbuf) + in + let boundary () = + read_space v lexbuf; + let closed = + if is_object then object_closed (fun () -> read_object_sep v lexbuf) + else array_closed (fun () -> read_array_sep v lexbuf) + in + position := if closed then Tail else Next + in + let rec advance read () = + match !position with + | Done -> None + | Tail -> after (); position := Done; None + | First -> + read_space v lexbuf; + position := if at_end () then Tail else Next; + advance read () + | Next -> + read_space v lexbuf; + if is_object then ignore (read_key v lexbuf); + let value = read v lexbuf in + boundary (); + Some value + in + let rec drain () = + match advance skip_json () with + | None -> () + | Some () -> drain () + in + { next = advance read_json; drain } + + let probe_items at lexbuf = + let v = init_lexer () in + let finish () = finish v lexbuf in + let materialize selection = finish (); Ready selection in + let container ~after = + if read_array_start lexbuf then + Some (Items (container_cursor v lexbuf ~is_object:false ~after)) + else if read_object_start lexbuf then + Some (Items (container_cursor v lexbuf ~is_object:true ~after)) + else None + in + let rec object_tail () = + read_space v lexbuf; + if object_closed (fun () -> read_object_sep v lexbuf) then finish () + else begin + read_space v lexbuf; + ignore (read_key v lexbuf); + skip_json v lexbuf; + object_tail () + end + in + let rec member key fields = + let name = read_key v lexbuf in + if name = key then + match container ~after:object_tail with + | Some items -> items + | None -> + let value = read_json v lexbuf in + object_tail (); + Ready (Selected value) + else begin + let value = read_json v lexbuf in + let fields = (name, value) :: fields in + read_space v lexbuf; + if object_closed (fun () -> read_object_sep v lexbuf) then + materialize (Whole (`Assoc (List.rev fields))) + else begin + read_space v lexbuf; + member key fields + end + end + in + read_space v lexbuf; + if read_eof lexbuf then Common.json_error "Blank input data"; + match at with + | Root -> + (match container ~after:finish with + | Some items -> items + | None -> materialize (Whole (read_json v lexbuf))) + | Member key -> + if not (read_object_start lexbuf) then + materialize (Whole (read_json v lexbuf)) + else begin + read_space v lexbuf; + if object_closed (fun () -> read_object_end lexbuf) then + materialize (Whole (`Assoc [])) + else member key [] + end + + let fold_lexbuf context ~at ~init ~f lexbuf = + let parse read = parse_with_error context read () in + let rec loop cursor state = + match parse cursor.next with + | Error _ as error -> error + | Ok None -> Ok (Folded state) + | Ok (Some value) -> + match f state value with + | Continue state -> loop cursor state + | Validate_rest state -> + Result.map (fun () -> Folded state) (parse cursor.drain) + in + match parse (fun () -> probe_items at lexbuf) with + | Error _ as error -> error + | Ok (Ready selection) -> Ok (Materialized selection) + | Ok (Items cursor) -> loop cursor init + + let fold_value ~at ~init ~f value = + let rec fold get state = function + | [] -> Folded state + | item :: rest -> + match f state (get item) with + | Continue state -> fold get state rest + | Validate_rest state -> Folded state + in + let selection = + match at, value with + | Member key, `Assoc fields -> + (match List.assoc_opt key fields with + | Some value -> Selected value + | None -> Whole value) + | _ -> Whole value + in + let target = match selection with Whole value | Selected value -> value in + match at, selection, target with + | Member _, Whole _, _ -> Materialized selection + | _, _, `List items -> fold Fun.id init items + | _, _, `Assoc fields -> fold snd init fields + | _ -> Materialized selection + + let fold_items ~at ~init ~f source = + let from_channel context channel = + fold_lexbuf context ~at ~init ~f (Lexing.from_channel channel) + in + match source with + | Value value -> Ok (fold_value ~at ~init ~f value) + | String text -> fold_lexbuf "the string" ~at ~init ~f (Lexing.from_string text) + | Channel channel -> from_channel "from standard input" channel + | File file -> + match parse_with_error "the file" open_in file with + | Error _ as error -> error + | Ok channel -> + match from_channel "the file" channel with + | result -> close_in_noerr channel; result + | exception error -> + let backtrace = Printexc.get_raw_backtrace () in + close_in_noerr channel; + Printexc.raise_with_backtrace error backtrace + + let read_selected key lexbuf = + let v = init_lexer () in + read_space v lexbuf; + if read_eof lexbuf then Common.json_error "Blank input data"; + let result = + if not (read_object_start lexbuf) then Whole (read_json v lexbuf) + else + let fields = ref [] in + let selected = ref None in + let read_field () = + let name = read_ident v lexbuf in + read_space v lexbuf; + read_colon v lexbuf; + read_space v lexbuf; + match !selected with + | Some _ -> skip_json v lexbuf + | None -> + if name = key then begin + fields := []; + selected := Some (read_json v lexbuf) + end else + fields := (name, read_json v lexbuf) :: !fields + in + (try + read_space v lexbuf; + read_object_end lexbuf; + read_field (); + while true do + read_space v lexbuf; + read_object_sep v lexbuf; + read_space v lexbuf; + read_field () + done + with Common.End_of_object -> ()); + match !selected with + | Some value -> Selected value + | None -> Whole (`Assoc (List.rev !fields)) + in + finish v lexbuf; + result + + let read ~select source = + match select, source with + | _, Value value -> Ok (Whole value) + | None, String str -> Result.map (fun value -> Whole value) (parse_string str) + | None, File file -> Result.map (fun value -> Whole value) (parse_file file) + | None, Channel channel -> Result.map (fun value -> Whole value) (parse_channel channel) + | Some key, String str -> + parse_with_error "the string" + (fun str -> read_selected key (Lexing.from_string str)) str + | Some key, File file -> + parse_with_error "the file" + (with_file (fun channel -> read_selected key (Lexing.from_channel channel))) file + | Some key, Channel channel -> + parse_with_error "from standard input" + (fun channel -> read_selected key (Lexing.from_channel channel)) channel + end } diff --git a/source/jotason/test/Test_read.ml b/source/jotason/test/Test_read.ml index 6680369..d79de2d 100644 --- a/source/jotason/test/Test_read.ml +++ b/source/jotason/test/Test_read.ml @@ -309,6 +309,904 @@ let fail_missing_comma_object () = ) (parse {|{"a":1 "b":2}|}) +let selection_testable = + let pp fmt = function + | Json.Input.Whole value -> + Format.fprintf fmt "Whole (%a)" Json.pp value + | Json.Input.Selected value -> + Format.fprintf fmt "Selected (%a)" Json.pp value + in + Alcotest.testable pp (fun a b -> Stdlib.compare a b = 0) + +let check_input name expected actual = + Alcotest.(check (result selection_testable string)) name expected actual + +let select_full select value = + match (select, value) with + | Some key, `Assoc fields -> ( + match List.assoc_opt key fields with + | Some value -> + Json.Input.Selected value + | None -> + Json.Input.Whole value + ) + | _ -> + Json.Input.Whole value + +let selection_cases = + [ + ("first", "wanted", {|{wanted:{z:[1,{x:2,x:3}],a:0},after:[4,5]}|}); + ("middle", "wanted", {|{before:[1,2],wanted:[{x:3},4],after:{y:5}}|}); + ("last", "wanted", {|{before:{a:1},other:[2],wanted:"last"}|}); + ("missing", "wanted", {|{z:1,a:{b:2,b:3},z:[4],a:5}|}); + ("empty object", "wanted", "{}"); + ("duplicate", "wanted", {|{wanted:1,other:2,wanted:[3,4]}|}); + ("null first duplicate", "wanted", {|{wanted:null,wanted:false}|}); + ("nested member only", "wanted", {|{other:{wanted:1}}|}); + ("escaped key", "wanted", {|{"wa\u006eted":true,wanted:false}|}); + ("empty key", "", {|{before:1,"":[],after:2}|}); + ("wrong root array", "wanted", {|[{wanted:1},{a:2,a:3}]|}); + ("wrong root string", "wanted", {|"wanted"|}); + ("wrong root integer", "wanted", "123"); + ("wrong root decimal", "wanted", "-1.20e-3"); + ("wrong root null", "wanted", "null"); + ("wrong root bool", "wanted", "false"); + ("wrong root NaN", "wanted", "NaN"); + ("wrong root infinity", "wanted", "Infinity"); + ("raw string whitespace", "wanted", "{wanted:1,after:\"line\n\ttwo\"}"); + ( "comments", + "wanted", + "// start\n/* root */ {before:1, /* member */ wanted:[2], // tail\n" + ^ "after:{a:/* value */3}} /* end */ // eof" + ); + ( "discarded scalars", + "wanted", + {|{wanted:1,after:[true,false,null,NaN,Infinity,-Infinity,0,-0,|} + ^ {|4611686018427387904,-4611686018427387905,|} + ^ {|9223372036854775808,-9223372036854775809,1.230e+4,-1.20e-3,|} + ^ {|"\"\\\/\b\f\n\r\t\u20AC\uD834\uDD1E","\uDC00"]}|} + ); + ] + +let input_selection () = + List.iter + (fun (name, key, text) -> + let value = Json.from_string text in + List.iter + (fun select -> + check_input name + (Ok (select_full select value)) + (Json.Input.read ~select (Json.Input.String text)) + ) + [ None; Some key ] + ) + selection_cases + +let input_value () = + let value = `Assoc [ ("wanted", `Int 1); ("wanted", `Int 2) ] in + List.iter + (fun select -> + match Json.Input.read ~select (Json.Input.Value value) with + | Ok (Json.Input.Whole actual) -> + Alcotest.(check bool) + "same value without parsing" true (actual == value) + | actual -> + check_input "Value returns Whole" (Ok (Json.Input.Whole value)) actual + ) + [ None; Some "wanted"; Some "missing" ] + +let discarded_errors = + List.map + (fun (name, tail) -> + (name, {|{before:[1],wanted:{x:[true,null]},after:|} ^ tail) + ) + [ + ("invalid escape", {|"\q"}|}); + ("invalid unicode digits", {|"\u00xz"}|}); + ("unterminated string", {|"unterminated|}); + ("unterminated escape", {|"escape\|}); + ("missing low surrogate", {|"\uD800"}|}); + ("invalid low surrogate", {|"\uD800\u0041"}|}); + ("high low surrogate", {|"\uD800\uD800"}|}); + ("truncated surrogate", {|"\uD800|}); + ("invalid nested key escape", {|{"\q":1}}|}); + ("invalid nested key surrogate", {|{"\uD800":1}}|}); + ("invalid later root key", {|1,"\q":2}|}); + ("invalid later root key surrogate", {|1,"\uD800":2}|}); + ("exponent overflow", "1e999999999999999999999999999999}"); + ("negative exponent overflow", "1e-999999999999999999999999999999}"); + ("leading zero", "01}"); + ("missing exponent", "1e+}"); + ("missing fractional digits", "1.}"); + ("plus sign", "+1}"); + ("invalid token", "undefined}"); + ("missing nested array comma", "[1 2]}"); + ("missing nested object comma", "{a:1 b:2}}"); + ("missing nested colon", "{a 1}}"); + ("array trailing comma", "[1,]}"); + ("object trailing comma", "{a:1,}}"); + ("root trailing comma", "1,}"); + ("truncated array", "[1"); + ("truncated object", "{a:1"); + ("truncated root", "1"); + ("unterminated comment", "/* unfinished"); + ("nested comment", "[1,/* unfinished"); + ("line comment hides closing braces", "1 // } "); + ] + @ [ + ("trailing junk", "{wanted:1} garbage"); + ("second document", "{wanted:1} {wanted:2}"); + ("trailing unterminated comment", "{wanted:1} /* unfinished"); + ("leading unterminated comment", "/* unfinished"); + ("empty input", ""); + ("blank", " \n\t"); + ("comments only", "/* comment */ // eof"); + ("bad preceding field", {|{before:"\q",wanted:1}|}); + ("bad selected value", {|{wanted:["\uD800"]}|}); + ("bad duplicate match", {|{wanted:1,wanted:"\q"}|}); + ("bad missing member", {|{other:"\q"}|}); + ("bad wrong root", {|[{wanted:1},"\q"]|}); + ] + +let check_input_error name full actual = + match full with + | Error message -> + check_input name (Error message) actual + | Ok _ -> + Alcotest.failf "%s: full parser unexpectedly accepted malformed input" + name + +let input_selection_errors () = + List.iter + (fun (name, text) -> + List.iter + (fun select -> + check_input_error name (Json.parse_string text) + (Json.Input.read ~select (Json.Input.String text)) + ) + [ None; Some "wanted"; Some "missing" ] + ) + discarded_errors + +let with_input_file text f = + let file = Filename.temp_file "jotason_input" ".json" in + Fun.protect + ~finally:(fun () -> Sys.remove file) + (fun () -> + let channel = open_out_bin file in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> output_string channel text); + f file + ) + +let with_input_channel file f = + let channel = open_in_bin file in + Fun.protect ~finally:(fun () -> close_in_noerr channel) (fun () -> f channel) + +let input_sources () = + List.iter + (fun (name, key, text) -> + with_input_file text (fun file -> + List.iter + (fun select -> + check_input (name ^ " file") + (Result.map (select_full select) (Json.parse_file file)) + (Json.Input.read ~select (Json.Input.File file)); + with_input_channel file (fun channel -> + let expected = + Result.map (select_full select) (Json.parse_channel channel) + in + seek_in channel 0; + check_input (name ^ " channel") expected + (Json.Input.read ~select (Json.Input.Channel channel)); + seek_in channel 0; + Alcotest.(check char) + "borrowed channel remains readable" text.[0] + (input_char channel) + ) + ) + [ None; Some key ] + ) + ) + selection_cases; + List.iter + (fun (name, text) -> + with_input_file text (fun file -> + List.iter + (fun select -> + check_input_error (name ^ " file") (Json.parse_file file) + (Json.Input.read ~select (Json.Input.File file)); + with_input_channel file (fun channel -> + let full = Json.parse_channel channel in + seek_in channel 0; + check_input_error (name ^ " channel") full + (Json.Input.read ~select (Json.Input.Channel channel)); + seek_in channel 0; + if text <> "" then + Alcotest.(check char) + "channel remains readable after error" text.[0] + (input_char channel) + ) + ) + [ None; Some "wanted" ] + ) + ) + discarded_errors; + with_input_file "{wanted:1}" (fun file -> + with_input_channel file (fun channel -> + close_in channel; + List.iter + (fun select -> + check_input_error "closed channel wrapper" + (Json.parse_channel channel) + (Json.Input.read ~select (Json.Input.Channel channel)) + ) + [ None; Some "wanted" ] + ) + ) + +let input_channel_refill () = + let padding = String.make 65537 'x' in + let text = + {|{before:["|} ^ padding ^ {|"],wanted:{x:"|} ^ padding + ^ {|\uD834\uDD1E",x:2},after:[{"|} ^ padding ^ {|":[]},"|} ^ padding + ^ {|"]}|} + in + with_input_file text (fun file -> + List.iter + (fun select -> + with_input_channel file (fun channel -> + let expected = + Result.map (select_full select) (Json.parse_channel channel) + in + seek_in channel 0; + check_input "refilled channel" expected + (Json.Input.read ~select (Json.Input.Channel channel)); + Alcotest.(check int) + "validated through EOF" (String.length text) (pos_in channel); + seek_in channel 0 + ) + ) + [ None; Some "wanted"; Some "missing" ] + ); + List.iter + (fun (name, tail) -> + let text = {|{wanted:1,after:["|} ^ padding ^ tail in + with_input_file text (fun file -> + with_input_channel file (fun channel -> + let full = Json.parse_channel channel in + seek_in channel 0; + check_input_error name full + (Json.Input.read ~select:(Some "wanted") + (Json.Input.Channel channel) + ) + ) + ) + ) + [ + ("refilled escape", {|\q"]}|}); + ("refilled surrogate", {|\uD800\u0041"]}|}); + ("refilled number", {|",1e999999999999999999999999999999]}|}); + ("refilled trailing junk", {|"]} junk|}); + ] + +let input_file_closure () = + List.iter + (fun text -> + with_input_file text (fun file -> + let descriptors () = + if Sys.file_exists "/proc/self/fd" then + Some (Array.length (Sys.readdir "/proc/self/fd")) + else + None + in + let before = descriptors () in + for _ = 1 to 32 do + List.iter + (fun select -> + check_input "repeated file read" + (Result.map (select_full select) (Json.parse_file file)) + (Json.Input.read ~select (Json.Input.File file)) + ) + [ None; Some "wanted"; Some "missing" ] + done; + Alcotest.(check (option int)) + "no leaked file descriptors" before (descriptors ()) + ) + ) + [ + "{wanted:1,after:[2,3]}"; + {|{wanted:1,after:"\q"}|}; + "{wanted:1,after:1e999999999999999999999999999999}"; + ]; + with_input_file "" (fun file -> + let missing = file ^ ".missing" in + List.iter + (fun select -> + check_input_error "missing file wrapper" (Json.parse_file missing) + (Json.Input.read ~select (Json.Input.File missing)) + ) + [ None; Some "wanted" ] + ) + +let input_discarded_containers () = + let text = + "{wanted:null,after:[" + ^ String.concat "," (List.init 10000 (fun _ -> "[[],{}]")) + ^ "]}" + in + let allocated select = + let before = Gc.allocated_bytes () in + let result = Json.Input.read ~select (Json.Input.String text) in + let bytes = Gc.allocated_bytes () -. before in + (result, bytes) + in + let full, full_bytes = allocated None in + let selected, selected_bytes = allocated (Some "wanted") in + check_input "complete selected value" (Ok (Json.Input.Selected `Null)) + selected; + check_input "complete full value" + (Result.map (fun value -> Json.Input.Whole value) (Json.parse_string text)) + full; + Alcotest.(check bool) + "discarding containers uses less than half the full parser allocation" true + (selected_bytes < full_bytes /. 2.) + +let items_testable = + let pp fmt = function + | Json.Input.Folded values -> + Format.fprintf fmt "Folded (%a)" Json.pp (`List values) + | Json.Input.Materialized selection -> + (Alcotest.pp selection_testable) fmt selection + in + Alcotest.testable pp (fun a b -> Stdlib.compare a b = 0) + +let check_items name expected actual = + Alcotest.(check (result items_testable string)) name expected actual + +let item_testable = Alcotest.testable Json.pp (fun a b -> Stdlib.compare a b = 0) + +let items_init = [ `String "initial state" ] + +let expected_items at value = + let open Json.Input in + let selection = + select_full (match at with Root -> None | Member key -> Some key) value + in + match (at, selection) with + | Root, Whole (`List values) | Member _, Selected (`List values) -> + Folded (List.rev_append values items_init) + | Root, Whole (`Assoc fields) | Member _, Selected (`Assoc fields) -> + Folded (List.rev_append (List.map snd fields) items_init) + | _ -> + Materialized selection + +let items_cases = + let open Json.Input in + List.concat_map + (fun (name, key, text) -> + [ (name ^ " root", Root, text); (name ^ " member", Member key, text) ] + ) + selection_cases + @ [ + ("root array", Root, {|[1,{a:[2],a:3},[4],null]|}); + ("root empty array", Root, "[]"); + ("root empty object", Root, "{}"); + ("root duplicate values", Root, "{a:1,a:2,b:[3],a:4}"); + ("member first array", Member "x", "{x:[1,{a:2}],after:3}"); + ("member middle object", Member "x", "{a:0,x:{k:1,k:2},b:3}"); + ("member last array", Member "x", "{a:0,x:[1,2]}"); + ("member last object", Member "x", "{a:0,x:{k:1,k:2}}"); + ("member empty array", Member "x", "{a:0,x:[],b:3}"); + ("member empty object", Member "x", "{a:0,x:{},b:3}"); + ("member duplicate array", Member "x", "{x:[1,2],x:[3]}"); + ("member duplicate object", Member "x", "{x:{k:1,k:2},x:[3]}"); + ("member empty first duplicate", Member "x", "{x:[],x:[3]}"); + ("member scalar first duplicate", Member "x", "{x:0,x:[3]}"); + ("member escaped key", Member "x", {|{"\u0078":[1,2],x:[3]}|}); + ("member empty key", Member "", {|{a:0,"":{k:1,k:2},b:3}|}); + ( "member comments", + Member "x", + "/*root*/{a:0,/*key*/x/*colon*/:/*array*/[1/*comma*/,//line\n" + ^ "{k:2}/*end*/]/*tail*/,b:3}//eof" + ); + ("root scalar", Root, "1"); + ("root string", Root, {|"text"|}); + ] + +let check_items_source name at text source = + let expected = expected_items at (Json.from_string text) in + let seen = ref [] in + let actual = + Json.Input.fold_items ~at ~init:items_init + ~f:(fun state value -> + seen := value :: !seen; + Json.Input.Continue (value :: state) + ) + source + in + check_items name (Ok expected) actual; + let expected_seen = + match expected with + | Json.Input.Folded values -> + List.filteri (fun i _ -> i < List.length values - 1) values + | Json.Input.Materialized _ -> + [] + in + Alcotest.(check (list item_testable)) + (name ^ " callbacks") expected_seen !seen + +let input_items () = + List.iter + (fun (name, at, text) -> + check_items_source name at text (Json.Input.String text); + check_items_source (name ^ " value") at text + (Json.Input.Value (Json.from_string text)) + ) + items_cases; + let value = `String "unparsed\255\000" in + let check_same at value = + match + Json.Input.fold_items ~at ~init:() + ~f:(fun _ _ -> Alcotest.fail "unexpected callback") + (Json.Input.Value value) + with + | Ok (Json.Input.Materialized (Json.Input.Whole actual)) -> + Alcotest.(check bool) "same supplied value" true (value == actual) + | _ -> + Alcotest.fail "expected the whole supplied value" + in + check_same Json.Input.Root value; + check_same (Json.Input.Member "missing") (`Assoc [ ("x", value) ]); + check_items "Value children do not parse" (Ok (Json.Input.Folded [ value ])) + (Json.Input.fold_items ~at:Json.Input.Root ~init:[] + ~f:(fun state item -> + Alcotest.(check bool) "same supplied child" true (item == value); + Json.Input.Continue (item :: state) + ) + (Json.Input.Value (`List [ value ])) + ) + +let items_errors = + let open Json.Input in + [ + ("leading zero boundary", Root, "[01]", []); + ("exponent boundary", Root, "[1e+]", []); + ("array boundary", Root, "[1 2]", []); + ("object boundary", Root, "{a:1 b:2}", []); + ("member array boundary", Member "x", "{x:[1 2]}", []); + ("member object boundary", Member "x", "{x:{a:1 b:2}}", []); + ("incomplete child", Root, "[{a:[1,]},{a:2}]", []); + ("late array boundary", Root, "[0,1 2]", [ `Int 0 ]); + ("late object boundary", Root, "{a:0,b:1 c:2}", [ `Int 0 ]); + ("array trailing comma", Root, "[1,]", [ `Int 1 ]); + ("object trailing comma", Root, "{a:1,}", [ `Int 1 ]); + ("truncated child", Root, "[1,{", [ `Int 1 ]); + ("missing boundary", Root, "[1", []); + ("root junk", Root, "[1] junk", [ `Int 1 ]); + ("root second document", Root, "{a:1} []", [ `Int 1 ]); + ("root tail comment", Root, "[1] /*", [ `Int 1 ]); + ("selected tail", Member "x", "{x:[1],tail:[2,]}", [ `Int 1 ]); + ("selected parent boundary", Member "x", "{x:[1] y:2}", [ `Int 1 ]); + ("selected missing parent end", Member "x", "{x:[1]", [ `Int 1 ]); + ("invalid later duplicate", Member "x", "{x:[1],x:[01]}", [ `Int 1 ]); + ("empty then invalid duplicate", Member "x", "{x:[],x:[01]}", []); + ("scalar then invalid duplicate", Member "x", "{x:0,x:[01]}", []); + ] + +let check_items_error name full actual = + match full with + | Error message -> + check_items name (Error message) actual + | Ok _ -> + Alcotest.failf "%s: full parser accepted malformed input" name + +let input_items_errors () = + List.iter + (fun (name, at, text, expected_seen) -> + let seen = ref [] in + let actual = + Json.Input.fold_items ~at ~init:items_init + ~f:(fun state value -> + seen := value :: !seen; + Json.Input.Continue (value :: state) + ) + (Json.Input.String text) + in + check_items_error name (Json.parse_string text) actual; + Alcotest.(check (list Testable.jotason)) + (name ^ " visible prefix") expected_seen (List.rev !seen) + ) + items_errors; + List.iter + (fun (name, text) -> + List.iter + (fun at -> + check_items_error name (Json.parse_string text) + (Json.Input.fold_items ~at ~init:items_init + ~f:(fun state value -> Json.Input.Continue (value :: state)) + (Json.Input.String text) + ) + ) + [ + Json.Input.Root; + Json.Input.Member "wanted"; + Json.Input.Member "missing"; + ] + ) + discarded_errors + +let validate_items_cases = + let open Json.Input in + [ + (Root, "[1,2,{a:[3]}]"); + (Root, "{a:1,a:2,b:[3]}"); + (Root, "[1]"); + (Root, "{a:1}"); + (Member "x", "{x:[1,2],x:[3],tail:{a:[4]}}"); + (Member "x", "{x:{a:1,b:2},tail:3}"); + (Root, "[1,01]"); + (Root, "{a:1,b:1e+}"); + (Root, "[1,]"); + (Root, "{a:1,}"); + (Root, "[1,2"); + (Root, "[1] junk"); + (Root, "[1] /*"); + (Member "x", "{x:[1,2],x:[01]}"); + (Member "x", "{x:{a:1,b:2},tail:[3,]}"); + (Member "x", "{x:[1] y:2}"); + (Member "x", "{x:[1]}"); + (Member "x", "{x:[1]} junk"); + ] + +let check_validate_items name at full source = + let calls = ref 0 in + let actual = + Json.Input.fold_items ~at ~init:items_init + ~f:(fun state value -> + incr calls; + Json.Input.Validate_rest (value :: state) + ) + source + in + Alcotest.(check int) (name ^ " stopped callbacks") 1 !calls; + match full with + | Ok _ -> + check_items name (Ok (Json.Input.Folded (`Int 1 :: items_init))) actual + | Error _ -> + check_items_error name full actual + +let input_items_validate_rest () = + List.iter + (fun (at, text) -> + let full = Json.parse_string text in + check_validate_items text at full (Json.Input.String text); + match full with + | Ok value -> + check_validate_items (text ^ " value") at full (Json.Input.Value value) + | Error _ -> + () + ) + validate_items_cases + +let input_items_sources () = + List.iter + (fun (name, at, text) -> + with_input_file text (fun file -> + check_items_source (name ^ " file") at text (Json.Input.File file); + with_input_channel file (fun channel -> + check_items_source (name ^ " channel") at text + (Json.Input.Channel channel); + Alcotest.(check int) + "validated EOF" (String.length text) (pos_in channel); + seek_in channel 0; + Alcotest.(check char) + "borrowed channel open" text.[0] (input_char channel) + ) + ) + ) + items_cases; + List.iter + (fun (name, at, text, _) -> + with_input_file text (fun file -> + let f state value = Json.Input.Continue (value :: state) in + check_items_error (name ^ " file") (Json.parse_file file) + (Json.Input.fold_items ~at ~init:items_init ~f (Json.Input.File file) + ); + with_input_channel file (fun channel -> + let expected = Json.parse_channel channel in + seek_in channel 0; + check_items_error (name ^ " channel") expected + (Json.Input.fold_items ~at ~init:items_init ~f + (Json.Input.Channel channel) + ); + seek_in channel 0 + ) + ) + ) + items_errors; + List.iter + (fun (at, text) -> + with_input_file text (fun file -> + check_validate_items (text ^ " file") at (Json.parse_file file) + (Json.Input.File file); + with_input_channel file (fun channel -> + let full = Json.parse_channel channel in + seek_in channel 0; + check_validate_items (text ^ " channel") at full + (Json.Input.Channel channel); + seek_in channel 0 + ) + ) + ) + validate_items_cases; + with_input_file "" (fun file -> + let f _ _ = Alcotest.fail "unexpected callback" in + let missing = file ^ ".missing" in + check_items_error "missing file" (Json.parse_file missing) + (Json.Input.fold_items ~at:Json.Input.Root ~init:[] ~f + (Json.Input.File missing) + ); + with_input_channel file (fun channel -> + close_in channel; + check_items_error "closed channel" + (Json.parse_channel channel) + (Json.Input.fold_items ~at:Json.Input.Root ~init:[] ~f + (Json.Input.Channel channel) + ) + ) + ) + +let[@inline never] raise_items_callback error = raise error + +let check_items_exception at source error = + let original_trace = ref "" in + match + Json.Input.fold_items ~at ~init:() + ~f:(fun _ _ -> + try raise_items_callback error + with caught -> + let trace = Printexc.get_raw_backtrace () in + original_trace := Printexc.raw_backtrace_to_string trace; + Printexc.raise_with_backtrace caught trace + ) + source + with + | _ -> + Alcotest.fail "callback exception did not escape" + | exception caught -> + let trace = + Printexc.get_raw_backtrace () |> Printexc.raw_backtrace_to_string + in + Alcotest.(check bool) "callback exception identity" true (caught == error); + Alcotest.(check bool) + "callback trace recorded" true (!original_trace <> ""); + Alcotest.(check bool) + "callback trace retained" true + (String.starts_with ~prefix:!original_trace trace) + +let input_items_exceptions () = + let recording = Printexc.backtrace_status () in + Fun.protect + ~finally:(fun () -> Printexc.record_backtrace recording) + (fun () -> + Printexc.record_backtrace true; + List.iter + (fun error -> + List.iter + (fun (at, text) -> + check_items_exception at (Json.Input.String text) error; + check_items_exception at + (Json.Input.Value (Json.from_string text)) + error; + with_input_file text (fun file -> + check_items_exception at (Json.Input.File file) error; + with_input_channel file (fun channel -> + check_items_exception at (Json.Input.Channel channel) + error; + seek_in channel 0; + Alcotest.(check char) + "channel open after exception" text.[0] + (input_char channel) + ) + ) + ) + [ + (Json.Input.Root, "[1,2]"); + (Json.Input.Root, "[1]"); + (Json.Input.Root, "{a:1}"); + (Json.Input.Member "x", "{x:[1]}"); + (Json.Input.Member "x", "{x:{a:1,b:2},tail:3}"); + ]; + check_items_exception Json.Input.Root + (Json.Input.String "[1,invalid]") error + ) + [ + Failure "callback"; + Json.Json_error "callback"; + Json.End_of_array; + Json.End_of_object; + ] + ) + +let input_items_file_closure () = + if Sys.file_exists "/proc/self/fd" then + List.iter + (fun text -> + with_input_file text (fun file -> + let descriptors () = Array.length (Sys.readdir "/proc/self/fd") in + let before = descriptors () in + for _ = 1 to 32 do + List.iter + (fun at -> + List.iter + (fun f -> + ignore + (Json.Input.fold_items ~at ~init:() ~f + (Json.Input.File file) + ) + ) + [ + (fun () _ -> Json.Input.Continue ()); + (fun () _ -> Json.Input.Validate_rest ()); + ]; + let error = Failure "close after callback" in + match + Json.Input.fold_items ~at ~init:() + ~f:(fun _ _ -> raise error) + (Json.Input.File file) + with + | _ -> + () + | exception caught -> + Alcotest.(check bool) + "callback identity on cleanup" true (caught == error) + ) + [ + Json.Input.Root; + Json.Input.Member "x"; + Json.Input.Member "missing"; + ] + done; + Alcotest.(check int) + "no leaked file descriptors" before (descriptors ()) + ) + ) + [ + "[1,2]"; + "{x:[1,2],tail:3}"; + "{x:[1],tail:[01]}"; + "[1,01]"; + "[01]"; + "1"; + "{x:1}"; + ] + +let input_items_refill () = + let padding = String.make 65537 'x' in + let text = + "{before:[\"" ^ padding ^ "\"],x:[{k:\"" ^ padding ^ "\"},2],tail:[\"" + ^ padding ^ "\"]}" + in + with_input_file text (fun file -> + with_input_channel file (fun channel -> + check_items_source "refilled items" (Json.Input.Member "x") text + (Json.Input.Channel channel); + seek_in channel 0 + ) + ) + +let input_items_pipe () = + if not Sys.win32 then + List.iter + (fun (at, prefix, tail, validate_rest, valid) -> + let input_read, input_write = Unix.pipe () in + let event_read, event_write = Unix.pipe () in + let close fd = + try Unix.close fd with Unix.Unix_error (Unix.EBADF, _, _) -> () + in + let send fd char = + if Unix.write fd (Bytes.make 1 char) 0 1 <> 1 then + failwith "short pipe write" + in + match Unix.fork () with + | 0 -> + close input_write; + close event_read; + let channel = Unix.in_channel_of_descr input_read in + ( try + let result = + Json.Input.fold_items ~at ~init:0 + ~f:(fun count value -> + if value <> `Int (count + 1) then + failwith "unexpected pipe item"; + send event_write 'I'; + if validate_rest then + Json.Input.Validate_rest (count + 1) + else + Json.Input.Continue (count + 1) + ) + (Json.Input.Channel channel) + in + ignore (Unix.fstat (Unix.descr_of_in_channel channel)); + let expected_count = + if validate_rest || tail = "" then + 1 + else + 2 + in + let correct = + match result with + | Ok (Json.Input.Folded count) -> + valid && count = expected_count + | Error _ -> + not valid + | _ -> + false + in + send event_write + ( if correct then + 'S' + else + 'F' + ) + with _ -> ( try send event_write 'F' with _ -> () + ) + ); + close_in_noerr channel; + close event_write; + Unix._exit 0 + | pid -> + Fun.protect + ~finally:(fun () -> + List.iter close + [ input_read; input_write; event_read; event_write ]; + ( try Unix.kill pid Sys.sigkill + with Unix.Unix_error (Unix.ESRCH, _, _) -> () + ); + ignore (Unix.waitpid [] pid) + ) + (fun () -> + close input_read; + close event_write; + let write text = + let bytes = Bytes.of_string text in + if + Unix.write input_write bytes 0 (Bytes.length bytes) + <> Bytes.length bytes + then + Alcotest.fail "short input write" + in + let receive expected = + let ready, _, _ = Unix.select [ event_read ] [] [] 3. in + if ready = [] then + Alcotest.fail "timed out waiting for parser event"; + let byte = Bytes.create 1 in + if Unix.read event_read byte 0 1 <> 1 then + Alcotest.fail "missing parser event"; + Alcotest.(check char) + "parser event" expected (Bytes.get byte 0) + in + write prefix; + receive 'I'; + write tail; + close input_write; + if (not validate_rest) && tail <> "" && valid then receive 'I'; + receive 'S' + ) + ) + [ + (Json.Input.Root, "[1,", "2]", false, true); + (Json.Input.Root, "{a:1,", "a:2}", false, true); + (Json.Input.Member "x", "{before:0,x:[1,", "2],tail:3}", false, true); + (Json.Input.Member "x", "{x:{a:1,", "a:2},x:[3]}", false, true); + (Json.Input.Root, "[1]", "", false, true); + (Json.Input.Root, "[1,", "2]", true, true); + (Json.Input.Member "x", "{x:[1,", "2],tail:[01]}", true, false); + (Json.Input.Root, "[1,", "01]", false, false); + ] + (* === Test list === *) let single_json = @@ -404,4 +1302,19 @@ let single_json = ("fail_missing_colon", `Quick, fail_missing_colon); ("fail_missing_comma_array", `Quick, fail_missing_comma_array); ("fail_missing_comma_object", `Quick, fail_missing_comma_object); + ("input_selection", `Quick, input_selection); + ("input_value", `Quick, input_value); + ("input_selection_errors", `Quick, input_selection_errors); + ("input_sources", `Quick, input_sources); + ("input_channel_refill", `Quick, input_channel_refill); + ("input_file_closure", `Quick, input_file_closure); + ("input_discarded_containers", `Quick, input_discarded_containers); + ("input_items", `Quick, input_items); + ("input_items_errors", `Quick, input_items_errors); + ("input_items_validate_rest", `Quick, input_items_validate_rest); + ("input_items_sources", `Quick, input_items_sources); + ("input_items_exceptions", `Quick, input_items_exceptions); + ("input_items_file_closure", `Quick, input_items_file_closure); + ("input_items_refill", `Quick, input_items_refill); + ("input_items_pipe", `Quick, input_items_pipe); ] diff --git a/source/jotason/test/dune b/source/jotason/test/dune index b6abd67..0c960b4 100644 --- a/source/jotason/test/dune +++ b/source/jotason/test/dune @@ -1,3 +1,3 @@ (test (name Test_jotason) - (libraries json alcotest)) + (libraries json alcotest unix)) diff --git a/source/test/Test.ml b/source/test/Test.ml index 8d3f168..e37409e 100644 --- a/source/test/Test.ml +++ b/source/test/Test.ml @@ -4,4 +4,5 @@ let _ = ("Parsing", Test_parse.tests); ("Runtime", Test_runtime.tests); ("Errors", Test_errors.tests); + ("Execution", Test_execution.tests); ] diff --git a/source/test/Test_execution.ml b/source/test/Test_execution.ml new file mode 100644 index 0000000..35e1a19 --- /dev/null +++ b/source/test/Test_execution.ml @@ -0,0 +1,1586 @@ +let rec representation : Json.t -> string = function + | `Null -> + "Null" + | `Bool b -> + Printf.sprintf "Bool(%b)" b + | `String s -> + Printf.sprintf "String(%S)" s + | `Int n -> + Printf.sprintf "Int(%d)" n + | `Int64 n -> + Printf.sprintf "Int64(%Ld)" n + | `Big_int n -> + "Big_int(" ^ Z.to_string n ^ ")" + | `Float n -> + Printf.sprintf "Float(bits=%Lx)" (Int64.bits_of_float n) + | `Decimal d -> + Printf.sprintf "Decimal(%s,%d)" (Z.to_string d.coeff) d.scale + | `List items -> + "List[" ^ String.concat ";" (List.map representation items) ^ "]" + | `Assoc fields -> + "Assoc[" + ^ String.concat ";" + (List.map + (fun (k, v) -> Printf.sprintf "%S:%s" k (representation v)) + fields + ) + ^ "]" + +let result_representation : Interpreter.execute_result -> string = function + | Ok values -> + "Ok[" ^ String.concat ";" (List.map representation values) ^ "]" + | Error error -> + "Error(" ^ error ^ ")" + | Halt code -> + Printf.sprintf "Halt(%d)" code + +let check_result label expected actual = + Alcotest.check Alcotest.string label + (result_representation expected) + (result_representation actual) + +let check_backend expected plan = + let name = function + | Execution.For_test.Compiled -> + "Compiled" + | Interpreted -> + "Interpreted" + in + Alcotest.check Alcotest.string "backend" (name expected) + (name (Execution.For_test.backend plan)) + +let parse query = + match Core.parse ~debug:false ~colorize:false query with + | Ok expr -> + expr + | Error error -> + Alcotest.failf "Cannot parse %S: %s" query error + +let fold_collect ~colorize ~verbose ?env plan input : Interpreter.execute_result + = + match + Execution.fold ~colorize ~verbose ?env ~init:[] + ~f:(fun acc value -> value :: acc) + plan input + with + | Completed values -> + Ok (List.rev values) + | Failed error -> + Error error + | Halted code -> + Halt code + +let interpreter_fold_collect ~colorize ~verbose ?env expr input : + Interpreter.execute_result = + match + Interpreter.fold ~colorize ~verbose ?env ~init:[] + ~f:(fun acc value -> value :: acc) + expr input + with + | Completed values -> + Ok (List.rev values) + | Failed error -> + Error error + | Halted code -> + Halt code + +let differential ?expected ?env backend expr inputs = + let plan = Execution.prepare expr in + check_backend backend plan; + List.iter + (fun (colorize, verbose) -> + List.iter + (fun input -> + let reference = + Interpreter.execute ~colorize ~verbose ?env expr input + in + let actual = Execution.execute ~colorize ~verbose ?env plan input in + check_result + (Ast.show_expression expr ^ " on " ^ representation input) + reference actual; + check_result "fold collection" reference + (fold_collect ~colorize ~verbose ?env plan input); + check_result "interpreter fold collection" reference + (interpreter_fold_collect ~colorize ~verbose ?env expr input); + Option.iter + (fun expected -> check_result "specified result" expected actual) + expected; + check_backend backend plan + ) + (inputs @ inputs) + ) + [ (false, false); (true, false); (false, true); (true, true) ] + +let compiled ?expected name query inputs = + Alcotest.test_case name `Quick (fun () -> + differential ?expected Execution.For_test.Compiled (parse query) inputs + ) + +let interpreted ?expected name query inputs = + Alcotest.test_case name `Quick (fun () -> + differential ?expected Execution.For_test.Interpreted (parse query) inputs + ) + +let obj fields : Json.t = `Assoc fields +let ints values : Json.t = `List (List.map (fun n -> `Int n) values) +let empty_obj = obj [] + +type expected_stream_cut = Expected_root | Expected_member of string + +let check_no_stream_cut backend query = + let plan = Execution.prepare (parse query) in + check_backend backend plan; + match Execution.For_test.stream_cut plan with + | None -> + () + | Some _ -> + Alcotest.failf "%S unexpectedly has a stream cut" query + +let stream_cut_analysis () = + let eligible = + [ + (".[]", Expected_root, ".", [ `Null; `Int 1; empty_obj ]); + ( ".[] | .value", + Expected_root, + ".value", + [ obj [ ("value", `Int 1) ]; empty_obj ] + ); + ( ".[] | select(.active) | .value", + Expected_root, + "select(.active) | .value", + [ + obj [ ("active", `Bool true); ("value", `Int 1) ]; + obj [ ("active", `Bool false); ("value", `Int 2) ]; + ] + ); + (".rows[]", Expected_member "rows", ".", [ `Int 1; empty_obj ]); + ( ".rows[] | .value", + Expected_member "rows", + ".value", + [ obj [ ("value", `Int 1) ]; empty_obj ] + ); + ( ".[\"line-items\"][] | .id", + Expected_member "line-items", + ".id", + [ obj [ ("id", `Int 1) ] ] + ); + ( ".rows[] | select(.active) | [.value, .other]", + Expected_member "rows", + "select(.active) | [.value, .other]", + [ + obj [ ("active", `Bool true); ("value", `Int 1); ("other", `Int 2) ]; + obj [ ("active", `Bool false) ]; + ] + ); + ( ".rows[] | map(.id)", + Expected_member "rows", + "map(.id)", + [ `List [ obj [ ("id", `Int 1) ]; obj [ ("id", `Int 2) ] ] ] + ); + ( ".[] | (., .value)", + Expected_root, + "., .value", + [ obj [ ("value", `Int 1) ] ] + ); + ] + in + List.iter + (fun (query, expected_cut, residual_query, inputs) -> + let plan = Execution.prepare (parse query) in + check_backend Execution.For_test.Compiled plan; + let residual = + match (expected_cut, Execution.For_test.stream_cut plan) with + | Expected_root, Some (Root_items residual) -> + residual + | Expected_member expected, Some (Member_items (actual, residual)) -> + Alcotest.check Alcotest.string "stream member" expected actual; + residual + | Expected_root, _ -> + Alcotest.failf "%S does not have the expected root cut" query + | Expected_member member, _ -> + Alcotest.failf "%S does not have the expected %S member cut" query + member + in + check_backend Execution.For_test.Compiled residual; + let expected_residual = Execution.prepare (parse residual_query) in + check_backend Execution.For_test.Compiled expected_residual; + List.iter + (fun input -> + check_result + (query ^ " residual on " ^ representation input) + (Execution.execute ~colorize:false ~verbose:false expected_residual + input + ) + (Execution.execute ~colorize:false ~verbose:false residual input) + ) + inputs + ) + eligible; + List.iter + (check_no_stream_cut Execution.For_test.Compiled) + [ + "."; + "null"; + ".rows"; + ".[0]"; + ".[0, 1]"; + "empty"; + "select(.)"; + ". + 1"; + "[]"; + "[.[]]"; + "map(.) | .[]"; + ".rows | map(.id) | .[]"; + ".a.b[]"; + ". | .[]"; + ".[0] | .[]"; + ".[], .[]"; + ".rows[], .rows[]"; + ".rows | (., .[])"; + ]; + List.iter + (check_no_stream_cut Execution.For_test.Interpreted) + [ + ".[] | .value?"; + ".rows[] | length"; + "fn selected: .rows[] | .value; selected"; + ".[]?"; + ] + +let numeric_matrix () = + let decimal s : Json.t = `Decimal (Json.Decimal.of_lexeme_exn s) in + let left = + [ + `Int 7; + `Int Int.max_int; + `Int64 Int64.max_int; + `Big_int (Z.of_string "922337203685477580812345"); + decimal "0.1"; + decimal "-3.25"; + `Float 0.1; + `Float (-0.0); + ] + in + let right = + [ + `Int 3; + `Int64 3L; + `Big_int (Z.of_int 3); + decimal "3.0"; + decimal "0.2"; + `Float 3.0; + `Int 0; + `Int64 0L; + `Big_int Z.zero; + decimal "0.0"; + `Float 0.0; + ] + in + let inputs = + List.concat_map + (fun l -> List.map (fun r -> obj [ ("l", l); ("r", r) ]) right) + left + in + List.iter + (fun op -> + differential Execution.For_test.Compiled + Ast.(Operation (Key "l", op, Key "r")) + inputs + ) + Ast. + [ + Add; + Subtract; + Multiply; + Divide; + Modulo; + Equal; + Not_equal; + Greater_than; + Greater_than_or_equal; + Less_than; + Less_than_or_equal; + And; + Or; + ] + +let unsupported_structure () = + let open Ast in + let number = Literal (Number (Integer "1")) in + let unsupported = + [ + Optional Identity; + Variable "x"; + Env_var "HOME"; + Fn0 Now; + Fn0 Debug; + Fn0 Stderr; + Fn0 Halt; + Fn0 Length; + Fn1 (With_expr (Map_values, Identity)); + Fn2 (Limit, number, Identity); + Fn ("f", [], Identity); + Apply ("f", []); + As (Identity, Pat_var "x", Variable "x"); + If_then_else (Identity, number, Identity); + Try (Identity, Some number, None); + Update (Identity, number); + Assign (Key "x", number); + Alternative (Identity, number); + Reduce (Index [], Pat_var "x", number, Identity); + Foreach (Index [], Pat_var "x", number, Identity, Identity); + Dynamic_access number; + Slice (Some 0, Some 1); + Slice_expr (Some number, None); + Object []; + Object [ (Literal (String "x"), Some Identity) ]; + Range (number, None, None); + Fma (number, number, number); + Operation (Comma (number, number), Add, number); + Operation (number, Add, Fn0 Empty); + Operation (Fn1 (With_expr (Select, Identity)), Add, number); + ] + in + List.iter + (fun expr -> + List.iter + (fun wrapped -> + check_backend Execution.For_test.Interpreted + (Execution.prepare wrapped) + ) + [ + expr; + Pipe (Identity, expr); + Pipe (expr, Identity); + Pipe (Fn0 Empty, expr); + Comma (number, expr); + Comma (expr, number); + List (Some expr); + Fn1 (With_expr (Map, expr)); + Fn1 (With_expr (Select, expr)); + Operation (number, Add, expr); + ] + ) + unsupported + +let literal_timing () = + let open Ast in + List.iter + (fun bad -> + let literal = Literal (Number bad) in + differential Execution.For_test.Compiled literal [ `Null ]; + differential ~expected:(Interpreter.Ok []) Execution.For_test.Compiled + (Pipe (Fn0 Empty, literal)) + [ `Null ]; + differential + ~expected:(Interpreter.Ok [ `List [] ]) + Execution.For_test.Compiled + (Fn1 (With_expr (Map, literal))) + [ `List [] ]; + differential Execution.For_test.Compiled + (Comma (Key "missing", literal)) + [ empty_obj ]; + differential Execution.For_test.Compiled + (Operation (Key "missing", Add, literal)) + [ empty_obj ]; + differential Execution.For_test.Interpreted + (Pipe (Fn0 Empty, Optional literal)) + [ `Null ]; + differential Execution.For_test.Interpreted + (Comma (Identity, Optional literal)) + [ `Null ] + ) + [ + Integer "not-an-integer"; + Decimal "not-a-decimal"; + Decimal "1e999999999999999999999"; + ] + +let environment_reuse () = + let expr = parse "., $x" in + let plan = Execution.prepare expr in + check_backend Execution.For_test.Interpreted plan; + List.iter + (fun env -> + check_result "per-call environment" + (Interpreter.execute ~colorize:false ~verbose:false ~env expr `Null) + (Execution.execute ~colorize:false ~verbose:false ~env plan `Null); + check_result "per-call fold environment" + (Interpreter.execute ~colorize:false ~verbose:false ~env expr `Null) + (fold_collect ~colorize:false ~verbose:false ~env plan `Null); + differential ~env Execution.For_test.Interpreted expr [ `Null ]; + differential ~env Execution.For_test.Compiled (parse ".") [ `Null ] + ) + [ [ ("x", `Int 1) ]; []; [ ("x", `String "next") ]; [] ] + +let stream_compositions () = + let open Ast in + let atoms = + [ + Identity; + Key "x"; + Index []; + Index [ -1 ]; + Index [ 0; -1; 0 ]; + Fn0 Empty; + Literal Null; + Literal (Bool false); + List None; + Fn1 (With_expr (Select, Identity)); + ] + in + let inputs = + [ + `Null; + `Int 1; + empty_obj; + obj [ ("x", `Int 2); ("a", `Bool false) ]; + ints []; + ints [ 0; 1; 2 ]; + `List [ ints []; ints [ 1; 2 ] ]; + `List [ obj [ ("x", `Int 3) ]; empty_obj ]; + ] + in + List.iter + (fun left -> + List.iter + (fun right -> + List.iter + (fun expr -> differential Execution.For_test.Compiled expr inputs) + [ + Pipe (left, right); + Comma (left, right); + List (Some (Pipe (left, right))); + Fn1 (With_expr (Map, Comma (left, right))); + Pipe (left, Fn1 (With_expr (Select, right))); + ] + ) + atoms + ) + atoms + +let long_filtered_stream () = + let expr = parse ".[] | select(false, false) | .missing" in + differential ~expected:(Interpreter.Ok []) Execution.For_test.Compiled expr + [ `List (List.init 20000 (fun n -> `Int n)) ] + +let fold_late_error () = + List.iter + (fun (backend, query) -> + let expr = parse query in + let plan = Execution.prepare expr in + check_backend backend plan; + let seen = ref [] in + let result = + Execution.fold ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> seen := value :: !seen) + plan empty_obj + in + check_result "values before failure" + (Ok [ `Int 1; `Int 2 ]) + (Ok (List.rev !seen)); + match result with + | Failed error -> + check_result "late error" + (Interpreter.execute ~colorize:false ~verbose:false expr empty_obj) + (Error error) + | _ -> + Alcotest.fail "expected fold failure" + ) + [ + (Execution.For_test.Compiled, "1, 2, .missing, 3"); + (Execution.For_test.Compiled, "1, 2, 1 % 0, 3"); + (Execution.For_test.Interpreted, "1, 2, .missing, length"); + (Execution.For_test.Interpreted, "1, 2, 1 % 0, length"); + (Execution.For_test.Interpreted, "1, 2, error(\"stop\"), 3"); + (Execution.For_test.Interpreted, "1, 2, break, 3"); + ] + +let check_callback_exception ?(at = 1) call = + let exception Callback_error of int ref in + let expected = Callback_error (ref 42) in + let calls = ref 0 in + let original_backtrace = ref "" in + let recording = Printexc.backtrace_status () in + Printexc.record_backtrace true; + Fun.protect + ~finally:(fun () -> Printexc.record_backtrace recording) + (fun () -> + let callback _ = + incr calls; + if !calls = at then ( + try raise expected + with exn -> + let backtrace = Printexc.get_raw_backtrace () in + original_backtrace := Printexc.raw_backtrace_to_string backtrace; + Printexc.raise_with_backtrace exn backtrace + ) + in + match call callback with + | _ -> + Alcotest.fail "callback exception did not escape" + | exception actual -> + let backtrace = Printexc.get_backtrace () in + Alcotest.check Alcotest.bool "same exception instance" true + (actual == expected); + Alcotest.check Alcotest.int "stops at failing callback" at !calls; + Alcotest.check Alcotest.bool "callback backtrace recorded" true + (!original_backtrace <> ""); + Alcotest.check Alcotest.bool "callback backtrace preserved" true + (String.starts_with ~prefix:!original_backtrace backtrace) + ) + +let fold_callback_exception () = + List.iter + (fun (backend, query) -> + let expr = parse query in + let plan = Execution.prepare expr in + check_backend backend plan; + List.iter + (fun at -> + check_callback_exception ~at (fun callback -> + Execution.fold ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> callback value) + plan `Null + ); + check_callback_exception ~at (fun callback -> + Interpreter.fold ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> callback value) + expr `Null + ) + ) + [ 1; 2 ]; + check_result "reuse after callback exception" + (Interpreter.execute ~colorize:false ~verbose:false expr `Null) + (fold_collect ~colorize:false ~verbose:false plan `Null) + ) + [ + (Execution.For_test.Compiled, "1, 2"); + (Execution.For_test.Interpreted, "range(1; 3)"); + (Execution.For_test.Interpreted, "try (1, 2, error(\"query\")) catch 3"); + (Execution.For_test.Interpreted, "(1, 2, .missing)?"); + (Execution.For_test.Interpreted, "1, 2, halt"); + ] + +let fold_halt () = + List.iter + (fun (query, code) -> + let expr = parse query in + differential ~expected:(Halt code) Execution.For_test.Interpreted expr + [ `Null ]; + let seen = ref [] in + let result = + Execution.fold ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> seen := value :: !seen) + (Execution.prepare expr) `Null + in + check_result "values before halt" + (Ok [ `Int 1; `Int 2 ]) + (Ok (List.rev !seen)); + match result with + | Halted actual -> + Alcotest.check Alcotest.int "halt code" code actual + | _ -> + Alcotest.fail "expected halted fold" + ) + [ ("1, 2, halt, 3", 0); ("1, 2, halt_error(7), 3", 7) ] + +let fold_long_stream () = + let count = 100000 in + let input = `List (List.init count (fun n -> `Int n)) in + List.iter + (fun (backend, query) -> + let plan = Execution.prepare (parse query) in + check_backend backend plan; + match + Execution.fold ~colorize:false ~verbose:false ~init:0 + ~f:(fun index value -> + if value <> `Int index then Alcotest.fail "output order changed"; + index + 1 + ) + plan input + with + | Completed actual -> + Alcotest.check Alcotest.int "output count" count actual + | _ -> + Alcotest.fail "expected completed fold" + ) + [ + (Execution.For_test.Compiled, ".[]"); + (Execution.For_test.Interpreted, ".[]?"); + ] + +let core_output () = + List.iter + (fun (query, input) -> + let expr = parse query in + List.iter + (fun colorize -> + List.iter + (fun (raw, summarize) -> + let expected = + match + Interpreter.execute ~colorize ~verbose:false expr input + with + | Ok values -> + Ok + (String.concat "\n" + (List.map + (Json.to_string_pretty ~colorize ~summarize ~raw) + values + ) + ) + | Error error -> + Error error + | Halt _ -> + Alcotest.fail "unexpected halt" + in + Alcotest.check + (Alcotest.result Alcotest.string Alcotest.string) + query expected + (Core.run ~colorize ~raw ~summarize query input); + let output = Buffer.create 32 in + let first = ref true in + let seen = ref [] in + let emit value = + if !first then + first := false + else + Buffer.add_char output '\n'; + Buffer.add_string output value; + seen := value :: !seen + in + let actual = + Core.run_iter ~colorize ~raw ~summarize ~emit query input + in + Alcotest.check + (Alcotest.result Alcotest.string Alcotest.string) + (query ^ " run_iter") expected + (Result.map + (fun count -> + Alcotest.check Alcotest.int + (query ^ " run_iter count") + (List.length !seen) count; + Buffer.contents output + ) + actual + ); + match Interpreter.execute ~colorize ~verbose:false expr input with + | Ok values -> + Alcotest.check + (Alcotest.list Alcotest.string) + "one emit per result, without separators" + (List.map + (Json.to_string_pretty ~colorize ~summarize ~raw) + values + ) + (List.rev !seen) + | Error _ -> + () + | Halt _ -> + Alcotest.fail "unexpected halt" + ) + [ (false, false); (true, false); (false, true); (true, true) ] + ) + [ false; true ] + ) + [ + (".[]", `List [ `String "first"; obj [ ("z", `Int 1); ("a", `Int 2) ] ]); + (".[] | .x", `List [ obj [ ("x", `Int 1) ]; empty_obj ]); + ("empty", `Null); + ("map(. + 0.1)", ints [ 1; 2 ]); + (".missing?", empty_obj); + (".[]", `List [ `String ""; `String ""; `String "last"; `String "" ]); + (".[]?", `List [ `String ""; `String "last"; `String "" ]); + ] + +let core_iter_errors () = + List.iter + (fun (query, expected_seen) -> + let seen = ref [] in + let actual = + Core.run_iter ~colorize:false ~verbose:true + ~emit:(fun value -> seen := value :: !seen) + query empty_obj + in + Alcotest.check + (Alcotest.list Alcotest.string) + "emits before error" expected_seen (List.rev !seen); + match actual with + | Error error -> + Alcotest.check + (Alcotest.result Alcotest.string Alcotest.string) + "same error as run" + (Core.run ~colorize:false ~verbose:true query empty_obj) + (Error error) + | Ok _ -> + Alcotest.fail "expected run_iter error" + ) + [ + ("1, .missing, 2", [ "1" ]); + ("1, error(\"stop\")", [ "1" ]); + ("1, .missing, length", [ "1" ]); + ("1, 1 % 0, length", [ "1" ]); + ("1, break, 2", [ "1" ]); + ("[", []); + ]; + List.iter + (fun query -> + check_callback_exception (fun emit -> + Core.run_iter ~colorize:false ~emit query `Null + ) + ) + [ "1, .missing"; "range(1; 3)"; "1, error(\"stop\")" ] + +let parse_input text = + match Json.parse_string text with + | Ok input -> + input + | Error error -> + Alcotest.failf "Cannot parse input %S: %s" text error + +let load_input plan source = + match Execution.load plan source with + | Ok loaded -> + loaded + | Error error -> + Alcotest.failf "Cannot load input: %s" error + +let observe_fold call = + let seen = ref [] in + let result : Interpreter.execute_result = + match + call (fun acc value -> + seen := value :: !seen; + value :: acc + ) + with + | Execution.Completed values -> + Ok (List.rev values) + | Failed error -> + Error error + | Halted code -> + Halt code + in + (result, List.rev !seen) + +let check_fold label (expected, expected_seen) (actual, actual_seen) = + check_result (label ^ " terminal") expected actual; + check_result (label ^ " callback order") (Ok expected_seen) (Ok actual_seen) + +let loaded_shapes = + List.map + (fun query -> (Execution.For_test.Compiled, query)) + [ + ".a"; + ".a.b"; + ".a | 1"; + ".a | empty"; + ".a | .[] | .b"; + ".a | (., .b)"; + ".a | .b | .c | .d"; + "."; + ".[0]"; + ".a, .b"; + "[.a]"; + ".a + 1"; + ".[]"; + ] + @ [ (Execution.For_test.Interpreted, ".a?") ] + +let loaded_plan_matrix () = + let inputs = + [ + ("selected first", {|{"a":{"b":{"c":{"d":0.10}}},"z":[1,2]}|}); + ("selected middle", {|{"z":[1,2],"a":{"b":{"c":{"d":0.10}}},"b":9}|}); + ("selected last", {|{"z":[1,2],"a":{"b":{"c":{"d":0.10}}}}|}); + ("missing key", {|{"a-near":1,"b":2,"z":[3]}|}); + ("first duplicate wins", {|{"a":1,"a":{"b":2},"b":3}|}); + ("selected null", {|{"a":null,"a":2,"b":3}|}); + ("scalar root", "42"); + ("array root", {|[{"a":1},{"b":2}]|}); + ( "ordered selected stream", + {|{"a":[{"b":0.10},{"b":9223372036854775807},{"b":9223372036854775808}],"z":0}|} + ); + ( "selected late error", + {|{"a":[{"b":"first"},{"other":2},{"b":"unreached"}],"z":0}|} + ); + ("selected nested error", {|{"a":{"b":{"c":false}},"z":0}|}); + ] + in + List.iter + (fun (backend, query) -> + let plan = Execution.prepare (parse query) in + check_backend backend plan; + List.iter + (fun (name, text) -> + let input = parse_input text in + let loaded = load_input plan (Json.Input.String text) in + List.iter + (fun (colorize, verbose) -> + let label = query ^ " / " ^ name in + let expected = Execution.execute ~colorize ~verbose plan input in + let expected_fold = + observe_fold (fun f -> + Execution.fold ~colorize ~verbose ~init:[] ~f plan input + ) + in + check_result (label ^ " full fold") expected (fst expected_fold); + for _ = 1 to 2 do + check_result + (label ^ " loaded execution") + expected + (Execution.execute_loaded ~colorize ~verbose loaded); + check_fold label expected_fold + (observe_fold (fun f -> + Execution.fold_loaded ~colorize ~verbose ~init:[] ~f + loaded + ) + ) + done + ) + [ (false, false); (true, true) ] + ) + inputs + ) + loaded_shapes + +let malformed_source_inputs = + [ {|{"a":[{"b":1}],"discarded":"\q"}|}; {|{"a":[{"b":1}],"discarded":[2|} ] + +let input_error text = + match Json.parse_string text with + | Error error -> + error + | Ok _ -> + Alcotest.failf "Malformed input was accepted: %S" text + +let loaded_plan_invalid_tail () = + List.iter + (fun text -> + let expected = input_error text in + List.iter + (fun (_, query) -> + Alcotest.check + (Alcotest.result Alcotest.unit Alcotest.string) + (query ^ " validates discarded tail") + (Error expected) + (Result.map + (fun _ -> ()) + (Execution.load + (Execution.prepare (parse query)) + (Json.Input.String text) + ) + ) + ) + loaded_shapes + ) + malformed_source_inputs + +let loaded_callback_reuse () = + List.iter + (fun (query, text) -> + let plan = Execution.prepare (parse query) in + let input = parse_input text in + let expected = + Execution.execute ~colorize:false ~verbose:false plan input + in + List.iter + (fun source -> + let loaded = load_input plan source in + List.iter + (fun at -> + check_callback_exception ~at (fun callback -> + Execution.fold_loaded ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> callback value) + loaded + ); + check_result "loaded execute after callback exception" expected + (Execution.execute_loaded ~colorize:false ~verbose:false loaded); + check_fold "loaded fold after callback exception" + (observe_fold (fun f -> + Execution.fold ~colorize:false ~verbose:false ~init:[] ~f + plan input + ) + ) + (observe_fold (fun f -> + Execution.fold_loaded ~colorize:false ~verbose:false + ~init:[] ~f loaded + ) + ) + ) + [ 1; 2 ] + ) + [ Json.Input.String text; Json.Input.Value input ] + ) + [ + (".a | .[] | .b", {|{"a":[{"b":1},{"b":2}]}|}); + (".a | (., .b)", {|{"a":{"b":2}}|}); + (".a? | .[] | .b", {|{"a":[{"b":1},{"b":2}]}|}); + ] + +let observe_iter call = + let seen = ref [] in + let result = call (fun value -> seen := value :: !seen) in + (result, List.rev !seen) + +let check_iter label (expected, expected_seen) (actual, actual_seen) = + Alcotest.check + (Alcotest.result Alcotest.int Alcotest.string) + (label ^ " terminal") expected actual; + Alcotest.check + (Alcotest.list Alcotest.string) + (label ^ " emitted prefix") + expected_seen actual_seen + +let core_source_calls () = + List.iter + (fun (query, text, error_prefix) -> + let input = parse_input text in + List.iter + (fun colorize -> + List.iter + (fun (raw, summarize) -> + let expected = + Core.run ~colorize ~verbose:true ~raw ~summarize query input + in + let expected_iter = + observe_iter (fun emit -> + Core.run_iter ~colorize ~verbose:true ~raw ~summarize ~emit + query input + ) + in + ( match (error_prefix, expected) with + | None, Error error -> + Alcotest.failf "%s: expected success, got %s" query error + | Some _, Ok _ -> + Alcotest.fail "expected a Core error" + | _ -> + () + ); + Option.iter + (fun prefix -> + check_iter + (query ^ " reference late error") + ( Result.map (fun _ -> List.length prefix) expected, + List.map + (Json.to_string_pretty ~colorize ~raw ~summarize) + prefix + ) + expected_iter + ) + error_prefix; + List.iter + (fun source -> + Alcotest.check + (Alcotest.result Alcotest.string Alcotest.string) + (query ^ " Core source output") + expected + (Core.run_input ~colorize ~verbose:true ~raw ~summarize + query source + ); + check_iter + (query ^ " Core source iteration") + expected_iter + (observe_iter (fun emit -> + Core.run_input_iter ~colorize ~verbose:true ~raw + ~summarize ~emit query source + ) + ) + ) + [ Core.String text; Core.Value input ] + ) + [ (false, false); (true, false); (false, true); (true, true) ] + ) + [ false; true ] + ) + [ + ( ".a | .[]", + {|{"a":["","a long string with more than twenty characters",{"z":1,"b":2},[1,2]],"z":0}|}, + None + ); + (".", {|{"a":1,"a":2,"b":[3,4]}|}, None); + (".a | empty", {|{"a":null,"z":0}|}, None); + (".a?", {|{"other":1}|}, None); + ( ".a | .[] | .b", + {|{"a":[{"b":"first"},{"other":2},{"b":"unreached"}],"z":0}|}, + Some [ `String "first" ] + ); + (".a | (., .b)", {|{"a":42,"z":0}|}, Some [ `Int 42 ]); + (".a, .missing", {|{"a":"first","z":0}|}, Some [ `String "first" ]); + ( "fn selected: .a[]; selected | .b", + {|{"a":[{"b":"first"},{"other":2}]}|}, + Some [ `String "first" ] + ); + (".a", {|{"a-near":1,"z":0}|}, Some []); + ("[", {|{"a":1}|}, Some []); + ] + +let core_source_error_precedence () = + List.iter + (fun colorize -> + let query_error = + match Core.parse ~debug:false ~colorize "[" with + | Error error -> + error + | Ok _ -> + Alcotest.fail "expected an invalid query" + in + Alcotest.check + (Alcotest.result Alcotest.string Alcotest.string) + "valid JSON exposes query error" (Error query_error) + (Core.run_input ~colorize "[" (Core.String {|{"a":1}|})); + List.iter + (fun text -> + let expected = input_error text in + Alcotest.check Alcotest.bool "distinct JSON and query errors" true + (expected <> query_error); + List.iter + (fun query -> + Alcotest.check + (Alcotest.result Alcotest.string Alcotest.string) + (query ^ " JSON error wins") + (Error expected) + (Core.run_input ~colorize query (Core.String text)); + check_iter + (query ^ " validates before emitting") + (Error expected, []) + (observe_iter (fun emit -> + Core.run_input_iter ~colorize ~emit query (Core.String text) + ) + ) + ) + [ ".a"; ".a | empty"; ".a | .[] | .b"; ".a?"; "[" ] + ) + malformed_source_inputs + ) + [ false; true ] + +let observe_source ?(colorize = false) ?(verbose = false) ?env plan source = + observe_fold (fun f -> + Execution.fold_source ~colorize ~verbose ?env ~init:[] ~f plan source + ) + +(* Reimplements the validate-first path fold_source takes for plans without a + stream cut, so tests can pin the atomic ground truth for comparison. *) +let observe_validated ?(colorize = false) ?(verbose = false) ?env plan source = + observe_fold (fun f -> + match Execution.load plan source with + | Ok loaded -> + Execution.fold_loaded ~colorize ~verbose ?env ~init:[] ~f loaded + | Error error -> + Execution.Failed error + ) + +let source_plan_matrix () = + let inputs = + [ + "[]"; + "{}"; + "null"; + "false"; + "42"; + {|"scalar"|}; + "[0.10,9223372036854775807,9223372036854775808]"; + {|[{"id":1,"next":2},{"id":3,"next":4}]|}; + {|{"z":{"id":1},"a":{"id":2},"z":{"id":3}}|}; + {|[{"id":1},{},{"id":3}]|}; + {|[[{"id":1},{"id":2}],[{"id":3}]]|}; + {|[[{"id":1}],[{"id":2},{}],[{"id":3}]]|}; + ] + in + List.iter + (fun suffix -> + List.iter + (fun head -> + let query = head ^ suffix in + let plan = Execution.prepare (parse query) in + check_backend Execution.For_test.Compiled plan; + Alcotest.check Alcotest.bool "eligible source plan" true + (Option.is_some (Execution.For_test.stream_cut plan)); + let texts = + if head = ".[]" then + inputs + else + List.concat_map + (fun text -> + [ + {|{"rows":|} ^ text ^ {|,"rows":[99],"tail":0}|}; + {|{"before":[1,2],"rows":|} ^ text ^ "}"; + ] + ) + inputs + @ [ "null"; "42"; "[]"; "{}"; {|{"rows-near":1,"tail":2}|} ] + in + List.iter + (fun text -> + let input = parse_input text in + List.iter + (fun (colorize, verbose) -> + let expected = + observe_fold (fun f -> + Execution.fold_loaded ~colorize ~verbose ~init:[] ~f + (load_input plan (Json.Input.String text)) + ) + in + List.iter + (fun source -> + check_fold + (query ^ " on " ^ text) + expected + (observe_source ~colorize ~verbose plan source) + ) + [ Json.Input.String text; Json.Input.Value input ] + ) + [ (false, false); (true, true) ] + ) + texts + ) + [ ".[]"; ".rows[]" ] + ) + [ + ""; + " | empty"; + " | .id"; + " | select(.id > 1) | .id"; + " | [.id, .next]"; + " | map(.id)"; + " | (., .id, .next)"; + " | .[] | (.id, .id + 10)"; + ] + +let source_error_drain () = + List.iter + (fun (query, valid, malformed, expected_seen) -> + let plan = Execution.prepare (parse query) in + let expected = observe_validated plan (Json.Input.String valid) in + ( match fst expected with + | Error _ -> + () + | _ -> + Alcotest.fail "expected query error" + ); + check_result "validated error prefix" (Ok expected_seen) + (Ok (snd expected)); + check_fold "saved query error after valid tail" expected + (observe_source plan (Json.Input.String valid)); + List.iter + (fun text -> + check_fold "later input error wins" + (Error (input_error text), expected_seen) + (observe_source plan (Json.Input.String text)); + check_fold "reuse after input error" expected + (observe_source plan (Json.Input.Value (parse_input valid))) + ) + malformed + ) + [ + ( ".[] | (.id, .next)", + {|[{"id":1},{"id":2,"next":3}]|}, + [ {|[{"id":1},{"id":2,"next":3},|}; {|[{"id":1},"\q"]|} ], + [ `Int 1 ] + ); + ( ".rows[] | .id", + {|{"rows":[{"id":1},{},{"id":3}],"tail":[4]}|}, + [ + {|{"rows":[{"id":1},{},{"id":3}],"tail":[4|}; + {|{"rows":[{"id":1},{},{"id":3}],"rows":"\q"}|}; + {|{"rows":[{"id":1},{},"\q"]}|}; + ], + [ `Int 1 ] + ); + (".[] | 1 % 0", "[1,2,3]", [ "[1,2,"; "[1,2,3] trailing" ], []); + ] + +let source_invalid_tail () = + List.iter + (fun (query, text, prefix) -> + let plan = Execution.prepare (parse query) in + check_fold "successful items before malformed tail" + (Error (input_error text), prefix) + (observe_source plan (Json.Input.String text)); + check_fold "validating first never exposes an invalid input prefix" + (Error (input_error text), []) + (observe_validated plan (Json.Input.String text)) + ) + [ + (".[]", "[1,2,", [ `Int 1; `Int 2 ]); + (".[]", "[1,2x]", [ `Int 1 ]); + (".[]", {|{"a":1,"a":2,"b":"\q"}|}, [ `Int 1; `Int 2 ]); + (".[] | (., . + 10)", "[1,2,", [ `Int 1; `Int 11; `Int 2; `Int 12 ]); + (".rows[] | .id", {|{"rows":[{"id":1},{"id":2}x]}|}, [ `Int 1 ]); + (".rows[]", {|{"rows":[1,2],"tail":"\q"}|}, [ `Int 1; `Int 2 ]); + (".rows[]", {|{"rows":[1],"rows":[2,}|}, [ `Int 1 ]); + (".rows[]", {|{"rows":[],"tail":"\q"}|}, []); + ] + +let source_validation_barriers () = + List.iter + (fun (query, valid, malformed) -> + let plan = Execution.prepare (parse query) in + Alcotest.check Alcotest.bool "no stream cut" true + (Option.is_none (Execution.For_test.stream_cut plan)); + check_fold "barrier validates before callbacks" + (Error (input_error malformed), []) + (observe_source plan (Json.Input.String malformed)); + let expected = observe_validated plan (Json.Input.String valid) in + List.iter + (fun source -> + check_fold "barrier valid input" expected (observe_source plan source) + ) + [ Json.Input.String valid; Json.Input.Value (parse_input valid) ] + ) + [ + ("[.[]]", "[1,2]", "[1,2,"); + ( ".rows | map(.id) | .[]", + {|{"rows":[{"id":1}]}|}, + {|{"rows":[{"id":1}],"tail":"\q"}|} + ); + (".[]?", "[1,2]", "[1,2,"); + ("fn items: .[]; items", "[1,2]", "[1,2,"); + ]; + let plan = Execution.prepare (parse ".[], $x, halt_error(7)") in + check_fold "fallback environment and halt" + (Halt 7, [ `Int 1; `Int 2; `Int 3 ]) + (observe_source ~env:[ ("x", `Int 3) ] plan (Json.Input.String "[1,2]")); + check_fold "invalid input precedes fallback halt" + (Error (input_error "[1,2,"), []) + (observe_source ~env:[ ("x", `Int 3) ] plan (Json.Input.String "[1,2,")) + +let source_callback_reuse () = + List.iter + (fun (query, text) -> + let plan = Execution.prepare (parse query) in + let expected = observe_validated plan (Json.Input.String text) in + List.iter + (fun source -> + List.iter + (fun at -> + check_callback_exception ~at (fun callback -> + Execution.fold_source ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> callback value) + plan source + ); + check_fold "source reuse after callback exception" expected + (observe_source plan source) + ) + [ 1; 2 ] + ) + [ Json.Input.String text; Json.Input.Value (parse_input text) ]; + let file = Filename.temp_file "execution-source-" ".json" in + Fun.protect + ~finally:(fun () -> Sys.remove file) + (fun () -> + let channel = open_out file in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> output_string channel text); + check_callback_exception (fun callback -> + Execution.fold_source ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> callback value) + plan (Json.Input.File file) + ); + check_fold "source file after callback exception" expected + (observe_source plan (Json.Input.File file)) + ) + ) + [ + (".[] | (., . + 10)", "[1,2]"); + (".rows[] | .id", {|{"rows":[{"id":1},{"id":2}]}|}); + (".[]?", "[1,2]"); + ]; + let plan = Execution.prepare (parse ".[] | .id") in + List.iter + (fun text -> + ignore (observe_source plan (Json.Input.String text)); + check_fold "prepared plan recovers from failure" + (Ok [ `Int 9 ], [ `Int 9 ]) + (observe_source plan (Json.Input.String {|[{"id":9}]|})) + ) + [ {|[{"id":1},{},{"id":3}]|}; {|[{"id":1},|} ]; + check_callback_exception (fun callback -> + Execution.fold_source ~colorize:false ~verbose:false ~init:() + ~f:(fun () value -> callback value) + plan (Json.Input.String {|[{"id":1},|}) + ) + +let core_streaming () = + List.iter + (fun (query, text, prefix) -> + let expected_error = input_error text in + check_iter "Core run_input_iter permits prefixes" + (Error expected_error, prefix) + (observe_iter (fun emit -> + Core.run_input_iter ~colorize:false ~emit query (Core.String text) + ) + ); + check_iter "Core debug forces validation first" (Error expected_error, []) + (observe_iter (fun emit -> + Core.run_input_iter ~debug:true ~colorize:false ~emit query + (Core.String text) + ) + ) + ) + [ + (".[]", "[1,2,", [ "1"; "2" ]); + (".rows[] | .id", {|{"rows":[{"id":1},{},|}, [ "1" ]); + ("[.[]]", "[1,2,", []); + (".rows | map(.id) | .[]", {|{"rows":[{"id":1}],"tail":[|}, []); + (".[]?", "[1,2,", []); + ("fn items: .[]; items", "[1,2,", []); + ("[", "[1,2,", []); + ]; + List.iter + (fun (query, text) -> + let input = parse_input text in + let expected = + observe_iter (fun emit -> + Core.run_iter ~colorize:false ~raw:true ~summarize:true ~emit query + input + ) + in + List.iter + (fun source -> + check_iter "Core run_input_iter valid input" expected + (observe_iter (fun emit -> + Core.run_input_iter ~colorize:false ~raw:true ~summarize:true + ~emit query source + ) + ) + ) + [ Core.String text; Core.Value input ] + ) + [ + (".[]", {|["","long string with more than twenty characters",3]|}); + (".rows[] | .id", {|{"rows":[{"id":1},{},{"id":3}]}|}); + (".rows[]", {|{"rows":42}|}); + ("[", "[1,2]"); + ]; + List.iter + (fun (query, text) -> + check_callback_exception (fun emit -> + Core.run_input_iter ~colorize:false ~emit query (Core.String text) + ) + ) + [ (".[]", "[1,2,"); (".rows[] | .id", {|{"rows":[{"id":1},|}) ] + +let tests = + [ + compiled "identity preserves representation" "." + [ + `Null; + `Int64 1L; + `Big_int Z.one; + `Float 1.0; + obj [ ("z", `Int 1); ("a", `Int 2); ("z", `Int 3) ]; + ]; + compiled "all literals" + "true, false, null, \"text\", 1, -2, 0.10, 1e3, 9223372036854775807, \ + 9223372036854775808" + [ `Null ]; + compiled + ~expected:(Ok [ `Int 4 ]) + "nested paths" ".a.b[0].c" + [ obj [ ("a", obj [ ("b", `List [ obj [ ("c", `Int 4) ] ]) ]) ] ]; + compiled + ~expected:(Ok [ `Int 1 ]) + "first duplicate key" ".x" + [ obj [ ("x", `Int 1); ("x", `Int 2) ] ]; + compiled + ~expected:(Ok [ `Int 2; `Int 1; `Int 3 ]) + "object iteration order" ".[]" + [ obj [ ("z", `Int 2); ("a", `Int 1); ("z", `Int 3) ] ]; + compiled + ~expected:(Ok [ `Int 3; `Int 1; `Int 3; `Int 1 ]) + "negative and duplicate indices" ".[2, 0, -1, 0]" + [ ints [ 1; 2; 3 ] ]; + compiled + ~expected:(Ok [ `Int 3 ]) + "scalar negative index" ".[-1]" + [ ints [ 1; 2; 3 ] ]; + compiled ~expected:(Ok []) "empty iteration" ".[]" [ ints []; empty_obj ]; + compiled + ~expected:(Ok [ `Int 1; `Int 2; `Int 3; `Int 4 ]) + "depth-first pipe" ".[] | .[]" + [ `List [ ints [ 1; 2 ]; ints [ 3; 4 ] ] ]; + compiled + ~expected:(Ok [ `Int 1; `Int 11; `Int 2; `Int 12 ]) + "pipe into comma" ".[] | (., . + 10)" + [ ints [ 1; 2 ] ]; + compiled + ~expected:(Ok [ `Int 1; `Int 2; `Int 1; `Int 2 ]) + "comma restarts input" ".[], .[]" + [ ints [ 1; 2 ] ]; + compiled + ~expected:(Ok [ `List [ `Int 1; `Int 2; `Int 9 ] ]) + "list collection" "[.[], empty, 9]" + [ ints [ 1; 2 ] ]; + compiled ~expected:(Ok [ `List [] ]) "empty list" "[]" [ `Null ]; + compiled + ~expected:(Ok [ `List [] ]) + "empty collected list" "[empty]" [ `Null ]; + compiled ~expected:(Ok []) "empty does not run right pipe" + "empty | .missing" [ `Null ]; + compiled ~expected:(Ok [ `Int 4 ]) "comma after empty" "empty, 4" [ `Null ]; + compiled + ~expected:(Ok [ `List [ `Int 2; `Int 1; `Int 4; `Int 3 ] ]) + "map flattens each child stream" "map(. + 1, .)" + [ ints [ 1; 3 ] ]; + compiled + ~expected:(Ok [ `List [] ]) + "map empty" "map(empty)" + [ ints [ 1; 2 ] ]; + compiled + ~expected:(Ok [ `List [] ]) + "map empty input skips child" "map(.missing)" + [ ints [] ]; + compiled + ~expected:(Ok [ `List [ `List [ `Int 1; `Int 2 ]; `List [ `Int 3 ] ] ]) + "nested map and list" "map([.[]])" + [ `List [ ints [ 1; 2 ]; ints [ 3 ] ] ]; + compiled + ~expected:(Ok [ `Int 2; `Int 3 ]) + "select scalar" ".[] | select(. > 1)" + [ ints [ 1; 2; 3 ] ]; + compiled + ~expected:(Ok [ `Int 7; `Int 7; `Int 7; `Int 7 ]) + "select yields for every truthy result" + "select(false, null, true, 0, \"\", [])" + [ `Int 7 ]; + compiled ~expected:(Ok []) "select empty" "select(empty)" [ `Null ]; + compiled + ~expected:(Ok [ `List [ `Int 2; `Int 3 ] ]) + "map select" "map(select(. > 1))" + [ ints [ 1; 2; 3 ] ]; + compiled "exact scalar arithmetic" + "0.1 + 0.2, 1 / 8, 1 / 3, 9223372036854775807 + 1, 1.20 * 3, 1e3 - 0.5" + [ `Null ]; + compiled "operations on collected scalars" "[.[]] + map(. * 2)" + [ ints [ 1; 2 ] ]; + compiled "boolean operations evaluate both sides" "false and .missing" + [ empty_obj ]; + compiled "or evaluates both sides" "true or .missing" [ empty_obj ]; + compiled "left operand fails first" ".left + .right" [ empty_obj ]; + compiled "division and modulo errors" "1 / 0" [ `Null ]; + compiled "modulo exception" "1 % 0" [ `Null ]; + compiled "string operations" "\"ab\" * 3, \"a,b\" / \",\", \"a\" + \"b\"" + [ `Null ]; + compiled "list operators" ".l + .r, .l - .r" + [ obj [ ("l", ints [ 2; 1; 2 ]); ("r", ints [ 2; 3 ]) ] ]; + compiled "object operator order" ".l + .r, .l * .r" + [ + obj + [ + ("l", obj [ ("z", obj [ ("x", `Int 1) ]); ("a", `Int 2) ]); + ("r", obj [ ("z", obj [ ("y", `Int 3) ]); ("b", `Int 4) ]); + ]; + ]; + compiled "missing key after yield and recovery" ".[] | .x" + [ + `List [ obj [ ("x", `Int 1) ] ]; + `List [ obj [ ("x", `Int 1) ]; empty_obj ]; + `List [ obj [ ("x", `Int 9) ] ]; + ]; + compiled "index error after yield and recovery" ".[0, 2]" + [ ints [ 1; 2; 3 ]; ints [ 1 ]; ints [ 9; 8; 7 ] ]; + compiled "negative index out of range" ".[-4]" [ ints [ 1; 2 ] ]; + compiled "list discards earlier yields" "[1, .missing]" [ empty_obj ]; + compiled "map discards prior items" "map(.x)" + [ + `List [ obj [ ("x", `Int 1) ]; empty_obj ]; + ints []; + `List [ obj [ ("x", `Int 2) ] ]; + ]; + compiled "select late error" "select(true, .missing)" [ empty_obj ]; + compiled "depth-first error precedence" "(.a, .missing) | (.x, .y)" + [ obj [ ("a", obj [ ("x", `Int 1) ]) ] ]; + compiled "comma does not open later iterator early" ".missing, .[]" + [ `Null ]; + compiled "downstream errors precede later source errors" + "(1, .missing) | .[]" [ empty_obj ]; + compiled "input errors and suggestions" ".foo" + [ + `Null; + `Int 1; + ints []; + obj [ ("foo-bar", `Int 2) ]; + obj [ ("foo", `Int 9) ]; + ]; + compiled "iteration type errors" ".[]" + [ `Null; `Bool false; `String "abc"; `Int 1 ]; + compiled "index type errors" ".[0]" [ `Null; empty_obj; `String "abc" ]; + compiled "map type errors" "map(.)" [ empty_obj; `Null; `String "abc" ]; + compiled "operator errors" ". + true, . < \"a\"" + [ `Null; `Int 1; empty_obj; ints [] ]; + interpreted + ~expected:(Ok [ `Int 11; `Int 21; `Int 12; `Int 22 ]) + "left-major stream operation fallback" "(1, 2) + (10, 20)" [ `Null ]; + interpreted "optional access fallback" ".x?" + [ empty_obj; obj [ ("x", `Int 1) ] ]; + interpreted "mixed pipe fallback" ".[] | .x?" + [ `List [ empty_obj; obj [ ("x", `Int 2) ] ] ]; + interpreted "map child fallback" "map(.x?)" [ `List [ empty_obj ] ]; + interpreted "select child fallback" "select(.x?)" [ empty_obj ]; + interpreted "functions fallback" "fn double: . * 2; double" [ `Int 3 ]; + interpreted "binding fallback" ". as $x | $x + 1" [ `Int 3 ]; + interpreted "control fallback" "if . then 1 else 2 end" + [ `Bool false; `Bool true ]; + interpreted "update fallback" ".x |= . + 1" [ obj [ ("x", `Int 1) ] ]; + interpreted "reduce fallback" "reduce .[] as $x (0; . + $x)" + [ ints [ 1; 2 ] ]; + interpreted "foreach fallback" "[foreach .[] as $x (0; . + $x; .)]" + [ ints [ 1; 2 ] ]; + interpreted "slice fallback" ".[0:2]" [ ints [ 1; 2; 3 ] ]; + interpreted "dynamic access fallback" ".k as $key | .[$key]" + [ obj [ ("k", `String "x"); ("x", `Int 2) ] ]; + interpreted "constructor fallback" "{x: .}" [ `Int 1 ]; + interpreted "caught runtime error fallback" "try .x catch ." [ empty_obj ]; + interpreted "halt remains a result" "halt" [ `Null ]; + interpreted "user error fallback discards earlier yields" + "1, error(\"stop\")" [ `Null ]; + interpreted + ~expected:(Ok [ `List [ `Int64 1L; `Int64 2L ]; `List [ `Int 3 ] ]) + "fold only sees top-level collections" "[range(1; 3)], [3]" [ `Null ]; + interpreted ~expected:(Ok []) "fallback empty fold" "empty?" [ `Null ]; + interpreted + ~expected:(Ok [ `Int 1; `String "stop"; `Int 2 ]) + "caught user error preserves yield order" + "try (1, error(\"stop\")) catch (., 2)" [ `Null ]; + Alcotest.test_case "stream cut analysis" `Quick stream_cut_analysis; + Alcotest.test_case "numeric constructor matrix" `Quick numeric_matrix; + Alcotest.test_case "whole-tree structural fallback" `Quick + unsupported_structure; + Alcotest.test_case "numeric conversion timing" `Quick literal_timing; + Alcotest.test_case "fallback environment reuse" `Quick environment_reuse; + Alcotest.test_case "stream composition matrix" `Quick stream_compositions; + Alcotest.test_case "long filtered stream" `Quick long_filtered_stream; + Alcotest.test_case "fold late error preserves callbacks" `Quick + fold_late_error; + Alcotest.test_case "fold callback exceptions escape" `Quick + fold_callback_exception; + Alcotest.test_case "fold halt preserves callbacks" `Quick fold_halt; + Alcotest.test_case "fold long output stream" `Quick fold_long_stream; + Alcotest.test_case "Core output flags" `Quick core_output; + Alcotest.test_case "Core run_iter errors and callbacks" `Quick + core_iter_errors; + Alcotest.test_case "loaded plan source matrix" `Quick loaded_plan_matrix; + Alcotest.test_case "loaded plans validate discarded tails" `Quick + loaded_plan_invalid_tail; + Alcotest.test_case "loaded input reuse after callback exceptions" `Quick + loaded_callback_reuse; + Alcotest.test_case "Core source output and late errors" `Quick + core_source_calls; + Alcotest.test_case "Core source JSON error precedence" `Quick + core_source_error_precedence; + Alcotest.test_case "source streaming plan matrix" `Quick source_plan_matrix; + Alcotest.test_case "source query errors drain input" `Quick + source_error_drain; + Alcotest.test_case "source invalid tails preserve valid prefixes" `Quick + source_invalid_tail; + Alcotest.test_case "source barriers validate first" `Quick + source_validation_barriers; + Alcotest.test_case "source callback exceptions and plan reuse" `Quick + source_callback_reuse; + Alcotest.test_case "Core run_input_iter streaming and debug policy" `Quick + core_streaming; + ]