From 61cd969e7daf6c622b89b24a3aa6bc1f3510c6c7 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 1 Aug 2024 12:42:38 +0200 Subject: [PATCH 01/17] Add Pp_ast module and ppxlib-pp-ast executable Signed-off-by: Nathan Rebours --- CHANGES.md | 3 + bin/dune | 5 ++ bin/pp_ast.ml | 117 +++++++++++++++++++++++++++++++++++++ src/driver.mli | 9 +++ src/pp_ast.ml | 154 +++++++++++++++++++++++++++++++++++++++++++++++++ src/pp_ast.mli | 7 +++ src/ppxlib.ml | 1 + 7 files changed, 296 insertions(+) create mode 100644 bin/dune create mode 100644 bin/pp_ast.ml create mode 100644 src/pp_ast.ml create mode 100644 src/pp_ast.mli diff --git a/CHANGES.md b/CHANGES.md index 484d3149f..27117023e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -14,6 +14,9 @@ details. ### Other changes +- Add ppxlib's AST pretty-printing utilities in `Ppxlib.Pp_ast` and + a `ppxlib-pp-ast` executable (#, @NathanReb) + 0.33.0 (2024-07-22) ------------------- diff --git a/bin/dune b/bin/dune new file mode 100644 index 000000000..9f11573b4 --- /dev/null +++ b/bin/dune @@ -0,0 +1,5 @@ +(executable + (name pp_ast) + (public_name ppxlib-pp-ast) + (package ppxlib) + (libraries ppxlib ppxlib_ast astlib stdppx stdlib-shims)) diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml new file mode 100644 index 000000000..5e888c89b --- /dev/null +++ b/bin/pp_ast.ml @@ -0,0 +1,117 @@ +open Ppxlib + +module Kind = struct + type t = Signature | Structure | Expression | Pattern | Core_type + + let to_utils_kind = function + | Structure -> Ppxlib__Utils.Kind.Impl + | Signature -> Ppxlib__Utils.Kind.Intf + | _ -> assert false +end + +module Ast = struct + type t = + | Str of structure + | Sig of signature + | Exp of expression + | Pat of pattern + | Typ of core_type +end + +let parse_node ~kind ~input_name fn = + let all_source = + match fn with + | "-" -> Stdppx.In_channel.input_all stdin + | _ -> Stdppx.In_channel.(with_file fn ~f:input_all) + in + let lexbuf = Lexing.from_string all_source in + lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = input_name }; + Astlib.Location.set_input_lexbuf (Some lexbuf); + match (kind : Kind.t) with + | Expression -> Ast.Exp (Parse.expression lexbuf) + | Pattern -> Ast.Pat (Parse.pattern lexbuf) + | Core_type -> Ast.Typ (Parse.core_type lexbuf) + | Signature | Structure -> assert false + +let load_input ~kind ~input_name fn = + match (kind : Kind.t) with + | Structure | Signature -> ( + let kind = Kind.to_utils_kind kind in + match Driver.load_input ~kind ~input_name ~relocate:false fn with + | Error (loc_err, _ver) -> Location.Error.raise loc_err + | Ok (_ast_input_name, _version, ast) -> ( + match (ast : Ppxlib__Utils.Intf_or_impl.t) with + | Impl str -> Ast.Str str + | Intf sig_ -> Ast.Sig sig_)) + | Expression | Pattern | Core_type -> parse_node ~kind ~input_name fn + +let pp_ast ast = + match (ast : Ast.t) with + | Str str -> Pp_ast.structure Format.std_formatter str + | Sig sig_ -> Pp_ast.signature Format.std_formatter sig_ + | Exp exp -> Pp_ast.expression Format.std_formatter exp + | Pat pat -> Pp_ast.pattern Format.std_formatter pat + | Typ typ -> Pp_ast.core_type Format.std_formatter typ + +let input = ref None +let kind = ref None + +let set_input fn = + match !input with + | None -> input := Some fn + | Some _ -> raise (Arg.Bad "too many input files") + +let set_kind k = + match !kind with + | Some _ -> raise (Arg.Bad "must specify at most one of --impl or --intf") + | _ -> kind := Some k + +let exe_name = Stdlib.Filename.basename Stdlib.Sys.executable_name + +let args = + [ + ("-", Arg.Unit (fun () -> set_input "-"), " Read input from stdin"); + ( "--str", + Arg.Unit (fun () -> set_kind Kind.Structure), + " Treat the input as a .ml file" ); + ( "--sig", + Arg.Unit (fun () -> set_kind Kind.Signature), + " Treat the input as a .mli file" ); + ( "--exp", + Arg.Unit (fun () -> set_kind Kind.Expression), + " Treat the input as a single OCaml expression" ); + ( "--pat", + Arg.Unit (fun () -> set_kind Kind.Pattern), + " Treat the input as a single OCaml pattern" ); + ( "--typ", + Arg.Unit (fun () -> set_kind Kind.Core_type), + " Treat the input as a single OCaml core_type" ); + ] + +let main () = + let usage = Printf.sprintf "%s [extra_args] [/-]" exe_name in + Arg.parse (Arg.align args) set_input usage; + match !input with + | None -> + Printf.eprintf "%s: no input file given\n%!" exe_name; + Stdlib.exit 2 + | Some fn -> + let kind = + match !kind with + | Some k -> k + | None -> ( + match Ppxlib__Utils.Kind.of_filename fn with + | Some Intf -> Signature + | Some Impl -> Structure + | None -> + Printf.eprintf + "%s: Could not guess kind from filename %S\n\ + \ Please use relevant CLI flag" exe_name fn; + Stdlib.exit 2) + in + let input_name = match fn with "-" -> "" | _ -> fn in + let ast = load_input ~kind ~input_name fn in + pp_ast ast; + Format.printf "%!\n" + +let () = main () diff --git a/src/driver.mli b/src/driver.mli index 49e9e9a60..4a058afe2 100644 --- a/src/driver.mli +++ b/src/driver.mli @@ -245,3 +245,12 @@ val map_signature : signature -> signature val enable_checks : unit -> unit val enable_location_check : unit -> unit val disable_location_check : unit -> unit + +val load_input : + kind:Utils.Kind.t -> + input_name:string -> + relocate:bool -> + string -> + ( string * Utils.Ast_io.input_version * Utils.Intf_or_impl.t, + Location.Error.t * Utils.Ast_io.input_version ) + result diff --git a/src/pp_ast.ml b/src/pp_ast.ml new file mode 100644 index 000000000..920674f95 --- /dev/null +++ b/src/pp_ast.ml @@ -0,0 +1,154 @@ +open Import + +type simple_val = + | Unit + | Int of int + | String of string + | Bool of bool + | Char of char + | Array of simple_val list + | Float of float + | Int32 of int32 + | Int64 of int64 + | Nativeint of nativeint + | Record of (string * simple_val) list + | Constr of string * simple_val list + | Tuple of simple_val list + | List of simple_val list + | Special of string + +let pp_collection ~pp_elm ~open_ ~close ~sep fmt l = + match l with + | [] -> Format.fprintf fmt "%s%s" open_ close + | hd :: tl -> + Format.fprintf fmt "@[%s %a@," open_ pp_elm hd; + List.iter tl ~f:(fun sv -> Format.fprintf fmt "%s %a@," sep pp_elm sv); + Format.fprintf fmt "%s@]" close + +let rec pp_simple_val fmt simple_val = + match simple_val with + | Unit -> Format.fprintf fmt "()" + | Int i -> Format.fprintf fmt "%i" i + | String s -> Format.fprintf fmt "%S" s + | Special s -> Format.fprintf fmt "%s" s + | Bool b -> Format.fprintf fmt "%B" b + | Char c -> Format.fprintf fmt "%c" c + | Float f -> Format.fprintf fmt "%f" f + | Int32 i32 -> Format.fprintf fmt "%li" i32 + | Int64 i64 -> Format.fprintf fmt "%Li" i64 + | Nativeint ni -> Format.fprintf fmt "%ni" ni + | Array l -> + pp_collection ~pp_elm:pp_simple_val ~open_:"[|" ~close:"|]" ~sep:";" fmt l + | Tuple l -> + pp_collection ~pp_elm:pp_simple_val ~open_:"(" ~close:")" ~sep:"," fmt l + | List l -> + pp_collection ~pp_elm:pp_simple_val ~open_:"[" ~close:"]" ~sep:";" fmt l + | Record fields -> + pp_collection ~pp_elm:pp_field ~open_:"{" ~close:"}" ~sep:";" fmt fields + | Constr (cname, []) -> Format.fprintf fmt "%s" cname + | Constr (cname, [ (Constr (_, _ :: _) as x) ]) -> + Format.fprintf fmt "@[%s@ (%a)@]" cname pp_simple_val x + | Constr (cname, [ x ]) -> + Format.fprintf fmt "@[%s@ %a@]" cname pp_simple_val x + | Constr (cname, l) -> + Format.fprintf fmt "@[%s@ %a@]" cname pp_simple_val (Tuple l) + +and pp_field fmt (fname, simple_val) = + Format.fprintf fmt "@[%s =@ %a@]" fname pp_simple_val simple_val + +class lift_simple_val = + object (self) + inherit [simple_val] Ast_traverse.lift + method unit () = Unit + method int i = Int i + method string s = String s + method bool b = Bool b + method char c = Char c + method float f = Float f + method int32 i32 = Int32 i32 + method int64 i64 = Int64 i64 + method nativeint ni = Nativeint ni + method! list lift_a list = List (List.map ~f:lift_a list) + method tuple res_list = Tuple res_list + method record fields = Record fields + method constr ctr res_list = Constr (ctr, res_list) + + method array lift_a array = + Array (Array.map ~f:lift_a array |> Array.to_list) + + method other _a = Special "__" + method! location _loc = Special "__loc" + method! location_stack _ls = Special "__lstack" + method! position _p = Special "__pos" + method! attributes _a = Special "__attrs" + method! loc lift_a a_loc = lift_a a_loc.txt + method! core_type ct = self#core_type_desc ct.ptyp_desc + method! row_field rf = self#row_field_desc rf.prf_desc + method! object_field obf = self#object_field_desc obf.pof_desc + method! pattern pat = self#pattern_desc pat.ppat_desc + method! expression exp = self#expression_desc exp.pexp_desc + method! class_type cty = self#class_type_desc cty.pcty_desc + method! class_type_field ctf = self#class_type_field_desc ctf.pctf_desc + method! class_expr cl = self#class_expr_desc cl.pcl_desc + method! class_field cf = self#class_field_desc cf.pcf_desc + method! module_type mty = self#module_type_desc mty.pmty_desc + method! signature_item sigi = self#signature_item_desc sigi.psig_desc + method! module_expr mod_ = self#module_expr_desc mod_.pmod_desc + method! structure_item stri = self#structure_item_desc stri.pstr_desc + + method! directive_argument dira = + self#directive_argument_desc dira.pdira_desc + + method! rec_flag rec_flag = + match rec_flag with + | Nonrecursive -> Constr ("Nonrecursive", []) + | Recursive -> Constr ("Recursive", []) + + method! direction_flag direction_flag = + match direction_flag with + | Upto -> Constr ("Upto", []) + | Downto -> Constr ("Downto", []) + + method! private_flag private_flag = + match private_flag with + | Private -> Constr ("Private", []) + | Public -> Constr ("Public", []) + + method! mutable_flag mutable_flag = + match mutable_flag with + | Mutable -> Constr ("Mutable", []) + | Immutable -> Constr ("Immutable", []) + + method! virtual_flag virtual_flag = + match virtual_flag with + | Virtual -> Constr ("Virtual", []) + | Concrete -> Constr ("Concrete", []) + + method! override_flag override_flag = + match override_flag with + | Override -> Constr ("Override", []) + | Fresh -> Constr ("Fresh", []) + + method! closed_flag closed_flag = + match closed_flag with + | Closed -> Constr ("Closed", []) + | Open -> Constr ("Open", []) + + method! variance variance = + match variance with + | Covariant -> Constr ("Covariant", []) + | Contravariant -> Constr ("Contravariant", []) + | NoVariance -> Constr ("NoVariance", []) + + method! injectivity injectivity = + match injectivity with + | Injective -> Constr ("Injective", []) + | NoInjectivity -> Constr ("NoInjectivity", []) + end + +let lift_simple_val = new lift_simple_val +let structure fmt str = pp_simple_val fmt (lift_simple_val#structure str) +let signature fmt str = pp_simple_val fmt (lift_simple_val#signature str) +let expression fmt str = pp_simple_val fmt (lift_simple_val#expression str) +let pattern fmt str = pp_simple_val fmt (lift_simple_val#pattern str) +let core_type fmt str = pp_simple_val fmt (lift_simple_val#core_type str) diff --git a/src/pp_ast.mli b/src/pp_ast.mli new file mode 100644 index 000000000..3627fa5ff --- /dev/null +++ b/src/pp_ast.mli @@ -0,0 +1,7 @@ +open! Import + +val structure : Format.formatter -> structure -> unit +val signature : Format.formatter -> signature -> unit +val expression : Format.formatter -> expression -> unit +val pattern : Format.formatter -> pattern -> unit +val core_type : Format.formatter -> core_type -> unit diff --git a/src/ppxlib.ml b/src/ppxlib.ml index d354da578..f786e7187 100644 --- a/src/ppxlib.ml +++ b/src/ppxlib.ml @@ -36,6 +36,7 @@ module Expansion_helpers = Expansion_helpers module Merlin_helpers = Merlin_helpers module Spellcheck = Spellcheck module Keyword = Keyword +module Pp_ast = Pp_ast (** {2 Driver-related modules} *) From d68dfc311404efef3dc37c01bf786b1e9d2c5bdc Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 22 Aug 2024 13:26:00 +0200 Subject: [PATCH 02/17] Update CHANGES.md Signed-off-by: Nathan Rebours Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com> --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 27117023e..f14588a81 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -15,7 +15,7 @@ details. ### Other changes - Add ppxlib's AST pretty-printing utilities in `Ppxlib.Pp_ast` and - a `ppxlib-pp-ast` executable (#, @NathanReb) + a `ppxlib-pp-ast` executable (#517, @NathanReb) 0.33.0 (2024-07-22) ------------------- From 2d7f79c3f0d19c20afce2f42668041ebb9edf7a4 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 22 Aug 2024 17:48:32 +0200 Subject: [PATCH 03/17] Add simple tests for ppxlib-pp-ast Signed-off-by: Nathan Rebours --- test/ppxlib-pp-ast/basic/dune | 3 ++ test/ppxlib-pp-ast/basic/run.t | 77 ++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+) create mode 100644 test/ppxlib-pp-ast/basic/dune create mode 100644 test/ppxlib-pp-ast/basic/run.t diff --git a/test/ppxlib-pp-ast/basic/dune b/test/ppxlib-pp-ast/basic/dune new file mode 100644 index 000000000..3a84894c3 --- /dev/null +++ b/test/ppxlib-pp-ast/basic/dune @@ -0,0 +1,3 @@ +(cram + (deps + (package ppxlib))) diff --git a/test/ppxlib-pp-ast/basic/run.t b/test/ppxlib-pp-ast/basic/run.t new file mode 100644 index 000000000..e9f100830 --- /dev/null +++ b/test/ppxlib-pp-ast/basic/run.t @@ -0,0 +1,77 @@ +ppxlib-pp-ast is a simple utility to pretty-print the AST corresponding +to a given piece of source code or a marshalled AST. + +It can be used on regular .ml files: + + $ cat > test.ml << EOF + > let x = x + 2 + > EOF + $ ppxlib-pp-ast test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_ident (Lident "x")) + ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ] + ) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ] + +on .mli files: + + $ cat > test.mli << EOF + > val x : int + > EOF + $ ppxlib-pp-ast test.mli + [ Psig_value + { pval_name = "x" + ; pval_type = Ptyp_constr ( Lident "int", []) + ; pval_prim = [] + ; pval_attributes = __attrs + ; pval_loc = __loc + } + ] + +But it can also be used to pretty a single expression: + + $ ppxlib-pp-ast --exp - << EOF + > x + 2 + > EOF + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_ident (Lident "x")) + ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ] + ) + +on a single pattern: + + $ ppxlib-pp-ast --pat - << EOF + > (x, _::tl) + > EOF + Ppat_tuple + [ Ppat_var "x" + ; Ppat_construct + ( Lident "::", Some ( [], Ppat_tuple [ Ppat_any; Ppat_var "tl"])) + ] + +or on a single core_type: + + $ ppxlib-pp-ast --typ - << EOF + > (int * string) result + > EOF + Ptyp_constr + ( Lident "result" + , [ Ptyp_tuple + [ Ptyp_constr ( Lident "int", []) + ; Ptyp_constr ( Lident "string", []) + ] + ] + ) From 3946bf7fb1409e929aaa1a78c65dec1c6058e86d Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 22 Aug 2024 19:24:38 +0200 Subject: [PATCH 04/17] Add ways to configure whether attributes are shown by Pp_ast Signed-off-by: Nathan Rebours --- bin/pp_ast.ml | 19 +++-- src/pp_ast.ml | 128 +++++++++++++++++++++++----- src/pp_ast.mli | 30 +++++-- test/ppxlib-pp-ast/show-attrs/dune | 3 + test/ppxlib-pp-ast/show-attrs/run.t | 76 +++++++++++++++++ 5 files changed, 225 insertions(+), 31 deletions(-) create mode 100644 test/ppxlib-pp-ast/show-attrs/dune create mode 100644 test/ppxlib-pp-ast/show-attrs/run.t diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 5e888c89b..d8c0f31e3 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -45,16 +45,17 @@ let load_input ~kind ~input_name fn = | Intf sig_ -> Ast.Sig sig_)) | Expression | Pattern | Core_type -> parse_node ~kind ~input_name fn -let pp_ast ast = +let pp_ast ~config ast = match (ast : Ast.t) with - | Str str -> Pp_ast.structure Format.std_formatter str - | Sig sig_ -> Pp_ast.signature Format.std_formatter sig_ - | Exp exp -> Pp_ast.expression Format.std_formatter exp - | Pat pat -> Pp_ast.pattern Format.std_formatter pat - | Typ typ -> Pp_ast.core_type Format.std_formatter typ + | Str str -> Pp_ast.structure ~config Format.std_formatter str + | Sig sig_ -> Pp_ast.signature ~config Format.std_formatter sig_ + | Exp exp -> Pp_ast.expression ~config Format.std_formatter exp + | Pat pat -> Pp_ast.pattern ~config Format.std_formatter pat + | Typ typ -> Pp_ast.core_type ~config Format.std_formatter typ let input = ref None let kind = ref None +let show_attrs = ref false let set_input fn = match !input with @@ -86,6 +87,9 @@ let args = ( "--typ", Arg.Unit (fun () -> set_kind Kind.Core_type), " Treat the input as a single OCaml core_type" ); + ( "--show-attrs", + Arg.Set show_attrs, + "Show attributes in the pretty printed output" ); ] let main () = @@ -111,7 +115,8 @@ let main () = in let input_name = match fn with "-" -> "" | _ -> fn in let ast = load_input ~kind ~input_name fn in - pp_ast ast; + let config = Pp_ast.Config.make ~show_attrs:!show_attrs () in + pp_ast ~config ast; Format.printf "%!\n" let () = main () diff --git a/src/pp_ast.ml b/src/pp_ast.ml index 920674f95..b4e931190 100644 --- a/src/pp_ast.ml +++ b/src/pp_ast.ml @@ -1,5 +1,16 @@ open Import +module Config = struct + type t = { show_attrs : bool } + + module Default = struct + let show_attrs = false + end + + let default = { show_attrs = Default.show_attrs } + let make ?(show_attrs = Default.show_attrs) () = { show_attrs } +end + type simple_val = | Unit | Int of int @@ -58,7 +69,10 @@ and pp_field fmt (fname, simple_val) = class lift_simple_val = object (self) - inherit [simple_val] Ast_traverse.lift + inherit [simple_val] Ast_traverse.lift as super + val mutable config = Config.default + method set_config new_config = config <- new_config + method get_config () = config method unit () = Unit method int i = Int i method string s = String s @@ -80,21 +94,83 @@ class lift_simple_val = method! location _loc = Special "__loc" method! location_stack _ls = Special "__lstack" method! position _p = Special "__pos" - method! attributes _a = Special "__attrs" method! loc lift_a a_loc = lift_a a_loc.txt - method! core_type ct = self#core_type_desc ct.ptyp_desc - method! row_field rf = self#row_field_desc rf.prf_desc - method! object_field obf = self#object_field_desc obf.pof_desc - method! pattern pat = self#pattern_desc pat.ppat_desc - method! expression exp = self#expression_desc exp.pexp_desc - method! class_type cty = self#class_type_desc cty.pcty_desc - method! class_type_field ctf = self#class_type_field_desc ctf.pctf_desc - method! class_expr cl = self#class_expr_desc cl.pcl_desc - method! class_field cf = self#class_field_desc cf.pcf_desc - method! module_type mty = self#module_type_desc mty.pmty_desc - method! signature_item sigi = self#signature_item_desc sigi.psig_desc - method! module_expr mod_ = self#module_expr_desc mod_.pmod_desc + + method! attributes attrs = + match config.Config.show_attrs with + | false -> Special "__attrs" + | true -> super#attributes attrs + + method lift_record_with_desc + : 'record 'desc. + lift_desc:('desc -> simple_val) -> + lift_record:('record -> simple_val) -> + desc:'desc -> + attrs:attributes -> + 'record -> + simple_val = + fun ~lift_desc ~lift_record ~desc ~attrs x -> + match (config.show_attrs, attrs) with + | true, [] | false, _ -> lift_desc desc + | true, _ -> lift_record x + + method! core_type ct = + self#lift_record_with_desc ~lift_desc:self#core_type_desc + ~lift_record:super#core_type ~desc:ct.ptyp_desc + ~attrs:ct.ptyp_attributes ct + + method! row_field rf = + self#lift_record_with_desc ~lift_desc:self#row_field_desc + ~lift_record:super#row_field ~desc:rf.prf_desc ~attrs:rf.prf_attributes + rf + + method! object_field obf = + self#lift_record_with_desc ~lift_desc:self#object_field_desc + ~lift_record:super#object_field ~desc:obf.pof_desc + ~attrs:obf.pof_attributes obf + + method! pattern pat = + self#lift_record_with_desc ~lift_desc:self#pattern_desc + ~lift_record:super#pattern ~desc:pat.ppat_desc + ~attrs:pat.ppat_attributes pat + + method! expression exp = + self#lift_record_with_desc ~lift_desc:self#expression_desc + ~lift_record:super#expression ~desc:exp.pexp_desc + ~attrs:exp.pexp_attributes exp + + method! class_type cty = + self#lift_record_with_desc ~lift_desc:self#class_type_desc + ~lift_record:super#class_type ~desc:cty.pcty_desc + ~attrs:cty.pcty_attributes cty + + method! class_type_field ctf = + self#lift_record_with_desc ~lift_desc:self#class_type_field_desc + ~lift_record:super#class_type_field ~desc:ctf.pctf_desc + ~attrs:ctf.pctf_attributes ctf + + method! class_expr cl = + self#lift_record_with_desc ~lift_desc:self#class_expr_desc + ~lift_record:super#class_expr ~desc:cl.pcl_desc ~attrs:cl.pcl_attributes + cl + + method! class_field cf = + self#lift_record_with_desc ~lift_desc:self#class_field_desc + ~lift_record:super#class_field ~desc:cf.pcf_desc + ~attrs:cf.pcf_attributes cf + + method! module_type mty = + self#lift_record_with_desc ~lift_desc:self#module_type_desc + ~lift_record:super#module_type ~desc:mty.pmty_desc + ~attrs:mty.pmty_attributes mty + + method! module_expr mod_ = + self#lift_record_with_desc ~lift_desc:self#module_expr_desc + ~lift_record:super#module_expr ~desc:mod_.pmod_desc + ~attrs:mod_.pmod_attributes mod_ + method! structure_item stri = self#structure_item_desc stri.pstr_desc + method! signature_item sigi = self#signature_item_desc sigi.psig_desc method! directive_argument dira = self#directive_argument_desc dira.pdira_desc @@ -147,8 +223,22 @@ class lift_simple_val = end let lift_simple_val = new lift_simple_val -let structure fmt str = pp_simple_val fmt (lift_simple_val#structure str) -let signature fmt str = pp_simple_val fmt (lift_simple_val#signature str) -let expression fmt str = pp_simple_val fmt (lift_simple_val#expression str) -let pattern fmt str = pp_simple_val fmt (lift_simple_val#pattern str) -let core_type fmt str = pp_simple_val fmt (lift_simple_val#core_type str) + +type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit + +let with_config ~config ~f = + let old_config = lift_simple_val#get_config () in + lift_simple_val#set_config config; + let res = f () in + lift_simple_val#set_config old_config; + res + +let pp_with_config (type a) (lifter : a -> simple_val) + ?(config = Config.default) fmt (x : a) = + with_config ~config ~f:(fun () -> pp_simple_val fmt (lifter x)) + +let structure = pp_with_config lift_simple_val#structure +let signature = pp_with_config lift_simple_val#signature +let expression = pp_with_config lift_simple_val#expression +let pattern = pp_with_config lift_simple_val#pattern +let core_type = pp_with_config lift_simple_val#core_type diff --git a/src/pp_ast.mli b/src/pp_ast.mli index 3627fa5ff..7c6f8be30 100644 --- a/src/pp_ast.mli +++ b/src/pp_ast.mli @@ -1,7 +1,27 @@ open! Import -val structure : Format.formatter -> structure -> unit -val signature : Format.formatter -> signature -> unit -val expression : Format.formatter -> expression -> unit -val pattern : Format.formatter -> pattern -> unit -val core_type : Format.formatter -> core_type -> unit +module Config : sig + type t + (** Type for AST pretty-printing config *) + + val make : ?show_attrs:bool -> unit -> t + (** Create a custom pretty-printing config. + + Default values are the ones that are used when no configuration is passed + to the pretty-printers defined below. + + @param show_attrs + controls whether attributes are shown or hidden. It defaults to [false]. + When set to [true], records such as [expression] that have a [desc] + field will only be printed if the list of attributes is non-empty, + otherwise their [_desc] field will be printed directly instead, as it is + the case when [show_attrs] is [false]. *) +end + +type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit + +val structure : structure pp +val signature : signature pp +val expression : expression pp +val pattern : pattern pp +val core_type : core_type pp diff --git a/test/ppxlib-pp-ast/show-attrs/dune b/test/ppxlib-pp-ast/show-attrs/dune new file mode 100644 index 000000000..3a84894c3 --- /dev/null +++ b/test/ppxlib-pp-ast/show-attrs/dune @@ -0,0 +1,3 @@ +(cram + (deps + (package ppxlib))) diff --git a/test/ppxlib-pp-ast/show-attrs/run.t b/test/ppxlib-pp-ast/show-attrs/run.t new file mode 100644 index 000000000..5f6e94b94 --- /dev/null +++ b/test/ppxlib-pp-ast/show-attrs/run.t @@ -0,0 +1,76 @@ +ppxlib-pp-ast as a --show-attrs flag that controls whether attributes are shown + +Consider the following .ml file: + + $ cat > test.ml << EOF + > let x = 2 + (2[@foo 1]) + > [@@bar: int * string] + > EOF + +And how it's printed without the flag: + + $ ppxlib-pp-ast test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ] + ) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ] + +And with the flag: + + $ ppxlib-pp-ast --show-attrs test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ; ( Nolabel + , { pexp_desc = Pexp_constant (Pconst_integer ( "2", None)) + ; pexp_loc = __loc + ; pexp_loc_stack = __lstack + ; pexp_attributes = + [ { attr_name = "foo" + ; attr_payload = + PStr + [ Pstr_eval + ( Pexp_constant + (Pconst_integer ( "1", None)) + , [] + ) + ] + ; attr_loc = __loc + } + ] + } + ) + ] + ) + ; pvb_attributes = + [ { attr_name = "bar" + ; attr_payload = + PTyp + (Ptyp_tuple + [ Ptyp_constr ( Lident "int", []) + ; Ptyp_constr ( Lident "string", []) + ]) + ; attr_loc = __loc + } + ] + ; pvb_loc = __loc + } + ] + ) + ] From 82d9afc6224376fddb0616fcf433ca78e8b0f729 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Mon, 2 Sep 2024 11:32:17 +0200 Subject: [PATCH 05/17] Update bin/pp_ast.ml Signed-off-by: Nathan Rebours Co-authored-by: Patrick Ferris --- bin/pp_ast.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index d8c0f31e3..9df9187ac 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -64,7 +64,10 @@ let set_input fn = let set_kind k = match !kind with - | Some _ -> raise (Arg.Bad "must specify at most one of --impl or --intf") + | Some _ -> + raise + (Arg.Bad + "must specify at most one of --str, --sig, --exp, --pat or --typ") | _ -> kind := Some k let exe_name = Stdlib.Filename.basename Stdlib.Sys.executable_name From 0b77843e3bf000d1fa106cab92d688ae6696530e Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Wed, 4 Sep 2024 12:21:00 +0200 Subject: [PATCH 06/17] Expose Utils in Ppxlib_private Signed-off-by: Nathan Rebours --- bin/pp_ast.ml | 6 +++--- src/ppxlib.ml | 4 +++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 9df9187ac..f7f414d7e 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -4,8 +4,8 @@ module Kind = struct type t = Signature | Structure | Expression | Pattern | Core_type let to_utils_kind = function - | Structure -> Ppxlib__Utils.Kind.Impl - | Signature -> Ppxlib__Utils.Kind.Intf + | Structure -> Ppxlib_private.Utils.Kind.Impl + | Signature -> Ppxlib_private.Utils.Kind.Intf | _ -> assert false end @@ -40,7 +40,7 @@ let load_input ~kind ~input_name fn = match Driver.load_input ~kind ~input_name ~relocate:false fn with | Error (loc_err, _ver) -> Location.Error.raise loc_err | Ok (_ast_input_name, _version, ast) -> ( - match (ast : Ppxlib__Utils.Intf_or_impl.t) with + match (ast : Ppxlib_private.Utils.Intf_or_impl.t) with | Impl str -> Ast.Str str | Intf sig_ -> Ast.Sig sig_)) | Expression | Pattern | Core_type -> parse_node ~kind ~input_name fn diff --git a/src/ppxlib.ml b/src/ppxlib.ml index f786e7187..c7a9193b6 100644 --- a/src/ppxlib.ml +++ b/src/ppxlib.ml @@ -104,8 +104,10 @@ end (**/**) -(* For tests and Ppx_core compatibility layer *) +(* For tests, Ppx_core compatibility layer and use by ppxlib-pp-ast + and other internal tools. *) module Ppxlib_private = struct module Common = Common module Name = Name + module Utils = Utils end From 087698e1d7adb3aaab540abec49c7e9b28be3cf8 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 5 Sep 2024 17:40:36 +0200 Subject: [PATCH 07/17] Flatten ppxlib-pp-ast cram tests Signed-off-by: Nathan Rebours --- test/ppxlib-pp-ast/{basic/run.t => basic.t} | 0 test/ppxlib-pp-ast/{basic => }/dune | 0 test/ppxlib-pp-ast/{show-attrs/run.t => show-attrs.t} | 0 test/ppxlib-pp-ast/show-attrs/dune | 3 --- 4 files changed, 3 deletions(-) rename test/ppxlib-pp-ast/{basic/run.t => basic.t} (100%) rename test/ppxlib-pp-ast/{basic => }/dune (100%) rename test/ppxlib-pp-ast/{show-attrs/run.t => show-attrs.t} (100%) delete mode 100644 test/ppxlib-pp-ast/show-attrs/dune diff --git a/test/ppxlib-pp-ast/basic/run.t b/test/ppxlib-pp-ast/basic.t similarity index 100% rename from test/ppxlib-pp-ast/basic/run.t rename to test/ppxlib-pp-ast/basic.t diff --git a/test/ppxlib-pp-ast/basic/dune b/test/ppxlib-pp-ast/dune similarity index 100% rename from test/ppxlib-pp-ast/basic/dune rename to test/ppxlib-pp-ast/dune diff --git a/test/ppxlib-pp-ast/show-attrs/run.t b/test/ppxlib-pp-ast/show-attrs.t similarity index 100% rename from test/ppxlib-pp-ast/show-attrs/run.t rename to test/ppxlib-pp-ast/show-attrs.t diff --git a/test/ppxlib-pp-ast/show-attrs/dune b/test/ppxlib-pp-ast/show-attrs/dune deleted file mode 100644 index 3a84894c3..000000000 --- a/test/ppxlib-pp-ast/show-attrs/dune +++ /dev/null @@ -1,3 +0,0 @@ -(cram - (deps - (package ppxlib))) From 4cec4c28b9bae498327357b89ed229cb580cd048 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 5 Sep 2024 17:49:43 +0200 Subject: [PATCH 08/17] Add ways to configure whether locations are shown Signed-off-by: Nathan Rebours --- bin/pp_ast.ml | 13 +- src/pp_ast.ml | 54 +++- src/pp_ast.mli | 21 +- test/ppxlib-pp-ast/show-locs.t | 464 +++++++++++++++++++++++++++++++++ 4 files changed, 540 insertions(+), 12 deletions(-) create mode 100644 test/ppxlib-pp-ast/show-locs.t diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index f7f414d7e..112c8093a 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -56,6 +56,8 @@ let pp_ast ~config ast = let input = ref None let kind = ref None let show_attrs = ref false +let show_locs = ref false +let loc_mode = ref `Short let set_input fn = match !input with @@ -93,6 +95,12 @@ let args = ( "--show-attrs", Arg.Set show_attrs, "Show attributes in the pretty printed output" ); + ( "--show-locs", + Arg.Set show_locs, + "Show locations in the pretty printed output" ); + ( "--full-locs", + Arg.Unit (fun () -> loc_mode := `Full), + "Display locations in long form. Has no effect without --show-locs." ); ] let main () = @@ -118,7 +126,10 @@ let main () = in let input_name = match fn with "-" -> "" | _ -> fn in let ast = load_input ~kind ~input_name fn in - let config = Pp_ast.Config.make ~show_attrs:!show_attrs () in + let config = + Pp_ast.Config.make ~show_attrs:!show_attrs ~show_locs:!show_locs + ~loc_mode:!loc_mode () + in pp_ast ~config ast; Format.printf "%!\n" diff --git a/src/pp_ast.ml b/src/pp_ast.ml index b4e931190..338db8cfd 100644 --- a/src/pp_ast.ml +++ b/src/pp_ast.ml @@ -1,16 +1,26 @@ open Import module Config = struct - type t = { show_attrs : bool } + type loc_mode = [ `Short | `Full ] + type t = { show_attrs : bool; show_locs : bool; loc_mode : loc_mode } module Default = struct let show_attrs = false + let show_locs = false + let loc_mode = `Short end - let default = { show_attrs = Default.show_attrs } - let make ?(show_attrs = Default.show_attrs) () = { show_attrs } + let default = + let open Default in + { show_attrs; show_locs; loc_mode } + + let make ?(show_attrs = Default.show_attrs) ?(show_locs = Default.show_locs) + ?(loc_mode = Default.loc_mode) () = + { show_attrs; show_locs; loc_mode } end +let cnum (pos : Lexing.position) = pos.pos_cnum - pos.pos_bol + type simple_val = | Unit | Int of int @@ -91,10 +101,36 @@ class lift_simple_val = Array (Array.map ~f:lift_a array |> Array.to_list) method other _a = Special "__" - method! location _loc = Special "__loc" method! location_stack _ls = Special "__lstack" - method! position _p = Special "__pos" - method! loc lift_a a_loc = lift_a a_loc.txt + + method! position pos = + match (config.Config.show_locs, config.Config.loc_mode) with + | true, `Full -> super#position pos + | _, _ -> Special "__pos" + + method! loc lift_a a_loc = + match config.Config.show_locs with + | true -> super#loc lift_a a_loc + | false -> lift_a a_loc.txt + + method! location loc = + match (config.Config.show_locs, config.Config.loc_mode) with + | false, _ -> Special "__loc" + | true, `Full -> super#location loc + | true, `Short -> + let begin_line = loc.loc_start.pos_lnum in + let begin_char = cnum loc.loc_start in + let end_line = loc.loc_end.pos_lnum in + let end_char = cnum loc.loc_end in + let repr = + if Int.equal begin_line end_line then + Format.sprintf "l%ic%i..%i" begin_line begin_char end_char + else + Format.sprintf "l%ic%i..l%ic%i" begin_line begin_char end_line + end_char + in + let with_ghost = if loc.loc_ghost then repr ^ "(g)" else repr in + Special with_ghost method! attributes attrs = match config.Config.show_attrs with @@ -110,9 +146,9 @@ class lift_simple_val = 'record -> simple_val = fun ~lift_desc ~lift_record ~desc ~attrs x -> - match (config.show_attrs, attrs) with - | true, [] | false, _ -> lift_desc desc - | true, _ -> lift_record x + match (config.show_locs, config.show_attrs, attrs) with + | false, false, _ | false, true, [] -> lift_desc desc + | _, true, _ | true, _, _ -> lift_record x method! core_type ct = self#lift_record_with_desc ~lift_desc:self#core_type_desc diff --git a/src/pp_ast.mli b/src/pp_ast.mli index 7c6f8be30..61b98b8fb 100644 --- a/src/pp_ast.mli +++ b/src/pp_ast.mli @@ -4,7 +4,12 @@ module Config : sig type t (** Type for AST pretty-printing config *) - val make : ?show_attrs:bool -> unit -> t + val make : + ?show_attrs:bool -> + ?show_locs:bool -> + ?loc_mode:[ `Short | `Full ] -> + unit -> + t (** Create a custom pretty-printing config. Default values are the ones that are used when no configuration is passed @@ -15,7 +20,19 @@ module Config : sig When set to [true], records such as [expression] that have a [desc] field will only be printed if the list of attributes is non-empty, otherwise their [_desc] field will be printed directly instead, as it is - the case when [show_attrs] is [false]. *) + the case when [show_attrs] is [false]. + + @param show_loc + controls whether locations are shown or hidden. Defaults to [false]. + + @param loc_mode + controls how locations are shown if they are shown at + all. + - When set to [`Short], locations are displayed as ["l1c6..l2c2"] for + multiline locations and as ["l1c6..12"] for single line locations. + Ghost locations are suffixed with a ["(g)"]. + - When set to [`Full], locations are displayed as any other record would + be. Defaults to [`Short]. *) end type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit diff --git a/test/ppxlib-pp-ast/show-locs.t b/test/ppxlib-pp-ast/show-locs.t new file mode 100644 index 000000000..e5331c124 --- /dev/null +++ b/test/ppxlib-pp-ast/show-locs.t @@ -0,0 +1,464 @@ +ppxlib-pp-ast as a --show-loc flag that controls whether locations are shown + +Consider the following .ml file: + + $ cat > test.ml << EOF + > let x = 2 + > let y = true + > let z = + > fun x -> + > x + > EOF + +This is how it's printed without the flag: + + $ ppxlib-pp-ast test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None)) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "y" + ; pvb_expr = Pexp_construct ( Lident "true", None) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "z" + ; pvb_expr = + Pexp_fun ( Nolabel, None, Ppat_var "x", Pexp_ident (Lident "x")) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ] + +Now how it's printed with the flag: + + $ ppxlib-pp-ast --show-locs test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = + { ppat_desc = Ppat_var { txt = "x"; loc = l1c4..5} + ; ppat_loc = l1c4..5 + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ; pvb_expr = + { pexp_desc = Pexp_constant (Pconst_integer ( "2", None)) + ; pexp_loc = l1c8..9 + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ; pvb_attributes = __attrs + ; pvb_loc = l1c0..9 + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = + { ppat_desc = Ppat_var { txt = "y"; loc = l2c4..5} + ; ppat_loc = l2c4..5 + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ; pvb_expr = + { pexp_desc = + Pexp_construct + ( { txt = Lident "true"; loc = l2c8..12}, None) + ; pexp_loc = l2c8..12 + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ; pvb_attributes = __attrs + ; pvb_loc = l2c0..12 + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = + { ppat_desc = Ppat_var { txt = "z"; loc = l3c4..5} + ; ppat_loc = l3c4..5 + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ; pvb_expr = + { pexp_desc = + Pexp_fun + ( Nolabel + , None + , { ppat_desc = Ppat_var { txt = "x"; loc = l4c5..6} + ; ppat_loc = l4c5..6 + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + , { pexp_desc = + Pexp_ident { txt = Lident "x"; loc = l5c1..2} + ; pexp_loc = l5c1..2 + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ) + ; pexp_loc = l4c1..l5c2 + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ; pvb_attributes = __attrs + ; pvb_loc = l3c0..l5c2 + } + ] + ) + ] + +You can also pass an additional --full-locs flag to display location in their +original form as opposed to the default, condensed one shown above: + + $ ppxlib-pp-ast --show-locs --full-locs test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = + { ppat_desc = + Ppat_var + { txt = "x" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 4 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 5 + } + ; loc_ghost = false + } + } + ; ppat_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 4 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 5 + } + ; loc_ghost = false + } + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ; pvb_expr = + { pexp_desc = Pexp_constant (Pconst_integer ( "2", None)) + ; pexp_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 8 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 9 + } + ; loc_ghost = false + } + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ; pvb_attributes = __attrs + ; pvb_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 0 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 9 + } + ; loc_ghost = false + } + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = + { ppat_desc = + Ppat_var + { txt = "y" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 14 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 15 + } + ; loc_ghost = false + } + } + ; ppat_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 14 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 15 + } + ; loc_ghost = false + } + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ; pvb_expr = + { pexp_desc = + Pexp_construct + ( { txt = Lident "true" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 18 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 22 + } + ; loc_ghost = false + } + } + , None + ) + ; pexp_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 18 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 22 + } + ; loc_ghost = false + } + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ; pvb_attributes = __attrs + ; pvb_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 10 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 2 + ; pos_bol = 10 + ; pos_cnum = 22 + } + ; loc_ghost = false + } + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = + { ppat_desc = + Ppat_var + { txt = "z" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 3 + ; pos_bol = 23 + ; pos_cnum = 27 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 3 + ; pos_bol = 23 + ; pos_cnum = 28 + } + ; loc_ghost = false + } + } + ; ppat_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 3 + ; pos_bol = 23 + ; pos_cnum = 27 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 3 + ; pos_bol = 23 + ; pos_cnum = 28 + } + ; loc_ghost = false + } + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + ; pvb_expr = + { pexp_desc = + Pexp_fun + ( Nolabel + , None + , { ppat_desc = + Ppat_var + { txt = "x" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 36 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 37 + } + ; loc_ghost = false + } + } + ; ppat_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 36 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 37 + } + ; loc_ghost = false + } + ; ppat_loc_stack = __lstack + ; ppat_attributes = __attrs + } + , { pexp_desc = + Pexp_ident + { txt = Lident "x" + ; loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 42 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 43 + } + ; loc_ghost = false + } + } + ; pexp_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 42 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 43 + } + ; loc_ghost = false + } + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ) + ; pexp_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 4 + ; pos_bol = 31 + ; pos_cnum = 32 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 43 + } + ; loc_ghost = false + } + ; pexp_loc_stack = __lstack + ; pexp_attributes = __attrs + } + ; pvb_attributes = __attrs + ; pvb_loc = + { loc_start = + { pos_fname = "test.ml" + ; pos_lnum = 3 + ; pos_bol = 23 + ; pos_cnum = 23 + } + ; loc_end = + { pos_fname = "test.ml" + ; pos_lnum = 5 + ; pos_bol = 41 + ; pos_cnum = 43 + } + ; loc_ghost = false + } + } + ] + ) + ] From 6df5e1f0a9ed32db685fbd9436e9504c5c755888 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 5 Sep 2024 18:28:10 +0200 Subject: [PATCH 09/17] Improve Pp_ast's documentation Signed-off-by: Nathan Rebours --- src/pp_ast.mli | 61 +++++++++++++++++++++++++++++++++++--------------- 1 file changed, 43 insertions(+), 18 deletions(-) diff --git a/src/pp_ast.mli b/src/pp_ast.mli index 61b98b8fb..c8d4cbb9d 100644 --- a/src/pp_ast.mli +++ b/src/pp_ast.mli @@ -1,3 +1,36 @@ +(** This module implements pretty printers for the OCaml AST's version used by + ppxlib. + + Those pretty printers show the AST as its OCaml representation and do not + pretty print the corresponding source code. For printing ASTs as source code + use the {!Ppxlib.Pprintast} module instead. + + For example, calling [Pp_ast.expression Format.std_formatter [%expr x + 2]] + will print: + {v + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_ident (Lident "x")) + ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ] + ) + v} + + To keep the output easily readable, records with [_desc] fields such as + {!Ppxlib.Ast.type-expression} or {!Ppxlib.Ast.type-pattern} are not printed + as such and only the value of the corresponding [_desc] field is printed + instead. This prevents AST nodes metadata, such as locations or attributes, + from polluting the output, keeping it relatively concise and clean. The same + goes for {!Location.type-loc} values which are printed as the value of their + [txt] field. + + {!Location.t} and {!Ppxlib.Ast.attributes} are not displayed by default even + outside of the records mentioned above. + + The {!Config} module below allows to override part or all of this behaviour. + When configured to display locations or attributes, the entire record will + be displayed, not only its [_desc] field. *) + open! Import module Config : sig @@ -10,29 +43,21 @@ module Config : sig ?loc_mode:[ `Short | `Full ] -> unit -> t - (** Create a custom pretty-printing config. - - Default values are the ones that are used when no configuration is passed - to the pretty-printers defined below. - - @param show_attrs - controls whether attributes are shown or hidden. It defaults to [false]. - When set to [true], records such as [expression] that have a [desc] - field will only be printed if the list of attributes is non-empty, - otherwise their [_desc] field will be printed directly instead, as it is - the case when [show_attrs] is [false]. - - @param show_loc + (** Create a custom pretty-printing config. Default values are the ones that + are used when no configuration is passed to the pretty-printers defined in + {!Pp_ast}. + @param ?show_attrs + controls whether attributes are shown or hidden. Defaults to [false]. + @param ?show_loc controls whether locations are shown or hidden. Defaults to [false]. - - @param loc_mode - controls how locations are shown if they are shown at - all. + @param ?loc_mode + controls how locations are shown if they are shown at all. Defaults to + [`Short]. - When set to [`Short], locations are displayed as ["l1c6..l2c2"] for multiline locations and as ["l1c6..12"] for single line locations. Ghost locations are suffixed with a ["(g)"]. - When set to [`Full], locations are displayed as any other record would - be. Defaults to [`Short]. *) + be. *) end type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit From 258b4a7f86b556275c9059316d0ca285a26af4d9 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Fri, 6 Sep 2024 12:22:31 +0200 Subject: [PATCH 10/17] Expose Pp_ast.strucure_item and signature_item Signed-off-by: Nathan Rebours --- src/pp_ast.ml | 2 ++ src/pp_ast.mli | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/pp_ast.ml b/src/pp_ast.ml index 338db8cfd..d755854b4 100644 --- a/src/pp_ast.ml +++ b/src/pp_ast.ml @@ -274,7 +274,9 @@ let pp_with_config (type a) (lifter : a -> simple_val) with_config ~config ~f:(fun () -> pp_simple_val fmt (lifter x)) let structure = pp_with_config lift_simple_val#structure +let structure_item = pp_with_config lift_simple_val#structure_item let signature = pp_with_config lift_simple_val#signature +let signature_item = pp_with_config lift_simple_val#signature_item let expression = pp_with_config lift_simple_val#expression let pattern = pp_with_config lift_simple_val#pattern let core_type = pp_with_config lift_simple_val#core_type diff --git a/src/pp_ast.mli b/src/pp_ast.mli index c8d4cbb9d..ab66fdb34 100644 --- a/src/pp_ast.mli +++ b/src/pp_ast.mli @@ -63,7 +63,9 @@ end type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit val structure : structure pp +val structure_item : structure_item pp val signature : signature pp +val signature_item : signature_item pp val expression : expression pp val pattern : pattern pp val core_type : core_type pp From 12f57e2acc13a2ec4b05d41f140c3edfe4ec35dd Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Mon, 9 Sep 2024 15:21:23 +0200 Subject: [PATCH 11/17] Move ppxlib-pp-ast to a separate ppxlib-tools package Signed-off-by: Nathan Rebours --- bin/dune | 4 ++-- dune-project | 10 ++++++++++ ppxlib-tools.opam | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 46 insertions(+), 2 deletions(-) create mode 100644 ppxlib-tools.opam diff --git a/bin/dune b/bin/dune index 9f11573b4..ca8d6016f 100644 --- a/bin/dune +++ b/bin/dune @@ -1,5 +1,5 @@ (executable (name pp_ast) (public_name ppxlib-pp-ast) - (package ppxlib) - (libraries ppxlib ppxlib_ast astlib stdppx stdlib-shims)) + (package ppxlib-tools) + (libraries ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx stdlib-shims)) diff --git a/dune-project b/dune-project index d38312d21..28a8c7e51 100644 --- a/dune-project +++ b/dune-project @@ -45,6 +45,16 @@ ways of automatically traversing values of a given type, in particular allowing to inject a complex structured value into generated code. ")) +(package + (name ppxlib-tools) + (synopsis "Tools for PPX users and authors") + (description "Set of helper tools for PPX users and authors. + +ppxlib-pp-ast: Command line tool to pretty print OCaml ASTs in a human readable +format.") + (depends + (ppxlib (= :version)))) + (package (name ppxlib-bench) (synopsis "Run ppxlib benchmarks") diff --git a/ppxlib-tools.opam b/ppxlib-tools.opam new file mode 100644 index 000000000..cdcb90a61 --- /dev/null +++ b/ppxlib-tools.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Tools for PPX users and authors" +description: """ +Set of helper tools for PPX users and authors. + +ppxlib-pp-ast: Command line tool to pretty print OCaml ASTs in a human readable +format.""" +maintainer: ["opensource@janestreet.com"] +authors: ["Jane Street Group, LLC "] +license: "MIT" +homepage: "https://github.com/ocaml-ppx/ppxlib" +doc: "https://ocaml-ppx.github.io/ppxlib/" +bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" +depends: [ + "dune" {>= "2.7"} + "ppxlib" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git" From 3fee75e50a51e800b1b12dfe1cfdd228b12242d3 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 10 Sep 2024 10:50:13 +0200 Subject: [PATCH 12/17] Use cmdliner for ppxlib-pp-ast Signed-off-by: Nathan Rebours --- bin/dune | 3 +- bin/pp_ast.ml | 168 ++++++++++++++++++++++++---------------------- dune-project | 3 +- ppxlib-tools.opam | 1 + 4 files changed, 92 insertions(+), 83 deletions(-) diff --git a/bin/dune b/bin/dune index ca8d6016f..512b30f62 100644 --- a/bin/dune +++ b/bin/dune @@ -2,4 +2,5 @@ (name pp_ast) (public_name ppxlib-pp-ast) (package ppxlib-tools) - (libraries ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx stdlib-shims)) + (libraries cmdliner ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx + stdlib-shims)) diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 112c8093a..de36ab8a4 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -53,84 +53,90 @@ let pp_ast ~config ast = | Pat pat -> Pp_ast.pattern ~config Format.std_formatter pat | Typ typ -> Pp_ast.core_type ~config Format.std_formatter typ -let input = ref None -let kind = ref None -let show_attrs = ref false -let show_locs = ref false -let loc_mode = ref `Short - -let set_input fn = - match !input with - | None -> input := Some fn - | Some _ -> raise (Arg.Bad "too many input files") - -let set_kind k = - match !kind with - | Some _ -> - raise - (Arg.Bad - "must specify at most one of --str, --sig, --exp, --pat or --typ") - | _ -> kind := Some k - -let exe_name = Stdlib.Filename.basename Stdlib.Sys.executable_name - -let args = - [ - ("-", Arg.Unit (fun () -> set_input "-"), " Read input from stdin"); - ( "--str", - Arg.Unit (fun () -> set_kind Kind.Structure), - " Treat the input as a .ml file" ); - ( "--sig", - Arg.Unit (fun () -> set_kind Kind.Signature), - " Treat the input as a .mli file" ); - ( "--exp", - Arg.Unit (fun () -> set_kind Kind.Expression), - " Treat the input as a single OCaml expression" ); - ( "--pat", - Arg.Unit (fun () -> set_kind Kind.Pattern), - " Treat the input as a single OCaml pattern" ); - ( "--typ", - Arg.Unit (fun () -> set_kind Kind.Core_type), - " Treat the input as a single OCaml core_type" ); - ( "--show-attrs", - Arg.Set show_attrs, - "Show attributes in the pretty printed output" ); - ( "--show-locs", - Arg.Set show_locs, - "Show locations in the pretty printed output" ); - ( "--full-locs", - Arg.Unit (fun () -> loc_mode := `Full), - "Display locations in long form. Has no effect without --show-locs." ); - ] - -let main () = - let usage = Printf.sprintf "%s [extra_args] [/-]" exe_name in - Arg.parse (Arg.align args) set_input usage; - match !input with - | None -> - Printf.eprintf "%s: no input file given\n%!" exe_name; - Stdlib.exit 2 - | Some fn -> - let kind = - match !kind with - | Some k -> k - | None -> ( - match Ppxlib__Utils.Kind.of_filename fn with - | Some Intf -> Signature - | Some Impl -> Structure - | None -> - Printf.eprintf - "%s: Could not guess kind from filename %S\n\ - \ Please use relevant CLI flag" exe_name fn; - Stdlib.exit 2) - in - let input_name = match fn with "-" -> "" | _ -> fn in - let ast = load_input ~kind ~input_name fn in - let config = - Pp_ast.Config.make ~show_attrs:!show_attrs ~show_locs:!show_locs - ~loc_mode:!loc_mode () - in - pp_ast ~config ast; - Format.printf "%!\n" - -let () = main () +let named f = Cmdliner.Term.(app (const f)) + +let show_attrs = + let doc = "Show atributes in the pretty printed output" in + named + (fun x -> `Show_attrs x) + Cmdliner.Arg.(value & flag & info ~doc [ "show-attrs" ]) + +let show_locs = + let doc = "Show locations in the pretty printed output" in + named + (fun x -> `Show_locs x) + Cmdliner.Arg.(value & flag & info ~doc [ "show-locs" ]) + +let loc_mode = + let full_locs = + let doc = + "Display locations in long form. Has no effect without --show-locs." + in + (`Full, Cmdliner.Arg.info ~doc [ "full-locs" ]) + in + named (fun x -> `Loc_mode x) Cmdliner.Arg.(value & vflag `Short [ full_locs ]) + +let kind = + let make_vflag (flag, (kind : Kind.t), doc) = + (Some kind, Cmdliner.Arg.info ~doc [ flag ]) + in + let kinds = + List.map make_vflag + [ + ("str", Structure, "Treat the input as a $(b,.ml) file"); + ("sig", Signature, "Treat the input as a $(b,.mli) file"); + ("exp", Expression, "Treat the input as a single OCaml expression"); + ("pat", Pattern, "Treat the input as a single OCaml pattern"); + ("typ", Core_type, "Treat the input as a single OCaml core_type"); + ] + in + named (fun x -> `Kind x) Cmdliner.Arg.(value & vflag None kinds) + +let input = + let docv = "INPUT" in + let doc = + "The $(docv) AST. Can be a binary AST file or a source file. Pass $(b,-) \ + to read from stdin instead." + in + named + (fun x -> `Input x) + Cmdliner.Arg.(required & pos 0 (some string) None & info ~doc ~docv []) + +let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt + +let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode) + (`Kind kind) (`Input fn) = + let open Stdppx.Result in + let kind = + match kind with + | Some k -> Ok k + | None -> ( + match Ppxlib_private.Utils.Kind.of_filename fn with + | Some Intf -> Ok Kind.Signature + | Some Impl -> Ok Kind.Structure + | None -> + errorf + "Could not guess kind from input %S\n\ + \ Please use relevant CLI flag" fn) + in + kind >>= fun kind -> + let input_name = match fn with "-" -> "" | _ -> fn in + let ast = load_input ~kind ~input_name fn in + let config = Pp_ast.Config.make ~show_attrs ~show_locs ~loc_mode () in + pp_ast ~config ast; + Format.printf "%!\n"; + Ok () + +let tool_name = "ppxlib-pp-ast" + +let info = + let open Cmdliner in + Cmd.info tool_name ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults + ~doc:"Pretty prints ppxlib's versioned ASTs from OCaml sources" + +let term = + Cmdliner.Term.(const run $ show_attrs $ show_locs $ loc_mode $ kind $ input) + +let () = + let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in + exit exit_code diff --git a/dune-project b/dune-project index 28a8c7e51..f7f31903f 100644 --- a/dune-project +++ b/dune-project @@ -53,7 +53,8 @@ allowing to inject a complex structured value into generated code. ppxlib-pp-ast: Command line tool to pretty print OCaml ASTs in a human readable format.") (depends - (ppxlib (= :version)))) + (ppxlib (= :version)) + cmdliner)) (package (name ppxlib-bench) diff --git a/ppxlib-tools.opam b/ppxlib-tools.opam index cdcb90a61..9a0cde635 100644 --- a/ppxlib-tools.opam +++ b/ppxlib-tools.opam @@ -15,6 +15,7 @@ bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ "dune" {>= "2.7"} "ppxlib" {= version} + "cmdliner" "odoc" {with-doc} ] build: [ From b5a9201a9094ddabf1304b1bda2114ea332f941b Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 10 Sep 2024 11:26:59 +0200 Subject: [PATCH 13/17] Allow passing OCaml string to ppxlib-pp-ast directly Signed-off-by: Nathan Rebours --- bin/pp_ast.ml | 65 ++++++++++++++++++++++++++------------ test/ppxlib-pp-ast/dune | 1 + test/ppxlib-pp-ast/input.t | 38 ++++++++++++++++++++++ 3 files changed, 84 insertions(+), 20 deletions(-) create mode 100644 test/ppxlib-pp-ast/input.t diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index de36ab8a4..3b80eec9a 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -18,32 +18,53 @@ module Ast = struct | Typ of core_type end -let parse_node ~kind ~input_name fn = - let all_source = - match fn with - | "-" -> Stdppx.In_channel.input_all stdin - | _ -> Stdppx.In_channel.(with_file fn ~f:input_all) - in - let lexbuf = Lexing.from_string all_source in +module Input = struct + type t = Stdin | File of string | Source of string + + let to_lexbuf t = + let all_source = + match t with + | Stdin -> Stdppx.In_channel.input_all stdin + | File fn -> Stdppx.In_channel.(with_file fn ~f:input_all) + | Source s -> s + in + Lexing.from_string all_source + + let from_string = function + | "-" -> Stdin + | s when Sys.file_exists s -> File s + | s -> Source s + + let to_driver_fn = function + | Stdin -> "-" + | File fn -> fn + | Source _ -> assert false +end + +let parse_node ~kind ~input_name input = + let lexbuf = Input.to_lexbuf input in lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = input_name }; Astlib.Location.set_input_lexbuf (Some lexbuf); match (kind : Kind.t) with | Expression -> Ast.Exp (Parse.expression lexbuf) | Pattern -> Ast.Pat (Parse.pattern lexbuf) | Core_type -> Ast.Typ (Parse.core_type lexbuf) - | Signature | Structure -> assert false + | Signature -> Ast.Str (Parse.implementation lexbuf) + | Structure -> Ast.Sig (Parse.interface lexbuf) -let load_input ~kind ~input_name fn = - match (kind : Kind.t) with - | Structure | Signature -> ( +let load_input ~kind ~input_name input = + match ((kind : Kind.t), (input : Input.t)) with + | (Structure | Signature), (Stdin | File _) -> ( let kind = Kind.to_utils_kind kind in + let fn = Input.to_driver_fn input in match Driver.load_input ~kind ~input_name ~relocate:false fn with | Error (loc_err, _ver) -> Location.Error.raise loc_err | Ok (_ast_input_name, _version, ast) -> ( match (ast : Ppxlib_private.Utils.Intf_or_impl.t) with | Impl str -> Ast.Str str | Intf sig_ -> Ast.Sig sig_)) - | Expression | Pattern | Core_type -> parse_node ~kind ~input_name fn + | (Expression | Pattern | Core_type), _ | _, Source _ -> + parse_node ~kind ~input_name input let pp_ast ~config ast = match (ast : Ast.t) with @@ -95,8 +116,8 @@ let kind = let input = let docv = "INPUT" in let doc = - "The $(docv) AST. Can be a binary AST file or a source file. Pass $(b,-) \ - to read from stdin instead." + "The $(docv) AST. Can be a binary AST file, a source file or a valid OCaml \ + source string. Pass $(b,-) to read from stdin instead." in named (fun x -> `Input x) @@ -105,23 +126,27 @@ let input = let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode) - (`Kind kind) (`Input fn) = + (`Kind kind) (`Input input) = let open Stdppx.Result in let kind = match kind with | Some k -> Ok k | None -> ( - match Ppxlib_private.Utils.Kind.of_filename fn with + match Ppxlib_private.Utils.Kind.of_filename input with | Some Intf -> Ok Kind.Signature | Some Impl -> Ok Kind.Structure | None -> errorf - "Could not guess kind from input %S\n\ - \ Please use relevant CLI flag" fn) + "Could not guess kind from input %S. Please use relevant CLI \ + flag." + input) in kind >>= fun kind -> - let input_name = match fn with "-" -> "" | _ -> fn in - let ast = load_input ~kind ~input_name fn in + let input = Input.from_string input in + let input_name = + match input with Stdin -> "" | File fn -> fn | Source _ -> "" + in + let ast = load_input ~kind ~input_name input in let config = Pp_ast.Config.make ~show_attrs ~show_locs ~loc_mode () in pp_ast ~config ast; Format.printf "%!\n"; diff --git a/test/ppxlib-pp-ast/dune b/test/ppxlib-pp-ast/dune index 3a84894c3..22266e261 100644 --- a/test/ppxlib-pp-ast/dune +++ b/test/ppxlib-pp-ast/dune @@ -1,3 +1,4 @@ (cram (deps + ../../bin/pp_ast.exe (package ppxlib))) diff --git a/test/ppxlib-pp-ast/input.t b/test/ppxlib-pp-ast/input.t new file mode 100644 index 000000000..1728a94c9 --- /dev/null +++ b/test/ppxlib-pp-ast/input.t @@ -0,0 +1,38 @@ +ppxlib-pp-ast can be used on files but it can also read from stdin: + + $ cat > test.ml << EOF + > let x = x + 2 + > EOF + $ cat test.ml | ppxlib-pp-ast --str - + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_ident (Lident "x")) + ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ] + ) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ] + +It can also read the input directly from the command line: + + $ ppxlib-pp-ast --exp "x + 2" + Pexp_apply + ( Pexp_ident (Lident "+") + , [ ( Nolabel, Pexp_ident (Lident "x")) + ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None))) + ] + ) + +Note that the kind must be specified when the input is not a file: + + $ ppxlib-pp-ast "x + 2" + ppxlib-pp-ast: Could not guess kind from input "x + 2". Please use relevant CLI flag. + [123] From 4429c424328c94c30ab43b96c5faa7a14ffe40b4 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 10 Sep 2024 14:39:24 +0200 Subject: [PATCH 14/17] Add a manual page to ppxlib-pp-ast Signed-off-by: Nathan Rebours --- bin/pp_ast.ml | 60 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 56 insertions(+), 4 deletions(-) diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 3b80eec9a..4312586b3 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -152,15 +152,67 @@ let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode) Format.printf "%!\n"; Ok () +let term = + Cmdliner.Term.(const run $ show_attrs $ show_locs $ loc_mode $ kind $ input) + let tool_name = "ppxlib-pp-ast" let info = + let p fmt = Printf.ksprintf (fun s -> `P s) fmt in let open Cmdliner in Cmd.info tool_name ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults - ~doc:"Pretty prints ppxlib's versioned ASTs from OCaml sources" - -let term = - Cmdliner.Term.(const run $ show_attrs $ show_locs $ loc_mode $ kind $ input) + ~doc:"Pretty prints ppxlib's ASTs from OCaml sources" + ~man: + [ + `S "DESCRIPTION"; + p + "$(b,%s) can be used to pretty print the OCaml AST for a given piece \ + of source code." + tool_name; + `P + "It prints the AST version used by ppxlib internally. This means the \ + code will be parsed (or the AST unmarshalled) using the installed \ + compiler and eventually migrated to ppxlib's expected version."; + `P + "It can read the source code directly from the command line or read \ + it from a file/the standard input. In the latter case you can pass \ + regular $(b,.ml) or $(b,.mli) files, marshalled AST files as the \ + ones produced by the ppxlib driver or a fragment of OCaml source \ + corresponding to an expression, a pattern or a core_type."; + `P + "When the input is not an $(b,.ml) or $(b,.mli) file you will have \ + to explicitly pass the expected AST node using flags such as \ + $(b,--str) or $(b,--exp)."; + `P "By default the output looks like this:"; + p "$(b,\\$ %s --exp \"x + 2\")" tool_name; + `Noblank; + `Pre + (String.concat "\n" + [ + {|Pexp_apply|}; + {| ( Pexp_ident (Lident "+")|}; + {| , [ ( Nolabel, Pexp_ident (Lident "x"))|}; + {| ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None)))|}; + {| ]|}; + {| )|}; + ]); + `P + "If you are already familiar with the OCaml AST you will note that \ + it prints a somewhat lighter version to keep the output concise. \ + Locations and attributes are not printed. Some specific record \ + types, such as $(b,expression) or $(b,pattern), are \"skipped\" to \ + avoid too much nesting. This does not hurt comprehension of the \ + underlying AST as these records only wrap a variant type to attach \ + metadata to it. The tool supports a set of flags you can use to \ + force printing of such metadata."; + `S "EXAMPLES"; + p "$(b,%s test.ml)" tool_name; + p "$(b,cat test.ml | %s -)" tool_name; + p "$(b,%s test.pp.ml)" tool_name; + p "$(b,%s --exp \"x + 2\")" tool_name; + p "$(b,%s --typ \"(int, string\\) Result.t\")" tool_name; + p "$(b,%s --show-locs --full-locs --pat \"_::tl\")" tool_name; + ] let () = let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in From 00d08f574a6fbf07d1a2d80eb256d58f4f4f4881 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 10 Sep 2024 14:51:09 +0200 Subject: [PATCH 15/17] Adjust deps for ppxlib-tools Signed-off-by: Nathan Rebours --- CHANGES.md | 3 ++- bin/dune | 3 +-- dune-project | 3 ++- ppxlib-tools.opam | 3 ++- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index f14588a81..bbdeb261d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -15,7 +15,8 @@ details. ### Other changes - Add ppxlib's AST pretty-printing utilities in `Ppxlib.Pp_ast` and - a `ppxlib-pp-ast` executable (#517, @NathanReb) + a `ppxlib-pp-ast` executable in a new separate `ppxlib-tools` package + (#517, @NathanReb) 0.33.0 (2024-07-22) ------------------- diff --git a/bin/dune b/bin/dune index 512b30f62..02d3b8452 100644 --- a/bin/dune +++ b/bin/dune @@ -2,5 +2,4 @@ (name pp_ast) (public_name ppxlib-pp-ast) (package ppxlib-tools) - (libraries cmdliner ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx - stdlib-shims)) + (libraries cmdliner ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx)) diff --git a/dune-project b/dune-project index f7f31903f..06244e5b4 100644 --- a/dune-project +++ b/dune-project @@ -53,8 +53,9 @@ allowing to inject a complex structured value into generated code. ppxlib-pp-ast: Command line tool to pretty print OCaml ASTs in a human readable format.") (depends + (ocaml (>= 4.08.0)) (ppxlib (= :version)) - cmdliner)) + (cmdliner (>= 1.3.0)))) (package (name ppxlib-bench) diff --git a/ppxlib-tools.opam b/ppxlib-tools.opam index 9a0cde635..14d64a9ec 100644 --- a/ppxlib-tools.opam +++ b/ppxlib-tools.opam @@ -14,8 +14,9 @@ doc: "https://ocaml-ppx.github.io/ppxlib/" bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ "dune" {>= "2.7"} + "ocaml" {>= "4.08.0"} "ppxlib" {= version} - "cmdliner" + "cmdliner" {>= "1.3.0"} "odoc" {with-doc} ] build: [ From f37ab1ac1b016c367702f9ed13e39847fcad6de3 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 10 Sep 2024 14:58:12 +0200 Subject: [PATCH 16/17] Attach ppxlib-pp-ast tests to the ppxlib-tools package Signed-off-by: Nathan Rebours --- dune-project | 3 +-- ppxlib-bench.opam | 2 +- ppxlib-tools.opam | 2 +- ppxlib.opam | 2 +- test/driver/exception_handling/dune | 24 ++++++++++++++----- .../dune | 8 +++++-- test/ppxlib-pp-ast/dune | 1 + 7 files changed, 29 insertions(+), 13 deletions(-) diff --git a/dune-project b/dune-project index 06244e5b4..c28b331c5 100644 --- a/dune-project +++ b/dune-project @@ -1,7 +1,6 @@ -(lang dune 2.7) +(lang dune 2.8) (name ppxlib) (using cinaps 1.0) -(allow_approximate_merlin) (implicit_transitive_deps false) (cram enable) (generate_opam_files true) diff --git a/ppxlib-bench.opam b/ppxlib-bench.opam index ec0248b25..5a7d77b5a 100644 --- a/ppxlib-bench.opam +++ b/ppxlib-bench.opam @@ -12,7 +12,7 @@ homepage: "https://github.com/ocaml-ppx/ppxlib" doc: "https://ocaml-ppx.github.io/ppxlib/" bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ - "dune" {>= "2.7"} + "dune" {>= "2.8"} "ocaml" {>= "4.04.1"} "ppxlib" {= version} "base" diff --git a/ppxlib-tools.opam b/ppxlib-tools.opam index 14d64a9ec..ca7b046d8 100644 --- a/ppxlib-tools.opam +++ b/ppxlib-tools.opam @@ -13,7 +13,7 @@ homepage: "https://github.com/ocaml-ppx/ppxlib" doc: "https://ocaml-ppx.github.io/ppxlib/" bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ - "dune" {>= "2.7"} + "dune" {>= "2.8"} "ocaml" {>= "4.08.0"} "ppxlib" {= version} "cmdliner" {>= "1.3.0"} diff --git a/ppxlib.opam b/ppxlib.opam index f05698c3b..25ebe0c05 100644 --- a/ppxlib.opam +++ b/ppxlib.opam @@ -20,7 +20,7 @@ homepage: "https://github.com/ocaml-ppx/ppxlib" doc: "https://ocaml-ppx.github.io/ppxlib/" bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ - "dune" {>= "2.7"} + "dune" {>= "2.8"} "ocaml" {>= "4.04.1" & < "5.4.0"} "ocaml-compiler-libs" {>= "v0.11.0"} "ppx_derivers" {>= "1.0"} diff --git a/test/driver/exception_handling/dune b/test/driver/exception_handling/dune index f37c12864..787595803 100644 --- a/test/driver/exception_handling/dune +++ b/test/driver/exception_handling/dune @@ -1,10 +1,22 @@ (executables - (names whole_file_exception whole_file_extension_point - whole_file_located_error extender deriver whole_file_multiple_errors - constant_type special_functions) + (names + whole_file_exception + whole_file_extension_point + whole_file_located_error + extender + deriver + whole_file_multiple_errors + constant_type + special_functions) (libraries ppxlib)) (cram - (deps extender.exe whole_file_exception.exe whole_file_located_error.exe - deriver.exe whole_file_extension_point.exe whole_file_multiple_errors.exe - constant_type.exe special_functions.exe)) + (deps + extender.exe + whole_file_exception.exe + whole_file_located_error.exe + deriver.exe + whole_file_extension_point.exe + whole_file_multiple_errors.exe + constant_type.exe + special_functions.exe)) diff --git a/test/driver/ocaml-ppx-context-load-path-migration/dune b/test/driver/ocaml-ppx-context-load-path-migration/dune index e55826656..bed007080 100644 --- a/test/driver/ocaml-ppx-context-load-path-migration/dune +++ b/test/driver/ocaml-ppx-context-load-path-migration/dune @@ -2,8 +2,12 @@ (name driver) (enabled_if (>= %{ocaml_version} "5.2")) - (libraries ppxlib ppxlib.ast ppxlib.astlib ocaml-compiler-libs.common - compiler-libs.common)) + (libraries + ppxlib + ppxlib.ast + ppxlib.astlib + ocaml-compiler-libs.common + compiler-libs.common)) (cram (enabled_if diff --git a/test/ppxlib-pp-ast/dune b/test/ppxlib-pp-ast/dune index 22266e261..da51e6044 100644 --- a/test/ppxlib-pp-ast/dune +++ b/test/ppxlib-pp-ast/dune @@ -1,4 +1,5 @@ (cram + (package ppxlib-tools) (deps ../../bin/pp_ast.exe (package ppxlib))) From 4cfa347e59b58ab1da1672bcf144c6d2099a4dee Mon Sep 17 00:00:00 2001 From: pedrobslisboa Date: Fri, 20 Sep 2024 17:11:22 +0200 Subject: [PATCH 17/17] Add json mapper for pp_ast --- bin/pp_ast.ml | 11 +- src/dune | 1 + src/pp_ast.ml | 44 +++- src/pp_ast.mli | 1 + test/ppxlib-pp-ast/json.t | 463 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 512 insertions(+), 8 deletions(-) create mode 100644 test/ppxlib-pp-ast/json.t diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 4312586b3..23e21d21c 100644 --- a/bin/pp_ast.ml +++ b/bin/pp_ast.ml @@ -97,6 +97,10 @@ let loc_mode = in named (fun x -> `Loc_mode x) Cmdliner.Arg.(value & vflag `Short [ full_locs ]) +let json = + let doc = "Show AST as json" in + named (fun x -> `Json x) Cmdliner.Arg.(value & flag & info ~doc [ "json" ]) + let kind = let make_vflag (flag, (kind : Kind.t), doc) = (Some kind, Cmdliner.Arg.info ~doc [ flag ]) @@ -126,7 +130,7 @@ let input = let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode) - (`Kind kind) (`Input input) = + (`Json json) (`Kind kind) (`Input input) = let open Stdppx.Result in let kind = match kind with @@ -147,13 +151,14 @@ let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode) match input with Stdin -> "" | File fn -> fn | Source _ -> "" in let ast = load_input ~kind ~input_name input in - let config = Pp_ast.Config.make ~show_attrs ~show_locs ~loc_mode () in + let config = Pp_ast.Config.make ~show_attrs ~show_locs ~loc_mode ~json () in pp_ast ~config ast; Format.printf "%!\n"; Ok () let term = - Cmdliner.Term.(const run $ show_attrs $ show_locs $ loc_mode $ kind $ input) + Cmdliner.Term.( + const run $ show_attrs $ show_locs $ loc_mode $ json $ kind $ input) let tool_name = "ppxlib-pp-ast" diff --git a/src/dune b/src/dune index a9152b2a3..e0eef2f28 100644 --- a/src/dune +++ b/src/dune @@ -9,6 +9,7 @@ ppx_derivers ppxlib_traverse_builtins stdppx + yojson stdlib-shims sexplib0) (flags diff --git a/src/pp_ast.ml b/src/pp_ast.ml index d755854b4..5b7f7b160 100644 --- a/src/pp_ast.ml +++ b/src/pp_ast.ml @@ -2,21 +2,28 @@ open Import module Config = struct type loc_mode = [ `Short | `Full ] - type t = { show_attrs : bool; show_locs : bool; loc_mode : loc_mode } + + type t = { + show_attrs : bool; + show_locs : bool; + loc_mode : loc_mode; + json : bool; + } module Default = struct let show_attrs = false let show_locs = false let loc_mode = `Short + let json = false end let default = let open Default in - { show_attrs; show_locs; loc_mode } + { show_attrs; show_locs; loc_mode; json } let make ?(show_attrs = Default.show_attrs) ?(show_locs = Default.show_locs) - ?(loc_mode = Default.loc_mode) () = - { show_attrs; show_locs; loc_mode } + ?(json = Default.json) ?(loc_mode = Default.loc_mode) () = + { show_attrs; show_locs; loc_mode; json } end let cnum (pos : Lexing.position) = pos.pos_cnum - pos.pos_bol @@ -77,6 +84,29 @@ let rec pp_simple_val fmt simple_val = and pp_field fmt (fname, simple_val) = Format.fprintf fmt "@[%s =@ %a@]" fname pp_simple_val simple_val +let rec pp_simple_val_to_yojson = function + | Unit -> `String "null" + | Int i -> `Int i + | String s -> `String s + | Bool b -> `Bool b + | Char c -> `String (String.make 1 c) + | Array l -> `List (List.map ~f:pp_simple_val_to_yojson l) + | Float f -> `Float f + | Int32 i32 -> `Int (Int32.to_int i32) + | Int64 i64 -> `Int (Int64.to_int i64) + | Nativeint ni -> `Int (Nativeint.to_int ni) + | Record fields -> + `Assoc (List.map ~f:(fun (k, v) -> (k, pp_simple_val_to_yojson v)) fields) + | Constr (cname, []) -> `String cname + | Constr (cname, [ (Constr (_, _ :: _) as x) ]) -> + `Assoc [ (cname, pp_simple_val_to_yojson x) ] + | Constr (cname, [ x ]) -> `Assoc [ (cname, pp_simple_val_to_yojson x) ] + | Constr (cname, l) -> + `Assoc [ (cname, `List (List.map ~f:pp_simple_val_to_yojson l)) ] + | Tuple l -> `List (List.map ~f:pp_simple_val_to_yojson l) + | List l -> `List (List.map ~f:pp_simple_val_to_yojson l) + | Special s -> `String s + class lift_simple_val = object (self) inherit [simple_val] Ast_traverse.lift as super @@ -271,7 +301,11 @@ let with_config ~config ~f = let pp_with_config (type a) (lifter : a -> simple_val) ?(config = Config.default) fmt (x : a) = - with_config ~config ~f:(fun () -> pp_simple_val fmt (lifter x)) + with_config ~config ~f:(fun () -> + if config.json then + Format.fprintf fmt "%s" + (Yojson.pretty_to_string (pp_simple_val_to_yojson (lifter x))) + else pp_simple_val fmt (lifter x)) let structure = pp_with_config lift_simple_val#structure let structure_item = pp_with_config lift_simple_val#structure_item diff --git a/src/pp_ast.mli b/src/pp_ast.mli index ab66fdb34..7f8fe4f09 100644 --- a/src/pp_ast.mli +++ b/src/pp_ast.mli @@ -40,6 +40,7 @@ module Config : sig val make : ?show_attrs:bool -> ?show_locs:bool -> + ?json:bool -> ?loc_mode:[ `Short | `Full ] -> unit -> t diff --git a/test/ppxlib-pp-ast/json.t b/test/ppxlib-pp-ast/json.t new file mode 100644 index 000000000..703e37ca2 --- /dev/null +++ b/test/ppxlib-pp-ast/json.t @@ -0,0 +1,463 @@ +ppxlib-pp-ast as a --json flag that pretty prints the AST in JSON format. + +Consider the following .ml file: + + $ cat > test.ml << EOF + > let x = 2 + > let y = true + > let z = + > fun x -> + > x + > EOF + +This is how it's printed without the flag: + + $ ppxlib-pp-ast test.ml + [ Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "x" + ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None)) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "y" + ; pvb_expr = Pexp_construct ( Lident "true", None) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ; Pstr_value + ( Nonrecursive + , [ { pvb_pat = Ppat_var "z" + ; pvb_expr = + Pexp_fun ( Nolabel, None, Ppat_var "x", Pexp_ident (Lident "x")) + ; pvb_attributes = __attrs + ; pvb_loc = __loc + } + ] + ) + ] + +Now how it's printed with the flag: + + $ ppxlib-pp-ast --json test.ml + [ + { + "Pstr_value": [ + "Nonrecursive", + [ + { + "pvb_pat": { "Ppat_var": "x" }, + "pvb_expr": { + "Pexp_constant": { "Pconst_integer": [ "2", "None" ] } + }, + "pvb_attributes": "__attrs", + "pvb_loc": "__loc" + } + ] + ] + }, + { + "Pstr_value": [ + "Nonrecursive", + [ + { + "pvb_pat": { "Ppat_var": "y" }, + "pvb_expr": { "Pexp_construct": [ { "Lident": "true" }, "None" ] }, + "pvb_attributes": "__attrs", + "pvb_loc": "__loc" + } + ] + ] + }, + { + "Pstr_value": [ + "Nonrecursive", + [ + { + "pvb_pat": { "Ppat_var": "z" }, + "pvb_expr": { + "Pexp_fun": [ + "Nolabel", + "None", + { "Ppat_var": "x" }, + { "Pexp_ident": { "Lident": "x" } } + ] + }, + "pvb_attributes": "__attrs", + "pvb_loc": "__loc" + } + ] + ] + } + ] + +You can compase with other flags, for example --show-locs to display location: + + $ ppxlib-pp-ast --json --show-locs --full-locs test.ml + [ + { + "Pstr_value": [ + "Nonrecursive", + [ + { + "pvb_pat": { + "ppat_desc": { + "Ppat_var": { + "txt": "x", + "loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 4 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 5 + }, + "loc_ghost": false + } + } + }, + "ppat_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 4 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 5 + }, + "loc_ghost": false + }, + "ppat_loc_stack": "__lstack", + "ppat_attributes": "__attrs" + }, + "pvb_expr": { + "pexp_desc": { + "Pexp_constant": { "Pconst_integer": [ "2", "None" ] } + }, + "pexp_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 8 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 9 + }, + "loc_ghost": false + }, + "pexp_loc_stack": "__lstack", + "pexp_attributes": "__attrs" + }, + "pvb_attributes": "__attrs", + "pvb_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 0 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 1, + "pos_bol": 0, + "pos_cnum": 9 + }, + "loc_ghost": false + } + } + ] + ] + }, + { + "Pstr_value": [ + "Nonrecursive", + [ + { + "pvb_pat": { + "ppat_desc": { + "Ppat_var": { + "txt": "y", + "loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 14 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 15 + }, + "loc_ghost": false + } + } + }, + "ppat_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 14 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 15 + }, + "loc_ghost": false + }, + "ppat_loc_stack": "__lstack", + "ppat_attributes": "__attrs" + }, + "pvb_expr": { + "pexp_desc": { + "Pexp_construct": [ + { + "txt": { "Lident": "true" }, + "loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 18 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 22 + }, + "loc_ghost": false + } + }, + "None" + ] + }, + "pexp_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 18 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 22 + }, + "loc_ghost": false + }, + "pexp_loc_stack": "__lstack", + "pexp_attributes": "__attrs" + }, + "pvb_attributes": "__attrs", + "pvb_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 10 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 2, + "pos_bol": 10, + "pos_cnum": 22 + }, + "loc_ghost": false + } + } + ] + ] + }, + { + "Pstr_value": [ + "Nonrecursive", + [ + { + "pvb_pat": { + "ppat_desc": { + "Ppat_var": { + "txt": "z", + "loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 3, + "pos_bol": 23, + "pos_cnum": 27 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 3, + "pos_bol": 23, + "pos_cnum": 28 + }, + "loc_ghost": false + } + } + }, + "ppat_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 3, + "pos_bol": 23, + "pos_cnum": 27 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 3, + "pos_bol": 23, + "pos_cnum": 28 + }, + "loc_ghost": false + }, + "ppat_loc_stack": "__lstack", + "ppat_attributes": "__attrs" + }, + "pvb_expr": { + "pexp_desc": { + "Pexp_fun": [ + "Nolabel", + "None", + { + "ppat_desc": { + "Ppat_var": { + "txt": "x", + "loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 4, + "pos_bol": 31, + "pos_cnum": 36 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 4, + "pos_bol": 31, + "pos_cnum": 37 + }, + "loc_ghost": false + } + } + }, + "ppat_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 4, + "pos_bol": 31, + "pos_cnum": 36 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 4, + "pos_bol": 31, + "pos_cnum": 37 + }, + "loc_ghost": false + }, + "ppat_loc_stack": "__lstack", + "ppat_attributes": "__attrs" + }, + { + "pexp_desc": { + "Pexp_ident": { + "txt": { "Lident": "x" }, + "loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 5, + "pos_bol": 41, + "pos_cnum": 42 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 5, + "pos_bol": 41, + "pos_cnum": 43 + }, + "loc_ghost": false + } + } + }, + "pexp_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 5, + "pos_bol": 41, + "pos_cnum": 42 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 5, + "pos_bol": 41, + "pos_cnum": 43 + }, + "loc_ghost": false + }, + "pexp_loc_stack": "__lstack", + "pexp_attributes": "__attrs" + } + ] + }, + "pexp_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 4, + "pos_bol": 31, + "pos_cnum": 32 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 5, + "pos_bol": 41, + "pos_cnum": 43 + }, + "loc_ghost": false + }, + "pexp_loc_stack": "__lstack", + "pexp_attributes": "__attrs" + }, + "pvb_attributes": "__attrs", + "pvb_loc": { + "loc_start": { + "pos_fname": "test.ml", + "pos_lnum": 3, + "pos_bol": 23, + "pos_cnum": 23 + }, + "loc_end": { + "pos_fname": "test.ml", + "pos_lnum": 5, + "pos_bol": 41, + "pos_cnum": 43 + }, + "loc_ghost": false + } + } + ] + ] + } + ]