Feat/pp ast pprintast

bin/pp_ast.ml

@@ -1,23 +1,5 @@
 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
 
@@ -41,38 +23,24 @@ module Input = struct
     | 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
+  match ((kind : Pp_ast.Kind.t), (input : Input.t)) with
   | (Structure | Signature), (Stdin | File _) -> (
-      let kind = Kind.to_utils_kind kind in
+      let kind =
+        match kind with
+        | Pp_ast.Kind.Structure -> Ppxlib_private.Utils.Kind.Impl
+        | Signature -> Ppxlib_private.Utils.Kind.Intf
+        | _ -> assert false
+      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_))
+          | Impl str -> Pp_ast.Ast.Str str
+          | Intf sig_ -> Pp_ast.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
+      Pp_ast.parse_node ~kind (input |> Input.to_lexbuf)
 
 let named f = Cmdliner.Term.(app (const f))
 
@@ -98,13 +66,13 @@ let loc_mode =
   named (fun x -> `Loc_mode x) Cmdliner.Arg.(value & vflag `Short [ full_locs ])
 
 let kind =
-  let make_vflag (flag, (kind : Kind.t), doc) =
+  let make_vflag (flag, (kind : Pp_ast.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");
+        ("str", Pp_ast.Kind.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");
@@ -133,8 +101,8 @@ let run (`Show_attrs show_attrs) (`Show_locs show_locs) (`Loc_mode loc_mode)
     | Some k -> Ok k
     | None -> (
         match Ppxlib_private.Utils.Kind.of_filename input with
-        | Some Intf -> Ok Kind.Signature
-        | Some Impl -> Ok Kind.Structure
+        | Some Intf -> Ok Pp_ast.Kind.Signature
+        | Some Impl -> Ok Pp_ast.Kind.Structure
         | None ->
             errorf
               "Could not guess kind from input %S. Please use relevant CLI \
@@ -148,7 +116,7 @@ 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;
+  Pp_ast.pp_ast ~config ast Format.std_formatter;
   Format.printf "%!\n";
   Ok ()
 

dune-project

@@ -25,7 +25,8 @@
   (ocamlfind :with-test)
   (re (and :with-test (>= 1.9.0)))
   (cinaps (and :with-test (>= v0.12.1)))
-  (ocamlformat (and :with-dev-setup (= 0.26.2))))
+  (ocamlformat (and :with-dev-setup (= 0.26.2)))
+  (alcotest :with-test))
  (conflicts
   (ocaml-migrate-parsetree (< 2.0.0))
   (ocaml-base-compiler (= 5.1.0~alpha1))

ppxlib.opam

@@ -31,6 +31,7 @@ depends: [
   "re" {with-test & >= "1.9.0"}
   "cinaps" {with-test & >= "v0.12.1"}
   "ocamlformat" {with-dev-setup & = "0.26.2"}
+  "alcotest" {with-test}
   "odoc" {with-doc}
 ]
 conflicts: [

src/pp_ast.ml

@@ -280,3 +280,45 @@ 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
+
+module Kind = struct
+  type t = Signature | Structure | Expression | Pattern | Core_type
+end
+
+module Ast = struct
+  type t =
+    | Str of structure
+    | Sig of signature
+    | Exp of expression
+    | Pat of pattern
+    | Typ of core_type
+end
+
+let parse_node ~kind 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)
+  | Structure -> Ast.Str (Parse.implementation lexbuf)
+  | Signature -> Ast.Sig (Parse.interface lexbuf)
+
+let pp_ast ~config ast formatter =
+  match (ast : Ast.t) with
+  | Str str -> structure ~config formatter str
+  | Sig sig_ -> signature ~config formatter sig_
+  | Exp exp -> expression ~config formatter exp
+  | Pat pat -> pattern ~config formatter pat
+  | Typ typ -> core_type ~config formatter typ
+
+let sprint ?(show_attrs = false) ?(show_locs = false) ?(loc_mode = `Short)
+    ?(kind = Kind.Expression) input =
+  let buffer = Buffer.create 256 in
+  let formatter = Format.formatter_of_buffer buffer in
+  let lexbuf = Lexing.from_string input in
+  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = "none" };
+  Astlib.Location.set_input_lexbuf (Some lexbuf);
+  let ast = parse_node ~kind lexbuf in
+  let config = Config.make ~show_attrs ~show_locs ~loc_mode () in
+  pp_ast ~config ast formatter;
+  Format.pp_print_flush formatter ();
+  Buffer.contents buffer

src/pp_ast.mli

@@ -69,3 +69,27 @@ val signature_item : signature_item pp
 val expression : expression pp
 val pattern : pattern pp
 val core_type : core_type pp
+
+module Kind : sig
+  type t = Signature | Structure | Expression | Pattern | Core_type
+end
+
+module Ast : sig
+  type t =
+    | Str of structure
+    | Sig of signature
+    | Exp of expression
+    | Pat of pattern
+    | Typ of core_type
+end
+
+val parse_node : kind:Kind.t -> Lexing.lexbuf -> Ast.t
+val pp_ast : config:Config.t -> Ast.t -> Format.formatter -> unit
+
+val sprint :
+  ?show_attrs:bool ->
+  ?show_locs:bool ->
+  ?loc_mode:[ `Full | `Short ] ->
+  ?kind:Kind.t ->
+  string ->
+  string

src/ppxlib.ml

@@ -62,7 +62,14 @@ module Ast_helper = Ppxlib_ast.Ast_helper
 module Asttypes = Ppxlib_ast.Asttypes
 module Parse = Ppxlib_ast.Parse
 module Parsetree = Ppxlib_ast.Parsetree
-module Pprintast = Ppxlib_ast.Pprintast
+
+module Pprintast = struct
+  include Ppxlib_ast.Pprintast
+  module Kind = Pp_ast.Kind
+
+  let sprint = Pp_ast.sprint
+end
+
 module Selected_ast = Ppxlib_ast.Selected_ast
 module Location = Location
 module Longident = Longident

test/pp_ast/dune

@@ -0,0 +1,9 @@
+(test
+ (name test)
+ (libraries ppxlib alcotest))
+
+(rule
+ (alias runtest)
+ (deps test.exe)
+ (action
+  (run %{deps})))

test/pp_ast/test.ml

@@ -0,0 +1,62 @@
+open Ppxlib
+
+let test title fn = Alcotest.test_case title `Quick fn
+
+let assert_string left right =
+  Alcotest.check Alcotest.string "should be equal" right left
+
+let sprint_ast_expr =
+  let ast = Pp_ast.sprint "42" in
+  test "sprint AST expression" @@ fun () ->
+  assert_string ast "Pexp_constant (Pconst_integer ( \"42\", None))"
+
+let sprint_ast_pat =
+  let ast = Pp_ast.sprint ~kind:Pp_ast.Kind.Pattern "42" in
+  test "sprint AST pattern" @@ fun () ->
+  assert_string ast "Ppat_constant (Pconst_integer ( \"42\", None))"
+
+let sprint_ast_core_type =
+  let ast = Pp_ast.sprint ~kind:Pp_ast.Kind.Core_type "string" in
+  test "sprint AST core type" @@ fun () ->
+  assert_string ast "Ptyp_constr ( Lident \"string\", [])"
+
+let sprint_ast_sig =
+  let ast = Pp_ast.sprint ~kind:Pp_ast.Kind.Signature "val x: int" in
+  test "sprint AST signature" @@ fun () ->
+  assert_string ast
+    "[ Psig_value\n\
+    \    { pval_name = \"x\"\n\
+    \    ; pval_type = Ptyp_constr ( Lident \"int\", [])\n\
+    \    ; pval_prim = []\n\
+    \    ; pval_attributes = __attrs\n\
+    \    ; pval_loc = __loc\n\
+    \    }\n\
+     ]"
+
+let sprint_ast_str =
+  let ast = Pp_ast.sprint ~kind:Pp_ast.Kind.Structure "let x = 42" in
+  test "sprint AST structure" @@ fun () ->
+  assert_string ast
+    "[ Pstr_value\n\
+    \    ( Nonrecursive\n\
+    \    , [ { pvb_pat = Ppat_var \"x\"\n\
+    \        ; pvb_expr = Pexp_constant (Pconst_integer ( \"42\", None))\n\
+    \        ; pvb_attributes = __attrs\n\
+    \        ; pvb_loc = __loc\n\
+    \        }\n\
+    \      ]\n\
+    \    )\n\
+     ]"
+
+let () =
+  Alcotest.run ~show_errors:true ~compact:true ~tail_errors:`Unlimited "ppxlib"
+    [
+      ( "Pprintast",
+        [
+          sprint_ast_expr;
+          sprint_ast_pat;
+          sprint_ast_str;
+          sprint_ast_sig;
+          sprint_ast_core_type;
+        ] );
+    ]