Add ways to configure whether attributes are shown by Pp_ast

Signed-off-by: Nathan Rebours <nathan.p.rebours@gmail.com>

bin/pp_ast.ml

@@ -45,16 +45,17 @@ let load_input ~kind ~input_name fn =
           | Intf sig_ -> Ast.Sig sig_))
   | Expression | Pattern | Core_type -> parse_node ~kind ~input_name fn
 
-let pp_ast ast =
+let pp_ast ~config ast =
   match (ast : Ast.t) with
-  | Str str -> Pp_ast.structure Format.std_formatter str
-  | Sig sig_ -> Pp_ast.signature Format.std_formatter sig_
-  | Exp exp -> Pp_ast.expression Format.std_formatter exp
-  | Pat pat -> Pp_ast.pattern Format.std_formatter pat
-  | Typ typ -> Pp_ast.core_type Format.std_formatter typ
+  | 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 input = ref None
 let kind = ref None
+let show_attrs = ref false
 
 let set_input fn =
   match !input with
@@ -86,6 +87,9 @@ let args =
     ( "--typ",
       Arg.Unit (fun () -> set_kind Kind.Core_type),
       "<file> Treat the input as a single OCaml core_type" );
+    ( "--show-attrs",
+      Arg.Set show_attrs,
+      "Show attributes in the pretty printed output" );
   ]
 
 let main () =
@@ -111,7 +115,8 @@ let main () =
       in
       let input_name = match fn with "-" -> "<stdin>" | _ -> fn in
       let ast = load_input ~kind ~input_name fn in
-      pp_ast ast;
+      let config = Pp_ast.Config.make ~show_attrs:!show_attrs () in
+      pp_ast ~config ast;
       Format.printf "%!\n"
 
 let () = main ()

src/pp_ast.ml

@@ -1,5 +1,16 @@
 open Import
 
+module Config = struct
+  type t = { show_attrs : bool }
+
+  module Default = struct
+    let show_attrs = false
+  end
+
+  let default = { show_attrs = Default.show_attrs }
+  let make ?(show_attrs = Default.show_attrs) () = { show_attrs }
+end
+
 type simple_val =
   | Unit
   | Int of int
@@ -58,7 +69,10 @@ and pp_field fmt (fname, simple_val) =
 
 class lift_simple_val =
   object (self)
-    inherit [simple_val] Ast_traverse.lift
+    inherit [simple_val] Ast_traverse.lift as super
+    val mutable config = Config.default
+    method set_config new_config = config <- new_config
+    method get_config () = config
     method unit () = Unit
     method int i = Int i
     method string s = String s
@@ -80,21 +94,83 @@ class lift_simple_val =
     method! location _loc = Special "__loc"
     method! location_stack _ls = Special "__lstack"
     method! position _p = Special "__pos"
-    method! attributes _a = Special "__attrs"
     method! loc lift_a a_loc = lift_a a_loc.txt
