Change construct generated by driver to silence warning 34

The new one works better with coverage tools such as `bisect_ppx` since it avoids generating an unvisitable coverage point. Update CHANGES.md Signed-off-by: Mathieu Barbin <[email protected]>
ocaml-ppx · Jul 15, 2024 · 431aea8 · 431aea8
1 parent 62f49bf
commit 431aea8
Show file tree

Hide file tree

Showing 6 changed files with 48 additions and 25 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -14,6 +14,9 @@ details.
 
 ### Other changes
 
+- Driver: Change the construct generated to silence warning 34 to work
+  better with coverage tools such as `bisect_ppx`. (#495, @mbarbin)
+
 - new functions `Ast_builder.{e,p}list_tail` that take an extra tail
   expression/pattern argument parameter compared to `Ast_builder.{e,p}list`, so
   they can build ASTs like `a :: b :: c` instead of only `[ a; b ]`.

diff --git a/src/deriving.ml b/src/deriving.ml
@@ -710,9 +710,22 @@ let types_used_by_deriving (tds : type_declaration list) : structure_item list =
           [
             value_binding ~loc ~pat:(ppat_any ~loc)
               ~expr:
-                (pexp_fun ~loc Nolabel None
-                   (ppat_constraint ~loc (ppat_any ~loc) typ)
-                   (eunit ~loc));
+                (pexp_constraint ~loc
+                   (pexp_variant ~loc "None" None)
+                   (ptyp_variant ~loc
+                      [
+                        {
+                          prf_desc = Rtag ({ txt = "None"; loc }, true, []);
+                          prf_loc = loc;
+                          prf_attributes = [];
+                        };
+                        {
+                          prf_desc = Rtag ({ txt = "Some"; loc }, false, [ typ ]);
+                          prf_loc = loc;
+                          prf_attributes = [];
+                        };
+                      ]
+                      Closed None));
           ])
 
 let merge_generators field l =

diff --git a/test/deriving/inline/example/ppx_deriving_example.ml b/test/deriving/inline/example/ppx_deriving_example.ml
@@ -3,7 +3,7 @@ type t = A [@@deriving_inline foo]
 include struct
   [@@@ocaml.warning "-60"]
 
-  let _ = fun (_ : t) -> ()
+  let _ = (`None : [ `None | `Some of t ])
 
   module Foo = struct end
 

diff --git a/test/deriving_warning/run.t b/test/deriving_warning/run.t
@@ -42,8 +42,9 @@ Let's call the driver with -unused-code-warnings=false:
 
   $ ./driver.exe -unused-code-warnings=false -impl zero_do_warn.ml
   type t = int[@@deriving zero_do_warn]
-  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
-                                                                      ]
+  include struct let _ = (`None : [ `None  | `Some of t ]) end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
   include
     struct
       [@@@ocaml.warning "-60"]
@@ -61,8 +62,9 @@ Now if we use -unused-code-warnings=true:
 
   $ ./driver.exe -unused-code-warnings=true -impl zero_do_warn.ml
   type t = int[@@deriving zero_do_warn]
-  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
-                                                                      ]
+  include struct let _ = (`None : [ `None  | `Some of t ]) end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
   include struct module Zero = struct type t =
                                         | T0  end
                  let zero = Zero.T0 end[@@ocaml.doc "@inline"][@@merlin.hide ]
@@ -102,8 +104,9 @@ The default value of the -unused-code-warnings should be false:
 
   $ ./driver.exe -impl zero_do_warn.ml
   type t = int[@@deriving zero_do_warn]
-  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
-                                                                      ]
+  include struct let _ = (`None : [ `None  | `Some of t ]) end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
   include
     struct
       [@@@ocaml.warning "-60"]
@@ -134,7 +137,7 @@ output:
   include
     struct
       [@@@ocaml.warning "-60"]
-      let _ = fun (_ : t) -> ()
+      let _ = (`None : [ `None  | `Some of t ])
       module One = struct type 'a t =
                             | T1 of 'a  end
       let one = One.T1 zero
@@ -146,7 +149,7 @@ output:
   include
     struct
       [@@@ocaml.warning "-60"]
-      let _ = fun (_ : t) -> ()
+      let _ = (`None : [ `None  | `Some of t ])
       module One = struct type 'a t =
                             | T1 of 'a  end
       let one = One.T1 zero
