Add json mapper for pp_ast

CHANGES.md

@@ -14,6 +14,10 @@ details.
 
 ### Other changes
 
+- Add ppxlib's AST pretty-printing utilities in `Ppxlib.Pp_ast` and
+  a `ppxlib-pp-ast` executable in a new separate `ppxlib-tools` package
+  (#517, @NathanReb)
+
 0.33.0 (2024-07-22)
 -------------------
 

bin/dune

@@ -0,0 +1,5 @@
+(executable
+ (name pp_ast)
+ (public_name ppxlib-pp-ast)
+ (package ppxlib-tools)
+ (libraries cmdliner ppxlib ppxlib.ast ppxlib.astlib ppxlib.stdppx))

bin/pp_ast.ml

@@ -0,0 +1,224 @@
+open Ppxlib
+
+module Kind = struct
+  type t = Signature | Structure | Expression | Pattern | Core_type
+
+  let to_utils_kind = function
+    | Structure -> Ppxlib_private.Utils.Kind.Impl
+    | Signature -> Ppxlib_private.Utils.Kind.Intf
+    | _ -> assert false
+end
+
+module Ast = struct
+  type t =
+    | Str of structure
+    | Sig of signature
+    | Exp of expression
+    | Pat of pattern
+    | Typ of core_type
+end
+
+module Input = struct
+  type t = Stdin | File of string | Source of string
+
+  let to_lexbuf t =
+    let all_source =
+      match t with
+      | Stdin -> Stdppx.In_channel.input_all stdin
+      | File fn -> Stdppx.In_channel.(with_file fn ~f:input_all)
+      | Source s -> s
+    in
+    Lexing.from_string all_source
+
+  let from_string = function
+    | "-" -> Stdin
+    | s when Sys.file_exists s -> File s
+    | s -> Source s
+
+  let to_driver_fn = function
+    | Stdin -> "-"
+    | File fn -> fn
+    | Source _ -> assert false
+end
+
+let parse_node ~kind ~input_name input =
+  let lexbuf = Input.to_lexbuf input in
+  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = input_name };
+  Astlib.Location.set_input_lexbuf (Some lexbuf);
+  match (kind : Kind.t) with
+  | Expression -> Ast.Exp (Parse.expression lexbuf)
+  | Pattern -> Ast.Pat (Parse.pattern lexbuf)
+  | Core_type -> Ast.Typ (Parse.core_type lexbuf)
+  | Signature -> Ast.Str (Parse.implementation lexbuf)
+  | Structure -> Ast.Sig (Parse.interface lexbuf)
+
+let load_input ~kind ~input_name input =
+  match ((kind : Kind.t), (input : Input.t)) with
+  | (Structure | Signature), (Stdin | File _) -> (
+      let kind = Kind.to_utils_kind kind in
+      let fn = Input.to_driver_fn input in
+      match Driver.load_input ~kind ~input_name ~relocate:false fn with
+      | Error (loc_err, _ver) -> Location.Error.raise loc_err
+      | Ok (_ast_input_name, _version, ast) -> (
+          match (ast : Ppxlib_private.Utils.Intf_or_impl.t) with
+          | Impl str -> Ast.Str str
+          | Intf sig_ -> Ast.Sig sig_))
+  | (Expression | Pattern | Core_type), _ | _, Source _ ->
+      parse_node ~kind ~input_name input
+
+let pp_ast ~config 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
+
+let named f = Cmdliner.Term.(app (const f))
+
+let show_attrs =
+  let doc = "Show atributes in the pretty printed output" in
+  named
+    (fun x -> `Show_attrs x)
+    Cmdliner.Arg.(value & flag & info ~doc [ "show-attrs" ])
+
+let show_locs =
+  let doc = "Show locations in the pretty printed output" in
+  named
+    (fun x -> `Show_locs x)
+    Cmdliner.Arg.(value & flag & info ~doc [ "show-locs" ])
+
+let loc_mode =
+  let full_locs =
+    let doc =
+      "Display locations in long form. Has no effect without --show-locs."
+    in
+    (`Full, Cmdliner.Arg.info ~doc [ "full-locs" ])
+  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 ])
+  in
+  let kinds =
+    List.map make_vflag
+      [
+        ("str", Structure, "Treat the input as a $(b,.ml) file");
+        ("sig", Signature, "Treat the input as a $(b,.mli) file");
+        ("exp", Expression, "Treat the input as a single OCaml expression");
+        ("pat", Pattern, "Treat the input as a single OCaml pattern");
+        ("typ", Core_type, "Treat the input as a single OCaml core_type");
+      ]
+  in
+  named (fun x -> `Kind x) Cmdliner.Arg.(value & vflag None kinds)
+
+let input =
+  let docv = "INPUT" in
+  let doc =
+    "The $(docv) AST. Can be a binary AST file, a source file or a valid OCaml \
+     source string. Pass $(b,-) to read from stdin instead."
+  in
+  named
+    (fun x -> `Input x)
+    Cmdliner.Arg.(required & pos 0 (some string) None & info ~doc ~docv [])
+
+let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt
+
+let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode)
+    (`Json json) (`Kind kind) (`Input input) =
+  let open Stdppx.Result in
+  let kind =
+    match kind with
+    | Some k -> Ok k
+    | None -> (
+        match Ppxlib_private.Utils.Kind.of_filename input with
+        | Some Intf -> Ok Kind.Signature
+        | Some Impl -> Ok Kind.Structure
+        | None ->
+            errorf
+              "Could not guess kind from input %S. Please use relevant CLI \
+               flag."
+              input)
+  in
+  kind >>= fun kind ->
+  let input = Input.from_string input in
+  let input_name =
+    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 ~json () in
+  pp_ast ~config ast;
+  Format.printf "%!\n";
+  Ok ()
+
+let term =
+  Cmdliner.Term.(
+    const run $ show_attrs $ show_locs $ loc_mode $ json $ kind $ input)
+
+let tool_name = "ppxlib-pp-ast"
+
+let info =
+  let p fmt = Printf.ksprintf (fun s -> `P s) fmt in
+  let open Cmdliner in
+  Cmd.info tool_name ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults
+    ~doc:"Pretty prints ppxlib's ASTs from OCaml sources"
+    ~man:
+      [
+        `S "DESCRIPTION";
+        p
+          "$(b,%s) can be used to pretty print the OCaml AST for a given piece \
+           of source code."
+          tool_name;
+        `P
+          "It prints the AST version used by ppxlib internally. This means the \
+           code will be parsed (or the AST unmarshalled) using the installed \
+           compiler and eventually migrated to ppxlib's expected version.";
+        `P
+          "It can read the source code directly from the command line or read \
+           it from a file/the standard input. In the latter case you can pass \
+           regular $(b,.ml) or $(b,.mli) files, marshalled AST files as the \
+           ones produced by the ppxlib driver or a fragment of OCaml source \
+           corresponding to an expression, a pattern or a core_type.";
+        `P
+          "When the input is not an $(b,.ml) or $(b,.mli) file you will have \
+           to explicitly pass the expected AST node using flags such as \
+           $(b,--str) or $(b,--exp).";
+        `P "By default the output looks like this:";
+        p "$(b,\\$ %s --exp \"x + 2\")" tool_name;
+        `Noblank;
+        `Pre
+          (String.concat "\n"
+             [
+               {|Pexp_apply|};
+               {|  ( Pexp_ident (Lident "+")|};
+               {|  , [ ( Nolabel, Pexp_ident (Lident "x"))|};
+               {|    ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None)))|};
+               {|    ]|};
+               {|  )|};
+             ]);
+        `P
+          "If you are already familiar with the OCaml AST you will note that \
+           it prints a somewhat lighter version to keep the output concise. \
+           Locations and attributes are not printed. Some specific record \
+           types, such as $(b,expression) or $(b,pattern), are \"skipped\" to \
+           avoid too much nesting. This does not hurt comprehension of the \
+           underlying AST as these records only wrap a variant type to attach \
+           metadata to it. The tool supports a set of flags you can use to \
+           force printing of such metadata.";
+        `S "EXAMPLES";
+        p "$(b,%s test.ml)" tool_name;
+        p "$(b,cat test.ml | %s -)" tool_name;
+        p "$(b,%s test.pp.ml)" tool_name;
+        p "$(b,%s --exp \"x + 2\")" tool_name;
+        p "$(b,%s --typ \"(int, string\\) Result.t\")" tool_name;
+        p "$(b,%s --show-locs --full-locs --pat \"_::tl\")" tool_name;
+      ]
+
+let () =
+  let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in
+  exit exit_code