-    method! core_type ct = self#core_type_desc ct.ptyp_desc
-    method! row_field rf = self#row_field_desc rf.prf_desc
-    method! object_field obf = self#object_field_desc obf.pof_desc
-    method! pattern pat = self#pattern_desc pat.ppat_desc
-    method! expression exp = self#expression_desc exp.pexp_desc
-    method! class_type cty = self#class_type_desc cty.pcty_desc
-    method! class_type_field ctf = self#class_type_field_desc ctf.pctf_desc
-    method! class_expr cl = self#class_expr_desc cl.pcl_desc
-    method! class_field cf = self#class_field_desc cf.pcf_desc
-    method! module_type mty = self#module_type_desc mty.pmty_desc
-    method! signature_item sigi = self#signature_item_desc sigi.psig_desc
-    method! module_expr mod_ = self#module_expr_desc mod_.pmod_desc
+
+    method! attributes attrs =
+      match config.Config.show_attrs with
+      | false -> Special "__attrs"
+      | true -> super#attributes attrs
+
+    method lift_record_with_desc
+        : 'record 'desc.
+          lift_desc:('desc -> simple_val) ->
+          lift_record:('record -> simple_val) ->
+          desc:'desc ->
+          attrs:attributes ->
+          'record ->
+          simple_val =
+      fun ~lift_desc ~lift_record ~desc ~attrs x ->
+        match (config.show_attrs, attrs) with
+        | true, [] | false, _ -> lift_desc desc
+        | true, _ -> lift_record x
+
+    method! core_type ct =
+      self#lift_record_with_desc ~lift_desc:self#core_type_desc
+        ~lift_record:super#core_type ~desc:ct.ptyp_desc
+        ~attrs:ct.ptyp_attributes ct
+
+    method! row_field rf =
+      self#lift_record_with_desc ~lift_desc:self#row_field_desc
+        ~lift_record:super#row_field ~desc:rf.prf_desc ~attrs:rf.prf_attributes
+        rf
+
+    method! object_field obf =
+      self#lift_record_with_desc ~lift_desc:self#object_field_desc
+        ~lift_record:super#object_field ~desc:obf.pof_desc
+        ~attrs:obf.pof_attributes obf
+
+    method! pattern pat =
+      self#lift_record_with_desc ~lift_desc:self#pattern_desc
+        ~lift_record:super#pattern ~desc:pat.ppat_desc
+        ~attrs:pat.ppat_attributes pat
+
+    method! expression exp =
+      self#lift_record_with_desc ~lift_desc:self#expression_desc
+        ~lift_record:super#expression ~desc:exp.pexp_desc
+        ~attrs:exp.pexp_attributes exp
+
+    method! class_type cty =
+      self#lift_record_with_desc ~lift_desc:self#class_type_desc
+        ~lift_record:super#class_type ~desc:cty.pcty_desc
+        ~attrs:cty.pcty_attributes cty
+
+    method! class_type_field ctf =
+      self#lift_record_with_desc ~lift_desc:self#class_type_field_desc
+        ~lift_record:super#class_type_field ~desc:ctf.pctf_desc
+        ~attrs:ctf.pctf_attributes ctf
+
+    method! class_expr cl =
+      self#lift_record_with_desc ~lift_desc:self#class_expr_desc
+        ~lift_record:super#class_expr ~desc:cl.pcl_desc ~attrs:cl.pcl_attributes
+        cl
+
+    method! class_field cf =
+      self#lift_record_with_desc ~lift_desc:self#class_field_desc
+        ~lift_record:super#class_field ~desc:cf.pcf_desc
+        ~attrs:cf.pcf_attributes cf
+
+    method! module_type mty =
+      self#lift_record_with_desc ~lift_desc:self#module_type_desc
+        ~lift_record:super#module_type ~desc:mty.pmty_desc
+        ~attrs:mty.pmty_attributes mty
+
+    method! module_expr mod_ =
+      self#lift_record_with_desc ~lift_desc:self#module_expr_desc
+        ~lift_record:super#module_expr ~desc:mod_.pmod_desc
+        ~attrs:mod_.pmod_attributes mod_
+
     method! structure_item stri = self#structure_item_desc stri.pstr_desc
+    method! signature_item sigi = self#signature_item_desc sigi.psig_desc
 
     method! directive_argument dira =
       self#directive_argument_desc dira.pdira_desc
@@ -147,8 +223,22 @@ class lift_simple_val =
   end
 
 let lift_simple_val = new lift_simple_val
-let structure fmt str = pp_simple_val fmt (lift_simple_val#structure str)
-let signature fmt str = pp_simple_val fmt (lift_simple_val#signature str)
-let expression fmt str = pp_simple_val fmt (lift_simple_val#expression str)
-let pattern fmt str = pp_simple_val fmt (lift_simple_val#pattern str)
-let core_type fmt str = pp_simple_val fmt (lift_simple_val#core_type str)
+
+type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit
+
+let with_config ~config ~f =
+  let old_config = lift_simple_val#get_config () in
+  lift_simple_val#set_config config;
+  let res = f () in
+  lift_simple_val#set_config old_config;
+  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))
+
+let structure = pp_with_config lift_simple_val#structure
+let signature = pp_with_config lift_simple_val#signature
+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

src/pp_ast.mli

@@ -1,7 +1,27 @@
 open! Import
 
-val structure : Format.formatter -> structure -> unit
-val signature : Format.formatter -> signature -> unit
-val expression : Format.formatter -> expression -> unit
-val pattern : Format.formatter -> pattern -> unit
-val core_type : Format.formatter -> core_type -> unit
+module Config : sig
+  type t
+  (** Type for AST pretty-printing config *)
+
+  val make : ?show_attrs:bool -> unit -> t
+  (** Create a custom pretty-printing config.
+
+      Default values are the ones that are used when no configuration is passed
+      to the pretty-printers defined below.
+
+      @param show_attrs
+        controls whether attributes are shown or hidden. It defaults to [false].
+        When set to [true], records such as [expression] that have a [desc]
+        field will only be printed if the list of attributes is non-empty,
+        otherwise their [_desc] field will be printed directly instead, as it is
+        the case when [show_attrs] is [false]. *)
+end
+
+type 'node pp = ?config:Config.t -> Format.formatter -> 'node -> unit
+
+val structure : structure pp
+val signature : signature pp
+val expression : expression pp
+val pattern : pattern pp
+val core_type : core_type pp

test/ppxlib-pp-ast/show-attrs/dune

@@ -0,0 +1,3 @@
+(cram
+ (deps
+  (package ppxlib)))

test/ppxlib-pp-ast/show-attrs/run.t

@@ -0,0 +1,76 @@
+ppxlib-pp-ast as a --show-attrs flag that controls whether attributes are shown
+
+Consider the following .ml file:
+
+  $ cat > test.ml << EOF
+  > let x = 2 + (2[@foo 1])
+  > [@@bar: int * string]
+  > EOF
+
+And how it's printed without the flag:
+
+  $ ppxlib-pp-ast test.ml
+  [ Pstr_value
+      ( Nonrecursive
+      , [ { pvb_pat = Ppat_var "x"
+          ; pvb_expr =
+              Pexp_apply
+                ( Pexp_ident (Lident "+")
+                , [ ( Nolabel, Pexp_constant (Pconst_integer ( "2", None)))
+                  ; ( Nolabel, Pexp_constant (Pconst_integer ( "2", None)))
+                  ]
+                )
+          ; pvb_attributes = __attrs
+          ; pvb_loc = __loc
+          }
+        ]
+      )
+  ]
+
+And with the flag:
+
+  $ ppxlib-pp-ast --show-attrs test.ml
+  [ Pstr_value
+      ( Nonrecursive
+      , [ { pvb_pat = Ppat_var "x"
+          ; pvb_expr =
+              Pexp_apply
+                ( Pexp_ident (Lident "+")
+                , [ ( Nolabel, Pexp_constant (Pconst_integer ( "2", None)))
+                  ; ( Nolabel
+                    , { pexp_desc = Pexp_constant (Pconst_integer ( "2", None))
+                      ; pexp_loc = __loc
+                      ; pexp_loc_stack = __lstack
+                      ; pexp_attributes =
+                          [ { attr_name = "foo"
+                            ; attr_payload =
+                                PStr
+                                  [ Pstr_eval
+                                      ( Pexp_constant
+                                          (Pconst_integer ( "1", None))
+                                      , []
+                                      )
+                                  ]
+                            ; attr_loc = __loc
+                            }
+                          ]
+                      }
+                    )
+                  ]
+                )
+          ; pvb_attributes =
+              [ { attr_name = "bar"
+                ; attr_payload =
+                    PTyp
+                      (Ptyp_tuple
+                         [ Ptyp_constr ( Lident "int", [])
+                         ; Ptyp_constr ( Lident "string", [])
+                         ])
+                ; attr_loc = __loc
+                }
+              ]
+          ; pvb_loc = __loc
+          }
+        ]
+      )
+  ]