diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 4312586b..7b5cca0a 100644 --- a/bin/pp_ast.ml +++ b/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 () diff --git a/dune-project b/dune-project index 14cfdd73..7d339153 100644 --- a/dune-project +++ b/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)) diff --git a/ppxlib.opam b/ppxlib.opam index 729d62d6..1c113cec 100644 --- a/ppxlib.opam +++ b/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: [ diff --git a/src/pp_ast.ml b/src/pp_ast.ml index d755854b..7e8ebf51 100644 --- a/src/pp_ast.ml +++ b/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 diff --git a/src/pp_ast.mli b/src/pp_ast.mli index ab66fdb3..aaa91caa 100644 --- a/src/pp_ast.mli +++ b/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 diff --git a/src/ppxlib.ml b/src/ppxlib.ml index c7a9193b..30734e5c 100644 --- a/src/ppxlib.ml +++ b/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 diff --git a/test/pp_ast/dune b/test/pp_ast/dune new file mode 100644 index 00000000..13a84bb2 --- /dev/null +++ b/test/pp_ast/dune @@ -0,0 +1,9 @@ +(test + (name test) + (libraries ppxlib alcotest)) + +(rule + (alias runtest) + (deps test.exe) + (action + (run %{deps}))) diff --git a/test/pp_ast/test.ml b/test/pp_ast/test.ml new file mode 100644 index 00000000..86ffbbf9 --- /dev/null +++ b/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; + ] ); + ]