From ccbaed998c2dae24bd73ec76068703af8f7eded7 Mon Sep 17 00:00:00 2001 From: pedrobslisboa Date: Fri, 20 Sep 2024 17:11:22 +0200 Subject: [PATCH] Add json mapper for pp_ast Signed-off-by: pedrobslisboa --- bin/pp_ast.ml | 11 +- dune-project | 1 + ppxlib.opam | 1 + src/pp_ast.ml | 71 +++++- src/pp_ast.mli | 1 + test/ppxlib-pp-ast/json.t | 496 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 573 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 4312586b..23e21d21 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/dune-project b/dune-project index 14cfdd73..c99d66bc 100644 --- a/dune-project +++ b/dune-project @@ -22,6 +22,7 @@ (sexplib0 (>= v0.12)) (sexplib0 (and :with-test (>= "v0.15"))) ; Printexc.register_printer in sexplib0 changed stdlib-shims + yojson (ocamlfind :with-test) (re (and :with-test (>= 1.9.0))) (cinaps (and :with-test (>= v0.12.1))) diff --git a/ppxlib.opam b/ppxlib.opam index 729d62d6..fb723f96 100644 --- a/ppxlib.opam +++ b/ppxlib.opam @@ -27,6 +27,7 @@ depends: [ "sexplib0" {>= "v0.12"} "sexplib0" {with-test & >= "v0.15"} "stdlib-shims" + "yojson" "ocamlfind" {with-test} "re" {with-test & >= "1.9.0"} "cinaps" {with-test & >= "v0.12.1"} diff --git a/src/pp_ast.ml b/src/pp_ast.ml index d755854b..fbaef36a 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 @@ -38,6 +45,58 @@ type simple_val = | List of simple_val list | Special of string +let pp_simple_val_to_json fmt simple_val = + let rec aux indent fmt simple_val = + match simple_val with + | Unit -> Format.fprintf fmt {|"null"|} + | Int i -> Format.fprintf fmt "%d" 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 "%ld" i32 + | Int64 i64 -> Format.fprintf fmt "%Ld" i64 + | Nativeint ni -> Format.fprintf fmt "%nd" ni + | Array l | Tuple l | List l -> + Format.fprintf fmt "[\n"; + List.iteri + ~f:(fun i sv -> + if i > 0 then Format.fprintf fmt ",\n"; + Format.fprintf fmt "%s" (String.make (indent + 2) ' '); + aux (indent + 2) fmt sv) + l; + Format.fprintf fmt "\n%s]" (String.make indent ' ') + | Record fields -> + Format.fprintf fmt "{\n"; + List.iteri + ~f:(fun i (k, v) -> + if i > 0 then Format.fprintf fmt ",\n"; + Format.fprintf fmt "%s\"%s\": " (String.make (indent + 2) ' ') k; + aux (indent + 2) fmt v) + fields; + Format.fprintf fmt "\n%s}" (String.make indent ' ') + | Constr (cname, []) -> Format.fprintf fmt {|"%s"|} cname + | Constr (cname, [ (Constr (_, _ :: _) as x) ]) -> + Format.fprintf fmt "{\n%s\"%s\": " (String.make (indent + 2) ' ') cname; + aux (indent + 2) fmt x; + Format.fprintf fmt "\n%s}" (String.make indent ' ') + | Constr (cname, [ x ]) -> + Format.fprintf fmt "{\n%s\"%s\": " (String.make (indent + 2) ' ') cname; + aux (indent + 2) fmt x; + Format.fprintf fmt "\n%s}" (String.make indent ' ') + | Constr (cname, l) -> + Format.fprintf fmt "{\n%s\"%s\": [\n" (String.make (indent + 2) ' ') cname; + List.iteri + ~f:(fun i sv -> + if i > 0 then Format.fprintf fmt ",\n"; + Format.fprintf fmt "%s" (String.make (indent + 4) ' '); + aux (indent + 4) fmt sv) + l; + Format.fprintf fmt "\n%s]\n%s}" (String.make (indent + 2) ' ') (String.make indent ' ') + in + aux 0 fmt simple_val + let pp_collection ~pp_elm ~open_ ~close ~sep fmt l = match l with | [] -> Format.fprintf fmt "%s%s" open_ close @@ -271,7 +330,9 @@ 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 pp_simple_val_to_json fmt (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 ab66fdb3..7f8fe4f0 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 00000000..675d3b54 --- /dev/null +++ b/test/ppxlib-pp-ast/json.t @@ -0,0 +1,496 @@ +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 + } + } + ] + ] + } + ]