dune-project

@@ -1,7 +1,6 @@
-(lang dune 2.7)
+(lang dune 2.8)
 (name ppxlib)
 (using cinaps 1.0)
-(allow_approximate_merlin)
 (implicit_transitive_deps false)
 (cram enable)
 (generate_opam_files true)
@@ -45,6 +44,18 @@ ways of automatically traversing values of a given type, in particular
 allowing to inject a complex structured value into generated code.
 "))
 
+(package
+ (name ppxlib-tools)
+ (synopsis "Tools for PPX users and authors")
+ (description "Set of helper tools for PPX users and authors.
+
+ppxlib-pp-ast: Command line tool to pretty print OCaml ASTs in a human readable
+format.")
+ (depends
+  (ocaml (>= 4.08.0))
+  (ppxlib (= :version))
+  (cmdliner (>= 1.3.0))))
+
 (package
  (name ppxlib-bench)
  (synopsis "Run ppxlib benchmarks")

ppxlib-bench.opam

@@ -12,7 +12,7 @@ homepage: "https://github.com/ocaml-ppx/ppxlib"
 doc: "https://ocaml-ppx.github.io/ppxlib/"
 bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues"
 depends: [
-  "dune" {>= "2.7"}
+  "dune" {>= "2.8"}
   "ocaml" {>= "4.04.1"}
   "ppxlib" {= version}
   "base"

ppxlib-tools.opam

@@ -0,0 +1,36 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Tools for PPX users and authors"
+description: """
+Set of helper tools for PPX users and authors.
+
+ppxlib-pp-ast: Command line tool to pretty print OCaml ASTs in a human readable
+format."""
+maintainer: ["[email protected]"]
+authors: ["Jane Street Group, LLC <[email protected]>"]
+license: "MIT"
+homepage: "https://github.com/ocaml-ppx/ppxlib"
+doc: "https://ocaml-ppx.github.io/ppxlib/"
+bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues"
+depends: [
+  "dune" {>= "2.8"}
+  "ocaml" {>= "4.08.0"}
+  "ppxlib" {= version}
+  "cmdliner" {>= "1.3.0"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git"

ppxlib.opam

@@ -20,7 +20,7 @@ homepage: "https://github.com/ocaml-ppx/ppxlib"
 doc: "https://ocaml-ppx.github.io/ppxlib/"
 bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues"
 depends: [
-  "dune" {>= "2.7"}
+  "dune" {>= "2.8"}
   "ocaml" {>= "4.04.1" & < "5.4.0"}
   "ocaml-compiler-libs" {>= "v0.11.0"}
   "ppx_derivers" {>= "1.0"}

src/driver.mli

@@ -245,3 +245,12 @@ val map_signature : signature -> signature
 val enable_checks : unit -> unit
 val enable_location_check : unit -> unit
 val disable_location_check : unit -> unit
+
+val load_input :
+  kind:Utils.Kind.t ->
+  input_name:string ->
+  relocate:bool ->
+  string ->
+  ( string * Utils.Ast_io.input_version * Utils.Intf_or_impl.t,
+    Location.Error.t * Utils.Ast_io.input_version )
+  result

src/dune

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