From 86614dda6b6db9e7b79889a40a429922c2e0d71a Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Fri, 6 Feb 2026 08:12:41 +0000 Subject: [PATCH 01/12] Replace Menhir parser with handmade recursive descent parser - Remove Parser.mly (Menhir grammar) and menhirLib dependency - Add Parser.ml: handmade recursive descent / Pratt parser - Update Core.ml to call Parser.program directly - Update dune build to remove menhir stanza - Update dune-project to remove menhir dependency - All 701 unit tests pass, CLI cram tests pass - Minor improvement: error pointers now span full expressions Co-authored-by: David Sancho --- cli/test/errors.t | 4 +- dune-project | 2 - query-json.opam | 1 - source/Core.ml | 44 +-- source/Parser.ml | 883 ++++++++++++++++++++++++++++++++++++++++++++++ source/Parser.mly | 469 ------------------------ source/dune | 5 - 7 files changed, 893 insertions(+), 515 deletions(-) create mode 100644 source/Parser.ml delete mode 100644 source/Parser.mly diff --git a/cli/test/errors.t b/cli/test/errors.t index ffe3191..c98591f 100644 --- a/cli/test/errors.t +++ b/cli/test/errors.t @@ -33,7 +33,7 @@ startswith is deprecated error[deprecated]: `startswith` is deprecated --> startswith("Hello") - ^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^ hint: use `starts_with` instead @@ -51,7 +51,7 @@ endswith is deprecated error[deprecated]: `endswith` is deprecated --> endswith("world") - ^^^^^^^^^ + ^^^^^^^^^^^^^^^^^ hint: use `ends_with` instead diff --git a/dune-project b/dune-project index d218c69..e3bda46 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,5 @@ (lang dune 3.17) -(using menhir 2.0) (using melange 0.1) (name query-json) @@ -33,7 +32,6 @@ (ocaml (>= 5.4.0)) (dune (>= 3.17)) dune-build-info - (menhir (>= 20250903)) (cmdliner (>= 1.1.0)) sedlex ppx_deriving diff --git a/query-json.opam b/query-json.opam index c21c83e..408ece7 100644 --- a/query-json.opam +++ b/query-json.opam @@ -17,7 +17,6 @@ depends: [ "ocaml" {>= "5.4.0"} "dune" {>= "3.17" & >= "3.17"} "dune-build-info" - "menhir" {>= "20250903"} "cmdliner" {>= "1.1.0"} "sedlex" "ppx_deriving" diff --git a/source/Core.ml b/source/Core.ml index cf4dd30..4c701c5 100644 --- a/source/Core.ml +++ b/source/Core.ml @@ -6,25 +6,6 @@ end let last_position = ref Location.none -exception Lexer_error of string - -let provider ~debug buf = - let start, _ = Sedlexing.lexing_positions buf in - let token = - match Lexer.tokenize buf with - | Ok t -> t - | Error e -> - let _, stop = Sedlexing.lexing_positions buf in - last_position := { loc_start = start; loc_end = stop }; - raise (Lexer_error e) - in - let _, stop = Sedlexing.lexing_positions buf in - last_position := { loc_start = start; loc_end = stop }; - if debug then print_endline (Lexer.show_token token); - (token, start, stop) - -let menhir = MenhirLib.Convert.Simplified.traditional2revised Parser.program - let position_to_string start end_ = Printf.sprintf "[line: %d, char: %d-%d]" start.Lexing.pos_lnum (start.Lexing.pos_cnum - start.Lexing.pos_bol) @@ -32,32 +13,23 @@ let position_to_string start end_ = let parse ~debug ~colorize input = let buf = Sedlexing.Utf8.from_string input in - let next_token () = provider ~debug buf in - match menhir next_token with + match Parser.program buf with | ast -> if debug then print_endline (Ast.show_expression ast); Ok ast - | exception Lexer_error msg -> - if debug then ( - print_endline "Lexer error"; - print_endline msg); - let Location.{ loc_start; loc_end; _ } = !last_position in + | exception Query_error.Parse_error (err, start, end_) -> + last_position := { loc_start = start; loc_end = end_ }; let err = - Query_error.lexer_error ~message:msg ~input - ~start_pos:loc_start.pos_cnum ~end_pos:loc_end.pos_cnum + Query_error.with_location ~input ~start_pos:start.pos_cnum + ~end_pos:end_.pos_cnum err in Error (Query_error.format ~colorize err) | exception Failure msg -> + let Location.{ loc_start; loc_end; _ } = !last_position in let err = Query_error.semantic_error ~message:msg ~input - ~start_pos:!last_position.loc_start.pos_cnum - ~end_pos:!last_position.loc_end.pos_cnum - in - Error (Query_error.format ~colorize err) - | exception Query_error.Parse_error (err, start, end_) -> - let err = - Query_error.with_location ~input ~start_pos:start.pos_cnum - ~end_pos:end_.pos_cnum err + ~start_pos:loc_start.pos_cnum + ~end_pos:loc_end.pos_cnum in Error (Query_error.format ~colorize err) | exception _exn -> diff --git a/source/Parser.ml b/source/Parser.ml new file mode 100644 index 0000000..a2a0bd7 --- /dev/null +++ b/source/Parser.ml @@ -0,0 +1,883 @@ +open Ast + +type stream = { + buf : Sedlexing.lexbuf; + mutable token : Lexer.token; + mutable start_pos : Lexing.position; + mutable end_pos : Lexing.position; +} + +let make_stream buf = + let s = { buf; token = Lexer.EOF; start_pos = Lexing.dummy_pos; end_pos = Lexing.dummy_pos } in + s + +let advance s = + let start, _ = Sedlexing.lexing_positions s.buf in + let tok = + match Lexer.tokenize s.buf with + | Ok t -> t + | Error e -> + let _, stop = Sedlexing.lexing_positions s.buf in + let err = + Query_error.lexer_error ~message:e ~input:"" + ~start_pos:start.pos_cnum ~end_pos:stop.pos_cnum + in + raise (Query_error.Parse_error (err, start, stop)) + in + let _, stop = Sedlexing.lexing_positions s.buf in + s.token <- tok; + s.start_pos <- start; + s.end_pos <- stop + +let peek s = s.token + +let eat s = + let tok = s.token in + advance s; + tok + +let expect s expected = + let tok = s.token in + if tok = expected then + advance s + else + let msg = + Printf.sprintf "expected %s, got %s" + (Lexer.show_token expected) + (Lexer.show_token tok) + in + let err = + Query_error.parse_error ~message:msg ~input:"" + ~start_pos:s.start_pos.pos_cnum ~end_pos:s.end_pos.pos_cnum + in + raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) + +let error s msg = + let err = + Query_error.parse_error ~message:msg ~input:"" + ~start_pos:s.start_pos.pos_cnum ~end_pos:s.end_pos.pos_cnum + in + raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) + +let optional_question s = + match peek s with + | Lexer.QUESTION_MARK -> advance s; true + | _ -> false + +let raise_fn_error s err = + raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) + +let apply_fn_result s = function + | Ok ast -> ast + | Error err -> raise_fn_error s err + +let wrap_optional opt expr = + if opt then Optional expr else expr + +let rec parse_program s = + advance s; + match peek s with + | Lexer.EOF -> Identity + | _ -> + let e = parse_sequence_expr s in + expect s Lexer.EOF; + e + +and parse_sequence_expr s = + parse_fn_or_expr s + +and parse_fn_or_expr s = + match peek s with + | Lexer.FN -> parse_fn_def s + | Lexer.TRY -> parse_try s + | _ -> parse_pipe_expr s + +and parse_fn_def s = + let _start = s.start_pos in + advance s; + match peek s with + | Lexer.IDENTIFIER name -> + advance s; + let params = + match peek s with + | Lexer.OPEN_PARENT -> + advance s; + let ps = parse_fn_params s in + expect s Lexer.CLOSE_PARENT; + ps + | _ -> [] + in + expect s Lexer.COLON; + let body = parse_sequence_expr s in + expect s Lexer.SEMICOLON; + let rest = parse_sequence_expr s in + Pipe (Fn (name, params, body), rest) + | Lexer.FUNCTION name -> + advance s; + let params = parse_fn_params s in + expect s Lexer.CLOSE_PARENT; + expect s Lexer.COLON; + let body = parse_sequence_expr s in + expect s Lexer.SEMICOLON; + let rest = parse_sequence_expr s in + Pipe (Fn (name, params, body), rest) + | _ -> error s "expected function name after 'fn'" + +and parse_fn_params s = + match peek s with + | Lexer.CLOSE_PARENT -> [] + | _ -> + let p = parse_fn_param s in + let rec loop acc = + match peek s with + | Lexer.SEMICOLON -> + advance s; + (match peek s with + | Lexer.CLOSE_PARENT -> List.rev acc + | _ -> + let p = parse_fn_param s in + loop (p :: acc)) + | _ -> List.rev acc + in + loop [p] + +and parse_fn_param s = + match peek s with + | Lexer.IDENTIFIER name -> advance s; name + | Lexer.VARIABLE name -> advance s; "$" ^ name + | _ -> error s "expected parameter name" + +and parse_try s = + advance s; + let body = parse_sequence_expr s in + match peek s with + | Lexer.CATCH -> + advance s; + let handler = parse_item_expr s in + (match peek s with + | Lexer.FINALLY -> + advance s; + let cleanup = parse_item_expr s in + Try (body, Some handler, Some cleanup) + | _ -> Try (body, Some handler, None)) + | _ -> body + +and parse_pipe_expr s = + let left = parse_comma_expr s in + parse_pipe_right s left + +and parse_pipe_right s left = + match peek s with + | Lexer.PIPE -> + advance s; + let right = parse_fn_or_expr s in + parse_pipe_right s (Pipe (left, right)) + | Lexer.UPDATE_ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Update (left, right)) + | Lexer.ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Assign (left, right)) + | Lexer.PLUS_ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Update (left, Operation (Identity, Add, right))) + | Lexer.MINUS_ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Update (left, Operation (Identity, Subtract, right))) + | Lexer.MULT_ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Update (left, Operation (Identity, Multiply, right))) + | Lexer.DIV_ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Update (left, Operation (Identity, Divide, right))) + | Lexer.ALT_ASSIGN -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Update (left, Alternative (Identity, right))) + | Lexer.ALTERNATIVE -> + advance s; + let right = parse_item_expr s in + parse_pipe_right s (Alternative (left, right)) + | _ -> left + +and parse_comma_expr s = + let left = parse_or_expr s in + parse_comma_right s left + +and parse_comma_right s left = + match peek s with + | Lexer.COMMA -> + advance s; + let right = parse_or_expr s in + parse_comma_right s (Comma (left, right)) + | _ -> left + +and parse_or_expr s = + let left = parse_and_expr s in + parse_or_right s left + +and parse_or_right s left = + match peek s with + | Lexer.OR -> + advance s; + let right = parse_and_expr s in + parse_or_right s (Operation (left, Or, right)) + | _ -> left + +and parse_and_expr s = + let left = parse_comparison_expr s in + parse_and_right s left + +and parse_and_right s left = + match peek s with + | Lexer.AND -> + advance s; + let right = parse_comparison_expr s in + parse_and_right s (Operation (left, And, right)) + | _ -> left + +and parse_comparison_expr s = + let left = parse_add_expr s in + match peek s with + | Lexer.EQUAL -> + advance s; + let right = parse_add_expr s in + Operation (left, Equal, right) + | Lexer.NOT_EQUAL -> + advance s; + let right = parse_add_expr s in + Operation (left, Not_equal, right) + | Lexer.GREATER -> + advance s; + let right = parse_add_expr s in + Operation (left, Greater_than, right) + | Lexer.LOWER -> + advance s; + let right = parse_add_expr s in + Operation (left, Less_than, right) + | Lexer.GREATER_EQUAL -> + advance s; + let right = parse_add_expr s in + Operation (left, Greater_than_or_equal, right) + | Lexer.LOWER_EQUAL -> + advance s; + let right = parse_add_expr s in + Operation (left, Less_than_or_equal, right) + | _ -> left + +and parse_add_expr s = + let left = parse_mul_expr s in + parse_add_right s left + +and parse_add_right s left = + match peek s with + | Lexer.ADD -> + advance s; + let right = parse_mul_expr s in + parse_add_right s (Operation (left, Add, right)) + | Lexer.SUB -> + advance s; + let right = parse_mul_expr s in + parse_add_right s (Operation (left, Subtract, right)) + | _ -> left + +and parse_mul_expr s = + let left = parse_term s in + parse_mul_right s left + +and parse_mul_right s left = + match peek s with + | Lexer.MULT -> + advance s; + let right = parse_term s in + parse_mul_right s (Operation (left, Multiply, right)) + | Lexer.DIV -> + advance s; + let right = parse_term s in + parse_mul_right s (Operation (left, Divide, right)) + | Lexer.MODULO -> + advance s; + let right = parse_term s in + parse_mul_right s (Operation (left, Modulo, right)) + | _ -> left + +and parse_item_expr s = + parse_or_expr s + +and parse_term s = + let e = parse_primary s in + parse_postfix s e + +and parse_postfix s e = + match peek s with + | Lexer.DOT -> ( + advance s; + match peek s with + | Lexer.STRING k -> + advance s; + let opt = optional_question s in + let access = if opt then Optional (Key k) else Key k in + parse_postfix s (Pipe (e, access)) + | Lexer.IDENTIFIER k -> + advance s; + let opt = optional_question s in + let access = if opt then Optional (Key k) else Key k in + parse_postfix s (Pipe (e, access)) + | _ -> parse_postfix s (Pipe (e, Identity))) + | Lexer.OPEN_BRACKET -> + let result = parse_bracket_access s e in + parse_postfix s result + | _ -> e + +and parse_bracket_access s e = + advance s; + match peek s with + | Lexer.CLOSE_BRACKET -> + advance s; + let opt = optional_question s in + let idx = Index [] in + if opt then Pipe (e, Optional idx) else Pipe (e, idx) + | Lexer.STRING key -> + advance s; + expect s Lexer.CLOSE_BRACKET; + let opt = optional_question s in + if opt then Pipe (e, Optional (Key key)) else Pipe (e, Key key) + | Lexer.VARIABLE var -> + advance s; + expect s Lexer.CLOSE_BRACKET; + Pipe (e, Dynamic_access (Variable var)) + | Lexer.COLON -> + advance s; + let end_ = parse_index_number s in + expect s Lexer.CLOSE_BRACKET; + Pipe (e, Slice (None, Some end_)) + | _ -> + let first_num = parse_index_number s in + (match peek s with + | Lexer.COLON -> ( + advance s; + match peek s with + | Lexer.CLOSE_BRACKET -> + advance s; + Pipe (e, Slice (Some first_num, None)) + | _ -> + let end_ = parse_index_number s in + expect s Lexer.CLOSE_BRACKET; + Pipe (e, Slice (Some first_num, Some end_))) + | Lexer.COMMA -> + let indices = parse_remaining_indices s [first_num] in + expect s Lexer.CLOSE_BRACKET; + let opt = optional_question s in + let idx_expr = Index indices in + if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) + | Lexer.CLOSE_BRACKET -> + advance s; + let opt = optional_question s in + let idx_expr = Index [first_num] in + if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) + | _ -> error s "expected ':', ',' or ']' in bracket expression") + +and parse_remaining_indices s acc = + match peek s with + | Lexer.COMMA -> + advance s; + let n = parse_index_number s in + parse_remaining_indices s (acc @ [n]) + | _ -> acc + +and parse_index_number s = + match peek s with + | Lexer.SUB -> + advance s; + (match peek s with + | Lexer.INT n -> advance s; -n + | Lexer.INT64 n -> advance s; Int64.to_int (Int64.neg n) + | Lexer.BIG_INT n -> advance s; Z.to_int (Z.neg n) + | Lexer.FLOAT n -> advance s; int_of_float (-.n) + | _ -> error s "expected number after '-'") + | Lexer.INT n -> advance s; n + | Lexer.INT64 n -> advance s; Int64.to_int n + | Lexer.BIG_INT n -> advance s; Z.to_int n + | Lexer.FLOAT n -> advance s; int_of_float n + | _ -> error s "expected index number" + +and parse_number_literal s = + match peek s with + | Lexer.SUB -> + advance s; + (match peek s with + | Lexer.INT n -> advance s; Int (-n) + | Lexer.INT64 n -> advance s; Int64 (Int64.neg n) + | Lexer.BIG_INT n -> advance s; Big_int (Z.neg n) + | Lexer.FLOAT n -> advance s; Float (-.n) + | _ -> error s "expected number after '-'") + | Lexer.INT n -> advance s; Int n + | Lexer.INT64 n -> advance s; Int64 n + | Lexer.BIG_INT n -> advance s; Big_int n + | Lexer.FLOAT n -> advance s; Float n + | _ -> error s "expected number" + +and parse_primary s = + match peek s with + | Lexer.DOT -> parse_dot s + | Lexer.STRING str -> + advance s; + Literal (String str) + | Lexer.INT _ | Lexer.INT64 _ | Lexer.BIG_INT _ | Lexer.FLOAT _ -> + let lit = parse_number_literal s in + Literal lit + | Lexer.SUB -> + let lit = parse_number_literal s in + Literal lit + | Lexer.BOOL b -> + advance s; + Literal (Bool b) + | Lexer.NULL -> + advance s; + Literal Null + | Lexer.VARIABLE var -> + advance s; + Variable var + | Lexer.INTERP_START -> + parse_interpolated_string s + | Lexer.TEMPLATE_START -> + parse_template_literal s + | Lexer.RANGE -> + parse_range s + | Lexer.FLATTEN -> + parse_flatten s + | Lexer.REDUCE -> + parse_reduce s + | Lexer.FOREACH -> + parse_foreach s + | Lexer.IF -> + parse_if s + | Lexer.FUNCTION name -> + parse_function_call s name + | Lexer.IDENTIFIER name -> + parse_identifier s name + | Lexer.OPEN_BRACKET -> + parse_array_construction s + | Lexer.OPEN_BRACE -> + parse_object_construction s + | Lexer.OPEN_PARENT -> + parse_paren s + | _ -> + error s (Printf.sprintf "unexpected token: %s" (Lexer.show_token (peek s))) + +and parse_dot s = + advance s; + match peek s with + | Lexer.STRING k -> + advance s; + let opt = optional_question s in + if opt then Optional (Key k) else Key k + | Lexer.IDENTIFIER k -> + advance s; + let opt = optional_question s in + if opt then Optional (Key k) else Key k + | Lexer.OPEN_BRACKET -> + parse_bracket_access s Identity + | _ -> Identity + +and parse_range s = + advance s; + expect s Lexer.OPEN_PARENT; + let from = parse_sequence_expr s in + match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + Range (from, None, None) + | Lexer.SEMICOLON -> + advance s; + let upto = parse_sequence_expr s in + (match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + Range (from, Some upto, None) + | Lexer.SEMICOLON -> + advance s; + let step = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + Range (from, Some upto, Some step) + | _ -> error s "expected ')' or ';' in range") + | _ -> error s "expected ')' or ';' in range" + +and parse_flatten s = + advance s; + match peek s with + | Lexer.OPEN_PARENT -> + advance s; + (match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + Fn0 Flatten + | _ -> + let e = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + Fn1 (With_expr (Flatten_n, e))) + | _ -> Fn0 Flatten + +and parse_reduce s = + advance s; + let expr = parse_sequence_expr s in + expect s Lexer.AS; + let var = match peek s with + | Lexer.VARIABLE v -> advance s; v + | _ -> error s "expected variable after 'as'" + in + expect s Lexer.OPEN_PARENT; + let init = parse_sequence_expr s in + expect s Lexer.SEMICOLON; + let update = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + Reduce (expr, var, init, update) + +and parse_foreach s = + advance s; + let expr = parse_sequence_expr s in + expect s Lexer.AS; + let var = match peek s with + | Lexer.VARIABLE v -> advance s; v + | _ -> error s "expected variable after 'as'" + in + expect s Lexer.OPEN_PARENT; + let init = parse_sequence_expr s in + expect s Lexer.SEMICOLON; + let update = parse_sequence_expr s in + match peek s with + | Lexer.SEMICOLON -> + advance s; + let extract = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + Foreach (expr, var, init, update, extract) + | Lexer.CLOSE_PARENT -> + advance s; + Foreach (expr, var, init, update, Identity) + | _ -> error s "expected ';' or ')' in foreach" + +and parse_if s = + advance s; + let cond = parse_item_expr s in + expect s Lexer.THEN; + let then_branch = parse_sequence_expr s in + let elifs = parse_elifs s in + expect s Lexer.ELSE; + let else_branch = parse_sequence_expr s in + expect s Lexer.END; + let rec fold_elif elifs else_b = + match elifs with + | [] -> else_b + | (c, b) :: rest -> If_then_else (c, b, fold_elif rest else_b) + in + If_then_else (cond, then_branch, fold_elif elifs else_branch) + +and parse_elifs s = + match peek s with + | Lexer.ELIF -> + advance s; + let cond = parse_item_expr s in + expect s Lexer.THEN; + let branch = parse_sequence_expr s in + (cond, branch) :: parse_elifs s + | _ -> [] + +and parse_function_call s name = + let fn_start = s.start_pos in + advance s; + match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + let opt = optional_question s in + let ast = + if Language.can_default_to_identity name then begin + match Language.map_unary_fn name Identity with + | Ok a -> a + | Error err -> raise (Query_error.Parse_error (err, fn_start, s.end_pos)) + end else + let err = Language.error_for_missing_arg name in + raise (Query_error.Parse_error (err, fn_start, s.end_pos)) + in + wrap_optional opt ast + | _ -> + let arg1 = parse_sequence_expr s in + (match peek s with + | Lexer.SEMICOLON -> + advance s; + let arg2 = parse_sequence_expr s in + (match peek s with + | Lexer.SEMICOLON -> + advance s; + let arg3 = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + let opt = optional_question s in + let ast = match name with + | "fma" -> Fma (arg1, arg2, arg3) + | _ -> Apply (name, [arg1; arg2; arg3]) + in + wrap_optional opt ast + | Lexer.CLOSE_PARENT -> + advance s; + let opt = optional_question s in + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_binary_fn name arg1 arg2) in + wrap_optional opt ast + | _ -> error s "expected ';' or ')' in function call") + | Lexer.CLOSE_PARENT -> + advance s; + let opt = optional_question s in + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_unary_fn name arg1) in + wrap_optional opt ast + | _ -> error s "expected ';' or ')' in function call") + +and parse_identifier s name = + let fn_start = s.start_pos in + advance s; + match peek s with + | Lexer.QUESTION_MARK -> ( + advance s; + match peek s with + | Lexer.OPEN_PARENT -> + advance s; + let arg1 = parse_sequence_expr s in + (match peek s with + | Lexer.SEMICOLON -> + advance s; + let arg2 = parse_sequence_expr s in + (match peek s with + | Lexer.SEMICOLON -> + advance s; + let arg3 = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + let ast = match name with + | "fma" -> Fma (arg1, arg2, arg3) + | _ -> Apply (name, [arg1; arg2; arg3]) + in + Optional ast + | Lexer.CLOSE_PARENT -> + advance s; + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_binary_fn name arg1 arg2) in + Optional ast + | _ -> error s "expected ';' or ')' in optional function call") + | Lexer.CLOSE_PARENT -> + advance s; + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_unary_fn name arg1) in + Optional ast + | _ -> error s "expected ';' or ')' in optional function call") + | _ -> + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_nullary_fn name) in + Optional ast) + | _ -> + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_nullary_fn name) in + let opt = optional_question s in + wrap_optional opt ast + +and parse_array_construction s = + advance s; + match peek s with + | Lexer.CLOSE_BRACKET -> + advance s; + List None + | _ -> + let e = parse_sequence_expr s in + expect s Lexer.CLOSE_BRACKET; + List (Some e) + +and parse_object_construction s = + advance s; + match peek s with + | Lexer.CLOSE_BRACE -> + advance s; + Object [] + | _ -> + let pairs = parse_key_value_list s in + expect s Lexer.CLOSE_BRACE; + Object pairs + +and parse_key_value_list s = + let pair = parse_key_value s in + let rec loop acc = + match peek s with + | Lexer.COMMA -> + advance s; + let pair = parse_key_value s in + loop (pair :: acc) + | _ -> List.rev acc + in + loop [pair] + +and parse_key_value s = + match peek s with + | Lexer.OPEN_PARENT -> + advance s; + let key_expr = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + expect s Lexer.COLON; + let value = parse_term s in + (key_expr, Some value) + | Lexer.IDENTIFIER key -> + advance s; + (match peek s with + | Lexer.COLON -> + advance s; + let value = parse_term s in + (Literal (String key), Some value) + | _ -> (Literal (String key), None)) + | Lexer.STRING key -> + advance s; + (match peek s with + | Lexer.COLON -> + advance s; + let value = parse_term s in + (Literal (String key), Some value) + | _ -> (Literal (String key), None)) + | _ -> error s "expected key in object construction" + +and parse_paren s = + advance s; + let e = parse_sequence_expr s in + match peek s with + | Lexer.AS -> + advance s; + let var = match peek s with + | Lexer.VARIABLE v -> advance s; v + | _ -> error s "expected variable after 'as'" + in + expect s Lexer.PIPE; + let body = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + As (e, var, body) + | Lexer.CLOSE_PARENT -> + advance s; + let opt = optional_question s in + wrap_optional opt e + | _ -> error s "expected ')' or 'as'" + +and parse_interpolated_string s = + advance s; + let parts = parse_interp_body s in + match parts with + | [] -> Literal (String "") + | [single] -> single + | first :: rest -> + List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest + +and parse_interp_body s = + match peek s with + | Lexer.INTERP_END -> + advance s; + [] + | Lexer.INTERP_TEXT text -> + advance s; + (match peek s with + | Lexer.INTERP_END -> + advance s; + [Literal (String text)] + | Lexer.INTERP_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_interp_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected interpolation expression or end of string") + | Lexer.INTERP_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_interp_after_expr s in + Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected string interpolation content" + +and parse_interp_after_expr s = + match peek s with + | Lexer.INTERP_END -> + advance s; + [] + | Lexer.INTERP_TEXT text -> + advance s; + (match peek s with + | Lexer.INTERP_END -> + advance s; + [Literal (String text)] + | Lexer.INTERP_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_interp_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected interpolation expression or end of string") + | Lexer.INTERP_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_interp_after_expr s in + Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected string interpolation content" + +and parse_template_literal s = + advance s; + let parts = parse_template_body s in + match parts with + | [] -> Literal (String "") + | [single] -> single + | first :: rest -> + List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest + +and parse_template_body s = + match peek s with + | Lexer.TEMPLATE_END -> + advance s; + [] + | Lexer.TEMPLATE_TEXT text -> + advance s; + (match peek s with + | Lexer.TEMPLATE_END -> + advance s; + [Literal (String text)] + | Lexer.TEMPLATE_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_template_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected template expression or end of template") + | Lexer.TEMPLATE_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_template_after_expr s in + Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected template literal content" + +and parse_template_after_expr s = + match peek s with + | Lexer.TEMPLATE_END -> + advance s; + [] + | Lexer.TEMPLATE_TEXT text -> + advance s; + (match peek s with + | Lexer.TEMPLATE_END -> + advance s; + [Literal (String text)] + | Lexer.TEMPLATE_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_template_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected template expression or end of template") + | Lexer.TEMPLATE_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_template_after_expr s in + Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected template literal content" + +let program buf = + let s = make_stream buf in + parse_program s diff --git a/source/Parser.mly b/source/Parser.mly deleted file mode 100644 index d9b6c96..0000000 --- a/source/Parser.mly +++ /dev/null @@ -1,469 +0,0 @@ -%{ - open Ast -%} - -%token STRING -%token INT -%token INT64 -%token BIG_INT -%token FLOAT -%token BOOL -%token NULL -%token IDENTIFIER -%token VARIABLE -%token RANGE -%token FLATTEN -%token REDUCE -%token FOREACH -%token IF THEN ELSE ELIF END -%token DOT -%token PIPE -%token UPDATE_ASSIGN -%token PLUS_ASSIGN -%token MINUS_ASSIGN -%token MULT_ASSIGN -%token DIV_ASSIGN -%token ALT_ASSIGN -%token ASSIGN -%token ALTERNATIVE -%token SEMICOLON -%token COLON -%token ADD SUB MULT DIV MODULO -%token EQUAL NOT_EQUAL GREATER LOWER GREATER_EQUAL LOWER_EQUAL AND OR - -%token FUNCTION -%token OPEN_PARENT -%token CLOSE_PARENT -%token TRY -%token CATCH -%token FINALLY - -(* String interpolation tokens *) -%token INTERP_START -%token INTERP_TEXT -%token INTERP_EXPR_START -%token INTERP_END - -(* Template literal tokens (backtick strings) *) -%token TEMPLATE_START -%token TEMPLATE_TEXT -%token TEMPLATE_EXPR_START -%token TEMPLATE_END - -%token QUESTION_MARK - -%token OPEN_BRACKET -%token CLOSE_BRACKET - -%token COMMA -%token OPEN_BRACE -%token CLOSE_BRACE -%token AS -%token FN -%token EOF - -/* FN_PREC is a dummy precedence for function definitions - must be lower than PIPE and others so that operators are shifted into the 'rest' expression: fn f: body; rest | x - should parse as: fn f: body; (rest | x) */ -%nonassoc FN_PREC -/* according to https://github.com/stedolan/jq/issues/1326 */ -%right PIPE UPDATE_ASSIGN PLUS_ASSIGN MINUS_ASSIGN MULT_ASSIGN DIV_ASSIGN ALT_ASSIGN ASSIGN ALTERNATIVE /* lowest precedence */ -%left COMMA -%left OR -%left AND -%nonassoc NOT_EQUAL EQUAL LOWER GREATER LOWER_EQUAL GREATER_EQUAL -%left ADD SUB -%left MULT DIV MODULO /* highest precedence */ - -%start program - -%% - -fn_param: - | p = IDENTIFIER { p } - | p = VARIABLE { "$" ^ p } - -fn_params: - | { [] } - | p = fn_param { [p] } - | p = fn_param; SEMICOLON; rest = fn_params { p :: rest } - -program: - | e = sequence_expr; EOF; - { e } - | EOF; - { Identity } - -string_or_identifier: - | key = IDENTIFIER { Literal (String key) } - | key = STRING { Literal (String key) } - -key_value (E): - | key = string_or_identifier - { key, None } - | OPEN_PARENT; e1 = sequence_expr CLOSE_PARENT; COLON; e2 = E - { e1, Some e2 } - | key = string_or_identifier; COLON; e = E - { key, Some e } - -elif_term: - | ELIF cond = item_expr THEN e = sequence_expr - { cond, e } - -// sequence_expr handles the lowest precedence operators: comma and pipe -// while item_expr handles the higher precedence operators -sequence_expr: - | left = sequence_expr; COMMA; right = sequence_expr; - { Comma (left, right) } - - | left = sequence_expr; PIPE; right = sequence_expr; - { Pipe (left, right) } - - | left = sequence_expr; UPDATE_ASSIGN; right = item_expr; - { Update (left, right) } - - | left = sequence_expr; ASSIGN; right = item_expr; - { Assign (left, right) } - - | left = sequence_expr; PLUS_ASSIGN; right = item_expr; - { Update (left, Operation (Identity, Add, right)) } - - | left = sequence_expr; MINUS_ASSIGN; right = item_expr; - { Update (left, Operation (Identity, Subtract, right)) } - - | left = sequence_expr; MULT_ASSIGN; right = item_expr; - { Update (left, Operation (Identity, Multiply, right)) } - - | left = sequence_expr; DIV_ASSIGN; right = item_expr; - { Update (left, Operation (Identity, Divide, right)) } - - | left = sequence_expr; ALT_ASSIGN; right = item_expr; - { Update (left, Alternative (Identity, right)) } - - | left = sequence_expr; ALTERNATIVE; right = item_expr; - { Alternative (left, right) } - - | TRY; e = sequence_expr; CATCH; handler = item_expr; FINALLY; cleanup = item_expr - { Try (e, Some handler, Some cleanup) } - - | TRY; e = sequence_expr; CATCH; handler = item_expr - { Try (e, Some handler, None) } - - (* Nested function definitions within expressions *) - | FN; name = IDENTIFIER; COLON; body = sequence_expr; SEMICOLON; rest = sequence_expr %prec FN_PREC - { Pipe (Fn (name, [], body), rest) } - | FN; name = IDENTIFIER; OPEN_PARENT; params = fn_params; CLOSE_PARENT; COLON; body = sequence_expr; SEMICOLON; rest = sequence_expr %prec FN_PREC - { Pipe (Fn (name, params, body), rest) } - | FN; name = FUNCTION; params = fn_params; CLOSE_PARENT; COLON; body = sequence_expr; SEMICOLON; rest = sequence_expr %prec FN_PREC - { Pipe (Fn (name, params, body), rest) } - - | e = item_expr - { e } - -%inline operator: - | SUB {Subtract} - | ADD {Add} - | MULT {Multiply} - | DIV {Divide} - | MODULO {Modulo} - | EQUAL {Equal} - | NOT_EQUAL {Not_equal} - | GREATER {Greater_than} - | LOWER {Less_than} - | GREATER_EQUAL {Greater_than_or_equal} - | LOWER_EQUAL {Less_than_or_equal} - | AND {And} - | OR {Or} - -item_expr: - | left = item_expr; op = operator; right = item_expr; - { Operation (left, op, right) } - - | e = term - { e } - -(* number_literal returns an Ast.literal for use in expressions *) -number_literal: - | n = INT; - { Int n } - | SUB; n = INT; - { Int (-n) } - | n = INT64; - { Int64 n } - | SUB; n = INT64; - { Int64 (Int64.neg n) } - | n = BIG_INT; - { Big_int n } - | SUB; n = BIG_INT; - { Big_int (Z.neg n) } - | n = FLOAT; - { Float n } - | SUB; n = FLOAT; - { Float (-.n) } - -(* index_number returns an int for array indexing *) -index_number: - | n = INT; - { n } - | SUB; n = INT; - { -n } - | n = INT64; - { Int64.to_int n } - | SUB; n = INT64; - { Int64.to_int (Int64.neg n) } - | n = BIG_INT; - { Z.to_int n } - | SUB; n = BIG_INT; - { Z.to_int (Z.neg n) } - | n = FLOAT; - { int_of_float n } - | SUB; n = FLOAT; - { int_of_float (-.n) } - -interp_after_expr: - | INTERP_END - { [] } - | s = INTERP_TEXT; INTERP_END - { [Literal (String s)] } - | s = INTERP_TEXT; INTERP_EXPR_START; e = sequence_expr; rest = interp_after_expr - { Literal (String s) :: Pipe (e, Fn0 To_string) :: rest } - | INTERP_EXPR_START; e = sequence_expr; rest = interp_after_expr - { Pipe (e, Fn0 To_string) :: rest } - -interp_body: - | INTERP_END - { [] } - | s = INTERP_TEXT; INTERP_END - { [Literal (String s)] } - | s = INTERP_TEXT; INTERP_EXPR_START; e = sequence_expr; rest = interp_after_expr - { Literal (String s) :: Pipe (e, Fn0 To_string) :: rest } - | INTERP_EXPR_START; e = sequence_expr; rest = interp_after_expr - { Pipe (e, Fn0 To_string) :: rest } - -interpolated_string: - | INTERP_START; parts = interp_body - { - match parts with - | [] -> Literal (String "") - | [single] -> single - | first :: rest -> - List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest - } - -template_after_expr: - | TEMPLATE_END - { [] } - | s = TEMPLATE_TEXT; TEMPLATE_END - { [Literal (String s)] } - | s = TEMPLATE_TEXT; TEMPLATE_EXPR_START; e = sequence_expr; rest = template_after_expr - { Literal (String s) :: Pipe (e, Fn0 To_string) :: rest } - | TEMPLATE_EXPR_START; e = sequence_expr; rest = template_after_expr - { Pipe (e, Fn0 To_string) :: rest } - -template_body: - | TEMPLATE_END - { [] } - | s = TEMPLATE_TEXT; TEMPLATE_END - { [Literal (String s)] } - | s = TEMPLATE_TEXT; TEMPLATE_EXPR_START; e = sequence_expr; rest = template_after_expr - { Literal (String s) :: Pipe (e, Fn0 To_string) :: rest } - | TEMPLATE_EXPR_START; e = sequence_expr; rest = template_after_expr - { Pipe (e, Fn0 To_string) :: rest } - -template_literal: - | TEMPLATE_START; parts = template_body - { - match parts with - | [] -> Literal (String "") - | [single] -> single - | first :: rest -> - List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest - } - -term: - | DOT; - { Identity } - | s = STRING; - { Literal (String s) } - | interp = interpolated_string - { interp } - | template = template_literal - { template } - | n = number_literal; - { Literal n } - | b = BOOL; - { Literal (Bool b) } - | NULL - { Literal(Null) } - | var = VARIABLE; - { Variable var } - | RANGE; OPEN_PARENT; from = sequence_expr; CLOSE_PARENT; - { Range (from, None, None) } - | RANGE; OPEN_PARENT; from = sequence_expr; SEMICOLON; upto = sequence_expr; CLOSE_PARENT; - { Range (from, Some upto, None) } - | RANGE; OPEN_PARENT; from = sequence_expr; SEMICOLON; upto = sequence_expr; SEMICOLON; step = sequence_expr; CLOSE_PARENT; - { Range (from, Some upto, Some step) } - | f = FUNCTION; arg1 = sequence_expr; SEMICOLON; arg2 = sequence_expr; SEMICOLON; arg3 = sequence_expr; CLOSE_PARENT; opt = boption(QUESTION_MARK) - { let ast = match f with - | "fma" -> Fma (arg1, arg2, arg3) - | _ -> Apply (f, [arg1; arg2; arg3]) - in - match opt with - | true -> Optional ast - | false -> ast - } - | FLATTEN; - { Fn0 Flatten } - | FLATTEN; OPEN_PARENT; CLOSE_PARENT; - { Fn0 Flatten } - | FLATTEN; OPEN_PARENT; e = sequence_expr; CLOSE_PARENT; - { Fn1 (With_expr (Flatten_n, e)) } - | f = FUNCTION; arg1 = sequence_expr; SEMICOLON; arg2 = sequence_expr; CLOSE_PARENT; opt = boption(QUESTION_MARK) - { let ast = match Language.map_binary_fn f arg1 arg2 with - | Ok ast -> ast - | Error err -> Query_error.raise err $startpos(f) $endpos(f) - in - match opt with - | true -> Optional ast - | false -> ast - } - | f = FUNCTION; CLOSE_PARENT; opt = boption(QUESTION_MARK) - { (* Check if this 1-arity function can default to identity *) - let ast = - if Language.can_default_to_identity f then - match Language.map_unary_fn f Identity with - | Ok ast -> ast - | Error err -> Query_error.raise err $startpos(f) $endpos(f) - else - Query_error.raise (Language.error_for_missing_arg f) $startpos(f) $endpos(f) - in - match opt with - | true -> Optional ast - | false -> ast - } - | f = FUNCTION; arg = sequence_expr; CLOSE_PARENT; opt = boption(QUESTION_MARK) - { let ast = match Language.map_unary_fn f arg with - | Ok ast -> ast - | Error err -> Query_error.raise err $startpos(f) $endpos(f) - in - match opt with - | true -> Optional ast - | false -> ast - } - | REDUCE; expr = sequence_expr; AS; var = VARIABLE; OPEN_PARENT; init = sequence_expr; SEMICOLON; update = sequence_expr; CLOSE_PARENT; - { Reduce (expr, var, init, update) } - | FOREACH; expr = sequence_expr; AS; var = VARIABLE; OPEN_PARENT; init = sequence_expr; SEMICOLON; update = sequence_expr; SEMICOLON; extract = sequence_expr; CLOSE_PARENT; - { Foreach (expr, var, init, update, extract) } - | FOREACH; expr = sequence_expr; AS; var = VARIABLE; OPEN_PARENT; init = sequence_expr; SEMICOLON; update = sequence_expr; CLOSE_PARENT; - { Foreach (expr, var, init, update, Identity) } - | OPEN_PARENT; expr = sequence_expr; AS; var = VARIABLE; PIPE; body = sequence_expr; CLOSE_PARENT - { As (expr, var, body) } - | f = IDENTIFIER; opt = boption(QUESTION_MARK) - { let ast = match Language.map_nullary_fn f with - | Ok ast -> ast - | Error err -> Query_error.raise err $startpos(f) $endpos(f) - in - match opt with - | true -> Optional ast - | false -> ast - } - (* Optional function call: first?(expr) is equivalent to first(expr)? *) - | f = IDENTIFIER; QUESTION_MARK; OPEN_PARENT; arg = sequence_expr; CLOSE_PARENT - { let ast = match Language.map_unary_fn f arg with - | Ok ast -> ast - | Error err -> Query_error.raise err $startpos(f) $endpos(f) - in - Optional ast - } - (* Optional function call with two args: nth?(n; expr) *) - | f = IDENTIFIER; QUESTION_MARK; OPEN_PARENT; arg1 = sequence_expr; SEMICOLON; arg2 = sequence_expr; CLOSE_PARENT - { let ast = match Language.map_binary_fn f arg1 arg2 with - | Ok ast -> ast - | Error err -> Query_error.raise err $startpos(f) $endpos(f) - in - Optional ast - } - (* Optional function call with three args: fn?(a; b; c) *) - | f = IDENTIFIER; QUESTION_MARK; OPEN_PARENT; arg1 = sequence_expr; SEMICOLON; arg2 = sequence_expr; SEMICOLON; arg3 = sequence_expr; CLOSE_PARENT - { let ast = match f with - | "fma" -> Fma (arg1, arg2, arg3) - | _ -> Apply (f, [arg1; arg2; arg3]) - in - Optional ast - } - | OPEN_BRACKET; e = option(sequence_expr); CLOSE_BRACKET; - { List e } - - | OPEN_BRACE; CLOSE_BRACE; - { Object [] } - - | e = delimited(OPEN_BRACE, separated_nonempty_list(COMMA, key_value (term)), CLOSE_BRACE); - { Object e } - - | OPEN_PARENT; e = sequence_expr; CLOSE_PARENT; opt = boption(QUESTION_MARK) - { match opt with - | true -> Optional e - | false -> e - } - - /* Index: .[0] or .[0,1,2], optionally with ? for optional access */ - | e = term; OPEN_BRACKET; indices = separated_nonempty_list(COMMA, index_number); CLOSE_BRACKET; opt = boption(QUESTION_MARK) - { let idx_expr = Index indices in - match opt with - | true -> Pipe (e, Optional idx_expr) - | false -> Pipe (e, idx_expr) } - - /* String key access: .["foo"] */ - | e = term; OPEN_BRACKET; key = STRING; CLOSE_BRACKET - { Pipe (e, Key key) } - - /* Optional string key access: .["foo"]? */ - | e = term; OPEN_BRACKET; key = STRING; CLOSE_BRACKET; QUESTION_MARK - { Pipe (e, Optional (Key key)) } - - /* Dynamic access with variable: .[$var] */ - | e = term; OPEN_BRACKET; var = VARIABLE; CLOSE_BRACKET - { Pipe (e, Dynamic_access (Variable var)) } - - /* Empty brackets: .[] */ - | e = term; OPEN_BRACKET; CLOSE_BRACKET - { Pipe (e, Index []) } - - /* Optional iterator: .[]? */ - | e = term; OPEN_BRACKET; CLOSE_BRACKET; QUESTION_MARK - { Pipe (e, Optional (Index [])) } - - /* Full slice with both indices: .[1:5] */ - | e = term; OPEN_BRACKET; start = index_number; COLON; end_ = index_number; CLOSE_BRACKET - { Pipe (e, Slice (Some start, Some end_)) } - - /* Start-only slice: .[3:] */ - | e = term; OPEN_BRACKET; start = index_number; COLON; CLOSE_BRACKET - { Pipe (e, Slice (Some start, None)) } - - /* End-only slice: .[:3] */ - | e = term; OPEN_BRACKET; COLON; end_ = index_number; CLOSE_BRACKET - { Pipe (e, Slice (None, Some end_)) } - - | DOT; k = STRING; opt = boption(QUESTION_MARK) - | DOT; k = IDENTIFIER; opt = boption(QUESTION_MARK) - { match opt with - | true -> Optional (Key k) - | false -> Key k - } - - | e = term; DOT; k = STRING; opt = boption(QUESTION_MARK) - | e = term; DOT; k = IDENTIFIER; opt = boption(QUESTION_MARK) - { match opt with - | true -> Pipe (e, Optional (Key k)) - | false -> Pipe (e, Key k) - } - - | IF; cond = item_expr; THEN e1 = sequence_expr; elifs = list(elif_term) ELSE; e2 = sequence_expr; END - { - let rec fold_elif elifs else_branch = - match elifs with - | [] -> else_branch - | (cond, branch) :: rest -> If_then_else(cond, branch, fold_elif rest else_branch) - in - If_then_else(cond, e1, fold_elif elifs e2) - } diff --git a/source/dune b/source/dune index 4faf423..109d30f 100644 --- a/source/dune +++ b/source/dune @@ -3,7 +3,6 @@ (wrapped false) (public_name query-json.core) (libraries - menhirLib json sedlex str @@ -15,7 +14,3 @@ (pps ppx_deriving.show sedlex.ppx)) (instrumentation (backend bisect_ppx))) - -(menhir - (flags --strict --external-tokens Lexer --explain --dump) - (modules Parser)) From 69c3dacc98a4e1a6623e618d40c59cc411b2efbe Mon Sep 17 00:00:00 2001 From: Cursor Agent Date: Fri, 6 Feb 2026 08:15:07 +0000 Subject: [PATCH 02/12] Add parser benchmark and clean up error handling - Add benchmarks/bench_parser.ml: measures parse-only performance across 22 queries of varying complexity (100k iterations each) - Add bench-parser Makefile target - Clean up inlined error handling in Parser.ml zero-arg function case - Average parse time: ~2.7 microseconds per query Co-authored-by: David Sancho --- Makefile | 4 +++ benchmarks/bench_parser.ml | 59 ++++++++++++++++++++++++++++++++++++++ benchmarks/dune | 3 ++ source/Parser.ml | 10 +++---- 4 files changed, 71 insertions(+), 5 deletions(-) create mode 100644 benchmarks/bench_parser.ml create mode 100644 benchmarks/dune diff --git a/Makefile b/Makefile index 3d36d1e..9914feb 100644 --- a/Makefile +++ b/Makefile @@ -120,6 +120,10 @@ demo: ## Generate demo from tape file (usage: make demo FILE=cli-basic) bench: ## Run benchmarks ./benchmarks/bench.sh +.PHONY: bench-parser +bench-parser: ## Run parser-only benchmark + $(DUNE) exec benchmarks/bench_parser.exe + .PHONY: release release: ## Create a new release (usage: make release VERSION=1.2.3) @if [ -z "$(VERSION)" ]; then \ diff --git a/benchmarks/bench_parser.ml b/benchmarks/bench_parser.ml new file mode 100644 index 0000000..ee9e8df --- /dev/null +++ b/benchmarks/bench_parser.ml @@ -0,0 +1,59 @@ +let queries = + [ + ("identity", "."); + ("field_access", ".foo.bar.baz"); + ("array_index", ".[0]"); + ("pipe_chain", ".foo | .bar | .baz | .qux"); + ("map_simple", "map(.x + 1)"); + ("arithmetic", "1 + 2 * 3 - 4 / 5 % 6"); + ("comparison", ". > 5 and . < 10 or . == 0"); + ("array_construct", "[.[] | {name: .name, city: .address.city}]"); + ("object_construct", "{a: .x, b: .y, c: (.z | to_string)}"); + ("if_then_else", "if . > 0 then \"positive\" elif . < 0 then \"negative\" else \"zero\" end"); + ("reduce", "reduce .[] as $x (0; . + $x)"); + ("foreach", "[foreach .[] as $x (0; . + $x; .)]"); + ("fn_def", "fn double: . * 2; fn add1: . + 1; map(double | add1)"); + ("try_catch", "try .foo catch \"not found\""); + ("string_interp", "\"Hello, \\(.name)! Age: \\(.age)\""); + ("complex_real_world", + "group_by(.category) | [.[]] | map({category: .[0].category, count: length, total: (map(.val) | add)})"); + ("nested_functions", + "fn fact: if . <= 1 then 1 else . * ((. - 1) | fact) end; 10 | fact"); + ("filter_chain", + ".[] | select(.active == true and .age >= 18) | {name: .name, email: .email}"); + ("update_assign", ".foo |= . + 1 | .bar += 2 | .baz -= 3"); + ("optional_access", ".foo?.bar?[]? | select(. > 0)"); + ("range_expressions", "[range(0; 10; 2)] | map(. * .)"); + ("walk_transform", + "walk(if type == \"object\" then with_entries(.key |= to_uppercase) else . end)"); + ] + +let iterations = 100_000 + +let time_parse query = + let start = Unix.gettimeofday () in + for _ = 1 to iterations do + let buf = Sedlexing.Utf8.from_string query in + ignore (Parser.program buf) + done; + let stop = Unix.gettimeofday () in + stop -. start + +let () = + Printf.printf "Parser Benchmark (%d iterations per query)\n" iterations; + Printf.printf "%-25s %10s %12s\n" "Query" "Total (s)" "Per-parse (ns)"; + Printf.printf "%s\n" (String.make 50 '-'); + let total_time = ref 0.0 in + let total_parses = ref 0 in + List.iter (fun (name, query) -> + let elapsed = time_parse query in + let ns_per = elapsed /. Float.of_int iterations *. 1_000_000_000.0 in + Printf.printf "%-25s %10.3f %12.0f\n" name elapsed ns_per; + total_time := !total_time +. elapsed; + total_parses := !total_parses + iterations + ) queries; + Printf.printf "%s\n" (String.make 50 '-'); + let avg_ns = !total_time /. Float.of_int !total_parses *. 1_000_000_000.0 in + Printf.printf "%-25s %10.3f %12.0f\n" "TOTAL" !total_time avg_ns; + Printf.printf "\nTotal parses: %d\n" !total_parses; + Printf.printf "Total time: %.3f s\n" !total_time diff --git a/benchmarks/dune b/benchmarks/dune new file mode 100644 index 0000000..b785178 --- /dev/null +++ b/benchmarks/dune @@ -0,0 +1,3 @@ +(executable + (name bench_parser) + (libraries query-json.core unix sedlex)) diff --git a/source/Parser.ml b/source/Parser.ml index a2a0bd7..902bca1 100644 --- a/source/Parser.ml +++ b/source/Parser.ml @@ -595,14 +595,14 @@ and parse_function_call s name = | Lexer.CLOSE_PARENT -> advance s; let opt = optional_question s in + let raise_err err = raise (Query_error.Parse_error (err, fn_start, s.end_pos)) in let ast = - if Language.can_default_to_identity name then begin + if Language.can_default_to_identity name then match Language.map_unary_fn name Identity with | Ok a -> a - | Error err -> raise (Query_error.Parse_error (err, fn_start, s.end_pos)) - end else - let err = Language.error_for_missing_arg name in - raise (Query_error.Parse_error (err, fn_start, s.end_pos)) + | Error err -> raise_err err + else + raise_err (Language.error_for_missing_arg name) in wrap_optional opt ast | _ -> From 893e1a7cd0435e9ec1e551339da66bb23b8a57c6 Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Fri, 6 Feb 2026 09:47:49 +0000 Subject: [PATCH 03/12] Implement a bench --- benchmarks/bench_parser.ml | 96 +++++-- source/Core.ml | 3 +- source/Parser.ml | 566 ++++++++++++++++++++----------------- source/Parser.mli | 1 + source/dune | 9 +- 5 files changed, 374 insertions(+), 301 deletions(-) create mode 100644 source/Parser.mli diff --git a/benchmarks/bench_parser.ml b/benchmarks/bench_parser.ml index ee9e8df..c344f61 100644 --- a/benchmarks/bench_parser.ml +++ b/benchmarks/bench_parser.ml @@ -9,51 +9,91 @@ let queries = ("comparison", ". > 5 and . < 10 or . == 0"); ("array_construct", "[.[] | {name: .name, city: .address.city}]"); ("object_construct", "{a: .x, b: .y, c: (.z | to_string)}"); - ("if_then_else", "if . > 0 then \"positive\" elif . < 0 then \"negative\" else \"zero\" end"); + ( "if_then_else", + "if . > 0 then \"positive\" elif . < 0 then \"negative\" else \"zero\" \ + end" ); ("reduce", "reduce .[] as $x (0; . + $x)"); ("foreach", "[foreach .[] as $x (0; . + $x; .)]"); ("fn_def", "fn double: . * 2; fn add1: . + 1; map(double | add1)"); ("try_catch", "try .foo catch \"not found\""); ("string_interp", "\"Hello, \\(.name)! Age: \\(.age)\""); - ("complex_real_world", - "group_by(.category) | [.[]] | map({category: .[0].category, count: length, total: (map(.val) | add)})"); - ("nested_functions", - "fn fact: if . <= 1 then 1 else . * ((. - 1) | fact) end; 10 | fact"); - ("filter_chain", - ".[] | select(.active == true and .age >= 18) | {name: .name, email: .email}"); + ( "complex_real_world", + "group_by(.category) | [.[]] | map({category: .[0].category, count: \ + length, total: (map(.val) | add)})" ); + ( "nested_functions", + "fn fact: if . <= 1 then 1 else . * ((. - 1) | fact) end; 10 | fact" ); + ( "filter_chain", + ".[] | select(.active == true and .age >= 18) | {name: .name, email: \ + .email}" ); ("update_assign", ".foo |= . + 1 | .bar += 2 | .baz -= 3"); ("optional_access", ".foo?.bar?[]? | select(. > 0)"); ("range_expressions", "[range(0; 10; 2)] | map(. * .)"); - ("walk_transform", - "walk(if type == \"object\" then with_entries(.key |= to_uppercase) else . end)"); + ( "walk_transform", + "walk(if type == \"object\" then with_entries(.key |= to_uppercase) else \ + . end)" ); ] +let warmup_iterations = 1_000 let iterations = 100_000 +let word_size = Sys.word_size / 8 -let time_parse query = +type result = { + elapsed : float; + minor_words : float; + promoted_words : float; + minor_collections : int; +} + +let bench query = + for _ = 1 to warmup_iterations do + let buf = Sedlexing.Utf8.from_string query in + ignore (Parser.program buf) + done; + Gc.compact (); + let before = Gc.quick_stat () in let start = Unix.gettimeofday () in for _ = 1 to iterations do let buf = Sedlexing.Utf8.from_string query in ignore (Parser.program buf) done; - let stop = Unix.gettimeofday () in - stop -. start + let elapsed = Unix.gettimeofday () -. start in + let after = Gc.quick_stat () in + { + elapsed; + minor_words = after.minor_words -. before.minor_words; + promoted_words = after.promoted_words -. before.promoted_words; + minor_collections = after.minor_collections - before.minor_collections; + } let () = - Printf.printf "Parser Benchmark (%d iterations per query)\n" iterations; - Printf.printf "%-25s %10s %12s\n" "Query" "Total (s)" "Per-parse (ns)"; - Printf.printf "%s\n" (String.make 50 '-'); + let n = Float.of_int iterations in + let total_queries = List.length queries in + Printf.printf "Parser Benchmark (%d iterations, %d warmup)\n\n" iterations + warmup_iterations; + Printf.printf "%-22s %8s %8s %8s %6s\n" "Query" "ns/op" "B/op" "prom/op" "GCs"; + Printf.printf "%s\n" (String.make 56 '-'); let total_time = ref 0.0 in - let total_parses = ref 0 in - List.iter (fun (name, query) -> - let elapsed = time_parse query in - let ns_per = elapsed /. Float.of_int iterations *. 1_000_000_000.0 in - Printf.printf "%-25s %10.3f %12.0f\n" name elapsed ns_per; - total_time := !total_time +. elapsed; - total_parses := !total_parses + iterations - ) queries; - Printf.printf "%s\n" (String.make 50 '-'); - let avg_ns = !total_time /. Float.of_int !total_parses *. 1_000_000_000.0 in - Printf.printf "%-25s %10.3f %12.0f\n" "TOTAL" !total_time avg_ns; - Printf.printf "\nTotal parses: %d\n" !total_parses; - Printf.printf "Total time: %.3f s\n" !total_time + let total_minor_w = ref 0.0 in + let total_promoted = ref 0.0 in + let total_gcs = ref 0 in + List.iter + (fun (name, query) -> + let r = bench query in + let ns = r.elapsed /. n *. 1e9 in + let bytes = r.minor_words /. n *. Float.of_int word_size in + let promoted = r.promoted_words /. n *. Float.of_int word_size in + Printf.printf "%-22s %8.0f %8.0f %8.0f %6d\n" name ns bytes promoted + r.minor_collections; + total_time := !total_time +. r.elapsed; + total_minor_w := !total_minor_w +. r.minor_words; + total_promoted := !total_promoted +. r.promoted_words; + total_gcs := !total_gcs + r.minor_collections) + queries; + let total_parses = Float.of_int total_queries *. n in + Printf.printf "%s\n" (String.make 56 '-'); + Printf.printf "%-22s %8.0f %8.0f %8.0f %6d\n" "AVERAGE" + (!total_time /. total_parses *. 1e9) + (!total_minor_w /. total_parses *. Float.of_int word_size) + (!total_promoted /. total_parses *. Float.of_int word_size) + !total_gcs; + Printf.printf "\n%.2fM parses in %.3fs\n" (total_parses /. 1e6) !total_time diff --git a/source/Core.ml b/source/Core.ml index 4c701c5..d23b7f3 100644 --- a/source/Core.ml +++ b/source/Core.ml @@ -28,8 +28,7 @@ let parse ~debug ~colorize input = let Location.{ loc_start; loc_end; _ } = !last_position in let err = Query_error.semantic_error ~message:msg ~input - ~start_pos:loc_start.pos_cnum - ~end_pos:loc_end.pos_cnum + ~start_pos:loc_start.pos_cnum ~end_pos:loc_end.pos_cnum in Error (Query_error.format ~colorize err) | exception _exn -> diff --git a/source/Parser.ml b/source/Parser.ml index 902bca1..65fccc3 100644 --- a/source/Parser.ml +++ b/source/Parser.ml @@ -8,7 +8,14 @@ type stream = { } let make_stream buf = - let s = { buf; token = Lexer.EOF; start_pos = Lexing.dummy_pos; end_pos = Lexing.dummy_pos } in + let s = + { + buf; + token = Lexer.EOF; + start_pos = Lexing.dummy_pos; + end_pos = Lexing.dummy_pos; + } + in s let advance s = @@ -19,8 +26,8 @@ let advance s = | Error e -> let _, stop = Sedlexing.lexing_positions s.buf in let err = - Query_error.lexer_error ~message:e ~input:"" - ~start_pos:start.pos_cnum ~end_pos:stop.pos_cnum + Query_error.lexer_error ~message:e ~input:"" ~start_pos:start.pos_cnum + ~end_pos:stop.pos_cnum in raise (Query_error.Parse_error (err, start, stop)) in @@ -31,15 +38,9 @@ let advance s = let peek s = s.token -let eat s = - let tok = s.token in - advance s; - tok - let expect s expected = let tok = s.token in - if tok = expected then - advance s + if tok = expected then advance s else let msg = Printf.sprintf "expected %s, got %s" @@ -61,7 +62,9 @@ let error s msg = let optional_question s = match peek s with - | Lexer.QUESTION_MARK -> advance s; true + | Lexer.QUESTION_MARK -> + advance s; + true | _ -> false let raise_fn_error s err = @@ -71,8 +74,7 @@ let apply_fn_result s = function | Ok ast -> ast | Error err -> raise_fn_error s err -let wrap_optional opt expr = - if opt then Optional expr else expr +let wrap_optional opt expr = if opt then Optional expr else expr let rec parse_program s = advance s; @@ -83,8 +85,7 @@ let rec parse_program s = expect s Lexer.EOF; e -and parse_sequence_expr s = - parse_fn_or_expr s +and parse_sequence_expr s = parse_fn_or_expr s and parse_fn_or_expr s = match peek s with @@ -93,7 +94,6 @@ and parse_fn_or_expr s = | _ -> parse_pipe_expr s and parse_fn_def s = - let _start = s.start_pos in advance s; match peek s with | Lexer.IDENTIFIER name -> @@ -130,36 +130,40 @@ and parse_fn_params s = let p = parse_fn_param s in let rec loop acc = match peek s with - | Lexer.SEMICOLON -> + | Lexer.SEMICOLON -> ( advance s; - (match peek s with - | Lexer.CLOSE_PARENT -> List.rev acc - | _ -> - let p = parse_fn_param s in - loop (p :: acc)) + match peek s with + | Lexer.CLOSE_PARENT -> List.rev acc + | _ -> + let p = parse_fn_param s in + loop (p :: acc)) | _ -> List.rev acc in - loop [p] + loop [ p ] and parse_fn_param s = match peek s with - | Lexer.IDENTIFIER name -> advance s; name - | Lexer.VARIABLE name -> advance s; "$" ^ name + | Lexer.IDENTIFIER name -> + advance s; + name + | Lexer.VARIABLE name -> + advance s; + "$" ^ name | _ -> error s "expected parameter name" and parse_try s = advance s; let body = parse_sequence_expr s in match peek s with - | Lexer.CATCH -> + | Lexer.CATCH -> ( advance s; let handler = parse_item_expr s in - (match peek s with - | Lexer.FINALLY -> - advance s; - let cleanup = parse_item_expr s in - Try (body, Some handler, Some cleanup) - | _ -> Try (body, Some handler, None)) + match peek s with + | Lexer.FINALLY -> + advance s; + let cleanup = parse_item_expr s in + Try (body, Some handler, Some cleanup) + | _ -> Try (body, Some handler, None)) | _ -> body and parse_pipe_expr s = @@ -307,8 +311,7 @@ and parse_mul_right s left = parse_mul_right s (Operation (left, Modulo, right)) | _ -> left -and parse_item_expr s = - parse_or_expr s +and parse_item_expr s = parse_or_expr s and parse_term s = let e = parse_primary s in @@ -357,70 +360,102 @@ and parse_bracket_access s e = let end_ = parse_index_number s in expect s Lexer.CLOSE_BRACKET; Pipe (e, Slice (None, Some end_)) - | _ -> + | _ -> ( let first_num = parse_index_number s in - (match peek s with - | Lexer.COLON -> ( - advance s; - match peek s with - | Lexer.CLOSE_BRACKET -> - advance s; - Pipe (e, Slice (Some first_num, None)) - | _ -> - let end_ = parse_index_number s in - expect s Lexer.CLOSE_BRACKET; - Pipe (e, Slice (Some first_num, Some end_))) - | Lexer.COMMA -> - let indices = parse_remaining_indices s [first_num] in - expect s Lexer.CLOSE_BRACKET; - let opt = optional_question s in - let idx_expr = Index indices in - if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) - | Lexer.CLOSE_BRACKET -> - advance s; - let opt = optional_question s in - let idx_expr = Index [first_num] in - if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) - | _ -> error s "expected ':', ',' or ']' in bracket expression") + match peek s with + | Lexer.COLON -> ( + advance s; + match peek s with + | Lexer.CLOSE_BRACKET -> + advance s; + Pipe (e, Slice (Some first_num, None)) + | _ -> + let end_ = parse_index_number s in + expect s Lexer.CLOSE_BRACKET; + Pipe (e, Slice (Some first_num, Some end_))) + | Lexer.COMMA -> + let indices = parse_remaining_indices s [ first_num ] in + expect s Lexer.CLOSE_BRACKET; + let opt = optional_question s in + let idx_expr = Index indices in + if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) + | Lexer.CLOSE_BRACKET -> + advance s; + let opt = optional_question s in + let idx_expr = Index [ first_num ] in + if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) + | _ -> error s "expected ':', ',' or ']' in bracket expression") and parse_remaining_indices s acc = match peek s with | Lexer.COMMA -> advance s; let n = parse_index_number s in - parse_remaining_indices s (acc @ [n]) + parse_remaining_indices s (acc @ [ n ]) | _ -> acc and parse_index_number s = match peek s with - | Lexer.SUB -> + | Lexer.SUB -> ( + advance s; + match peek s with + | Lexer.INT n -> + advance s; + -n + | Lexer.INT64 n -> + advance s; + Int64.to_int (Int64.neg n) + | Lexer.BIG_INT n -> + advance s; + Z.to_int (Z.neg n) + | Lexer.FLOAT n -> + advance s; + int_of_float (-.n) + | _ -> error s "expected number after '-'") + | Lexer.INT n -> + advance s; + n + | Lexer.INT64 n -> advance s; - (match peek s with - | Lexer.INT n -> advance s; -n - | Lexer.INT64 n -> advance s; Int64.to_int (Int64.neg n) - | Lexer.BIG_INT n -> advance s; Z.to_int (Z.neg n) - | Lexer.FLOAT n -> advance s; int_of_float (-.n) - | _ -> error s "expected number after '-'") - | Lexer.INT n -> advance s; n - | Lexer.INT64 n -> advance s; Int64.to_int n - | Lexer.BIG_INT n -> advance s; Z.to_int n - | Lexer.FLOAT n -> advance s; int_of_float n + Int64.to_int n + | Lexer.BIG_INT n -> + advance s; + Z.to_int n + | Lexer.FLOAT n -> + advance s; + int_of_float n | _ -> error s "expected index number" and parse_number_literal s = match peek s with - | Lexer.SUB -> + | Lexer.SUB -> ( advance s; - (match peek s with - | Lexer.INT n -> advance s; Int (-n) - | Lexer.INT64 n -> advance s; Int64 (Int64.neg n) - | Lexer.BIG_INT n -> advance s; Big_int (Z.neg n) - | Lexer.FLOAT n -> advance s; Float (-.n) - | _ -> error s "expected number after '-'") - | Lexer.INT n -> advance s; Int n - | Lexer.INT64 n -> advance s; Int64 n - | Lexer.BIG_INT n -> advance s; Big_int n - | Lexer.FLOAT n -> advance s; Float n + match peek s with + | Lexer.INT n -> + advance s; + Int (-n) + | Lexer.INT64 n -> + advance s; + Int64 (Int64.neg n) + | Lexer.BIG_INT n -> + advance s; + Big_int (Z.neg n) + | Lexer.FLOAT n -> + advance s; + Float (-.n) + | _ -> error s "expected number after '-'") + | Lexer.INT n -> + advance s; + Int n + | Lexer.INT64 n -> + advance s; + Int64 n + | Lexer.BIG_INT n -> + advance s; + Big_int n + | Lexer.FLOAT n -> + advance s; + Float n | _ -> error s "expected number" and parse_primary s = @@ -444,32 +479,21 @@ and parse_primary s = | Lexer.VARIABLE var -> advance s; Variable var - | Lexer.INTERP_START -> - parse_interpolated_string s - | Lexer.TEMPLATE_START -> - parse_template_literal s - | Lexer.RANGE -> - parse_range s - | Lexer.FLATTEN -> - parse_flatten s - | Lexer.REDUCE -> - parse_reduce s - | Lexer.FOREACH -> - parse_foreach s - | Lexer.IF -> - parse_if s - | Lexer.FUNCTION name -> - parse_function_call s name - | Lexer.IDENTIFIER name -> - parse_identifier s name - | Lexer.OPEN_BRACKET -> - parse_array_construction s - | Lexer.OPEN_BRACE -> - parse_object_construction s - | Lexer.OPEN_PARENT -> - parse_paren s + | Lexer.INTERP_START -> parse_interpolated_string s + | Lexer.TEMPLATE_START -> parse_template_literal s + | Lexer.RANGE -> parse_range s + | Lexer.FLATTEN -> parse_flatten s + | Lexer.REDUCE -> parse_reduce s + | Lexer.FOREACH -> parse_foreach s + | Lexer.IF -> parse_if s + | Lexer.FUNCTION name -> parse_function_call s name + | Lexer.IDENTIFIER name -> parse_identifier s name + | Lexer.OPEN_BRACKET -> parse_array_construction s + | Lexer.OPEN_BRACE -> parse_object_construction s + | Lexer.OPEN_PARENT -> parse_paren s | _ -> - error s (Printf.sprintf "unexpected token: %s" (Lexer.show_token (peek s))) + error s + (Printf.sprintf "unexpected token: %s" (Lexer.show_token (peek s))) and parse_dot s = advance s; @@ -482,8 +506,7 @@ and parse_dot s = advance s; let opt = optional_question s in if opt then Optional (Key k) else Key k - | Lexer.OPEN_BRACKET -> - parse_bracket_access s Identity + | Lexer.OPEN_BRACKET -> parse_bracket_access s Identity | _ -> Identity and parse_range s = @@ -494,42 +517,45 @@ and parse_range s = | Lexer.CLOSE_PARENT -> advance s; Range (from, None, None) - | Lexer.SEMICOLON -> + | Lexer.SEMICOLON -> ( advance s; let upto = parse_sequence_expr s in - (match peek s with - | Lexer.CLOSE_PARENT -> - advance s; - Range (from, Some upto, None) - | Lexer.SEMICOLON -> - advance s; - let step = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - Range (from, Some upto, Some step) - | _ -> error s "expected ')' or ';' in range") + match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + Range (from, Some upto, None) + | Lexer.SEMICOLON -> + advance s; + let step = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + Range (from, Some upto, Some step) + | _ -> error s "expected ')' or ';' in range") | _ -> error s "expected ')' or ';' in range" and parse_flatten s = advance s; match peek s with - | Lexer.OPEN_PARENT -> + | Lexer.OPEN_PARENT -> ( advance s; - (match peek s with - | Lexer.CLOSE_PARENT -> - advance s; - Fn0 Flatten - | _ -> - let e = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - Fn1 (With_expr (Flatten_n, e))) + match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + Fn0 Flatten + | _ -> + let e = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + Fn1 (With_expr (Flatten_n, e))) | _ -> Fn0 Flatten and parse_reduce s = advance s; let expr = parse_sequence_expr s in expect s Lexer.AS; - let var = match peek s with - | Lexer.VARIABLE v -> advance s; v + let var = + match peek s with + | Lexer.VARIABLE v -> + advance s; + v | _ -> error s "expected variable after 'as'" in expect s Lexer.OPEN_PARENT; @@ -543,8 +569,11 @@ and parse_foreach s = advance s; let expr = parse_sequence_expr s in expect s Lexer.AS; - let var = match peek s with - | Lexer.VARIABLE v -> advance s; v + let var = + match peek s with + | Lexer.VARIABLE v -> + advance s; + v | _ -> error s "expected variable after 'as'" in expect s Lexer.OPEN_PARENT; @@ -595,47 +624,51 @@ and parse_function_call s name = | Lexer.CLOSE_PARENT -> advance s; let opt = optional_question s in - let raise_err err = raise (Query_error.Parse_error (err, fn_start, s.end_pos)) in + let raise_err err = + raise (Query_error.Parse_error (err, fn_start, s.end_pos)) + in let ast = if Language.can_default_to_identity name then match Language.map_unary_fn name Identity with | Ok a -> a | Error err -> raise_err err - else - raise_err (Language.error_for_missing_arg name) + else raise_err (Language.error_for_missing_arg name) in wrap_optional opt ast - | _ -> + | _ -> ( let arg1 = parse_sequence_expr s in - (match peek s with - | Lexer.SEMICOLON -> - advance s; - let arg2 = parse_sequence_expr s in - (match peek s with - | Lexer.SEMICOLON -> - advance s; - let arg3 = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - let opt = optional_question s in - let ast = match name with - | "fma" -> Fma (arg1, arg2, arg3) - | _ -> Apply (name, [arg1; arg2; arg3]) - in - wrap_optional opt ast - | Lexer.CLOSE_PARENT -> - advance s; - let opt = optional_question s in - let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_binary_fn name arg1 arg2) in - wrap_optional opt ast - | _ -> error s "expected ';' or ')' in function call") - | Lexer.CLOSE_PARENT -> - advance s; - let opt = optional_question s in - let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_unary_fn name arg1) in - wrap_optional opt ast - | _ -> error s "expected ';' or ')' in function call") + match peek s with + | Lexer.SEMICOLON -> ( + advance s; + let arg2 = parse_sequence_expr s in + match peek s with + | Lexer.SEMICOLON -> + advance s; + let arg3 = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + let opt = optional_question s in + let ast = + match name with + | "fma" -> Fma (arg1, arg2, arg3) + | _ -> Apply (name, [ arg1; arg2; arg3 ]) + in + wrap_optional opt ast + | Lexer.CLOSE_PARENT -> + advance s; + let opt = optional_question s in + let s_proxy = { s with start_pos = fn_start } in + let ast = + apply_fn_result s_proxy (Language.map_binary_fn name arg1 arg2) + in + wrap_optional opt ast + | _ -> error s "expected ';' or ')' in function call") + | Lexer.CLOSE_PARENT -> + advance s; + let opt = optional_question s in + let s_proxy = { s with start_pos = fn_start } in + let ast = apply_fn_result s_proxy (Language.map_unary_fn name arg1) in + wrap_optional opt ast + | _ -> error s "expected ';' or ')' in function call") and parse_identifier s name = let fn_start = s.start_pos in @@ -644,35 +677,41 @@ and parse_identifier s name = | Lexer.QUESTION_MARK -> ( advance s; match peek s with - | Lexer.OPEN_PARENT -> + | Lexer.OPEN_PARENT -> ( advance s; let arg1 = parse_sequence_expr s in - (match peek s with - | Lexer.SEMICOLON -> - advance s; - let arg2 = parse_sequence_expr s in - (match peek s with - | Lexer.SEMICOLON -> - advance s; - let arg3 = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - let ast = match name with - | "fma" -> Fma (arg1, arg2, arg3) - | _ -> Apply (name, [arg1; arg2; arg3]) - in - Optional ast - | Lexer.CLOSE_PARENT -> - advance s; - let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_binary_fn name arg1 arg2) in - Optional ast - | _ -> error s "expected ';' or ')' in optional function call") - | Lexer.CLOSE_PARENT -> - advance s; - let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_unary_fn name arg1) in - Optional ast - | _ -> error s "expected ';' or ')' in optional function call") + match peek s with + | Lexer.SEMICOLON -> ( + advance s; + let arg2 = parse_sequence_expr s in + match peek s with + | Lexer.SEMICOLON -> + advance s; + let arg3 = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + let ast = + match name with + | "fma" -> Fma (arg1, arg2, arg3) + | _ -> Apply (name, [ arg1; arg2; arg3 ]) + in + Optional ast + | Lexer.CLOSE_PARENT -> + advance s; + let s_proxy = { s with start_pos = fn_start } in + let ast = + apply_fn_result s_proxy + (Language.map_binary_fn name arg1 arg2) + in + Optional ast + | _ -> error s "expected ';' or ')' in optional function call") + | Lexer.CLOSE_PARENT -> + advance s; + let s_proxy = { s with start_pos = fn_start } in + let ast = + apply_fn_result s_proxy (Language.map_unary_fn name arg1) + in + Optional ast + | _ -> error s "expected ';' or ')' in optional function call") | _ -> let s_proxy = { s with start_pos = fn_start } in let ast = apply_fn_result s_proxy (Language.map_nullary_fn name) in @@ -715,7 +754,7 @@ and parse_key_value_list s = loop (pair :: acc) | _ -> List.rev acc in - loop [pair] + loop [ pair ] and parse_key_value s = match peek s with @@ -726,22 +765,22 @@ and parse_key_value s = expect s Lexer.COLON; let value = parse_term s in (key_expr, Some value) - | Lexer.IDENTIFIER key -> - advance s; - (match peek s with - | Lexer.COLON -> - advance s; - let value = parse_term s in - (Literal (String key), Some value) - | _ -> (Literal (String key), None)) - | Lexer.STRING key -> + | Lexer.IDENTIFIER key -> ( + advance s; + match peek s with + | Lexer.COLON -> + advance s; + let value = parse_term s in + (Literal (String key), Some value) + | _ -> (Literal (String key), None)) + | Lexer.STRING key -> ( advance s; - (match peek s with - | Lexer.COLON -> - advance s; - let value = parse_term s in - (Literal (String key), Some value) - | _ -> (Literal (String key), None)) + match peek s with + | Lexer.COLON -> + advance s; + let value = parse_term s in + (Literal (String key), Some value) + | _ -> (Literal (String key), None)) | _ -> error s "expected key in object construction" and parse_paren s = @@ -750,8 +789,11 @@ and parse_paren s = match peek s with | Lexer.AS -> advance s; - let var = match peek s with - | Lexer.VARIABLE v -> advance s; v + let var = + match peek s with + | Lexer.VARIABLE v -> + advance s; + v | _ -> error s "expected variable after 'as'" in expect s Lexer.PIPE; @@ -769,7 +811,7 @@ and parse_interpolated_string s = let parts = parse_interp_body s in match parts with | [] -> Literal (String "") - | [single] -> single + | [ single ] -> single | first :: rest -> List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest @@ -778,18 +820,18 @@ and parse_interp_body s = | Lexer.INTERP_END -> advance s; [] - | Lexer.INTERP_TEXT text -> - advance s; - (match peek s with - | Lexer.INTERP_END -> - advance s; - [Literal (String text)] - | Lexer.INTERP_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_interp_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected interpolation expression or end of string") + | Lexer.INTERP_TEXT text -> ( + advance s; + match peek s with + | Lexer.INTERP_END -> + advance s; + [ Literal (String text) ] + | Lexer.INTERP_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_interp_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected interpolation expression or end of string") | Lexer.INTERP_EXPR_START -> advance s; let e = parse_sequence_expr s in @@ -802,18 +844,18 @@ and parse_interp_after_expr s = | Lexer.INTERP_END -> advance s; [] - | Lexer.INTERP_TEXT text -> - advance s; - (match peek s with - | Lexer.INTERP_END -> - advance s; - [Literal (String text)] - | Lexer.INTERP_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_interp_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected interpolation expression or end of string") + | Lexer.INTERP_TEXT text -> ( + advance s; + match peek s with + | Lexer.INTERP_END -> + advance s; + [ Literal (String text) ] + | Lexer.INTERP_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_interp_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected interpolation expression or end of string") | Lexer.INTERP_EXPR_START -> advance s; let e = parse_sequence_expr s in @@ -826,7 +868,7 @@ and parse_template_literal s = let parts = parse_template_body s in match parts with | [] -> Literal (String "") - | [single] -> single + | [ single ] -> single | first :: rest -> List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest @@ -835,18 +877,18 @@ and parse_template_body s = | Lexer.TEMPLATE_END -> advance s; [] - | Lexer.TEMPLATE_TEXT text -> - advance s; - (match peek s with - | Lexer.TEMPLATE_END -> - advance s; - [Literal (String text)] - | Lexer.TEMPLATE_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_template_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected template expression or end of template") + | Lexer.TEMPLATE_TEXT text -> ( + advance s; + match peek s with + | Lexer.TEMPLATE_END -> + advance s; + [ Literal (String text) ] + | Lexer.TEMPLATE_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_template_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected template expression or end of template") | Lexer.TEMPLATE_EXPR_START -> advance s; let e = parse_sequence_expr s in @@ -859,18 +901,18 @@ and parse_template_after_expr s = | Lexer.TEMPLATE_END -> advance s; [] - | Lexer.TEMPLATE_TEXT text -> - advance s; - (match peek s with - | Lexer.TEMPLATE_END -> - advance s; - [Literal (String text)] - | Lexer.TEMPLATE_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_template_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected template expression or end of template") + | Lexer.TEMPLATE_TEXT text -> ( + advance s; + match peek s with + | Lexer.TEMPLATE_END -> + advance s; + [ Literal (String text) ] + | Lexer.TEMPLATE_EXPR_START -> + advance s; + let e = parse_sequence_expr s in + let rest = parse_template_after_expr s in + Literal (String text) :: Pipe (e, Fn0 To_string) :: rest + | _ -> error s "expected template expression or end of template") | Lexer.TEMPLATE_EXPR_START -> advance s; let e = parse_sequence_expr s in @@ -878,6 +920,4 @@ and parse_template_after_expr s = Pipe (e, Fn0 To_string) :: rest | _ -> error s "expected template literal content" -let program buf = - let s = make_stream buf in - parse_program s +let program buf = parse_program (make_stream buf) diff --git a/source/Parser.mli b/source/Parser.mli new file mode 100644 index 0000000..344fe13 --- /dev/null +++ b/source/Parser.mli @@ -0,0 +1 @@ +val program : Sedlexing.lexbuf -> Ast.expression diff --git a/source/dune b/source/dune index 109d30f..37a2a84 100644 --- a/source/dune +++ b/source/dune @@ -2,14 +2,7 @@ (name Core) (wrapped false) (public_name query-json.core) - (libraries - json - sedlex - str - unix - zarith - matrix.ansi - query-json.console-style) + (libraries json sedlex str unix zarith matrix.ansi query-json.console-style) (preprocess (pps ppx_deriving.show sedlex.ppx)) (instrumentation From 104cb15d41bcef57a231442f2438deb118a26b5b Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Tue, 10 Feb 2026 11:20:27 +0000 Subject: [PATCH 04/12] refactor: simplify lexer --- source/Lexer.ml | 242 +++++++++------------- source/Lexer.mli | 69 +++++++ source/Parser.ml | 513 ++++++++++++++++------------------------------- 3 files changed, 343 insertions(+), 481 deletions(-) create mode 100644 source/Lexer.mli diff --git a/source/Lexer.ml b/source/Lexer.ml index 75a65a2..9054b26 100644 --- a/source/Lexer.ml +++ b/source/Lexer.ml @@ -71,26 +71,76 @@ type token = | CATCH | FINALLY | FN - | INTERP_START - | INTERP_TEXT of string - | INTERP_EXPR_START - | INTERP_END - (* Template literal tokens (backtick strings) *) - | TEMPLATE_START - | TEMPLATE_TEXT of string - | TEMPLATE_EXPR_START - | TEMPLATE_END + | INTERP of string + | TEMPLATE of string | EOF [@@deriving show] -(* Token buffer for returning multiple tokens from a single lexer call *) -let token_buffer : token Queue.t = Queue.create () -let interp_paren_depth = ref (-1) -let inside_interp () = !interp_paren_depth >= 0 -let template_brace_depth = ref (-1) -let inside_template () = !template_brace_depth >= 0 +let humanize = function + | INT n -> Printf.sprintf "%d" n + | INT64 n -> Printf.sprintf "%Ld" n + | BIG_INT n -> Z.to_string n + | FLOAT n -> Printf.sprintf "%g" n + | STRING s -> Printf.sprintf "\"%s\"" s + | BOOL b -> if b then "true" else "false" + | IDENTIFIER s -> Printf.sprintf "'%s'" s + | FUNCTION s -> Printf.sprintf "'%s('" s + | VARIABLE s -> Printf.sprintf "$%s" s + | OPEN_PARENT -> "'('" + | CLOSE_PARENT -> "')'" + | OPEN_BRACKET -> "'['" + | CLOSE_BRACKET -> "']'" + | OPEN_BRACE -> "'{'" + | CLOSE_BRACE -> "'}'" + | SEMICOLON -> "';'" + | COLON -> "':'" + | DOT -> "'.'" + | PIPE -> "'|'" + | UPDATE_ASSIGN -> "'|='" + | PLUS_ASSIGN -> "'+='" + | MINUS_ASSIGN -> "'-='" + | MULT_ASSIGN -> "'*='" + | DIV_ASSIGN -> "'/='" + | ALT_ASSIGN -> "'//='" + | ASSIGN -> "'='" + | ALTERNATIVE -> "'//'" + | QUESTION_MARK -> "'?'" + | COMMA -> "','" + | NULL -> "null" + | ADD -> "'+'" + | SUB -> "'-'" + | DIV -> "'/'" + | MULT -> "'*'" + | MODULO -> "'%'" + | AND -> "'and'" + | OR -> "'or'" + | EQUAL -> "'=='" + | NOT_EQUAL -> "'!='" + | GREATER -> "'>'" + | LOWER -> "'<'" + | GREATER_EQUAL -> "'>='" + | LOWER_EQUAL -> "'<='" + | RANGE -> "'range'" + | FLATTEN -> "'flatten'" + | REDUCE -> "'reduce'" + | FOREACH -> "'foreach'" + | IF -> "'if'" + | THEN -> "'then'" + | ELSE -> "'else'" + | ELIF -> "'elif'" + | END -> "'end'" + | AS -> "'as'" + | TRY -> "'try'" + | CATCH -> "'catch'" + | FINALLY -> "'finally'" + | FN -> "'fn'" + | INTERP _ -> "string interpolation" + | TEMPLATE _ -> "template literal" + | EOF -> "end of input" -let read_string_part buf = +type string_part = Interp of string | End of string + +let tokenize_string buf = let buffer = Buffer.create 10 in let rec loop buf = match%sedlex buf with @@ -109,63 +159,16 @@ let read_string_part buf = | {|\t|} -> Buffer.add_char buffer '\t'; loop buf - | {|\(|} -> - (* store what we have and signal interpolation *) - `Interp (Buffer.contents buffer) - | '"' -> - (* end of string *) - `End (Buffer.contents buffer) + | {|\(|} -> Ok (Interp (Buffer.contents buffer)) + | '"' -> Ok (End (Buffer.contents buffer)) | Compl ('"' | '\\') -> Buffer.add_string buffer (lexeme buf); loop buf - | _ -> `Error "unmatched string" + | _ -> Error "unmatched string" in loop buf -let tokenize_string buf = - (* peek ahead to see if this string has any interpolation *) - match read_string_part buf with - | `End s -> Ok (STRING s) - | `Interp s -> - interp_paren_depth := 0; - if String.length s > 0 then Queue.add (INTERP_TEXT s) token_buffer; - Queue.add INTERP_EXPR_START token_buffer; - Ok INTERP_START - | `Error e -> Error e - -let tokenize_apply buf = - let identifier = lexeme buf in - match%sedlex buf with - | '(' -> Ok (FUNCTION identifier) - | _ -> Ok (IDENTIFIER identifier) - -let tokenize_variable buf = - match%sedlex buf with - | identifier -> - let var_name = lexeme buf in - Ok (VARIABLE var_name) - | _ -> Error "Expected variable name after $" - -let continue_interp_string buf = - match read_string_part buf with - | `End s -> ( - interp_paren_depth := -1; - if String.length s > 0 then Queue.add (INTERP_TEXT s) token_buffer; - Queue.add INTERP_END token_buffer; - (* Return the first queued token *) - match Queue.take_opt token_buffer with - | Some tok -> Ok tok - | None -> Ok INTERP_END) - | `Interp s -> ( - interp_paren_depth := 0; - if String.length s > 0 then Queue.add (INTERP_TEXT s) token_buffer; - Queue.add INTERP_EXPR_START token_buffer; - match Queue.take_opt token_buffer with - | Some tok -> Ok tok - | None -> Ok INTERP_EXPR_START) - | `Error e -> Error e - -let read_template_part buf = +let tokenize_template buf = let buffer = Buffer.create 10 in let rec loop buf = match%sedlex buf with @@ -187,53 +190,19 @@ let read_template_part buf = | {|\t|} -> Buffer.add_char buffer '\t'; loop buf - | "${" -> `Interp (Buffer.contents buffer) - | '`' -> `End (Buffer.contents buffer) + | "${" -> Ok (Interp (Buffer.contents buffer)) + | '`' -> Ok (End (Buffer.contents buffer)) | Compl ('`' | '\\' | '$') -> Buffer.add_string buffer (lexeme buf); loop buf | '$' -> Buffer.add_char buffer '$'; loop buf - | _ -> `Error "unmatched template literal" + | _ -> Error "unmatched template literal" in loop buf -let tokenize_template buf = - match read_template_part buf with - | `End s -> Ok (STRING s) - | `Interp s -> - template_brace_depth := 0; - if String.length s > 0 then Queue.add (TEMPLATE_TEXT s) token_buffer; - Queue.add TEMPLATE_EXPR_START token_buffer; - Ok TEMPLATE_START - | `Error e -> Error e - -let continue_template buf = - match read_template_part buf with - | `End s -> ( - template_brace_depth := -1; - if String.length s > 0 then Queue.add (TEMPLATE_TEXT s) token_buffer; - Queue.add TEMPLATE_END token_buffer; - match Queue.take_opt token_buffer with - | Some tok -> Ok tok - | None -> Ok TEMPLATE_END) - | `Interp s -> ( - template_brace_depth := 0; - if String.length s > 0 then Queue.add (TEMPLATE_TEXT s) token_buffer; - Queue.add TEMPLATE_EXPR_START token_buffer; - match Queue.take_opt token_buffer with - | Some tok -> Ok tok - | None -> Ok TEMPLATE_EXPR_START) - | `Error e -> Error e - let rec tokenize buf = - (* First, check if we have buffered tokens *) - match Queue.take_opt token_buffer with - | Some tok -> Ok tok - | None -> tokenize_impl buf - -and tokenize_impl buf = match%sedlex buf with | eof -> Ok EOF | '<' -> Ok LOWER @@ -252,19 +221,8 @@ and tokenize_impl buf = | "%" -> Ok MODULO | "[" -> Ok OPEN_BRACKET | "]" -> Ok CLOSE_BRACKET - | "{" -> - if inside_template () then incr template_brace_depth; - Ok OPEN_BRACE - | "}" -> - if inside_template () then begin - let end_of_template_expr = !template_brace_depth = 0 in - if end_of_template_expr then continue_template buf - else begin - decr template_brace_depth; - Ok CLOSE_BRACE - end - end - else Ok CLOSE_BRACE + | "{" -> Ok OPEN_BRACE + | "}" -> Ok CLOSE_BRACE | "|=" -> Ok UPDATE_ASSIGN | "+=" -> Ok PLUS_ASSIGN | "-=" -> Ok MINUS_ASSIGN @@ -280,19 +238,8 @@ and tokenize_impl buf = | "null" -> Ok NULL | "true" -> Ok (BOOL true) | "false" -> Ok (BOOL false) - | "(" -> - if inside_interp () then incr interp_paren_depth; - Ok OPEN_PARENT - | ")" -> - if inside_interp () then begin - let end_of_interpolation = !interp_paren_depth = 0 in - if end_of_interpolation then continue_interp_string buf - else begin - decr interp_paren_depth; - Ok CLOSE_PARENT - end - end - else Ok CLOSE_PARENT + | "(" -> Ok OPEN_PARENT + | ")" -> Ok CLOSE_PARENT | "range" -> Ok RANGE | "flatten" -> Ok FLATTEN | "reduce" -> Ok REDUCE @@ -305,23 +252,32 @@ and tokenize_impl buf = | "as" -> Ok AS | "fn" -> Ok FN | "def" -> Error "'def' is deprecated, use 'fn' instead" - | "try" -> ( - (* distinguish try(expr) from try expr. - Otherwise, the grammar has reduce/reduce conflicts because - TRY OPEN_PARENT could start either form. *) - match%sedlex - buf - with - | '(' -> Ok (FUNCTION "try") - | _ -> Ok TRY) + | "try" -> ( match%sedlex buf with '(' -> Ok (FUNCTION "try") | _ -> Ok TRY) | "catch" -> Ok CATCH | "finally" -> Ok FINALLY | "." -> Ok DOT | ".." -> Error "'..' is deprecated, use 'descend' instead" - | '$' -> tokenize_variable buf - | '"' -> tokenize_string buf - | '`' -> tokenize_template buf - | identifier -> tokenize_apply buf + | '$' -> ( + match%sedlex buf with + | identifier -> + let var_name = lexeme buf in + Ok (VARIABLE var_name) + | _ -> Error "Expected variable name after $") + | '"' -> ( + match tokenize_string buf with + | Ok (End s) -> Ok (STRING s) + | Ok (Interp s) -> Ok (INTERP s) + | Error e -> Error e) + | '`' -> ( + match tokenize_template buf with + | Ok (End s) -> Ok (STRING s) + | Ok (Interp s) -> Ok (TEMPLATE s) + | Error e -> Error e) + | identifier -> ( + let ident = lexeme buf in + match%sedlex buf with + | '(' -> Ok (FUNCTION ident) + | _ -> Ok (IDENTIFIER ident)) | float_number -> let num = lexeme buf in Ok (FLOAT (Float.of_string num)) diff --git a/source/Lexer.mli b/source/Lexer.mli new file mode 100644 index 0000000..2e1152f --- /dev/null +++ b/source/Lexer.mli @@ -0,0 +1,69 @@ +type token = + | INT of int + | INT64 of int64 + | BIG_INT of Z.t + | FLOAT of float + | STRING of string + | BOOL of bool + | IDENTIFIER of string + | FUNCTION of string + | VARIABLE of string + | OPEN_PARENT + | CLOSE_PARENT + | OPEN_BRACKET + | CLOSE_BRACKET + | OPEN_BRACE + | CLOSE_BRACE + | SEMICOLON + | COLON + | DOT + | PIPE + | UPDATE_ASSIGN + | PLUS_ASSIGN + | MINUS_ASSIGN + | MULT_ASSIGN + | DIV_ASSIGN + | ALT_ASSIGN + | ASSIGN + | ALTERNATIVE + | QUESTION_MARK + | COMMA + | NULL + | ADD + | SUB + | DIV + | MULT + | MODULO + | AND + | OR + | EQUAL + | NOT_EQUAL + | GREATER + | LOWER + | GREATER_EQUAL + | LOWER_EQUAL + | RANGE + | FLATTEN + | REDUCE + | FOREACH + | IF + | THEN + | ELSE + | ELIF + | END + | AS + | TRY + | CATCH + | FINALLY + | FN + | INTERP of string + | TEMPLATE of string + | EOF + +val humanize : token -> string + +type string_part = Interp of string | End of string + +val tokenize_string : Sedlexing.lexbuf -> (string_part, string) result +val tokenize_template : Sedlexing.lexbuf -> (string_part, string) result +val tokenize : Sedlexing.lexbuf -> (token, string) result diff --git a/source/Parser.ml b/source/Parser.ml index 65fccc3..c29250d 100644 --- a/source/Parser.ml +++ b/source/Parser.ml @@ -7,17 +7,6 @@ type stream = { mutable end_pos : Lexing.position; } -let make_stream buf = - let s = - { - buf; - token = Lexer.EOF; - start_pos = Lexing.dummy_pos; - end_pos = Lexing.dummy_pos; - } - in - s - let advance s = let start, _ = Sedlexing.lexing_positions s.buf in let tok = @@ -43,9 +32,8 @@ let expect s expected = if tok = expected then advance s else let msg = - Printf.sprintf "expected %s, got %s" - (Lexer.show_token expected) - (Lexer.show_token tok) + Printf.sprintf "expected %s, got %s" (Lexer.humanize expected) + (Lexer.humanize tok) in let err = Query_error.parse_error ~message:msg ~input:"" @@ -54,6 +42,7 @@ let expect s expected = raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) let error s msg = + let msg = Printf.sprintf "%s, got %s" msg (Lexer.humanize s.token) in let err = Query_error.parse_error ~message:msg ~input:"" ~start_pos:s.start_pos.pos_cnum ~end_pos:s.end_pos.pos_cnum @@ -76,6 +65,19 @@ let apply_fn_result s = function let wrap_optional opt expr = if opt then Optional expr else expr +let expect_variable s = + match peek s with + | Lexer.VARIABLE v -> + advance s; + v + | _ -> error s "expected variable after 'as'" + +let concat_parts = function + | [] -> Literal (String "") + | [ single ] -> single + | first :: rest -> + List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest + let rec parse_program s = advance s; match peek s with @@ -95,33 +97,32 @@ and parse_fn_or_expr s = and parse_fn_def s = advance s; - match peek s with - | Lexer.IDENTIFIER name -> - advance s; - let params = - match peek s with - | Lexer.OPEN_PARENT -> - advance s; - let ps = parse_fn_params s in - expect s Lexer.CLOSE_PARENT; - ps - | _ -> [] - in - expect s Lexer.COLON; - let body = parse_sequence_expr s in - expect s Lexer.SEMICOLON; - let rest = parse_sequence_expr s in - Pipe (Fn (name, params, body), rest) - | Lexer.FUNCTION name -> - advance s; - let params = parse_fn_params s in - expect s Lexer.CLOSE_PARENT; - expect s Lexer.COLON; - let body = parse_sequence_expr s in - expect s Lexer.SEMICOLON; - let rest = parse_sequence_expr s in - Pipe (Fn (name, params, body), rest) - | _ -> error s "expected function name after 'fn'" + let name, params = + match peek s with + | Lexer.IDENTIFIER name -> + advance s; + let params = + match peek s with + | Lexer.OPEN_PARENT -> + advance s; + let ps = parse_fn_params s in + expect s Lexer.CLOSE_PARENT; + ps + | _ -> [] + in + (name, params) + | Lexer.FUNCTION name -> + advance s; + let params = parse_fn_params s in + expect s Lexer.CLOSE_PARENT; + (name, params) + | _ -> error s "expected function name after 'fn'" + in + expect s Lexer.COLON; + let body = parse_sequence_expr s in + expect s Lexer.SEMICOLON; + let rest = parse_sequence_expr s in + Pipe (Fn (name, params, body), rest) and parse_fn_params s = match peek s with @@ -184,22 +185,18 @@ and parse_pipe_right s left = advance s; let right = parse_item_expr s in parse_pipe_right s (Assign (left, right)) - | Lexer.PLUS_ASSIGN -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Update (left, Operation (Identity, Add, right))) - | Lexer.MINUS_ASSIGN -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Update (left, Operation (Identity, Subtract, right))) - | Lexer.MULT_ASSIGN -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Update (left, Operation (Identity, Multiply, right))) + | Lexer.PLUS_ASSIGN | Lexer.MINUS_ASSIGN | Lexer.MULT_ASSIGN | Lexer.DIV_ASSIGN -> + let op = + match s.token with + | PLUS_ASSIGN -> Add + | MINUS_ASSIGN -> Subtract + | MULT_ASSIGN -> Multiply + | _ -> Divide + in advance s; let right = parse_item_expr s in - parse_pipe_right s (Update (left, Operation (Identity, Divide, right))) + parse_pipe_right s (Update (left, Operation (Identity, op, right))) | Lexer.ALT_ASSIGN -> advance s; let right = parse_item_expr s in @@ -249,30 +246,20 @@ and parse_and_right s left = and parse_comparison_expr s = let left = parse_add_expr s in match peek s with - | Lexer.EQUAL -> - advance s; - let right = parse_add_expr s in - Operation (left, Equal, right) - | Lexer.NOT_EQUAL -> - advance s; - let right = parse_add_expr s in - Operation (left, Not_equal, right) - | Lexer.GREATER -> - advance s; - let right = parse_add_expr s in - Operation (left, Greater_than, right) - | Lexer.LOWER -> - advance s; - let right = parse_add_expr s in - Operation (left, Less_than, right) - | Lexer.GREATER_EQUAL -> - advance s; - let right = parse_add_expr s in - Operation (left, Greater_than_or_equal, right) - | Lexer.LOWER_EQUAL -> + | Lexer.EQUAL | Lexer.NOT_EQUAL | Lexer.GREATER | Lexer.LOWER + | Lexer.GREATER_EQUAL | Lexer.LOWER_EQUAL -> + let op = + match s.token with + | EQUAL -> Equal + | NOT_EQUAL -> Not_equal + | GREATER -> Greater_than + | LOWER -> Less_than + | GREATER_EQUAL -> Greater_than_or_equal + | _ -> Less_than_or_equal + in advance s; let right = parse_add_expr s in - Operation (left, Less_than_or_equal, right) + Operation (left, op, right) | _ -> left and parse_add_expr s = @@ -281,14 +268,11 @@ and parse_add_expr s = and parse_add_right s left = match peek s with - | Lexer.ADD -> - advance s; - let right = parse_mul_expr s in - parse_add_right s (Operation (left, Add, right)) - | Lexer.SUB -> + | Lexer.ADD | Lexer.SUB -> + let op = match s.token with ADD -> Add | _ -> Subtract in advance s; let right = parse_mul_expr s in - parse_add_right s (Operation (left, Subtract, right)) + parse_add_right s (Operation (left, op, right)) | _ -> left and parse_mul_expr s = @@ -297,18 +281,13 @@ and parse_mul_expr s = and parse_mul_right s left = match peek s with - | Lexer.MULT -> - advance s; - let right = parse_term s in - parse_mul_right s (Operation (left, Multiply, right)) - | Lexer.DIV -> - advance s; - let right = parse_term s in - parse_mul_right s (Operation (left, Divide, right)) - | Lexer.MODULO -> + | Lexer.MULT | Lexer.DIV | Lexer.MODULO -> + let op = + match s.token with MULT -> Multiply | DIV -> Divide | _ -> Modulo + in advance s; let right = parse_term s in - parse_mul_right s (Operation (left, Modulo, right)) + parse_mul_right s (Operation (left, op, right)) | _ -> left and parse_item_expr s = parse_or_expr s @@ -322,12 +301,7 @@ and parse_postfix s e = | Lexer.DOT -> ( advance s; match peek s with - | Lexer.STRING k -> - advance s; - let opt = optional_question s in - let access = if opt then Optional (Key k) else Key k in - parse_postfix s (Pipe (e, access)) - | Lexer.IDENTIFIER k -> + | Lexer.STRING k | Lexer.IDENTIFIER k -> advance s; let opt = optional_question s in let access = if opt then Optional (Key k) else Key k in @@ -464,12 +438,8 @@ and parse_primary s = | Lexer.STRING str -> advance s; Literal (String str) - | Lexer.INT _ | Lexer.INT64 _ | Lexer.BIG_INT _ | Lexer.FLOAT _ -> - let lit = parse_number_literal s in - Literal lit - | Lexer.SUB -> - let lit = parse_number_literal s in - Literal lit + | Lexer.INT _ | Lexer.INT64 _ | Lexer.BIG_INT _ | Lexer.FLOAT _ | Lexer.SUB -> + Literal (parse_number_literal s) | Lexer.BOOL b -> advance s; Literal (Bool b) @@ -479,8 +449,8 @@ and parse_primary s = | Lexer.VARIABLE var -> advance s; Variable var - | Lexer.INTERP_START -> parse_interpolated_string s - | Lexer.TEMPLATE_START -> parse_template_literal s + | Lexer.INTERP initial_text -> parse_interpolated_string s initial_text + | Lexer.TEMPLATE initial_text -> parse_template_literal s initial_text | Lexer.RANGE -> parse_range s | Lexer.FLATTEN -> parse_flatten s | Lexer.REDUCE -> parse_reduce s @@ -491,18 +461,12 @@ and parse_primary s = | Lexer.OPEN_BRACKET -> parse_array_construction s | Lexer.OPEN_BRACE -> parse_object_construction s | Lexer.OPEN_PARENT -> parse_paren s - | _ -> - error s - (Printf.sprintf "unexpected token: %s" (Lexer.show_token (peek s))) + | _ -> error s "unexpected token" and parse_dot s = advance s; match peek s with - | Lexer.STRING k -> - advance s; - let opt = optional_question s in - if opt then Optional (Key k) else Key k - | Lexer.IDENTIFIER k -> + | Lexer.STRING k | Lexer.IDENTIFIER k -> advance s; let opt = optional_question s in if opt then Optional (Key k) else Key k @@ -551,13 +515,7 @@ and parse_reduce s = advance s; let expr = parse_sequence_expr s in expect s Lexer.AS; - let var = - match peek s with - | Lexer.VARIABLE v -> - advance s; - v - | _ -> error s "expected variable after 'as'" - in + let var = expect_variable s in expect s Lexer.OPEN_PARENT; let init = parse_sequence_expr s in expect s Lexer.SEMICOLON; @@ -569,13 +527,7 @@ and parse_foreach s = advance s; let expr = parse_sequence_expr s in expect s Lexer.AS; - let var = - match peek s with - | Lexer.VARIABLE v -> - advance s; - v - | _ -> error s "expected variable after 'as'" - in + let var = expect_variable s in expect s Lexer.OPEN_PARENT; let init = parse_sequence_expr s in expect s Lexer.SEMICOLON; @@ -617,58 +569,52 @@ and parse_elifs s = (cond, branch) :: parse_elifs s | _ -> [] -and parse_function_call s name = - let fn_start = s.start_pos in - advance s; +and parse_call_rest s fn_start name arg1 = match peek s with - | Lexer.CLOSE_PARENT -> + | Lexer.SEMICOLON -> ( advance s; - let opt = optional_question s in - let raise_err err = - raise (Query_error.Parse_error (err, fn_start, s.end_pos)) - in - let ast = - if Language.can_default_to_identity name then - match Language.map_unary_fn name Identity with - | Ok a -> a - | Error err -> raise_err err - else raise_err (Language.error_for_missing_arg name) - in - wrap_optional opt ast - | _ -> ( - let arg1 = parse_sequence_expr s in + let arg2 = parse_sequence_expr s in match peek s with | Lexer.SEMICOLON -> ( advance s; - let arg2 = parse_sequence_expr s in - match peek s with - | Lexer.SEMICOLON -> - advance s; - let arg3 = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - let opt = optional_question s in - let ast = - match name with - | "fma" -> Fma (arg1, arg2, arg3) - | _ -> Apply (name, [ arg1; arg2; arg3 ]) - in - wrap_optional opt ast - | Lexer.CLOSE_PARENT -> - advance s; - let opt = optional_question s in - let s_proxy = { s with start_pos = fn_start } in - let ast = - apply_fn_result s_proxy (Language.map_binary_fn name arg1 arg2) - in - wrap_optional opt ast - | _ -> error s "expected ';' or ')' in function call") + let arg3 = parse_sequence_expr s in + expect s Lexer.CLOSE_PARENT; + match name with + | "fma" -> Fma (arg1, arg2, arg3) + | _ -> Apply (name, [ arg1; arg2; arg3 ])) | Lexer.CLOSE_PARENT -> advance s; - let opt = optional_question s in - let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_unary_fn name arg1) in - wrap_optional opt ast + apply_fn_result + { s with start_pos = fn_start } + (Language.map_binary_fn name arg1 arg2) | _ -> error s "expected ';' or ')' in function call") + | Lexer.CLOSE_PARENT -> + advance s; + apply_fn_result + { s with start_pos = fn_start } + (Language.map_unary_fn name arg1) + | _ -> error s "expected ';' or ')' in function call" + +and parse_function_call s name = + let fn_start = s.start_pos in + advance s; + let ast = + match peek s with + | Lexer.CLOSE_PARENT -> + advance s; + let raise_err err = + raise (Query_error.Parse_error (err, fn_start, s.end_pos)) + in + if Language.can_default_to_identity name then + match Language.map_unary_fn name Identity with + | Ok a -> a + | Error err -> raise_err err + else raise_err (Language.error_for_missing_arg name) + | _ -> + let arg1 = parse_sequence_expr s in + parse_call_rest s fn_start name arg1 + in + wrap_optional (optional_question s) ast and parse_identifier s name = let fn_start = s.start_pos in @@ -677,50 +623,17 @@ and parse_identifier s name = | Lexer.QUESTION_MARK -> ( advance s; match peek s with - | Lexer.OPEN_PARENT -> ( + | Lexer.OPEN_PARENT -> advance s; let arg1 = parse_sequence_expr s in - match peek s with - | Lexer.SEMICOLON -> ( - advance s; - let arg2 = parse_sequence_expr s in - match peek s with - | Lexer.SEMICOLON -> - advance s; - let arg3 = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - let ast = - match name with - | "fma" -> Fma (arg1, arg2, arg3) - | _ -> Apply (name, [ arg1; arg2; arg3 ]) - in - Optional ast - | Lexer.CLOSE_PARENT -> - advance s; - let s_proxy = { s with start_pos = fn_start } in - let ast = - apply_fn_result s_proxy - (Language.map_binary_fn name arg1 arg2) - in - Optional ast - | _ -> error s "expected ';' or ')' in optional function call") - | Lexer.CLOSE_PARENT -> - advance s; - let s_proxy = { s with start_pos = fn_start } in - let ast = - apply_fn_result s_proxy (Language.map_unary_fn name arg1) - in - Optional ast - | _ -> error s "expected ';' or ')' in optional function call") + Optional (parse_call_rest s fn_start name arg1) | _ -> let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_nullary_fn name) in - Optional ast) + Optional (apply_fn_result s_proxy (Language.map_nullary_fn name))) | _ -> let s_proxy = { s with start_pos = fn_start } in let ast = apply_fn_result s_proxy (Language.map_nullary_fn name) in - let opt = optional_question s in - wrap_optional opt ast + wrap_optional (optional_question s) ast and parse_array_construction s = advance s; @@ -765,15 +678,7 @@ and parse_key_value s = expect s Lexer.COLON; let value = parse_term s in (key_expr, Some value) - | Lexer.IDENTIFIER key -> ( - advance s; - match peek s with - | Lexer.COLON -> - advance s; - let value = parse_term s in - (Literal (String key), Some value) - | _ -> (Literal (String key), None)) - | Lexer.STRING key -> ( + | Lexer.IDENTIFIER key | Lexer.STRING key -> ( advance s; match peek s with | Lexer.COLON -> @@ -789,135 +694,67 @@ and parse_paren s = match peek s with | Lexer.AS -> advance s; - let var = - match peek s with - | Lexer.VARIABLE v -> - advance s; - v - | _ -> error s "expected variable after 'as'" - in + let var = expect_variable s in expect s Lexer.PIPE; let body = parse_sequence_expr s in expect s Lexer.CLOSE_PARENT; As (e, var, body) | Lexer.CLOSE_PARENT -> advance s; - let opt = optional_question s in - wrap_optional opt e + wrap_optional (optional_question s) e | _ -> error s "expected ')' or 'as'" -and parse_interpolated_string s = +and parse_interpolated_string s initial_text = advance s; - let parts = parse_interp_body s in - match parts with - | [] -> Literal (String "") - | [ single ] -> single - | first :: rest -> - List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest - -and parse_interp_body s = - match peek s with - | Lexer.INTERP_END -> - advance s; - [] - | Lexer.INTERP_TEXT text -> ( - advance s; - match peek s with - | Lexer.INTERP_END -> - advance s; - [ Literal (String text) ] - | Lexer.INTERP_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_interp_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected interpolation expression or end of string") - | Lexer.INTERP_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_interp_after_expr s in - Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected string interpolation content" - -and parse_interp_after_expr s = - match peek s with - | Lexer.INTERP_END -> - advance s; - [] - | Lexer.INTERP_TEXT text -> ( - advance s; - match peek s with - | Lexer.INTERP_END -> - advance s; - [ Literal (String text) ] - | Lexer.INTERP_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_interp_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected interpolation expression or end of string") - | Lexer.INTERP_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_interp_after_expr s in - Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected string interpolation content" + let rec loop acc = + let e = parse_sequence_expr s in + if s.token <> Lexer.CLOSE_PARENT then + error s "expected ')' to close string interpolation"; + let acc = Pipe (e, Fn0 To_string) :: acc in + match Lexer.tokenize_string s.buf with + | Ok (End text) -> + advance s; + let acc = if text = "" then acc else Literal (String text) :: acc in + concat_parts (List.rev acc) + | Ok (Interp text) -> + advance s; + let acc = if text = "" then acc else Literal (String text) :: acc in + loop acc + | Error msg -> error s msg + in + let acc = + if initial_text = "" then [] else [ Literal (String initial_text) ] + in + loop acc -and parse_template_literal s = +and parse_template_literal s initial_text = advance s; - let parts = parse_template_body s in - match parts with - | [] -> Literal (String "") - | [ single ] -> single - | first :: rest -> - List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest - -and parse_template_body s = - match peek s with - | Lexer.TEMPLATE_END -> - advance s; - [] - | Lexer.TEMPLATE_TEXT text -> ( - advance s; - match peek s with - | Lexer.TEMPLATE_END -> - advance s; - [ Literal (String text) ] - | Lexer.TEMPLATE_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_template_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected template expression or end of template") - | Lexer.TEMPLATE_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_template_after_expr s in - Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected template literal content" - -and parse_template_after_expr s = - match peek s with - | Lexer.TEMPLATE_END -> - advance s; - [] - | Lexer.TEMPLATE_TEXT text -> ( - advance s; - match peek s with - | Lexer.TEMPLATE_END -> - advance s; - [ Literal (String text) ] - | Lexer.TEMPLATE_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_template_after_expr s in - Literal (String text) :: Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected template expression or end of template") - | Lexer.TEMPLATE_EXPR_START -> - advance s; - let e = parse_sequence_expr s in - let rest = parse_template_after_expr s in - Pipe (e, Fn0 To_string) :: rest - | _ -> error s "expected template literal content" + let rec loop acc = + let e = parse_sequence_expr s in + if s.token <> Lexer.CLOSE_BRACE then + error s "expected '}' to close template expression"; + let acc = Pipe (e, Fn0 To_string) :: acc in + match Lexer.tokenize_template s.buf with + | Ok (End text) -> + advance s; + let acc = if text = "" then acc else Literal (String text) :: acc in + concat_parts (List.rev acc) + | Ok (Interp text) -> + advance s; + let acc = if text = "" then acc else Literal (String text) :: acc in + loop acc + | Error msg -> error s msg + in + let acc = + if initial_text = "" then [] else [ Literal (String initial_text) ] + in + loop acc -let program buf = parse_program (make_stream buf) +let program buf = + parse_program + { + buf; + token = Lexer.EOF; + start_pos = Lexing.dummy_pos; + end_pos = Lexing.dummy_pos; + } From 0493b896ba18eb587f5e6a52e69f509faad6e1a5 Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Tue, 10 Feb 2026 11:48:02 +0000 Subject: [PATCH 05/12] refactor: simplify parser --- source/Parser.ml | 1155 +++++++++++++++++++++++----------------------- 1 file changed, 571 insertions(+), 584 deletions(-) diff --git a/source/Parser.ml b/source/Parser.ml index c29250d..11b3331 100644 --- a/source/Parser.ml +++ b/source/Parser.ml @@ -7,70 +7,67 @@ type stream = { mutable end_pos : Lexing.position; } -let advance s = - let start, _ = Sedlexing.lexing_positions s.buf in - let tok = - match Lexer.tokenize s.buf with - | Ok t -> t - | Error e -> - let _, stop = Sedlexing.lexing_positions s.buf in - let err = - Query_error.lexer_error ~message:e ~input:"" ~start_pos:start.pos_cnum +let advance stream = + let start, _ = Sedlexing.lexing_positions stream.buf in + let token = + match Lexer.tokenize stream.buf with + | Ok token -> token + | Error message -> + let _, stop = Sedlexing.lexing_positions stream.buf in + let error = + Query_error.lexer_error ~message ~input:"" ~start_pos:start.pos_cnum ~end_pos:stop.pos_cnum in - raise (Query_error.Parse_error (err, start, stop)) + Query_error.raise error start stop in - let _, stop = Sedlexing.lexing_positions s.buf in - s.token <- tok; - s.start_pos <- start; - s.end_pos <- stop + let _, stop = Sedlexing.lexing_positions stream.buf in + stream.token <- token; + stream.start_pos <- start; + stream.end_pos <- stop -let peek s = s.token +let peek stream = stream.token -let expect s expected = - let tok = s.token in - if tok = expected then advance s +let expect stream expected = + let token = stream.token in + if token = expected then advance stream else - let msg = + let message = Printf.sprintf "expected %s, got %s" (Lexer.humanize expected) - (Lexer.humanize tok) + (Lexer.humanize token) in - let err = - Query_error.parse_error ~message:msg ~input:"" - ~start_pos:s.start_pos.pos_cnum ~end_pos:s.end_pos.pos_cnum + let error = + Query_error.parse_error ~message ~input:"" + ~start_pos:stream.start_pos.pos_cnum ~end_pos:stream.end_pos.pos_cnum in - raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) + Query_error.raise error stream.start_pos stream.end_pos -let error s msg = - let msg = Printf.sprintf "%s, got %s" msg (Lexer.humanize s.token) in - let err = - Query_error.parse_error ~message:msg ~input:"" - ~start_pos:s.start_pos.pos_cnum ~end_pos:s.end_pos.pos_cnum +let error stream message = + let message = + Printf.sprintf "%s, got %s" message (Lexer.humanize stream.token) in - raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) - -let optional_question s = - match peek s with - | Lexer.QUESTION_MARK -> - advance s; - true - | _ -> false + let error = + Query_error.parse_error ~message ~input:"" + ~start_pos:stream.start_pos.pos_cnum ~end_pos:stream.end_pos.pos_cnum + in + Query_error.raise error stream.start_pos stream.end_pos -let raise_fn_error s err = - raise (Query_error.Parse_error (err, s.start_pos, s.end_pos)) +let optional_question stream expr = + match (peek stream : Lexer.token) with + | QUESTION_MARK -> + advance stream; + Optional expr + | _ -> expr -let apply_fn_result s = function +let unwrap_or_raise stream = function | Ok ast -> ast - | Error err -> raise_fn_error s err + | Error error -> Query_error.raise error stream.start_pos stream.end_pos -let wrap_optional opt expr = if opt then Optional expr else expr - -let expect_variable s = - match peek s with - | Lexer.VARIABLE v -> - advance s; - v - | _ -> error s "expected variable after 'as'" +let expect_variable stream = + match (peek stream : Lexer.token) with + | VARIABLE name -> + advance stream; + name + | _ -> error stream "expected variable after 'as'" let concat_parts = function | [] -> Literal (String "") @@ -78,178 +75,176 @@ let concat_parts = function | first :: rest -> List.fold_left (fun acc part -> Operation (acc, Add, part)) first rest -let rec parse_program s = - advance s; - match peek s with - | Lexer.EOF -> Identity +let rec parse_program stream = + advance stream; + match (peek stream : Lexer.token) with + | EOF -> Identity | _ -> - let e = parse_sequence_expr s in - expect s Lexer.EOF; - e + let expr = parse_sequence_expr stream in + expect stream EOF; + expr -and parse_sequence_expr s = parse_fn_or_expr s +and parse_sequence_expr stream = parse_fn_or_expr stream -and parse_fn_or_expr s = - match peek s with - | Lexer.FN -> parse_fn_def s - | Lexer.TRY -> parse_try s - | _ -> parse_pipe_expr s +and parse_fn_or_expr stream = + match (peek stream : Lexer.token) with + | FN -> parse_fn_def stream + | TRY -> parse_try stream + | _ -> parse_pipe_expr stream -and parse_fn_def s = - advance s; +and parse_fn_def stream = + advance stream; let name, params = - match peek s with - | Lexer.IDENTIFIER name -> - advance s; + match (peek stream : Lexer.token) with + | IDENTIFIER name -> + advance stream; let params = - match peek s with - | Lexer.OPEN_PARENT -> - advance s; - let ps = parse_fn_params s in - expect s Lexer.CLOSE_PARENT; - ps + match (peek stream : Lexer.token) with + | OPEN_PARENT -> + advance stream; + let params = parse_fn_params stream in + expect stream CLOSE_PARENT; + params | _ -> [] in (name, params) - | Lexer.FUNCTION name -> - advance s; - let params = parse_fn_params s in - expect s Lexer.CLOSE_PARENT; + | FUNCTION name -> + advance stream; + let params = parse_fn_params stream in + expect stream CLOSE_PARENT; (name, params) - | _ -> error s "expected function name after 'fn'" + | _ -> error stream "expected function name after 'fn'" in - expect s Lexer.COLON; - let body = parse_sequence_expr s in - expect s Lexer.SEMICOLON; - let rest = parse_sequence_expr s in + expect stream COLON; + let body = parse_sequence_expr stream in + expect stream SEMICOLON; + let rest = parse_sequence_expr stream in Pipe (Fn (name, params, body), rest) -and parse_fn_params s = - match peek s with - | Lexer.CLOSE_PARENT -> [] +and parse_fn_params stream = + match (peek stream : Lexer.token) with + | CLOSE_PARENT -> [] | _ -> - let p = parse_fn_param s in + let param = parse_fn_param stream in let rec loop acc = - match peek s with - | Lexer.SEMICOLON -> ( - advance s; - match peek s with - | Lexer.CLOSE_PARENT -> List.rev acc + match (peek stream : Lexer.token) with + | SEMICOLON -> ( + advance stream; + match (peek stream : Lexer.token) with + | CLOSE_PARENT -> List.rev acc | _ -> - let p = parse_fn_param s in - loop (p :: acc)) + let param = parse_fn_param stream in + loop (param :: acc)) | _ -> List.rev acc in - loop [ p ] + loop [ param ] -and parse_fn_param s = - match peek s with - | Lexer.IDENTIFIER name -> - advance s; +and parse_fn_param stream = + match (peek stream : Lexer.token) with + | IDENTIFIER name -> + advance stream; name - | Lexer.VARIABLE name -> - advance s; + | VARIABLE name -> + advance stream; "$" ^ name - | _ -> error s "expected parameter name" - -and parse_try s = - advance s; - let body = parse_sequence_expr s in - match peek s with - | Lexer.CATCH -> ( - advance s; - let handler = parse_item_expr s in - match peek s with - | Lexer.FINALLY -> - advance s; - let cleanup = parse_item_expr s in + | _ -> error stream "expected parameter name" + +and parse_try stream = + advance stream; + let body = parse_sequence_expr stream in + match (peek stream : Lexer.token) with + | CATCH -> ( + advance stream; + let handler = parse_item_expr stream in + match (peek stream : Lexer.token) with + | FINALLY -> + advance stream; + let cleanup = parse_item_expr stream in Try (body, Some handler, Some cleanup) | _ -> Try (body, Some handler, None)) | _ -> body -and parse_pipe_expr s = - let left = parse_comma_expr s in - parse_pipe_right s left - -and parse_pipe_right s left = - match peek s with - | Lexer.PIPE -> - advance s; - let right = parse_fn_or_expr s in - parse_pipe_right s (Pipe (left, right)) - | Lexer.UPDATE_ASSIGN -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Update (left, right)) - | Lexer.ASSIGN -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Assign (left, right)) - | Lexer.PLUS_ASSIGN | Lexer.MINUS_ASSIGN | Lexer.MULT_ASSIGN - | Lexer.DIV_ASSIGN -> +and parse_pipe_expr stream = + let left = parse_comma_expr stream in + parse_pipe_right stream left + +and parse_pipe_right stream left = + match (peek stream : Lexer.token) with + | PIPE -> + advance stream; + let right = parse_fn_or_expr stream in + parse_pipe_right stream (Pipe (left, right)) + | UPDATE_ASSIGN -> + advance stream; + let right = parse_item_expr stream in + parse_pipe_right stream (Update (left, right)) + | ASSIGN -> + advance stream; + let right = parse_item_expr stream in + parse_pipe_right stream (Assign (left, right)) + | PLUS_ASSIGN | MINUS_ASSIGN | MULT_ASSIGN | DIV_ASSIGN -> let op = - match s.token with + match stream.token with | PLUS_ASSIGN -> Add | MINUS_ASSIGN -> Subtract | MULT_ASSIGN -> Multiply | _ -> Divide in - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Update (left, Operation (Identity, op, right))) - | Lexer.ALT_ASSIGN -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Update (left, Alternative (Identity, right))) - | Lexer.ALTERNATIVE -> - advance s; - let right = parse_item_expr s in - parse_pipe_right s (Alternative (left, right)) + advance stream; + let right = parse_item_expr stream in + parse_pipe_right stream (Update (left, Operation (Identity, op, right))) + | ALT_ASSIGN -> + advance stream; + let right = parse_item_expr stream in + parse_pipe_right stream (Update (left, Alternative (Identity, right))) + | ALTERNATIVE -> + advance stream; + let right = parse_item_expr stream in + parse_pipe_right stream (Alternative (left, right)) | _ -> left -and parse_comma_expr s = - let left = parse_or_expr s in - parse_comma_right s left +and parse_comma_expr stream = + let left = parse_or_expr stream in + parse_comma_right stream left -and parse_comma_right s left = - match peek s with - | Lexer.COMMA -> - advance s; - let right = parse_or_expr s in - parse_comma_right s (Comma (left, right)) +and parse_comma_right stream left = + match (peek stream : Lexer.token) with + | COMMA -> + advance stream; + let right = parse_or_expr stream in + parse_comma_right stream (Comma (left, right)) | _ -> left -and parse_or_expr s = - let left = parse_and_expr s in - parse_or_right s left +and parse_or_expr stream = + let left = parse_and_expr stream in + parse_or_right stream left -and parse_or_right s left = - match peek s with - | Lexer.OR -> - advance s; - let right = parse_and_expr s in - parse_or_right s (Operation (left, Or, right)) +and parse_or_right stream left = + match (peek stream : Lexer.token) with + | OR -> + advance stream; + let right = parse_and_expr stream in + parse_or_right stream (Operation (left, Or, right)) | _ -> left -and parse_and_expr s = - let left = parse_comparison_expr s in - parse_and_right s left +and parse_and_expr stream = + let left = parse_comparison_expr stream in + parse_and_right stream left -and parse_and_right s left = - match peek s with - | Lexer.AND -> - advance s; - let right = parse_comparison_expr s in - parse_and_right s (Operation (left, And, right)) +and parse_and_right stream left = + match (peek stream : Lexer.token) with + | AND -> + advance stream; + let right = parse_comparison_expr stream in + parse_and_right stream (Operation (left, And, right)) | _ -> left -and parse_comparison_expr s = - let left = parse_add_expr s in - match peek s with - | Lexer.EQUAL | Lexer.NOT_EQUAL | Lexer.GREATER | Lexer.LOWER - | Lexer.GREATER_EQUAL | Lexer.LOWER_EQUAL -> +and parse_comparison_expr stream = + let left = parse_add_expr stream in + match (peek stream : Lexer.token) with + | EQUAL | NOT_EQUAL | GREATER | LOWER | GREATER_EQUAL | LOWER_EQUAL -> let op = - match s.token with + match stream.token with | EQUAL -> Equal | NOT_EQUAL -> Not_equal | GREATER -> Greater_than @@ -257,493 +252,485 @@ and parse_comparison_expr s = | GREATER_EQUAL -> Greater_than_or_equal | _ -> Less_than_or_equal in - advance s; - let right = parse_add_expr s in + advance stream; + let right = parse_add_expr stream in Operation (left, op, right) | _ -> left -and parse_add_expr s = - let left = parse_mul_expr s in - parse_add_right s left - -and parse_add_right s left = - match peek s with - | Lexer.ADD | Lexer.SUB -> - let op = match s.token with ADD -> Add | _ -> Subtract in - advance s; - let right = parse_mul_expr s in - parse_add_right s (Operation (left, op, right)) +and parse_add_expr stream = + let left = parse_mul_expr stream in + parse_add_right stream left + +and parse_add_right stream left = + match (peek stream : Lexer.token) with + | ADD | SUB -> + let op = match stream.token with ADD -> Add | _ -> Subtract in + advance stream; + let right = parse_mul_expr stream in + parse_add_right stream (Operation (left, op, right)) | _ -> left -and parse_mul_expr s = - let left = parse_term s in - parse_mul_right s left +and parse_mul_expr stream = + let left = parse_term stream in + parse_mul_right stream left -and parse_mul_right s left = - match peek s with - | Lexer.MULT | Lexer.DIV | Lexer.MODULO -> +and parse_mul_right stream left = + match (peek stream : Lexer.token) with + | MULT | DIV | MODULO -> let op = - match s.token with MULT -> Multiply | DIV -> Divide | _ -> Modulo + match stream.token with MULT -> Multiply | DIV -> Divide | _ -> Modulo in - advance s; - let right = parse_term s in - parse_mul_right s (Operation (left, op, right)) + advance stream; + let right = parse_term stream in + parse_mul_right stream (Operation (left, op, right)) | _ -> left -and parse_item_expr s = parse_or_expr s - -and parse_term s = - let e = parse_primary s in - parse_postfix s e - -and parse_postfix s e = - match peek s with - | Lexer.DOT -> ( - advance s; - match peek s with - | Lexer.STRING k | Lexer.IDENTIFIER k -> - advance s; - let opt = optional_question s in - let access = if opt then Optional (Key k) else Key k in - parse_postfix s (Pipe (e, access)) - | _ -> parse_postfix s (Pipe (e, Identity))) - | Lexer.OPEN_BRACKET -> - let result = parse_bracket_access s e in - parse_postfix s result - | _ -> e - -and parse_bracket_access s e = - advance s; - match peek s with - | Lexer.CLOSE_BRACKET -> - advance s; - let opt = optional_question s in - let idx = Index [] in - if opt then Pipe (e, Optional idx) else Pipe (e, idx) - | Lexer.STRING key -> - advance s; - expect s Lexer.CLOSE_BRACKET; - let opt = optional_question s in - if opt then Pipe (e, Optional (Key key)) else Pipe (e, Key key) - | Lexer.VARIABLE var -> - advance s; - expect s Lexer.CLOSE_BRACKET; - Pipe (e, Dynamic_access (Variable var)) - | Lexer.COLON -> - advance s; - let end_ = parse_index_number s in - expect s Lexer.CLOSE_BRACKET; - Pipe (e, Slice (None, Some end_)) +and parse_item_expr stream = parse_or_expr stream + +and parse_term stream = + let expr = parse_primary stream in + parse_postfix stream expr + +and parse_postfix stream expr = + match (peek stream : Lexer.token) with + | DOT -> ( + advance stream; + match (peek stream : Lexer.token) with + | STRING key | IDENTIFIER key -> + advance stream; + let access = optional_question stream (Key key) in + parse_postfix stream (Pipe (expr, access)) + | _ -> parse_postfix stream (Pipe (expr, Identity))) + | OPEN_BRACKET -> + let result = parse_bracket_access stream expr in + parse_postfix stream result + | _ -> expr + +and parse_bracket_access stream expr = + advance stream; + match (peek stream : Lexer.token) with + | CLOSE_BRACKET -> + advance stream; + Pipe (expr, optional_question stream (Index [])) + | STRING key -> + advance stream; + expect stream CLOSE_BRACKET; + Pipe (expr, optional_question stream (Key key)) + | VARIABLE var -> + advance stream; + expect stream CLOSE_BRACKET; + Pipe (expr, Dynamic_access (Variable var)) + | COLON -> + advance stream; + let end_ = parse_index_number stream in + expect stream CLOSE_BRACKET; + Pipe (expr, Slice (None, Some end_)) | _ -> ( - let first_num = parse_index_number s in - match peek s with - | Lexer.COLON -> ( - advance s; - match peek s with - | Lexer.CLOSE_BRACKET -> - advance s; - Pipe (e, Slice (Some first_num, None)) + let first_num = parse_index_number stream in + match (peek stream : Lexer.token) with + | COLON -> ( + advance stream; + match (peek stream : Lexer.token) with + | CLOSE_BRACKET -> + advance stream; + Pipe (expr, Slice (Some first_num, None)) | _ -> - let end_ = parse_index_number s in - expect s Lexer.CLOSE_BRACKET; - Pipe (e, Slice (Some first_num, Some end_))) - | Lexer.COMMA -> - let indices = parse_remaining_indices s [ first_num ] in - expect s Lexer.CLOSE_BRACKET; - let opt = optional_question s in - let idx_expr = Index indices in - if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) - | Lexer.CLOSE_BRACKET -> - advance s; - let opt = optional_question s in - let idx_expr = Index [ first_num ] in - if opt then Pipe (e, Optional idx_expr) else Pipe (e, idx_expr) - | _ -> error s "expected ':', ',' or ']' in bracket expression") - -and parse_remaining_indices s acc = - match peek s with - | Lexer.COMMA -> - advance s; - let n = parse_index_number s in - parse_remaining_indices s (acc @ [ n ]) + let end_ = parse_index_number stream in + expect stream CLOSE_BRACKET; + Pipe (expr, Slice (Some first_num, Some end_))) + | COMMA -> + let indices = parse_remaining_indices stream [ first_num ] in + expect stream CLOSE_BRACKET; + Pipe (expr, optional_question stream (Index indices)) + | CLOSE_BRACKET -> + advance stream; + Pipe (expr, optional_question stream (Index [ first_num ])) + | _ -> error stream "expected ':', ',' or ']' in bracket expression") + +and parse_remaining_indices stream acc = + match (peek stream : Lexer.token) with + | COMMA -> + advance stream; + let number = parse_index_number stream in + parse_remaining_indices stream (acc @ [ number ]) | _ -> acc -and parse_index_number s = - match peek s with - | Lexer.SUB -> ( - advance s; - match peek s with - | Lexer.INT n -> - advance s; - -n - | Lexer.INT64 n -> - advance s; - Int64.to_int (Int64.neg n) - | Lexer.BIG_INT n -> - advance s; - Z.to_int (Z.neg n) - | Lexer.FLOAT n -> - advance s; - int_of_float (-.n) - | _ -> error s "expected number after '-'") - | Lexer.INT n -> - advance s; - n - | Lexer.INT64 n -> - advance s; - Int64.to_int n - | Lexer.BIG_INT n -> - advance s; - Z.to_int n - | Lexer.FLOAT n -> - advance s; - int_of_float n - | _ -> error s "expected index number" - -and parse_number_literal s = - match peek s with - | Lexer.SUB -> ( - advance s; - match peek s with - | Lexer.INT n -> - advance s; - Int (-n) - | Lexer.INT64 n -> - advance s; - Int64 (Int64.neg n) - | Lexer.BIG_INT n -> - advance s; - Big_int (Z.neg n) - | Lexer.FLOAT n -> - advance s; - Float (-.n) - | _ -> error s "expected number after '-'") - | Lexer.INT n -> - advance s; - Int n - | Lexer.INT64 n -> - advance s; - Int64 n - | Lexer.BIG_INT n -> - advance s; - Big_int n - | Lexer.FLOAT n -> - advance s; - Float n - | _ -> error s "expected number" - -and parse_primary s = - match peek s with - | Lexer.DOT -> parse_dot s - | Lexer.STRING str -> - advance s; - Literal (String str) - | Lexer.INT _ | Lexer.INT64 _ | Lexer.BIG_INT _ | Lexer.FLOAT _ | Lexer.SUB -> - Literal (parse_number_literal s) - | Lexer.BOOL b -> - advance s; - Literal (Bool b) - | Lexer.NULL -> - advance s; +and parse_index_number stream = + match (peek stream : Lexer.token) with + | SUB -> ( + advance stream; + match (peek stream : Lexer.token) with + | INT number -> + advance stream; + -number + | INT64 number -> + advance stream; + Int64.to_int (Int64.neg number) + | BIG_INT number -> + advance stream; + Z.to_int (Z.neg number) + | FLOAT number -> + advance stream; + int_of_float (-.number) + | _ -> error stream "expected number after '-'") + | INT number -> + advance stream; + number + | INT64 number -> + advance stream; + Int64.to_int number + | BIG_INT number -> + advance stream; + Z.to_int number + | FLOAT number -> + advance stream; + int_of_float number + | _ -> error stream "expected index number" + +and parse_number_literal stream = + match (peek stream : Lexer.token) with + | SUB -> ( + advance stream; + match (peek stream : Lexer.token) with + | INT number -> + advance stream; + Int (-number) + | INT64 number -> + advance stream; + Int64 (Int64.neg number) + | BIG_INT number -> + advance stream; + Big_int (Z.neg number) + | FLOAT number -> + advance stream; + Float (-.number) + | _ -> error stream "expected number after '-'") + | INT number -> + advance stream; + Int number + | INT64 number -> + advance stream; + Int64 number + | BIG_INT number -> + advance stream; + Big_int number + | FLOAT number -> + advance stream; + Float number + | _ -> error stream "expected number" + +and parse_primary stream = + match (peek stream : Lexer.token) with + | DOT -> parse_dot stream + | STRING text -> + advance stream; + Literal (String text) + | INT _ | INT64 _ | BIG_INT _ | FLOAT _ | SUB -> + Literal (parse_number_literal stream) + | BOOL value -> + advance stream; + Literal (Bool value) + | NULL -> + advance stream; Literal Null - | Lexer.VARIABLE var -> - advance s; + | VARIABLE var -> + advance stream; Variable var - | Lexer.INTERP initial_text -> parse_interpolated_string s initial_text - | Lexer.TEMPLATE initial_text -> parse_template_literal s initial_text - | Lexer.RANGE -> parse_range s - | Lexer.FLATTEN -> parse_flatten s - | Lexer.REDUCE -> parse_reduce s - | Lexer.FOREACH -> parse_foreach s - | Lexer.IF -> parse_if s - | Lexer.FUNCTION name -> parse_function_call s name - | Lexer.IDENTIFIER name -> parse_identifier s name - | Lexer.OPEN_BRACKET -> parse_array_construction s - | Lexer.OPEN_BRACE -> parse_object_construction s - | Lexer.OPEN_PARENT -> parse_paren s - | _ -> error s "unexpected token" - -and parse_dot s = - advance s; - match peek s with - | Lexer.STRING k | Lexer.IDENTIFIER k -> - advance s; - let opt = optional_question s in - if opt then Optional (Key k) else Key k - | Lexer.OPEN_BRACKET -> parse_bracket_access s Identity + | INTERP initial_text -> parse_interpolated_string stream initial_text + | TEMPLATE initial_text -> parse_template_literal stream initial_text + | RANGE -> parse_range stream + | FLATTEN -> parse_flatten stream + | REDUCE -> parse_reduce stream + | FOREACH -> parse_foreach stream + | IF -> parse_if stream + | FUNCTION name -> parse_function_call stream name + | IDENTIFIER name -> parse_identifier stream name + | OPEN_BRACKET -> parse_array_construction stream + | OPEN_BRACE -> parse_object_construction stream + | OPEN_PARENT -> parse_paren stream + | _ -> error stream "unexpected token" + +and parse_dot stream = + advance stream; + match (peek stream : Lexer.token) with + | STRING key | IDENTIFIER key -> + advance stream; + optional_question stream (Key key) + | OPEN_BRACKET -> parse_bracket_access stream Identity | _ -> Identity -and parse_range s = - advance s; - expect s Lexer.OPEN_PARENT; - let from = parse_sequence_expr s in - match peek s with - | Lexer.CLOSE_PARENT -> - advance s; +and parse_range stream = + advance stream; + expect stream OPEN_PARENT; + let from = parse_sequence_expr stream in + match (peek stream : Lexer.token) with + | CLOSE_PARENT -> + advance stream; Range (from, None, None) - | Lexer.SEMICOLON -> ( - advance s; - let upto = parse_sequence_expr s in - match peek s with - | Lexer.CLOSE_PARENT -> - advance s; + | SEMICOLON -> ( + advance stream; + let upto = parse_sequence_expr stream in + match (peek stream : Lexer.token) with + | CLOSE_PARENT -> + advance stream; Range (from, Some upto, None) - | Lexer.SEMICOLON -> - advance s; - let step = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; + | SEMICOLON -> + advance stream; + let step = parse_sequence_expr stream in + expect stream CLOSE_PARENT; Range (from, Some upto, Some step) - | _ -> error s "expected ')' or ';' in range") - | _ -> error s "expected ')' or ';' in range" - -and parse_flatten s = - advance s; - match peek s with - | Lexer.OPEN_PARENT -> ( - advance s; - match peek s with - | Lexer.CLOSE_PARENT -> - advance s; + | _ -> error stream "expected ')' or ';' in range") + | _ -> error stream "expected ')' or ';' in range" + +and parse_flatten stream = + advance stream; + match (peek stream : Lexer.token) with + | OPEN_PARENT -> ( + advance stream; + match (peek stream : Lexer.token) with + | CLOSE_PARENT -> + advance stream; Fn0 Flatten | _ -> - let e = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - Fn1 (With_expr (Flatten_n, e))) + let expr = parse_sequence_expr stream in + expect stream CLOSE_PARENT; + Fn1 (With_expr (Flatten_n, expr))) | _ -> Fn0 Flatten -and parse_reduce s = - advance s; - let expr = parse_sequence_expr s in - expect s Lexer.AS; - let var = expect_variable s in - expect s Lexer.OPEN_PARENT; - let init = parse_sequence_expr s in - expect s Lexer.SEMICOLON; - let update = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; +and parse_reduce stream = + advance stream; + let expr = parse_sequence_expr stream in + expect stream AS; + let var = expect_variable stream in + expect stream OPEN_PARENT; + let init = parse_sequence_expr stream in + expect stream SEMICOLON; + let update = parse_sequence_expr stream in + expect stream CLOSE_PARENT; Reduce (expr, var, init, update) -and parse_foreach s = - advance s; - let expr = parse_sequence_expr s in - expect s Lexer.AS; - let var = expect_variable s in - expect s Lexer.OPEN_PARENT; - let init = parse_sequence_expr s in - expect s Lexer.SEMICOLON; - let update = parse_sequence_expr s in - match peek s with - | Lexer.SEMICOLON -> - advance s; - let extract = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; +and parse_foreach stream = + advance stream; + let expr = parse_sequence_expr stream in + expect stream AS; + let var = expect_variable stream in + expect stream OPEN_PARENT; + let init = parse_sequence_expr stream in + expect stream SEMICOLON; + let update = parse_sequence_expr stream in + match (peek stream : Lexer.token) with + | SEMICOLON -> + advance stream; + let extract = parse_sequence_expr stream in + expect stream CLOSE_PARENT; Foreach (expr, var, init, update, extract) - | Lexer.CLOSE_PARENT -> - advance s; + | CLOSE_PARENT -> + advance stream; Foreach (expr, var, init, update, Identity) - | _ -> error s "expected ';' or ')' in foreach" - -and parse_if s = - advance s; - let cond = parse_item_expr s in - expect s Lexer.THEN; - let then_branch = parse_sequence_expr s in - let elifs = parse_elifs s in - expect s Lexer.ELSE; - let else_branch = parse_sequence_expr s in - expect s Lexer.END; - let rec fold_elif elifs else_b = + | _ -> error stream "expected ';' or ')' in foreach" + +and parse_if stream = + advance stream; + let condition = parse_item_expr stream in + expect stream THEN; + let then_branch = parse_sequence_expr stream in + let elifs = parse_elifs stream in + expect stream ELSE; + let else_branch = parse_sequence_expr stream in + expect stream END; + let rec fold_elif elifs else_branch = match elifs with - | [] -> else_b - | (c, b) :: rest -> If_then_else (c, b, fold_elif rest else_b) + | [] -> else_branch + | (condition, branch) :: rest -> + If_then_else (condition, branch, fold_elif rest else_branch) in - If_then_else (cond, then_branch, fold_elif elifs else_branch) - -and parse_elifs s = - match peek s with - | Lexer.ELIF -> - advance s; - let cond = parse_item_expr s in - expect s Lexer.THEN; - let branch = parse_sequence_expr s in - (cond, branch) :: parse_elifs s + If_then_else (condition, then_branch, fold_elif elifs else_branch) + +and parse_elifs stream = + match (peek stream : Lexer.token) with + | ELIF -> + advance stream; + let condition = parse_item_expr stream in + expect stream THEN; + let branch = parse_sequence_expr stream in + (condition, branch) :: parse_elifs stream | _ -> [] -and parse_call_rest s fn_start name arg1 = - match peek s with - | Lexer.SEMICOLON -> ( - advance s; - let arg2 = parse_sequence_expr s in - match peek s with - | Lexer.SEMICOLON -> ( - advance s; - let arg3 = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; +and parse_call_rest stream fn_start name arg1 = + match (peek stream : Lexer.token) with + | SEMICOLON -> ( + advance stream; + let arg2 = parse_sequence_expr stream in + match (peek stream : Lexer.token) with + | SEMICOLON -> ( + advance stream; + let arg3 = parse_sequence_expr stream in + expect stream CLOSE_PARENT; match name with | "fma" -> Fma (arg1, arg2, arg3) | _ -> Apply (name, [ arg1; arg2; arg3 ])) - | Lexer.CLOSE_PARENT -> - advance s; - apply_fn_result - { s with start_pos = fn_start } + | CLOSE_PARENT -> + advance stream; + unwrap_or_raise + { stream with start_pos = fn_start } (Language.map_binary_fn name arg1 arg2) - | _ -> error s "expected ';' or ')' in function call") - | Lexer.CLOSE_PARENT -> - advance s; - apply_fn_result - { s with start_pos = fn_start } + | _ -> error stream "expected ';' or ')' in function call") + | CLOSE_PARENT -> + advance stream; + unwrap_or_raise + { stream with start_pos = fn_start } (Language.map_unary_fn name arg1) - | _ -> error s "expected ';' or ')' in function call" + | _ -> error stream "expected ';' or ')' in function call" -and parse_function_call s name = - let fn_start = s.start_pos in - advance s; +and parse_function_call stream name = + let fn_start = stream.start_pos in + advance stream; let ast = - match peek s with - | Lexer.CLOSE_PARENT -> - advance s; - let raise_err err = - raise (Query_error.Parse_error (err, fn_start, s.end_pos)) + match (peek stream : Lexer.token) with + | CLOSE_PARENT -> + advance stream; + let raise_error error = + Query_error.raise error fn_start stream.end_pos in if Language.can_default_to_identity name then match Language.map_unary_fn name Identity with - | Ok a -> a - | Error err -> raise_err err - else raise_err (Language.error_for_missing_arg name) + | Ok ast -> ast + | Error error -> raise_error error + else raise_error (Language.error_for_missing_arg name) | _ -> - let arg1 = parse_sequence_expr s in - parse_call_rest s fn_start name arg1 + let arg1 = parse_sequence_expr stream in + parse_call_rest stream fn_start name arg1 in - wrap_optional (optional_question s) ast - -and parse_identifier s name = - let fn_start = s.start_pos in - advance s; - match peek s with - | Lexer.QUESTION_MARK -> ( - advance s; - match peek s with - | Lexer.OPEN_PARENT -> - advance s; - let arg1 = parse_sequence_expr s in - Optional (parse_call_rest s fn_start name arg1) + optional_question stream ast + +and parse_identifier stream name = + let fn_start = stream.start_pos in + advance stream; + match (peek stream : Lexer.token) with + | QUESTION_MARK -> ( + advance stream; + match (peek stream : Lexer.token) with + | OPEN_PARENT -> + advance stream; + let arg1 = parse_sequence_expr stream in + Optional (parse_call_rest stream fn_start name arg1) | _ -> - let s_proxy = { s with start_pos = fn_start } in - Optional (apply_fn_result s_proxy (Language.map_nullary_fn name))) + let new_stream = { stream with start_pos = fn_start } in + Optional (unwrap_or_raise new_stream (Language.map_nullary_fn name))) | _ -> - let s_proxy = { s with start_pos = fn_start } in - let ast = apply_fn_result s_proxy (Language.map_nullary_fn name) in - wrap_optional (optional_question s) ast - -and parse_array_construction s = - advance s; - match peek s with - | Lexer.CLOSE_BRACKET -> - advance s; + let new_stream = { stream with start_pos = fn_start } in + let ast = unwrap_or_raise new_stream (Language.map_nullary_fn name) in + optional_question stream ast + +and parse_array_construction stream = + advance stream; + match (peek stream : Lexer.token) with + | CLOSE_BRACKET -> + advance stream; List None | _ -> - let e = parse_sequence_expr s in - expect s Lexer.CLOSE_BRACKET; - List (Some e) - -and parse_object_construction s = - advance s; - match peek s with - | Lexer.CLOSE_BRACE -> - advance s; + let expr = parse_sequence_expr stream in + expect stream CLOSE_BRACKET; + List (Some expr) + +and parse_object_construction stream = + advance stream; + match (peek stream : Lexer.token) with + | CLOSE_BRACE -> + advance stream; Object [] | _ -> - let pairs = parse_key_value_list s in - expect s Lexer.CLOSE_BRACE; + let pairs = parse_key_value_list stream in + expect stream CLOSE_BRACE; Object pairs -and parse_key_value_list s = - let pair = parse_key_value s in +and parse_key_value_list stream = + let pair = parse_key_value stream in let rec loop acc = - match peek s with - | Lexer.COMMA -> - advance s; - let pair = parse_key_value s in + match (peek stream : Lexer.token) with + | COMMA -> + advance stream; + let pair = parse_key_value stream in loop (pair :: acc) | _ -> List.rev acc in loop [ pair ] -and parse_key_value s = - match peek s with - | Lexer.OPEN_PARENT -> - advance s; - let key_expr = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - expect s Lexer.COLON; - let value = parse_term s in +and parse_key_value stream = + match (peek stream : Lexer.token) with + | OPEN_PARENT -> + advance stream; + let key_expr = parse_sequence_expr stream in + expect stream CLOSE_PARENT; + expect stream COLON; + let value = parse_term stream in (key_expr, Some value) - | Lexer.IDENTIFIER key | Lexer.STRING key -> ( - advance s; - match peek s with - | Lexer.COLON -> - advance s; - let value = parse_term s in + | IDENTIFIER key | STRING key -> ( + advance stream; + match (peek stream : Lexer.token) with + | COLON -> + advance stream; + let value = parse_term stream in (Literal (String key), Some value) | _ -> (Literal (String key), None)) - | _ -> error s "expected key in object construction" - -and parse_paren s = - advance s; - let e = parse_sequence_expr s in - match peek s with - | Lexer.AS -> - advance s; - let var = expect_variable s in - expect s Lexer.PIPE; - let body = parse_sequence_expr s in - expect s Lexer.CLOSE_PARENT; - As (e, var, body) - | Lexer.CLOSE_PARENT -> - advance s; - wrap_optional (optional_question s) e - | _ -> error s "expected ')' or 'as'" - -and parse_interpolated_string s initial_text = - advance s; + | _ -> error stream "expected key in object construction" + +and parse_paren stream = + advance stream; + let expr = parse_sequence_expr stream in + match (peek stream : Lexer.token) with + | AS -> + advance stream; + let var = expect_variable stream in + expect stream PIPE; + let body = parse_sequence_expr stream in + expect stream CLOSE_PARENT; + As (expr, var, body) + | CLOSE_PARENT -> + advance stream; + optional_question stream expr + | _ -> error stream "expected ')' or 'as'" + +and parse_interpolated_string stream initial_text = + advance stream; let rec loop acc = - let e = parse_sequence_expr s in - if s.token <> Lexer.CLOSE_PARENT then - error s "expected ')' to close string interpolation"; - let acc = Pipe (e, Fn0 To_string) :: acc in - match Lexer.tokenize_string s.buf with + let expr = parse_sequence_expr stream in + if stream.token <> CLOSE_PARENT then + error stream "expected ')' to close string interpolation"; + let acc = Pipe (expr, Fn0 To_string) :: acc in + match Lexer.tokenize_string stream.buf with | Ok (End text) -> - advance s; + advance stream; let acc = if text = "" then acc else Literal (String text) :: acc in concat_parts (List.rev acc) | Ok (Interp text) -> - advance s; + advance stream; let acc = if text = "" then acc else Literal (String text) :: acc in loop acc - | Error msg -> error s msg + | Error message -> error stream message in let acc = if initial_text = "" then [] else [ Literal (String initial_text) ] in loop acc -and parse_template_literal s initial_text = - advance s; +and parse_template_literal stream initial_text = + advance stream; let rec loop acc = - let e = parse_sequence_expr s in - if s.token <> Lexer.CLOSE_BRACE then - error s "expected '}' to close template expression"; - let acc = Pipe (e, Fn0 To_string) :: acc in - match Lexer.tokenize_template s.buf with + let expr = parse_sequence_expr stream in + if stream.token <> CLOSE_BRACE then + error stream "expected '}' to close template expression"; + let acc = Pipe (expr, Fn0 To_string) :: acc in + match Lexer.tokenize_template stream.buf with | Ok (End text) -> - advance s; + advance stream; let acc = if text = "" then acc else Literal (String text) :: acc in concat_parts (List.rev acc) | Ok (Interp text) -> - advance s; + advance stream; let acc = if text = "" then acc else Literal (String text) :: acc in loop acc - | Error msg -> error s msg + | Error message -> error stream message in let acc = if initial_text = "" then [] else [ Literal (String initial_text) ] @@ -754,7 +741,7 @@ let program buf = parse_program { buf; - token = Lexer.EOF; + token = EOF; start_pos = Lexing.dummy_pos; end_pos = Lexing.dummy_pos; } From fc62b1444734fb306484b25828021fc5b36c81bb Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Tue, 10 Feb 2026 11:54:10 +0000 Subject: [PATCH 06/12] refactor: rename Query_error -> Error --- source/Core.ml | 16 +++--- source/{Query_error.ml => Error.ml} | 0 source/{Query_error.mli => Error.mli} | 0 source/Interpreter.ml | 8 +-- source/Language.ml | 70 +++++++++++++-------------- source/Language.mli | 13 ++--- source/Parser.ml | 22 ++++----- 7 files changed, 59 insertions(+), 70 deletions(-) rename source/{Query_error.ml => Error.ml} (100%) rename source/{Query_error.mli => Error.mli} (100%) diff --git a/source/Core.ml b/source/Core.ml index d23b7f3..f323da8 100644 --- a/source/Core.ml +++ b/source/Core.ml @@ -17,30 +17,30 @@ let parse ~debug ~colorize input = | ast -> if debug then print_endline (Ast.show_expression ast); Ok ast - | exception Query_error.Parse_error (err, start, end_) -> + | exception Error.Parse_error (err, start, end_) -> last_position := { loc_start = start; loc_end = end_ }; let err = - Query_error.with_location ~input ~start_pos:start.pos_cnum + Error.with_location ~input ~start_pos:start.pos_cnum ~end_pos:end_.pos_cnum err in - Error (Query_error.format ~colorize err) + Error (Error.format ~colorize err) | exception Failure msg -> let Location.{ loc_start; loc_end; _ } = !last_position in let err = - Query_error.semantic_error ~message:msg ~input - ~start_pos:loc_start.pos_cnum ~end_pos:loc_end.pos_cnum + Error.semantic_error ~message:msg ~input ~start_pos:loc_start.pos_cnum + ~end_pos:loc_end.pos_cnum in - Error (Query_error.format ~colorize err) + Error (Error.format ~colorize err) | exception _exn -> let Location.{ loc_start; loc_end; _ } = !last_position in let err = - Query_error.parse_error ~input ~start_pos:loc_start.pos_cnum + Error.parse_error ~input ~start_pos:loc_start.pos_cnum ~end_pos:loc_end.pos_cnum ~message: (Printf.sprintf "problem parsing at %s" (position_to_string loc_start loc_end)) in - Error (Query_error.format ~colorize err) + Error (Error.format ~colorize err) let run ?(debug = false) ?(colorize = true) ?(verbose = false) ?(raw = false) ?(summarize = false) query json = diff --git a/source/Query_error.ml b/source/Error.ml similarity index 100% rename from source/Query_error.ml rename to source/Error.ml diff --git a/source/Query_error.mli b/source/Error.mli similarity index 100% rename from source/Query_error.mli rename to source/Error.mli diff --git a/source/Interpreter.ml b/source/Interpreter.ml index 4711638..69e4d03 100644 --- a/source/Interpreter.ml +++ b/source/Interpreter.ml @@ -3442,22 +3442,22 @@ let execute ~colorize ~verbose ?(env = []) expr json = let ctx = { colorize; verbose; env; fns = [] } in let format_error (err : Runtime_error.t) = let qerr = - Query_error.runtime_error + 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 - Query_error.format ~colorize qerr + Error.format ~colorize qerr in match collect ~ctx expr json with | results -> Ok results | effect Runtime_error.Fail err, _ -> Error (format_error err) | effect Break, _ -> let err = - Query_error.context_error ~message:"break used outside of loop context" + Error.context_error ~message:"break used outside of loop context" in - Error (Query_error.format ~colorize err) + Error (Error.format ~colorize err) | effect Halt exit_code, _ -> exit exit_code | exception e -> Error (Printexc.to_string e) diff --git a/source/Language.ml b/source/Language.ml index ba9cafe..147fb73 100644 --- a/source/Language.ml +++ b/source/Language.ml @@ -1347,7 +1347,7 @@ let arity_to_string (name : string) (arity : arity) : string = Printf.sprintf "%s(%s; %s; %s)" name arg1 arg2 arg3 | Variable_args args -> Printf.sprintf "%s(%s)" name args -let error_for_missing_arg (name : string) : Query_error.t = +let error_for_missing_arg (name : string) : Error.t = match find_function name with | Some f -> let usage = arity_to_string name f.arity in @@ -1365,10 +1365,10 @@ let error_for_missing_arg (name : string) : Query_error.t = |> List.map type_name_of_applicable |> String.concat ", " in - Query_error.missing_argument ~fn_name:name ~message ~usage + Error.missing_argument ~fn_name:name ~message ~usage ~description:f.description ~applicable_to ?example:f.example () | None -> - Query_error.missing_argument ~fn_name:name ~usage:name + Error.missing_argument ~fn_name:name ~usage:name ~description:"Unknown function" () (* Check if a function name is a 1-arity function that can accept Identity as default *) @@ -1391,13 +1391,13 @@ let can_default_to_identity (name : string) : bool = | _ -> false let require_string_literal ~fn_name ~what ~example = - Query_error.requires_literal ~fn_name ~what ~example + Error.requires_literal ~fn_name ~what ~example -let not_implemented feature = Query_error.not_implemented feature +let not_implemented feature = Error.not_implemented feature (* Map 2-argument function names to AST nodes *) let map_binary_fn (name : string) (arg1 : Ast.expression) - (arg2 : Ast.expression) : (Ast.expression, Query_error.t) result = + (arg2 : Ast.expression) : (Ast.expression, Error.t) result = let open Ast in match name with | "while" -> Ok (Fn2 (While, arg1, arg2)) @@ -1409,7 +1409,7 @@ let map_binary_fn (name : string) (arg1 : Ast.expression) | Literal ((Int _ | Float _) as n) -> Ok (Fn2 (Limit, Literal n, arg2)) | _ -> Error - (Query_error.requires_number_literal ~fn_name:"limit" + (Error.requires_number_literal ~fn_name:"limit" ~what:"first argument must be a number literal" ~example:"limit(3; range(10)) → 0, 1, 2" ())) | "skip" -> ( @@ -1417,7 +1417,7 @@ let map_binary_fn (name : string) (arg1 : Ast.expression) | Literal ((Int _ | Float _) as n) -> Ok (Fn2 (Skip, Literal n, arg2)) | _ -> Error - (Query_error.requires_number_literal ~fn_name:"skip" + (Error.requires_number_literal ~fn_name:"skip" ~what:"first argument must be a number literal" ~example:"skip(2; range(5)) → 2, 3, 4" ())) | "replace" | "sub" -> ( @@ -1461,21 +1461,19 @@ let map_binary_fn (name : string) (arg1 : Ast.expression) | "strftime" -> Error (not_implemented "strftime") | "strptime" -> Error (not_implemented "strptime") | "splits" -> - Error - (Query_error.not_implemented ~suggestion:"use `split` instead" "splits") + Error (Error.not_implemented ~suggestion:"use `split` instead" "splits") | "sql" -> Error (not_implemented "sql") | "dateadd" | "datesub" -> Error (not_implemented "date arithmetic") | "modulemeta" -> Error (not_implemented "modulemeta") (* Default: generic function application *) | _ -> Ok (Apply (name, [ arg1; arg2 ])) -let compile_regex (pattern : string) : - (Ast.compiled_regex, Query_error.t) result = +let compile_regex (pattern : string) : (Ast.compiled_regex, Error.t) result = try Ok { Ast.pattern; regex = Str.regexp pattern } - with _ -> Error (Query_error.invalid_regex ~pattern) + with _ -> Error (Error.invalid_regex ~pattern) let make_pattern_fn (fn : Ast.fn1_pattern) (pattern : string) : - (Ast.expression, Query_error.t) result = + (Ast.expression, Error.t) result = match compile_regex pattern with | Ok compiled -> Ok (Ast.Fn1 (With_pattern (fn, compiled))) | Error e -> Error e @@ -1487,7 +1485,7 @@ let make_expr_fn (fn : Ast.fn1_expr) (expr : Ast.expression) : Ast.expression = Ast.Fn1 (With_expr (fn, expr)) let map_unary_fn (name : string) (arg : Ast.expression) : - (Ast.expression, Query_error.t) result = + (Ast.expression, Error.t) result = let open Ast in match name with (* Array/iteration functions *) @@ -1529,11 +1527,10 @@ let map_unary_fn (name : string) (arg : Ast.expression) : (* String functions - expression-based *) | "starts_with" -> Ok (make_expr_fn Starts_with arg) | "startswith" -> - Error - (Query_error.deprecated ~old_name:"startswith" ~new_name:"starts_with") + Error (Error.deprecated ~old_name:"startswith" ~new_name:"starts_with") | "ends_with" -> Ok (make_expr_fn Ends_with arg) | "endswith" -> - Error (Query_error.deprecated ~old_name:"endswith" ~new_name:"ends_with") + Error (Error.deprecated ~old_name:"endswith" ~new_name:"ends_with") | "index" -> Ok (make_expr_fn Index_of arg) | "last_index" | "rindex" -> Ok (make_expr_fn Last_index_of arg) | "indices" | "find_indices" -> Ok (make_expr_fn Indices arg) @@ -1608,7 +1605,7 @@ let map_unary_fn (name : string) (arg : Ast.expression) : Ok (make_expr_fn Halt_error_n arg) | _ -> Error - (Query_error.requires_number_literal ~fn_name:"halt_error" + (Error.requires_number_literal ~fn_name:"halt_error" ~what:"requires a number literal exit code" ~example:"halt_error(1) terminates with exit code 1" ())) (* is_valid(expr) -> try (expr | true) catch false *) @@ -1626,28 +1623,27 @@ let map_unary_fn (name : string) (arg : Ast.expression) : | "tojsonstream" | "fromjsonstream" | "truncate_stream" -> Error (not_implemented "JSON stream functions") | "splits" -> - Error - (Query_error.not_implemented ~suggestion:"use `split` instead" "splits") + Error (Error.not_implemented ~suggestion:"use `split` instead" "splits") | "tojson" | "fromjson" -> Error - (Query_error.not_implemented + (Error.not_implemented ~suggestion:"use `to_string` (input is already JSON)" "tojson/fromjson") | "ascii" -> Error (not_implemented "ascii") | "modulemeta" -> Error (not_implemented "modulemeta") | "input" | "inputs" -> Error - (Query_error.not_implemented - ~description:"query-json reads all input upfront" "input/inputs") + (Error.not_implemented ~description:"query-json reads all input upfront" + "input/inputs") | "env" -> Error - (Query_error.unsupported ~fn_name:"env" + (Error.unsupported ~fn_name:"env" ~message:"with argument is not supported" ~suggestion:"use `$ENV.name` or `env.name` instead" ()) | "builtins" -> Error (not_implemented "builtins") | "limit" -> Error - (Query_error.requires_number_literal ~fn_name:"limit" + (Error.requires_number_literal ~fn_name:"limit" ~what:"first argument must be a number literal" ~example:"limit(3; range(10))" ()) | "until" | "while" -> @@ -1656,7 +1652,7 @@ let map_unary_fn (name : string) (arg : Ast.expression) : else "[until(. > 100; . * 2)]" in Error - (Query_error.missing_argument ~fn_name:name + (Error.missing_argument ~fn_name:name ~message:(Printf.sprintf "`%s` requires two arguments" name) ~usage:"condition and update expressions" ~description:"Loop construct" ~example ()) @@ -1664,7 +1660,7 @@ let map_unary_fn (name : string) (arg : Ast.expression) : | _ -> Ok (Apply (name, [ arg ])) (* Map 0-argument function/identifier names to AST nodes *) -let map_nullary_fn (name : string) : (Ast.expression, Query_error.t) result = +let map_nullary_fn (name : string) : (Ast.expression, Error.t) result = let open Ast in match name with (* Basic values *) @@ -1701,10 +1697,10 @@ let map_nullary_fn (name : string) : (Ast.expression, Query_error.t) result = | "add" -> Ok (Fn0 Add) (* String functions *) | "tostring" -> - Error (Query_error.deprecated ~old_name:"tostring" ~new_name:"to_string") + Error (Error.deprecated ~old_name:"tostring" ~new_name:"to_string") | "to_string" -> Ok (Fn0 To_string) | "tonumber" -> - Error (Query_error.deprecated ~old_name:"tonumber" ~new_name:"to_number") + Error (Error.deprecated ~old_name:"tonumber" ~new_name:"to_number") | "to_number" -> Ok (Fn0 To_number) | "to_codepoints" | "explode" -> Ok (Fn0 To_codepoints) | "from_codepoints" | "implode" -> Ok (Fn0 From_codepoints) @@ -1712,13 +1708,13 @@ let map_nullary_fn (name : string) : (Ast.expression, Query_error.t) result = | "to_lowercase" -> Ok (Fn0 To_lowercase) | "trim" -> Ok (Fn0 Trim) | "trim_left" -> - Error (Query_error.deprecated ~old_name:"trim_left" ~new_name:"trim") + Error (Error.deprecated ~old_name:"trim_left" ~new_name:"trim") | "left_trim" -> - Error (Query_error.deprecated ~old_name:"left_trim" ~new_name:"trim") + Error (Error.deprecated ~old_name:"left_trim" ~new_name:"trim") | "trim_right" -> - Error (Query_error.deprecated ~old_name:"trim_right" ~new_name:"trim") + Error (Error.deprecated ~old_name:"trim_right" ~new_name:"trim") | "right_trim" -> - Error (Query_error.deprecated ~old_name:"right_trim" ~new_name:"trim") + Error (Error.deprecated ~old_name:"right_trim" ~new_name:"trim") (* Math functions *) | "floor" -> Ok (Fn0 Floor) | "sqrt" -> Ok (Fn0 Sqrt) @@ -1745,9 +1741,9 @@ let map_nullary_fn (name : string) : (Ast.expression, Query_error.t) result = | "atanh" -> Ok (Fn0 Atanh) | "is_normal" -> Ok (Fn0 Is_normal) | "isnormal" -> - Error (Query_error.deprecated ~old_name:"isnormal" ~new_name:"is_normal") + Error (Error.deprecated ~old_name:"isnormal" ~new_name:"is_normal") | "truncate" | "trunc" -> Ok (Fn0 Truncate) - | "fabs" -> Error (Query_error.deprecated ~old_name:"fabs" ~new_name:"abs") + | "fabs" -> Error (Error.deprecated ~old_name:"fabs" ~new_name:"abs") | "cube_root" | "cbrt" -> Ok (Fn0 Cube_root) | "expm1" -> Ok (Fn0 Expm1) | "exp2" -> Ok (Fn0 Exp2) @@ -1803,7 +1799,7 @@ let map_nullary_fn (name : string) : (Ast.expression, Query_error.t) result = Error (not_implemented "JSON stream functions") | "tojson" | "fromjson" -> Error - (Query_error.not_implemented + (Error.not_implemented ~suggestion:"use `to_string` (input is already JSON)" "tojson/fromjson") | "input_filename" | "input_line_number" -> diff --git a/source/Language.mli b/source/Language.mli index e478ff2..f77f7c0 100644 --- a/source/Language.mli +++ b/source/Language.mli @@ -32,16 +32,11 @@ val functions_for_type : string -> function_info list val type_name_of_applicable : applicable_to -> string val applicable_of_json_type : string -> applicable_to val find_function : string -> function_info option -val error_for_missing_arg : string -> Query_error.t -val map_nullary_fn : string -> (Ast.expression, Query_error.t) result - -val map_unary_fn : - string -> Ast.expression -> (Ast.expression, Query_error.t) result +val error_for_missing_arg : string -> Error.t +val map_nullary_fn : string -> (Ast.expression, Error.t) result +val map_unary_fn : string -> Ast.expression -> (Ast.expression, Error.t) result val map_binary_fn : - string -> - Ast.expression -> - Ast.expression -> - (Ast.expression, Query_error.t) result + string -> Ast.expression -> Ast.expression -> (Ast.expression, Error.t) result val can_default_to_identity : string -> bool diff --git a/source/Parser.ml b/source/Parser.ml index 11b3331..690e366 100644 --- a/source/Parser.ml +++ b/source/Parser.ml @@ -15,10 +15,10 @@ let advance stream = | Error message -> let _, stop = Sedlexing.lexing_positions stream.buf in let error = - Query_error.lexer_error ~message ~input:"" ~start_pos:start.pos_cnum + Error.lexer_error ~message ~input:"" ~start_pos:start.pos_cnum ~end_pos:stop.pos_cnum in - Query_error.raise error start stop + Error.raise error start stop in let _, stop = Sedlexing.lexing_positions stream.buf in stream.token <- token; @@ -36,20 +36,20 @@ let expect stream expected = (Lexer.humanize token) in let error = - Query_error.parse_error ~message ~input:"" - ~start_pos:stream.start_pos.pos_cnum ~end_pos:stream.end_pos.pos_cnum + Error.parse_error ~message ~input:"" ~start_pos:stream.start_pos.pos_cnum + ~end_pos:stream.end_pos.pos_cnum in - Query_error.raise error stream.start_pos stream.end_pos + Error.raise error stream.start_pos stream.end_pos let error stream message = let message = Printf.sprintf "%s, got %s" message (Lexer.humanize stream.token) in let error = - Query_error.parse_error ~message ~input:"" - ~start_pos:stream.start_pos.pos_cnum ~end_pos:stream.end_pos.pos_cnum + Error.parse_error ~message ~input:"" ~start_pos:stream.start_pos.pos_cnum + ~end_pos:stream.end_pos.pos_cnum in - Query_error.raise error stream.start_pos stream.end_pos + Error.raise error stream.start_pos stream.end_pos let optional_question stream expr = match (peek stream : Lexer.token) with @@ -60,7 +60,7 @@ let optional_question stream expr = let unwrap_or_raise stream = function | Ok ast -> ast - | Error error -> Query_error.raise error stream.start_pos stream.end_pos + | Error error -> Error.raise error stream.start_pos stream.end_pos let expect_variable stream = match (peek stream : Lexer.token) with @@ -589,9 +589,7 @@ and parse_function_call stream name = match (peek stream : Lexer.token) with | CLOSE_PARENT -> advance stream; - let raise_error error = - Query_error.raise error fn_start stream.end_pos - in + let raise_error error = Error.raise error fn_start stream.end_pos in if Language.can_default_to_identity name then match Language.map_unary_fn name Identity with | Ok ast -> ast From ef91a02b516f98cda3b0426e1634dab107bee0b2 Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Tue, 10 Feb 2026 12:02:20 +0000 Subject: [PATCH 07/12] refactor: use pp_print --- source/Ast.ml | 5 +---- source/Lexer.ml | 5 +---- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/source/Ast.ml b/source/Ast.ml index 9c0fd5c..ffbd593 100644 --- a/source/Ast.ml +++ b/source/Ast.ml @@ -1,12 +1,9 @@ -(* Custom pp for Z.t since ppx_deriving can't derive it *) -let pp_z fmt z = Format.fprintf fmt "%s" (Z.to_string z) - type literal = | Bool of bool (* true *) | String of string (* "TEXT" *) | Int of int (* small integers that fit in native int *) | Int64 of int64 (* large integers that need 64-bit *) - | Big_int of Z.t [@printer fun fmt z -> pp_z fmt z] + | Big_int of Z.t [@printer fun fmt z -> Z.pp_print fmt z] (* huge integers beyond int64 range *) | Float of float (* 123.0 - floating point literals *) | Null (* null *) diff --git a/source/Lexer.ml b/source/Lexer.ml index 9054b26..92a7fb7 100644 --- a/source/Lexer.ml +++ b/source/Lexer.ml @@ -10,13 +10,10 @@ let identifier = let comment = [%sedlex.regexp? '#', Star (Compl '\n')] -(* Custom pp for Z.t since ppx_deriving can't derive it *) -let pp_z fmt z = Format.fprintf fmt "%s" (Z.to_string z) - type token = | INT of int (* small integers *) | INT64 of int64 (* large integers *) - | BIG_INT of Z.t [@printer fun fmt z -> pp_z fmt z] (* huge integers *) + | BIG_INT of Z.t [@printer fun fmt z -> Z.pp_print fmt z] (* huge integers *) | FLOAT of float | STRING of string | BOOL of bool From 2daf9ef3ca3c9716029ed5aaf172b8818903bb2a Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Tue, 10 Feb 2026 12:53:05 +0000 Subject: [PATCH 08/12] Big_int arithmetic support --- source/Interpreter.ml | 85 ++++++++++++++++++++++++++++++++----- source/test/Test_parse.ml | 11 +++++ source/test/Test_runtime.ml | 48 +++++++++++++++++++++ 3 files changed, 134 insertions(+), 10 deletions(-) diff --git a/source/Interpreter.ml b/source/Interpreter.ml index 69e4d03..43e1cf4 100644 --- a/source/Interpreter.ml +++ b/source/Interpreter.ml @@ -275,10 +275,19 @@ module Operators = struct | `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) | _ -> None let add ~ctx str (left : Json.t) (right : Json.t) : Json.t = match (left, right) with + (* Big_int arithmetic - preserves arbitrary precision *) + | `Big_int l, `Big_int r -> `Big_int (Z.add l r) + | `Big_int l, `Int r -> `Big_int (Z.add l (Z.of_int r)) + | `Int l, `Big_int r -> `Big_int (Z.add (Z.of_int l) r) + | `Big_int l, `Int64 r -> `Big_int (Z.add l (Z.of_int64 r)) + | `Int64 l, `Big_int r -> `Big_int (Z.add (Z.of_int64 l) r) + | `Big_int l, `Float r -> `Float (Z.to_float l +. r) + | `Float l, `Big_int r -> `Float (l +. Z.to_float r) (* Int64 arithmetic - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.add l r) | `Int64 l, `Int r -> `Int64 (Int64.add l (Int64.of_int r)) @@ -326,9 +335,11 @@ module Operators = struct | Some l, Some r -> `Float (fn l r) | _ -> fail_invalid_type ~ctx str left - let compare ~ctx:_ str _fn (left : Json.t) (right : Json.t) = - match (to_float left, to_float right) with - | Some l, Some r -> `Bool (_fn l r) + let compare ~ctx:_ str int_fn (left : Json.t) (right : Json.t) = + match (left, right) with + | ( (`Int _ | `Int64 _ | `Big_int _ | `Float _), + (`Int _ | `Int64 _ | `Big_int _ | `Float _) ) -> + `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) @@ -356,6 +367,14 @@ module Operators = struct let subtract ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with + (* Big_int arithmetic - preserves arbitrary precision *) + | `Big_int l, `Big_int r -> `Big_int (Z.sub l r) + | `Big_int l, `Int r -> `Big_int (Z.sub l (Z.of_int r)) + | `Int l, `Big_int r -> `Big_int (Z.sub (Z.of_int l) r) + | `Big_int l, `Int64 r -> `Big_int (Z.sub l (Z.of_int64 r)) + | `Int64 l, `Big_int r -> `Big_int (Z.sub (Z.of_int64 l) r) + | `Big_int l, `Float r -> `Float (Z.to_float l -. r) + | `Float l, `Big_int r -> `Float (l -. Z.to_float r) (* Int64 arithmetic - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.sub l r) | `Int64 l, `Int r -> `Int64 (Int64.sub l (Int64.of_int r)) @@ -396,6 +415,14 @@ module Operators = struct let multiply ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with + (* Big_int arithmetic - preserves arbitrary precision *) + | `Big_int l, `Big_int r -> `Big_int (Z.mul l r) + | `Big_int l, `Int r -> `Big_int (Z.mul l (Z.of_int r)) + | `Int l, `Big_int r -> `Big_int (Z.mul (Z.of_int l) r) + | `Big_int l, `Int64 r -> `Big_int (Z.mul l (Z.of_int64 r)) + | `Int64 l, `Big_int r -> `Big_int (Z.mul (Z.of_int64 l) r) + | `Big_int l, `Float r -> `Float (Z.to_float l *. r) + | `Float l, `Big_int r -> `Float (l *. Z.to_float r) (* Int64 arithmetic - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.mul l r) | `Int64 l, `Int r -> `Int64 (Int64.mul l (Int64.of_int r)) @@ -425,6 +452,14 @@ module Operators = struct let divide ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with + (* Big_int division - produces Float like other integer division *) + | `Big_int l, `Big_int r -> `Float (Z.to_float l /. Z.to_float r) + | `Big_int l, `Int r -> `Float (Z.to_float l /. Int.to_float r) + | `Int l, `Big_int r -> `Float (Int.to_float l /. Z.to_float r) + | `Big_int l, `Int64 r -> `Float (Z.to_float l /. Int64.to_float r) + | `Int64 l, `Big_int r -> `Float (Int64.to_float l /. Z.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) | `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) @@ -442,6 +477,14 @@ module Operators = struct let modulo ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with + (* Big_int modulo - preserves arbitrary precision *) + | `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 modulo - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.rem l r) | `Int64 l, `Int r -> `Int64 (Int64.rem l (Int64.of_int r)) @@ -572,6 +615,14 @@ let rec get_path value components = get_path (List.nth items idx) rest else `Null | _ -> `Null) + | `Big_int idx :: rest -> ( + let idx = Z.to_int idx in + match value with + | `List items -> + if idx >= 0 && idx < List.length items then + get_path (List.nth items idx) rest + else `Null + | _ -> `Null) | _ :: rest -> get_path value rest let rec set_path value path_components new_value = @@ -591,11 +642,12 @@ let rec set_path value path_components new_value = else `Assoc (fields @ [ (key, set_path `Null rest new_value) ]) | `Null -> `Assoc [ (key, set_path `Null rest new_value) ] | _ -> value) - | ((`Int _ | `Int64 _ | `Float _) as num) :: rest -> ( + | ((`Int _ | `Int64 _ | `Big_int _ | `Float _) as num) :: rest -> ( let idx = match num with | `Int i -> i | `Int64 i -> Int64.to_int i + | `Big_int z -> Z.to_int z | `Float f -> Float.to_int f | _ -> 0 in @@ -645,6 +697,7 @@ let tm_to_array (tm : Unix.tm) (is_dst : bool) : Json.t = let json_to_int = function | `Int n -> Some n | `Int64 n -> Some (Int64.to_int n) + | `Big_int z -> Some (Z.to_int z) | _ -> None let localtime ~ctx json = @@ -798,6 +851,7 @@ let length ~ctx (json : Json.t) = | `Null -> `Int64 0L | `Int n -> `Int64 (Int64.of_int (abs n)) | `Int64 n -> `Int64 (Int64.abs n) + | `Big_int z -> `Big_int (Z.abs z) | `Float f -> `Float (Float.abs f) | _ -> fail_invalid_type ~ctx "length" json @@ -827,6 +881,7 @@ let math_fn ~ctx fn name json = | `Float f -> `Float (fn f) | `Int n -> `Float (fn (Float.of_int n)) | `Int64 n -> `Float (fn (Int64.to_float n)) + | `Big_int z -> `Float (fn (Z.to_float z)) | _ -> fail_invalid_type ~ctx name json let abs_op ~ctx json = @@ -834,6 +889,7 @@ let abs_op ~ctx json = | `Float f -> `Float (Float.abs f) | `Int n -> `Int64 (Int64.of_int (abs n)) | `Int64 n -> `Int64 (Int64.abs n) + | `Big_int z -> `Big_int (Z.abs z) | _ -> fail_invalid_type ~ctx "abs" json let ceil_op ~ctx json = @@ -841,6 +897,7 @@ let ceil_op ~ctx json = | `Float f -> `Int64 (Int64.of_float (Float.ceil f)) | `Int n -> `Int64 (Int64.of_int n) | `Int64 n -> `Int64 n + | `Big_int z -> `Big_int z | _ -> fail_invalid_type ~ctx "ceil" json let round_op ~ctx json = @@ -848,12 +905,13 @@ let round_op ~ctx json = | `Float f -> `Int64 (Int64.of_float (Float.round f)) | `Int n -> `Int64 (Int64.of_int n) | `Int64 n -> `Int64 n + | `Big_int z -> `Big_int z | _ -> fail_invalid_type ~ctx "round" json let is_normal_op ~ctx json = match json with | `Float f -> `Bool (Float.is_finite f && not (Float.is_nan f)) - | `Int _ | `Int64 _ -> `Bool true + | `Int _ | `Int64 _ | `Big_int _ -> `Bool true | _ -> fail_invalid_type ~ctx "is_normal" json let logb_op ~ctx json = @@ -861,6 +919,7 @@ let logb_op ~ctx json = | `Float f -> `Float (Float.log2 (Float.abs f) |> Float.floor) | `Int n -> `Float (Float.log2 (Float.abs (Float.of_int n)) |> Float.floor) | `Int64 n -> `Float (Float.log2 (Float.abs (Int64.to_float n)) |> Float.floor) + | `Big_int z -> `Float (Float.log2 (Float.abs (Z.to_float z)) |> Float.floor) | _ -> fail_invalid_type ~ctx "logb" json let floor ~ctx (json : Json.t) = @@ -868,6 +927,7 @@ let floor ~ctx (json : Json.t) = | `Float f -> `Int64 (Int64.of_float (floor f)) | `Int n -> `Int64 (Int64.of_int n) | `Int64 n -> `Int64 n + | `Big_int z -> `Big_int z | _ -> fail_invalid_type ~ctx "floor" json let sqrt ~ctx (json : Json.t) = @@ -875,6 +935,7 @@ let sqrt ~ctx (json : Json.t) = | `Float f -> `Float (sqrt f) | `Int n -> `Float (sqrt (Float.of_int n)) | `Int64 n -> `Float (sqrt (Int64.to_float n)) + | `Big_int z -> `Float (sqrt (Z.to_float z)) | _ -> fail_invalid_type ~ctx "sqrt" json let to_number ~ctx (json : Json.t) = @@ -887,7 +948,7 @@ let to_number ~ctx (json : Json.t) = match Float.of_string_opt s with | Some f -> `Float f | None -> fail_invalid_type ~ctx "to_number" json)) - | `Int _ | `Int64 _ | `Float _ -> json + | `Int _ | `Int64 _ | `Big_int _ | `Float _ -> json | _ -> fail_invalid_type ~ctx "to_number" json let to_string ~ctx:_ (json : Json.t) = @@ -1038,7 +1099,7 @@ let from_codepoints ~ctx:_ (json : Json.t) = let is_nan ~ctx (json : Json.t) = match json with | `Float f -> `Bool (Float.is_nan f) - | `Int _ | `Int64 _ -> `Bool false + | `Int _ | `Int64 _ | `Big_int _ -> `Bool false | _ -> fail_invalid_type ~ctx "is_nan" json let get_envs () = @@ -1227,6 +1288,7 @@ let join_sep ~ctx sep json = | `Bool false -> Some "false" | `Int i -> Some (Int.to_string i) | `Int64 i -> Some (Int64.to_string i) + | `Big_int z -> Some (Z.to_string z) | `Float f -> if Float.is_integer f then Some (Int.to_string (Float.to_int f)) else Some (Float.to_string f) @@ -2976,11 +3038,12 @@ and delete_path value path_components = match value with | `Assoc fields -> `Assoc (List.filter (fun (k, _) -> k <> key) fields) | _ -> value) - | [ ((`Int _ | `Int64 _ | `Float _) as num) ] -> ( + | [ ((`Int _ | `Int64 _ | `Big_int _ | `Float _) as num) ] -> ( let idx = match num with | `Int i -> i | `Int64 i -> Int64.to_int i + | `Big_int z -> Z.to_int z | `Float f -> Float.to_int f | _ -> 0 in @@ -2995,11 +3058,12 @@ and delete_path value path_components = (fun (k, v) -> if k = key then (k, del_at v rest) else (k, v)) fields) | _ -> value) - | ((`Int _ | `Int64 _ | `Float _) as num) :: rest -> ( + | ((`Int _ | `Int64 _ | `Big_int _ | `Float _) as num) :: rest -> ( let idx = match num with | `Int i -> i | `Int64 i -> Int64.to_int i + | `Big_int z -> Z.to_int z | `Float f -> Float.to_int f | _ -> 0 in @@ -3077,11 +3141,12 @@ and setpath ~ctx path value_expr json = else `Assoc (fields @ [ (key, set_at `Null rest) ]) | `Null -> `Assoc [ (key, set_at `Null rest) ] | _ -> value) - | ((`Int _ | `Int64 _ | `Float _) as num) :: rest -> ( + | ((`Int _ | `Int64 _ | `Big_int _ | `Float _) as num) :: rest -> ( let idx = match num with | `Int i -> i | `Int64 i -> Int64.to_int i + | `Big_int z -> Z.to_int z | `Float f -> Float.to_int f | _ -> 0 in diff --git a/source/test/Test_parse.ml b/source/test/Test_parse.ml index 76d91e4..6c412ca 100644 --- a/source/test/Test_parse.ml +++ b/source/test/Test_parse.ml @@ -115,4 +115,15 @@ let tests = ( Literal (String "city"), Some (Pipe (Key "address", Key "city")) ); ] )))); + test "99999999999999999999999999999" + (Literal (Big_int (Z.of_string "99999999999999999999999999999"))); + test "9223372036854775808" + (Literal (Big_int (Z.of_string "9223372036854775808"))); + test "-99999999999999999999999999999" + (Literal (Big_int (Z.of_string "-99999999999999999999999999999"))); + test "99999999999999999999999999999 + 1" + (Operation + ( Literal (Big_int (Z.of_string "99999999999999999999999999999")), + Add, + Literal (Int 1) )); ] diff --git a/source/test/Test_runtime.ml b/source/test/Test_runtime.ml index 3eaa1d5..7f9b8b4 100644 --- a/source/test/Test_runtime.ml +++ b/source/test/Test_runtime.ml @@ -85,6 +85,53 @@ let int64_precision = test {|-9007199254740993 - 1|} {|null|} {|-9007199254740994|}; ] +let big_int = + [ + test {|.|} {|99999999999999999999999999999|} + {|99999999999999999999999999999|}; + test {|.|} {|-99999999999999999999999999999|} + {|-99999999999999999999999999999|}; + test {|9223372036854775808|} {|null|} {|9223372036854775808|}; + test {|99999999999999999999999999999|} {|null|} + {|99999999999999999999999999999|}; + test {|-99999999999999999999999999999|} {|null|} + {|-99999999999999999999999999999|}; + test {|.foo|} {|{"foo": 99999999999999999999999999999}|} + {|99999999999999999999999999999|}; + test {|.[]|} {|[99999999999999999999999999999, 42]|} + "99999999999999999999999999999\n42"; + test {|.[0]|} {|[99999999999999999999999999999]|} + {|99999999999999999999999999999|}; + test {|to_string|} {|99999999999999999999999999999|} + {|"99999999999999999999999999999"|}; + test {|type|} {|99999999999999999999999999999|} {|"number"|}; + test {|"\(.)"|} {|99999999999999999999999999999|} + {|"99999999999999999999999999999"|}; + test {|99999999999999999999999999999 + 1|} {|null|} + {|100000000000000000000000000000|}; + test {|99999999999999999999999999999 - 1|} {|null|} + {|99999999999999999999999999998|}; + test {|99999999999999999999999999999 * 2|} {|null|} + {|199999999999999999999999999998|}; + test {|. + 1|} {|99999999999999999999999999999|} + {|100000000000000000000000000000|}; + test {|. * 2|} {|99999999999999999999999999999|} + {|199999999999999999999999999998|}; + test {|. - 1|} {|99999999999999999999999999999|} + {|99999999999999999999999999998|}; + test {|. % 10|} {|99999999999999999999999999999|} {|9|}; + test {|99999999999999999999999999999 == 99999999999999999999999999999|} + {|null|} {|true|}; + test {|99999999999999999999999999999 < 100000000000000000000000000000|} + {|null|} {|true|}; + test {|99999999999999999999999999999 > 99999999999999999999999999998|} + {|null|} {|true|}; + test {|abs|} {|-99999999999999999999999999999|} + {|99999999999999999999999999999|}; + test {|length|} {|-99999999999999999999999999999|} + {|99999999999999999999999999999|}; + ] + let object_identifier_index = [ test {|.foo|} {|{"foo": 42, "bar": "less interesting data"}|} {|42|}; @@ -1507,6 +1554,7 @@ let tests = literals; large_numbers; int64_precision; + big_int; object_identifier_index; optional_object_identifier_index; array_index; From 419f550acd8f4464e6e76c22aa83ef8ca3010662 Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Tue, 10 Feb 2026 12:53:12 +0000 Subject: [PATCH 09/12] Add changes entry --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 1f70464..7ffb4b3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ ## 1.0.0~beta-1 +- [REFACTOR] Replace menhir-based parser with hand-written recursive descent parser +- [FIX] **Big_int arithmetic support**: All arithmetic, comparison, and math operations now handle arbitrary-precision integers - Rename functions for clarity - Deprecate `..` syntax, use `descend` - Improve REPL completions From 87e834f1aa22d30c4dae00489172c910028eb475 Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Wed, 11 Feb 2026 16:29:10 +0000 Subject: [PATCH 10/12] Cleanup commnents on Interpreter.ml --- source/Interpreter.ml | 100 ++++++++++-------------------------------- 1 file changed, 23 insertions(+), 77 deletions(-) diff --git a/source/Interpreter.ml b/source/Interpreter.ml index 43e1cf4..1b2f964 100644 --- a/source/Interpreter.ml +++ b/source/Interpreter.ml @@ -214,32 +214,26 @@ let rec substitute_params (params : string list) (args : expression list) (* nullary calls to a parameter name gets substituted with the argument expression *) | Apply (name, []) -> ( match find_param name with Some arg_expr -> arg_expr | None -> expr) - (* Arity-grouped variants *) - | Fn0 _ -> expr (* No sub-expressions to substitute *) + | Fn0 _ -> expr | Fn1 fn1 -> ( match fn1 with - | With_pattern _ -> expr (* Pattern has no sub-expressions *) - | With_separator _ -> expr (* Separator has no sub-expressions *) + | With_pattern _ -> expr + | With_separator _ -> expr | With_expr (f, e) -> Fn1 (With_expr (f, sub e))) | Fn2 (f, e1, e2) -> Fn2 (f, sub e1, sub e2) - (* Leaf expressions - no sub-expressions to substitute *) | Identity | Literal _ | Variable _ | Key _ | Env_var _ | Index _ | Slice _ -> expr - (* Binary operators *) | Pipe (l, r) -> Pipe (sub l, sub r) | Update (l, r) -> Update (sub l, sub r) | Alternative (l, r) -> Alternative (sub l, sub r) | Comma (l, r) -> Comma (sub l, sub r) | Operation (l, op, r) -> Operation (sub l, op, sub r) | Assign (l, r) -> Assign (sub l, sub r) - (* Constructors *) | List e -> List (sub_opt e) | Object pairs -> Object (List.map (fun (k, v) -> (sub k, sub_opt v)) pairs) - (* Access patterns *) | Optional e -> Optional (sub e) | Dynamic_access e -> Dynamic_access (sub e) | Slice_expr (a, b) -> Slice_expr (sub_opt a, sub_opt b) - (* Special constructs *) | If_then_else (c, t, e) -> If_then_else (sub c, sub t, sub e) | Range (e1, e2, e3) -> Range (sub e1, sub_opt e2, sub_opt e3) | Reduce (e, var, init, update) -> Reduce (sub e, var, sub init, sub update) @@ -248,7 +242,6 @@ let rec substitute_params (params : string list) (args : expression list) | As (e, var, body) -> As (sub e, var, sub body) | Try (e, h, f) -> Try (sub e, sub_opt h, sub_opt f) | Fma (e1, e2, e3) -> Fma (sub e1, sub e2, sub e3) - (* User-defined functions *) | Fn (name, params', body) -> Fn (name, params', sub body) | Apply (name, call_args) -> Apply (name, List.map sub call_args) @@ -280,7 +273,6 @@ module Operators = struct let add ~ctx str (left : Json.t) (right : Json.t) : Json.t = match (left, right) with - (* Big_int arithmetic - preserves arbitrary precision *) | `Big_int l, `Big_int r -> `Big_int (Z.add l r) | `Big_int l, `Int r -> `Big_int (Z.add l (Z.of_int r)) | `Int l, `Big_int r -> `Big_int (Z.add (Z.of_int l) r) @@ -288,20 +280,16 @@ module Operators = struct | `Int64 l, `Big_int r -> `Big_int (Z.add (Z.of_int64 l) r) | `Big_int l, `Float r -> `Float (Z.to_float l +. r) | `Float l, `Big_int r -> `Float (l +. Z.to_float r) - (* Int64 arithmetic - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.add l r) | `Int64 l, `Int r -> `Int64 (Int64.add l (Int64.of_int r)) | `Int l, `Int64 r -> `Int64 (Int64.add (Int64.of_int l) r) | `Int l, `Int r -> `Int64 (Int64.add (Int64.of_int l) (Int64.of_int r)) - (* Float arithmetic *) | `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) - (* String concatenation *) | `String l, `String r -> `String (l ^ r) - (* Object merge *) | `Assoc l_entries, `Assoc r_entries -> (* right side wins for duplicate keys (override, not merge) *) let updated_l = @@ -312,7 +300,7 @@ module Operators = struct | None -> (k, v)) l_entries in - (* Then add new keys from r that weren't in l *) + (* 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)) @@ -367,7 +355,6 @@ module Operators = struct let subtract ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with - (* Big_int arithmetic - preserves arbitrary precision *) | `Big_int l, `Big_int r -> `Big_int (Z.sub l r) | `Big_int l, `Int r -> `Big_int (Z.sub l (Z.of_int r)) | `Int l, `Big_int r -> `Big_int (Z.sub (Z.of_int l) r) @@ -375,18 +362,15 @@ module Operators = struct | `Int64 l, `Big_int r -> `Big_int (Z.sub (Z.of_int64 l) r) | `Big_int l, `Float r -> `Float (Z.to_float l -. r) | `Float l, `Big_int r -> `Float (l -. Z.to_float r) - (* Int64 arithmetic - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.sub l r) | `Int64 l, `Int r -> `Int64 (Int64.sub l (Int64.of_int r)) | `Int l, `Int64 r -> `Int64 (Int64.sub (Int64.of_int l) r) | `Int l, `Int r -> `Int64 (Int64.sub (Int64.of_int l) (Int64.of_int r)) - (* Float arithmetic *) | `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) - (* List subtraction *) | `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) @@ -395,7 +379,7 @@ module Operators = struct 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 *) + (* preserve key order: update existing keys from l with recursive merge from r *) let updated_l = List.map (fun (k, v) -> @@ -404,7 +388,7 @@ module Operators = struct | None -> (k, v)) l_entries in - (* Add new keys from r that weren't in l *) + (* 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)) @@ -415,7 +399,6 @@ module Operators = struct let multiply ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with - (* Big_int arithmetic - preserves arbitrary precision *) | `Big_int l, `Big_int r -> `Big_int (Z.mul l r) | `Big_int l, `Int r -> `Big_int (Z.mul l (Z.of_int r)) | `Int l, `Big_int r -> `Big_int (Z.mul (Z.of_int l) r) @@ -423,18 +406,15 @@ module Operators = struct | `Int64 l, `Big_int r -> `Big_int (Z.mul (Z.of_int64 l) r) | `Big_int l, `Float r -> `Float (Z.to_float l *. r) | `Float l, `Big_int r -> `Float (l *. Z.to_float r) - (* Int64 arithmetic - preserves precision *) | `Int64 l, `Int64 r -> `Int64 (Int64.mul l r) | `Int64 l, `Int r -> `Int64 (Int64.mul l (Int64.of_int r)) | `Int l, `Int64 r -> `Int64 (Int64.mul (Int64.of_int l) r) | `Int l, `Int r -> `Int64 (Int64.mul (Int64.of_int l) (Int64.of_int r)) - (* Float arithmetic *) | `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) - (* String repetition *) | `String s, `Int n -> if n <= 0 then `String "" else `String (String.concat "" (List.init n (fun _ -> s))) @@ -452,7 +432,6 @@ module Operators = struct let divide ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with - (* Big_int division - produces Float like other integer division *) | `Big_int l, `Big_int r -> `Float (Z.to_float l /. Z.to_float r) | `Big_int l, `Int r -> `Float (Z.to_float l /. Int.to_float r) | `Int l, `Big_int r -> `Float (Int.to_float l /. Z.to_float r) @@ -477,7 +456,6 @@ module Operators = struct let modulo ~ctx (left : Json.t) (right : Json.t) : Json.t = match (left, right) with - (* Big_int modulo - preserves arbitrary precision *) | `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) @@ -485,12 +463,10 @@ module Operators = struct | `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 modulo - preserves precision *) | `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 -> `Int64 (Int64.rem (Int64.of_int l) (Int64.of_int r)) - (* Float modulo *) | _ -> apply_float_operation ~ctx "%" mod_float left right end @@ -833,7 +809,7 @@ let range ?step from upto = let length ~ctx (json : Json.t) = let utf8_codepoint_length s = - (* Count the number of Unicode codepoints in a UTF-8 encoded string *) + (* count the number of Unicode codepoints in a UTF-8 encoded string *) let byte_len = String.length s in let rec count i n = if i >= byte_len then n @@ -858,12 +834,12 @@ let length ~ctx (json : Json.t) = let byte_length ~ctx (json : Json.t) = match json with | `String s -> - `Int64 (Int64.of_int (String.length s)) (* OCaml strings are byte arrays *) + `Int64 (Int64.of_int (String.length s)) | _ -> fail_invalid_type ~ctx "byte_length" json -(* Type selectors - filter input to only yield if it matches the type *) let type_selector ~ctx:_ type_name json = + (* filter input to only yield if it matches the type *) if Json.type_of json = type_name then yield json let iterables_selector ~ctx:_ json = @@ -875,7 +851,6 @@ let scalars_selector ~ctx:_ json = let values_selector ~ctx:_ json = match json with `Null -> () | _ -> yield json -(* Math helper functions *) let math_fn ~ctx fn name json = match json with | `Float f -> `Float (fn f) @@ -941,7 +916,7 @@ let sqrt ~ctx (json : Json.t) = let to_number ~ctx (json : Json.t) = match json with | `String s -> ( - (* Try to parse as Int64 first, then fall back to float *) + (* try to parse as Int64 first, then fall back to float *) match Int64.of_string_opt s with | Some i -> `Int64 i | None -> ( @@ -1377,11 +1352,9 @@ let slice ~ctx (start : int option) (finish : int option) (json : Json.t) = let rec interp ~ctx expression json : unit = match expression with | Identity -> yield json - (* Arity-grouped functions *) | Fn0 f -> interp_fn0 ~ctx f json | Fn1 fn1 -> interp_fn1 ~ctx fn1 json | Fn2 (f, e1, e2) -> interp_fn2 ~ctx f e1 e2 json - (* Leaf expressions *) | Literal literal -> ( match literal with | Bool b -> yield (`Bool b) @@ -1399,7 +1372,6 @@ let rec interp ~ctx expression json : unit = | Key key -> yield (member ~ctx key json) | Index idx -> index ~ctx idx json | Slice (start, finish) -> slice ~ctx start finish json - (* Binary operators *) | Pipe (left, right) -> pipe ~ctx left right json | Update (path_expr, transform) -> update ~ctx path_expr transform json | Alternative (left, right) -> alternative ~ctx left right json @@ -1408,20 +1380,17 @@ let rec interp ~ctx expression json : unit = interp ~ctx right_expr json | Operation (left, op, right) -> operation ~ctx left right op json | Assign (path, value_expr) -> assign ~ctx path value_expr json - (* Constructors *) | List None -> yield (`List []) | List (Some expr) -> let results = collect ~ctx expr json in yield (`List results) | Object [] -> yield (`Assoc []) | Object list -> objects ~ctx list json - (* Access patterns *) | Optional expr -> run (fun () -> interp ~ctx expr json) ~on_fail:(fun _ -> yield `Null) () | Dynamic_access expr -> dynamic_access ~ctx expr json | Slice_expr (start_expr, end_expr) -> slice_expr ~ctx start_expr end_expr json - (* Special constructs *) | If_then_else (cond, if_branch, else_branch) -> if_then_else ~ctx cond if_branch else_branch json | Range (from_expr, upto_expr, step_expr) -> @@ -1434,21 +1403,18 @@ let rec interp ~ctx expression json : unit = | Try (expr, handler, finally_expr) -> try_catch ~ctx expr handler finally_expr json | Fma (x_expr, y_expr, z_expr) -> fma_op ~ctx x_expr y_expr z_expr json - (* User-defined functions *) | Fn (_, _, _) -> - (* Fn on its own (not in a Pipe). It shouldn't happen in well-formed programs *) + (* fn on its own (not in a Pipe). It shouldn't happen in well-formed programs *) yield json | Apply (fname, args) -> call_function ~ctx fname args json and interp_fn0 ~ctx f json = match f with - (* String functions *) | Trim -> trim ~ctx json | To_uppercase -> to_uppercase ~ctx json | To_lowercase -> to_lowercase ~ctx json | To_codepoints -> yield (to_codepoints ~ctx json) | From_codepoints -> yield (from_codepoints ~ctx json) - (* Array functions *) | Sort -> yield (sort ~ctx json) | Unique -> yield (unique ~ctx json) | Reverse -> ( @@ -1465,17 +1431,14 @@ and interp_fn0 ~ctx f json = | Flatten -> yield (flatten ~ctx max_int json) | Combinations -> combinations ~ctx json | Transpose -> yield (transpose ~ctx json) - (* Object functions *) | Keys -> yield (keys ~ctx json) | To_entries -> yield (to_entries ~ctx json) | From_entries -> yield (from_entries ~ctx json) - (* Type functions *) | Type -> yield (`String (Json.type_of json)) | To_string -> yield (to_string ~ctx json) | To_number -> yield (to_number ~ctx json) | Length -> yield (length ~ctx json) | Byte_length -> yield (byte_length ~ctx json) - (* Type selectors *) | Numbers -> type_selector ~ctx "number" json | Strings -> type_selector ~ctx "string" json | Objects -> type_selector ~ctx "object" json @@ -1485,7 +1448,6 @@ and interp_fn0 ~ctx f json = | Iterables -> iterables_selector ~ctx json | Scalars -> scalars_selector ~ctx json | Values -> values_selector ~ctx json - (* Math functions *) | Floor -> yield (floor ~ctx json) | Sqrt -> yield (sqrt ~ctx json) | Abs -> yield (abs_op ~ctx json) @@ -1518,7 +1480,6 @@ and interp_fn0 ~ctx f json = | Nearbyint -> yield (math_fn ~ctx Float.round "nearbyint" json) | Logb -> yield (logb_op ~ctx json) | Infinite -> - (* infinite generates an infinite sequence 0, 1, 2, ... *) let rec infinite_gen n = yield (`Int64 n); infinite_gen (Int64.add n 1L) @@ -1526,28 +1487,23 @@ and interp_fn0 ~ctx f json = infinite_gen 0L | Nan -> yield (`Float nan) | Now -> yield (`Float (Unix.gettimeofday ())) - (* Path functions *) | Paths -> paths json | Leaf_paths -> leaf_paths json | Recurse -> yield_many (recurse_down json) | Recurse_down -> yield_many (recurse_down json) | Descend -> yield_many (descend_breadth_first json) | Dive -> yield_many (descend_depth json) - (* Control flow *) | Empty -> () | Not -> yield (Operators.not json) | Break -> break () | Halt -> halt () | Env -> yield (`Assoc (get_envs ())) - (* Debug/IO *) | Debug -> debug json | Stderr -> stderr json | Builtins -> yield (builtins_list ()) - (* Time *) | Localtime -> yield (localtime ~ctx json) | Gmtime -> yield (gmtime ~ctx json) | Mktime -> yield (mktime ~ctx json) - (* Custom helpers *) | Is_blank -> is_blank ~ctx json | Is_empty -> is_empty ~ctx Identity json @@ -1565,7 +1521,6 @@ and interp_fn1 ~ctx fn1 json = | Join -> yield (join_sep ~ctx sep json)) | With_expr (expr_fn, expr) -> ( match expr_fn with - (* Array functions *) | Map -> map ~ctx expr json | Map_values -> map_values ~ctx expr json | Flat_map -> flat_map ~ctx expr json @@ -1602,7 +1557,6 @@ and interp_fn1 ~ctx fn1 json = | Add_expr -> add_expr ~ctx expr json | Repeat -> repeat_expr ~ctx expr json | Binary_search -> binary_search ~ctx expr json - (* Object functions *) | Has -> ( match expr with | Literal ((String _ | Int _ | Int64 _ | Big_int _ | Float _) as lit) @@ -1618,7 +1572,6 @@ and interp_fn1 ~ctx fn1 json = | Pick -> pick ~ctx expr json | Getpath -> getpath ~ctx expr json | Delpaths -> delpaths ~ctx expr json - (* String functions *) | Starts_with -> starts_with ~ctx expr json | Ends_with -> ends_with ~ctx expr json | Index_of -> index_of ~ctx expr json @@ -1628,7 +1581,6 @@ and interp_fn1 ~ctx fn1 json = | Trim_start -> trim_start_impl ~ctx expr json | Trim_end -> trim_end_impl ~ctx expr json | Contains -> contains ~ctx expr json - (* Path functions *) | Walk -> walk_tree ~ctx expr json | Path -> path_of ~ctx expr json | Paths_filter -> paths_filter ~ctx expr json @@ -1644,7 +1596,6 @@ and interp_fn1 ~ctx fn1 json = | Find_all -> find_all ~ctx expr json | Find_first -> find_first ~ctx expr json | Paths_to -> paths_to ~ctx expr json - (* Control flow *) | Is_empty_expr -> is_empty ~ctx expr json | Error_msg -> error_msg ~ctx (Some expr) json | Halt_error_n -> ( @@ -1663,7 +1614,6 @@ and interp_fn1 ~ctx fn1 json = and interp_fn2 ~ctx f e1 e2 json = match f with - (* String functions *) | Replace -> ( match (e1, e2) with | Literal (String pattern), Literal (String replacement) -> @@ -1680,7 +1630,6 @@ and interp_fn2 ~ctx f e1 e2 json = Runtime_error.invalid_argument ~fn:"replace_all" ~expected:"string pattern and string replacement" ~found:"non-string arguments") - (* Control flow *) | While -> while_loop ~ctx e1 e2 json | Until -> until_loop ~ctx e1 e2 json | Limit -> ( @@ -1712,10 +1661,8 @@ and interp_fn2 ~ctx f e1 e2 json = | All_gen -> all_with_generator ~ctx e1 e2 json | Assert_msg -> assert_ ~ctx e1 (Some e2) json | Raise -> raise_error ~ctx e1 e2 json - (* Path functions *) | Setpath -> setpath ~ctx e1 e2 json | Nth -> nth ~ctx e1 e2 json - (* Math functions *) | Atan2 -> atan2_op ~ctx e1 e2 json | Copysign -> copysign_op ~ctx e1 e2 json | Ldexp -> ldexp_op ~ctx e1 e2 json @@ -2179,7 +2126,6 @@ and path_of ~ctx expr json = @ extract_paths current_path right value | _ -> [] and extract_path_for_value parent child = - (* First check if parent = child - this is the path [] *) if parent = child then Some [] else match (parent, child) with @@ -2305,7 +2251,7 @@ and call_function ~ctx fname args json = ~expected:(Int.to_string (List.length params) ^ " arguments") ~found:(Int.to_string (List.length args) ^ " arguments") else - (* Separate value params ($x) from filter params (x) *) + (* separate value params ($x) from filter params (x) *) let is_value_param p = String.length p > 0 && p.[0] = '$' in let filter_params, filter_args, value_params, value_args = List.fold_left2 @@ -2318,9 +2264,9 @@ and call_function ~ctx fname args json = let filter_args = List.rev filter_args in let value_params = List.rev value_params in let value_args = List.rev value_args in - (* Substitute filter params in body *) + (* substitute filter params in body *) let new_body = substitute_params filter_params filter_args body in - (* Evaluate value params and bind them as variables (strip the $ prefix for env lookup) *) + (* evaluate value params and bind them as variables (strip the $ prefix for env lookup) *) let value_bindings = List.map2 (fun param arg -> @@ -2401,7 +2347,7 @@ and contains ~ctx expr json = true with Not_found -> false) | `List haystack, `List needle -> - (* Every element in needle must be contained by some element in haystack *) + (* every element in needle must be contained by some element in haystack *) List.for_all (fun n -> List.exists (fun h -> value_contains h n) haystack) needle @@ -3033,7 +2979,7 @@ and del ~ctx:_ path json = and delete_path value path_components = let rec del_at value = function - | [] -> `Null (* Path points to root, delete returns null *) + | [] -> `Null (* path points to root, delete returns null *) | [ `String key ] -> ( match value with | `Assoc fields -> `Assoc (List.filter (fun (k, _) -> k <> key) fields) @@ -3160,7 +3106,7 @@ and setpath ~ctx path value_expr json = in `List (update_list 0 items) | `Null -> - (* Create array with nulls up to idx, then set value at idx *) + (* create array with nulls up to idx, then set value at idx *) let arr = List.init (idx + 1) (fun i -> if i = idx then set_at `Null rest else `Null) @@ -3191,7 +3137,7 @@ and pick ~ctx expr json = left_paths | Comma (left, right) -> extract_path_expr left @ extract_path_expr right | Dynamic_access inner -> - (* For dynamic access like .[$var], evaluate to get the key/index *) + (* for dynamic access like .[$var], evaluate to get the key/index *) let keys = collect ~ctx inner json in List.filter_map (function @@ -3308,7 +3254,7 @@ and slice_expr ~ctx (start_expr : expression option) slice ~ctx start finish json and assign ~ctx path value_expr json = - (* Assignment updates a path in the JSON structure *) + (* assignment updates a path in the JSON structure *) let values = collect ~ctx value_expr json in let new_value = match values with [] -> `Null | v :: _ -> v in let rec assign_path result p = @@ -3371,11 +3317,11 @@ and partition ~ctx expr json = | _ -> fail_invalid_type ~ctx "partition" json and is_empty ~ctx expr json = - (* With argument: check if expression produces no output (jq semantics) *) - (* When expr is Identity, this behaves like the 0-arg version *) + (* with argument: check if expression produces no output (jq semantics) *) + (* when expr is Identity, this behaves like the 0-arg version *) match expr with | Identity -> ( - (* No argument: check if the value itself is empty *) + (* no argument: check if the value itself is empty *) match json with | `Null -> yield (`Bool true) | `List [] -> yield (`Bool true) @@ -3386,7 +3332,7 @@ and is_empty ~ctx expr json = | `String _ -> yield (`Bool false) | _ -> fail_invalid_type ~ctx "is_empty" json) | _ -> ( - (* With argument: check if expression produces no output (jq semantics) *) + (* with argument: check if expression produces no output (jq semantics) *) match collect ~ctx expr json with | [] -> yield (`Bool true) | _ -> yield (`Bool false)) From c14437fd04e4ff6681d6e0ea3f3acd63027f974e Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Wed, 11 Feb 2026 16:56:20 +0000 Subject: [PATCH 11/12] Remove old comment from envvars --- source/Interpreter.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/source/Interpreter.ml b/source/Interpreter.ml index 1b2f964..43761b1 100644 --- a/source/Interpreter.ml +++ b/source/Interpreter.ml @@ -1078,7 +1078,6 @@ let is_nan ~ctx (json : Json.t) = | _ -> fail_invalid_type ~ctx "is_nan" json let get_envs () = - (* TODO: Do I need to escape stuff here? *) try Unix.environment () |> Array.to_list |> List.filter_map (fun s -> From 0ecb11de701beaebc539fb9e9f51d92ecb0fe9fd Mon Sep 17 00:00:00 2001 From: David Sancho Moreno Date: Wed, 11 Feb 2026 18:33:59 +0000 Subject: [PATCH 12/12] Improve errors on try/catch --- source/Core.ml | 23 +++++++---------------- source/Lexer.ml | 4 ++-- source/Parser.ml | 8 ++++---- 3 files changed, 13 insertions(+), 22 deletions(-) diff --git a/source/Core.ml b/source/Core.ml index f323da8..3e0f3eb 100644 --- a/source/Core.ml +++ b/source/Core.ml @@ -1,11 +1,3 @@ -module Location = struct - type t = { loc_start : Lexing.position; loc_end : Lexing.position } - - let none = { loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos } -end - -let last_position = ref Location.none - let position_to_string start end_ = Printf.sprintf "[line: %d, char: %d-%d]" start.Lexing.pos_lnum (start.Lexing.pos_cnum - start.Lexing.pos_bol) @@ -18,27 +10,26 @@ let parse ~debug ~colorize input = if debug then print_endline (Ast.show_expression ast); Ok ast | exception Error.Parse_error (err, start, end_) -> - last_position := { loc_start = start; loc_end = end_ }; let err = Error.with_location ~input ~start_pos:start.pos_cnum ~end_pos:end_.pos_cnum err in Error (Error.format ~colorize err) | exception Failure msg -> - let Location.{ loc_start; loc_end; _ } = !last_position in + let start, end_ = Sedlexing.lexing_positions buf in let err = - Error.semantic_error ~message:msg ~input ~start_pos:loc_start.pos_cnum - ~end_pos:loc_end.pos_cnum + Error.semantic_error ~message:msg ~input ~start_pos:start.pos_cnum + ~end_pos:end_.pos_cnum in Error (Error.format ~colorize err) | exception _exn -> - let Location.{ loc_start; loc_end; _ } = !last_position in + let start, end_ = Sedlexing.lexing_positions buf in let err = - Error.parse_error ~input ~start_pos:loc_start.pos_cnum - ~end_pos:loc_end.pos_cnum + Error.parse_error ~input ~start_pos:start.pos_cnum + ~end_pos:end_.pos_cnum ~message: (Printf.sprintf "problem parsing at %s" - (position_to_string loc_start loc_end)) + (position_to_string start end_)) in Error (Error.format ~colorize err) diff --git a/source/Lexer.ml b/source/Lexer.ml index 92a7fb7..1a5d5a7 100644 --- a/source/Lexer.ml +++ b/source/Lexer.ml @@ -98,9 +98,9 @@ let humanize = function | MINUS_ASSIGN -> "'-='" | MULT_ASSIGN -> "'*='" | DIV_ASSIGN -> "'/='" - | ALT_ASSIGN -> "'//='" + | ALT_ASSIGN -> "'??='" | ASSIGN -> "'='" - | ALTERNATIVE -> "'//'" + | ALTERNATIVE -> "'??'" | QUESTION_MARK -> "'?'" | COMMA -> "','" | NULL -> "null" diff --git a/source/Parser.ml b/source/Parser.ml index 690e366..216da30 100644 --- a/source/Parser.ml +++ b/source/Parser.ml @@ -162,7 +162,7 @@ and parse_try stream = let cleanup = parse_item_expr stream in Try (body, Some handler, Some cleanup) | _ -> Try (body, Some handler, None)) - | _ -> body + | _ -> error stream "expected 'catch' after 'try'" and parse_pipe_expr stream = let left = parse_comma_expr stream in @@ -300,7 +300,7 @@ and parse_postfix stream expr = advance stream; let access = optional_question stream (Key key) in parse_postfix stream (Pipe (expr, access)) - | _ -> parse_postfix stream (Pipe (expr, Identity))) + | _ -> error stream "expected property name after '.'") | OPEN_BRACKET -> let result = parse_bracket_access stream expr in parse_postfix stream result @@ -352,8 +352,8 @@ and parse_remaining_indices stream acc = | COMMA -> advance stream; let number = parse_index_number stream in - parse_remaining_indices stream (acc @ [ number ]) - | _ -> acc + parse_remaining_indices stream (number :: acc) + | _ -> List.rev acc and parse_index_number stream = match (peek stream : Lexer.token) with