Merge pull request #525 from NathanReb/fix-pp-ast-floating-attr

Filter out floating attributes in Pp_ast
ocaml-ppx · Sep 25, 2024 · 27a754c · 27a754c
2 parents ac7fcfc + 3771a48
commit 27a754c
Show file tree

Hide file tree

Showing 2 changed files with 237 additions and 0 deletions.
diff --git a/src/pp_ast.ml b/src/pp_ast.ml
@@ -208,6 +208,50 @@ class lift_simple_val =
     method! structure_item stri = self#structure_item_desc stri.pstr_desc
     method! signature_item sigi = self#signature_item_desc sigi.psig_desc
 
+    method! structure str =
+      match config.show_attrs with
+      | true -> super#structure str
+      | false ->
+          List.filter
+            ~f:(function
+              | { pstr_desc = Pstr_attribute _; _ } -> false | _ -> true)
+            str
+          |> super#structure
+
+    method! signature sig_ =
+      match config.show_attrs with
+      | true -> super#signature sig_
+      | false ->
+          List.filter
+            ~f:(function
+              | { psig_desc = Psig_attribute _; _ } -> false | _ -> true)
+            sig_
+          |> super#signature
+
+    method! class_structure cstr =
+      match config.show_attrs with
+      | true -> super#class_structure cstr
+      | false ->
+          let pcstr_fields =
+            List.filter
+              ~f:(function
+                | { pcf_desc = Pcf_attribute _; _ } -> false | _ -> true)
+              cstr.pcstr_fields
+          in
+          super#class_structure { cstr with pcstr_fields }
+
+    method! class_signature csig =
+      match config.show_attrs with
+      | true -> super#class_signature csig
+      | false ->
+          let pcsig_fields =
+            List.filter
+              ~f:(function
+                | { pctf_desc = Pctf_attribute _; _ } -> false | _ -> true)
+              csig.pcsig_fields
+          in
+          super#class_signature { csig with pcsig_fields }
+
     method! directive_argument dira =
       self#directive_argument_desc dira.pdira_desc
 

diff --git a/test/ppxlib-pp-ast/show-attrs.t b/test/ppxlib-pp-ast/show-attrs.t
@@ -74,3 +74,196 @@ And with the flag:
         ]
       )
   ]
