From b12844db29395ce92db3b17fd2633aeef6c877c7 Mon Sep 17 00:00:00 2001 From: Pedro B S Lisboa Date: Wed, 15 Jan 2025 16:40:09 +0800 Subject: [PATCH] Add json mapper for pp_ast Signed-off-by: Pedro B S Lisboa --- bin/dune | 2 +- bin/pp_ast.ml | 47 ++++++++++++++++++++++++++++++++++++++--------- src/pp_ast.ml | 37 ++++++++++++++++++++----------------- src/pp_ast.mli | 42 ++++++++++++++++++++++++++++++------------ 4 files changed, 89 insertions(+), 39 deletions(-) diff --git a/bin/dune b/bin/dune index 02d3b845..34877754 100644 --- a/bin/dune +++ b/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)) diff --git a/bin/pp_ast.ml b/bin/pp_ast.ml index 4312586b..45141220 100644 --- a/bin/pp_ast.ml +++ b/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" diff --git a/src/pp_ast.ml b/src/pp_ast.ml index 6292b3d8..b541d6c0 100644 --- a/src/pp_ast.ml +++ b/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 diff --git a/src/pp_ast.mli b/src/pp_ast.mli index 23a67d54..e0dd9269 100644 --- a/src/pp_ast.mli +++ b/src/pp_ast.mli @@ -60,28 +60,46 @@ 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 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"]