From a60d33c91ef1b87056d97482fda568a6f1c849fc 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/dune | 1 + src/pp_ast.ml | 44 +++- src/pp_ast.mli | 1 + test/ppxlib-pp-ast/json.t | 463 ++++++++++++++++++++++++++++++++++++++ 7 files changed, 514 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/dune-project b/dune-project index 14cfdd732..c99d66bc2 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 729d62d6c..fb723f96a 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/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 + } + } + ] + ] + } + ]