Add json mapper for pp_ast

Signed-off-by: pedrobslisboa <[email protected]>

bin/dune

@@ -2,4 +2,4 @@
  (name pp_ast)
  (public_name ppxlib-pp-ast)
  (package ppxlib-tools)
- (libraries cmdliner ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx))
+ (libraries cmdliner ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx yojson))

bin/pp_ast.ml

@@ -74,6 +74,14 @@ 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 pp_ast_json ~config ast =
+  match (ast : Ast.t) with
+  | Str str -> Yojson.Basic.to_string (Pp_ast.structure_json ~config str)
+  | Sig sig_ -> Yojson.Basic.to_string (Pp_ast.signature_json ~config sig_)
+  | Exp exp -> Yojson.Basic.to_string (Pp_ast.expression_json ~config exp)
+  | Pat pat -> Yojson.Basic.to_string (Pp_ast.pattern_json ~config pat)
+  | Typ typ -> Yojson.Basic.to_string (Pp_ast.core_type_json ~config typ)
+
 let named f = Cmdliner.Term.(app (const f))
 
 let show_attrs =
@@ -97,6 +105,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 +138,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
@@ -148,12 +160,14 @@ let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode)
   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;
+  if json then Format.printf "%s\n" (pp_ast_json ~config ast)
+  else 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/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,15 @@ type simple_val =
   | List of simple_val list
   | Special of string
 
+type json =
+  [ `Null
+  | `Bool of bool
+  | `Int of int
+  | `Float of float
+  | `String of string
+  | `Assoc of (string * json) list
+  | `List of json list ]
+
 let pp_collection ~pp_elm ~open_ ~close ~sep fmt l =
   match l with
   | [] -> Format.fprintf fmt "%s%s" open_ close
@@ -97,6 +113,28 @@ class lift_simple_val =
     method record fields = Record fields
     method constr ctr res_list = Constr (ctr, res_list)
 
+    method to_json (sv : simple_val) : json =
+      match sv with
+      | Unit -> `Null
+      | Int i -> `Int i
+      | String s -> `String s
+      | Special s -> `String s
+      | Bool b -> `Bool b
+      | Char c -> `String (String.make 1 c)
+      | 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)
+      | Array l -> `List (List.map ~f:self#to_json l)
+      | Tuple l -> `List (List.map ~f:self#to_json l)
+      | List l -> `List (List.map ~f:self#to_json l)
+      | Record fields ->
+          `Assoc (List.map fields ~f:(fun (k, v) -> (k, self#to_json v)))
+      | Constr (cname, []) -> `String cname
+      | Constr (cname, [ x ]) -> `Assoc [ (cname, self#to_json x) ]
+      | Constr (cname, l) ->
+          `Assoc [ (cname, `List (List.map ~f:self#to_json l)) ]
+
     method array lift_a array =
       Array (Array.map ~f:lift_a array |> Array.to_list)
 
@@ -261,6 +299,7 @@ class lift_simple_val =
 let lift_simple_val = new lift_simple_val
 
 type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit
+type 'node to_json = ?config:Config.t -> 'node -> json
 
 let with_config ~config ~f =
   let old_config = lift_simple_val#get_config () in
@@ -280,3 +319,26 @@ 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
+
+let to_json_with_config (type a) (lifter : a -> simple_val) ?(config = Config.default) x =
+  with_config ~config ~f:(fun () -> lift_simple_val#to_json (lifter x))
+
+let structure_json  =
+  to_json_with_config lift_simple_val#structure
+
+let structure_item_json =
+  to_json_with_config lift_simple_val#structure_item
+
+let signature_json =
+  to_json_with_config lift_simple_val#signature
+
+let signature_item_json =
+  to_json_with_config lift_simple_val#signature_item
+
+let expression_json =
+  to_json_with_config lift_simple_val#expression
+
+let pattern_json = to_json_with_config lift_simple_val#pattern
+
+let core_type_json =
+  to_json_with_config lift_simple_val#core_type

src/pp_ast.mli

@@ -33,13 +33,23 @@
 
 open! Import
 
+type json =
+  [ `Null
+  | `Bool of bool
+  | `Int of int
+  | `Float of float
+  | `String of string
+  | `Assoc of (string * json) list
+  | `List of json list ]
+
 module Config : sig
   type t
   (** Type for AST pretty-printing config *)
 
   val make :
     ?show_attrs:bool ->
     ?show_locs:bool ->
+    ?json:bool ->
     ?loc_mode:[ `Short | `Full ] ->
     unit ->
     t
@@ -61,6 +71,7 @@ module Config : sig
 end
 
 type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit
+type 'node to_json = ?config:Config.t -> 'node -> json
 
 val structure : structure pp
 val structure_item : structure_item pp
@@ -69,3 +80,12 @@ val signature_item : signature_item pp
 val expression : expression pp
 val pattern : pattern pp
 val core_type : core_type pp
+
+val structure_json : structure to_json
+val structure_item_json : structure_item to_json
+val signature_json : signature to_json
+val signature_item_json : signature_item to_json
+val expression_json : expression to_json
+val pattern_json : pattern to_json
+val core_type_json : core_type to_json
+