Add json mapper for pp_ast

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 -> "<stdin>" | File fn -> fn | Source _ -> "<cli>"
   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"
 

src/dune

@@ -9,6 +9,7 @@
   ppx_derivers
   ppxlib_traverse_builtins
   stdppx
+  yojson
   stdlib-shims
   sexplib0)
  (flags

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 "@[<hv 2>%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

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