@@ -196,8 +199,9 @@ unit_one:
 
   $ ./driver.exe -unused-code-warnings=true -impl alias_warn.ml
   type t = int[@@deriving alias_warn]
-  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
-                                                                      ]
+  include struct let _ = (`None : [ `None  | `Some of t ]) end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
   include struct let unit_one = () end[@@ocaml.doc "@inline"][@@merlin.hide ]
   include struct let unit_two = unit_one
                  let _ = unit_two end[@@ocaml.doc "@inline"][@@merlin.hide ]
@@ -207,8 +211,9 @@ the unused-code-warnings flag, there will be one for both:
 
   $ ./driver.exe -unused-code-warnings=false -impl alias_warn.ml
   type t = int[@@deriving alias_warn]
-  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
-                                                                      ]
+  include struct let _ = (`None : [ `None  | `Some of t ]) end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
   include struct let unit_one = ()
                  let _ = unit_one end[@@ocaml.doc "@inline"][@@merlin.hide ]
   include struct let unit_two = unit_one

diff --git a/test/driver/exception_handling/run.t b/test/driver/exception_handling/run.t
@@ -23,7 +23,7 @@ is rewritten to contain two of these nodes.
   type a = int[@@deriving deriver_extension_node]
   include
     struct
-      let _ = fun (_ : a) -> ()
+      let _ = (`None : [ `None  | `Some of a ])
       [%%ocaml.error "An error message in an extension node"]
     end[@@ocaml.doc "@inline"][@@merlin.hide ]
 

diff --git a/test/error_embedding/run.t b/test/error_embedding/run.t
@@ -8,7 +8,7 @@ Undefined derivers are turned into error nodes
   type t = int[@@deriving undefined]
   include
     struct
-      let _ = fun (_ : t) -> ()
+      let _ = (`None : [ `None  | `Some of t ])
       [%%ocaml.error
         "Ppxlib.Deriving: 'undefined' is not a supported type deriving generator"]
     end[@@ocaml.doc "@inline"][@@merlin.hide ]
@@ -32,13 +32,15 @@ Anything else will embed an error extension node
   $ echo "type b = int [@@deriving a_string unexpected_args]" >> parsing_payload_deriver.ml
   $ ./deriver.exe parsing_payload_deriver.ml
   type a = int[@@deriving a_string]
-  include struct let _ = fun (_ : a) -> ()
-                 let _ = "derived_string" end[@@ocaml.doc "@inline"][@@merlin.hide
-                                                                      ]
+  include
+    struct
+      let _ = (`None : [ `None  | `Some of a ])
+      let _ = "derived_string"
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
   type b = int[@@deriving a_string unexpected_args]
   include
     struct
-      let _ = fun (_ : b) -> ()
+      let _ = (`None : [ `None  | `Some of b ])
       [%%ocaml.error
         "Ppxlib.Deriving: non-optional labelled argument or record expected"]
     end[@@ocaml.doc "@inline"][@@merlin.hide ]
@@ -50,7 +52,7 @@ Error nodes are generated when dependent derivers are not applied.
   type a = int[@@deriving a_dependent_string]
   include
     struct
-      let _ = fun (_ : a) -> ()
+      let _ = (`None : [ `None  | `Some of a ])
       [%%ocaml.error
         "Deriver a_string is needed for a_dependent_string, you need to add it before in the list"]
       let _ = "derived_string"
@@ -60,7 +62,7 @@ Error nodes are generated when dependent derivers are not applied.
   type b = int[@@deriving (a_dependent_string, a_string)]
   include
     struct
-      let _ = fun (_ : b) -> ()
+      let _ = (`None : [ `None  | `Some of b ])
       [%%ocaml.error
         "Deriver a_string is needed for a_dependent_string, you need to add it before in the list"]
       let _ = "derived_string"
@@ -71,7 +73,7 @@ Error nodes are generated when dependent derivers are not applied.
   type b = int[@@deriving (a_string, a_dependent_string)]
   include
     struct
-      let _ = fun (_ : b) -> ()
+      let _ = (`None : [ `None  | `Some of b ])
       let _ = "derived_string"
       let _ = "derived_string"
     end[@@ocaml.doc "@inline"][@@merlin.hide ]