Add json mapper for pp_ast

Signed-off-by: Pedro B S Lisboa <[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

@@ -18,6 +18,29 @@ module Ast = struct
     | Typ of core_type
 end
 
+let rec simple_val_to_yojson : Pp_ast.simple_val -> Yojson.Basic.t = function
+  | 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 simple_val_to_yojson l)
+  | Tuple l -> `List (List.map simple_val_to_yojson l)
+  | List l -> `List (List.map simple_val_to_yojson l)
+  | Record fields ->
+      `Assoc (List.map (fun (k, v) -> (k, simple_val_to_yojson v)) fields)
+  | Constr (cname, []) -> `String cname
+  | Constr (cname, [ x ]) -> `Assoc [ (cname, simple_val_to_yojson x) ]
+  | Constr (cname, l) ->
+      `Assoc [ (cname, `List (List.map simple_val_to_yojson l)) ]
+
+let json_printer fmt value = Yojson.Basic.pp fmt (simple_val_to_yojson value)
+
 module Input = struct
   type t = Stdin | File of string | Source of string
 
@@ -66,13 +89,13 @@ let load_input ~kind ~input_name input =
   | (Expression | Pattern | Core_type), _ | _, Source _ ->
       parse_node ~kind ~input_name input
 
-let pp_ast ~config ast =
+let pp_ast ~config ?printer ast =
   match (ast : Ast.t) with
-  | 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
+  | Str str -> Pp_ast.structure ~config ?printer Format.std_formatter str
+  | Sig sig_ -> Pp_ast.signature ~config ?printer Format.std_formatter sig_
+  | Exp exp -> Pp_ast.expression ~config ?printer Format.std_formatter exp
+  | Pat pat -> Pp_ast.pattern ~config ?printer Format.std_formatter pat
+  | Typ typ -> Pp_ast.core_type ~config ?printer Format.std_formatter typ
 
 let named f = Cmdliner.Term.(app (const f))
 
@@ -97,6 +120,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 +153,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 +175,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;
+  let custom_printer = if json then Some json_printer else None in
+  pp_ast ~config ?printer:custom_printer 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

@@ -46,7 +46,10 @@ let pp_collection ~pp_elm ~open_ ~close ~sep fmt l =
       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 =
+type printer = Format.formatter -> simple_val -> unit
+
+let rec pp_simple_val : printer =
+ fun fmt simple_val ->
   match simple_val with
   | Unit -> Format.fprintf fmt "()"
   | Int i -> Format.fprintf fmt "%i" i
@@ -303,30 +306,30 @@ class lift_simple_val =
   end
 
 type 'a pp = Format.formatter -> 'a -> unit
-type 'a configurable = ?config:Config.t -> 'a pp
+type 'a configurable = ?config:Config.t -> ?printer:printer -> 'a pp
 type 'a configured = 'a pp
 
 module type S = sig
-  type 'a printer
-
-  val structure : structure printer
-  val structure_item : structure_item printer
-  val signature : signature printer
-  val signature_item : signature_item printer
-  val expression : expression printer
-  val pattern : pattern printer
-  val core_type : core_type printer
+  type 'a ast_printer
+
+  val structure : structure ast_printer
+  val structure_item : structure_item ast_printer
+  val signature : signature ast_printer
+  val signature_item : signature_item ast_printer
+  val expression : expression ast_printer
+  val pattern : pattern ast_printer
+  val core_type : core_type ast_printer
 end
 
 module type Conf = sig
   val config : Config.t
 end
 
-module type Configured = S with type 'a printer = 'a configured
-module type Configurable = S with type 'a printer = 'a configurable
+module type Configured = S with type 'a ast_printer = 'a configured
+module type Configurable = S with type 'a ast_printer = 'a configurable
 
 module Make (Conf : Conf) : Configured = struct
-  type 'a printer = 'a configured
+  type 'a ast_printer = 'a configured
 
   let lsv =
     let lift_simple_val = new lift_simple_val in
@@ -351,7 +354,7 @@ module Default = Make (struct
   let config = Config.default
 end)
 
-type 'a printer = 'a configurable
+type 'a ast_printer = 'a configurable
 
 let lift_simple_val = new lift_simple_val
 
@@ -363,8 +366,8 @@ let with_config ~config ~f =
   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))
+    ?(config = Config.default) ?(printer = pp_simple_val) fmt (x : a) =
+  with_config ~config ~f:(fun () -> printer 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

@@ -60,28 +60,49 @@ module Config : sig
           be. *)
 end
 
+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
+
+type printer = Format.formatter -> simple_val -> unit
+
+val pp_simple_val : printer
+
 type 'a pp = Format.formatter -> 'a -> unit
-type 'a configurable = ?config:Config.t -> 'a pp
+type 'a configurable = ?config:Config.t -> ?printer:printer -> 'a pp
 type 'a configured = 'a pp
 
 module type S = sig
-  type 'a printer
-
-  val structure : structure printer
-  val structure_item : structure_item printer
-  val signature : signature printer
-  val signature_item : signature_item printer
-  val expression : expression printer
-  val pattern : pattern printer
-  val core_type : core_type printer
+  type 'a ast_printer
+
+  val structure : structure ast_printer
+  val structure_item : structure_item ast_printer
+  val signature : signature ast_printer
+  val signature_item : signature_item ast_printer
+  val expression : expression ast_printer
+  val pattern : pattern ast_printer
+  val core_type : core_type ast_printer
 end
 
 module type Conf = sig
   val config : Config.t
 end
 
-module type Configured = S with type 'a printer = 'a configured
-module type Configurable = S with type 'a printer = 'a configurable
+module type Configured = S with type 'a ast_printer = 'a configured
+module type Configurable = S with type 'a ast_printer = 'a configurable
 
 module Make (Conf : Conf) : Configured [@@ocaml.warning "-67"]
 

test.ml

@@ -0,0 +1 @@
+let foo = "x"