+
+Without the flag, floating attributes are simply skipped. Consider the following
+files:
+
+  $ cat > test_floating.ml << EOF
+  > [@@@floating]
+  > let x = 2
+  > class c = object
+  >  [@@@floating]
+  >  method! f () = ()
+  > end
+  > EOF
+
+and:
+
+  $ cat > test_floating.mli << EOF
+  > [@@@floating]
+  > val x : int
+  > class type t = object
+  >   [@@@floating]
+  >   method f : unit -> unit
+  > end
+  > EOF
+
+When printed without the flag, floating attributes are filtered out:
+
+  $ ppxlib-pp-ast test_floating.ml
+  [ Pstr_value
+      ( Nonrecursive
+      , [ { pvb_pat = Ppat_var "x"
+          ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None))
+          ; pvb_attributes = __attrs
+          ; pvb_loc = __loc
+          }
+        ]
+      )
+  ; Pstr_class
+      [ { pci_virt = Concrete
+        ; pci_params = []
+        ; pci_name = "c"
+        ; pci_expr =
+            Pcl_structure
+              { pcstr_self = Ppat_any
+              ; pcstr_fields =
+                  [ Pcf_method
+                      ( "f"
+                      , Public
+                      , Cfk_concrete
+                          ( Override
+                          , Pexp_poly
+                              ( Pexp_fun
+                                  ( Nolabel
+                                  , None
+                                  , Ppat_construct ( Lident "()", None)
+                                  , Pexp_construct ( Lident "()", None)
+                                  )
+                              , None
+                              )
+                          )
+                      )
+                  ]
+              }
+        ; pci_loc = __loc
+        ; pci_attributes = __attrs
+        }
+      ]
+  ]
+
+  $ ppxlib-pp-ast test_floating.mli
+  [ Psig_value
+      { pval_name = "x"
+      ; pval_type = Ptyp_constr ( Lident "int", [])
+      ; pval_prim = []
+      ; pval_attributes = __attrs
+      ; pval_loc = __loc
+      }
+  ; Psig_class_type
+      [ { pci_virt = Concrete
+        ; pci_params = []
+        ; pci_name = "t"
+        ; pci_expr =
+            Pcty_signature
+              { pcsig_self = Ptyp_any
+              ; pcsig_fields =
+                  [ Pctf_method
+                      ( "f"
+                      , Public
+                      , Concrete
+                      , Ptyp_arrow
+                          ( Nolabel
+                          , Ptyp_constr ( Lident "unit", [])
+                          , Ptyp_constr ( Lident "unit", [])
+                          )
+                      )
+                  ]
+              }
+        ; pci_loc = __loc
+        ; pci_attributes = __attrs
+        }
+      ]
+  ]
+
+And now with the flag, we can see our floating attributes:
+
+  $ ppxlib-pp-ast --show-attrs test_floating.ml
+  [ Pstr_attribute
+      { attr_name = "floating"; attr_payload = PStr []; attr_loc = __loc}
+  ; Pstr_value
+      ( Nonrecursive
+      , [ { pvb_pat = Ppat_var "x"
+          ; pvb_expr = Pexp_constant (Pconst_integer ( "2", None))
+          ; pvb_attributes = []
+          ; pvb_loc = __loc
+          }
+        ]
+      )
+  ; Pstr_class
+      [ { pci_virt = Concrete
+        ; pci_params = []
+        ; pci_name = "c"
+        ; pci_expr =
+            Pcl_structure
+              { pcstr_self = Ppat_any
+              ; pcstr_fields =
+                  [ Pcf_attribute
+                      { attr_name = "floating"
+                      ; attr_payload = PStr []
+                      ; attr_loc = __loc
+                      }
+                  ; Pcf_method
+                      ( "f"
+                      , Public
+                      , Cfk_concrete
+                          ( Override
+                          , Pexp_poly
+                              ( Pexp_fun
+                                  ( Nolabel
+                                  , None
+                                  , Ppat_construct ( Lident "()", None)
+                                  , Pexp_construct ( Lident "()", None)
+                                  )
+                              , None
+                              )
+                          )
+                      )
+                  ]
+              }
+        ; pci_loc = __loc
+        ; pci_attributes = []
+        }
+      ]
+  ]
+
+  $ ppxlib-pp-ast --show-attrs test_floating.mli
+  [ Psig_attribute
+      { attr_name = "floating"; attr_payload = PStr []; attr_loc = __loc}
+  ; Psig_value
+      { pval_name = "x"
+      ; pval_type = Ptyp_constr ( Lident "int", [])
+      ; pval_prim = []
+      ; pval_attributes = []
+      ; pval_loc = __loc
+      }
+  ; Psig_class_type
+      [ { pci_virt = Concrete
+        ; pci_params = []
+        ; pci_name = "t"
+        ; pci_expr =
+            Pcty_signature
+              { pcsig_self = Ptyp_any
+              ; pcsig_fields =
+                  [ Pctf_attribute
+                      { attr_name = "floating"
+                      ; attr_payload = PStr []
+                      ; attr_loc = __loc
+                      }
+                  ; Pctf_method
+                      ( "f"
+                      , Public
+                      , Concrete
+                      , Ptyp_arrow
+                          ( Nolabel
+                          , Ptyp_constr ( Lident "unit", [])
+                          , Ptyp_constr ( Lident "unit", [])
+                          )
+                      )
+                  ]
+              }
+        ; pci_loc = __loc
+        ; pci_attributes = []
+        }
+      ]
+  ]