Add [@ignore] to exclude parts of tuples or records from the produced…

… Dyn.t

Signed-off-by: Nathan Rebours <[email protected]>

CHANGES.md

@@ -5,6 +5,8 @@
 - Initial implementation of `ppx_deriving_dyn`
 - Allow overriding the default `Dyn.t` converter for a given type or record
   field via the `[@to_dyn ...]` attribute
+- Allow ignoring parts of tuples, records or variant ars via the `[@ignore]`
+  attribute
 
 ### Changed
 

README.md

@@ -52,9 +52,8 @@ val to_dyn : t Dyn.builder
     + `list`
     + `array`
     + `option`
-- It uses `Dyn.pair` and `Dyn.triple` for tuples of the corresponding size
-- Larger tuple types are converted using an inline
-   `(fun (x0, x1, x2, x3) -> Dyn.tuple [...])`
+- Tuple types are converted using an inline
+   `(fun (x0, x1, x2, x3) -> Dyn.Tuple [...])`
 - It uses `Dyn.record` for record types
 - It uses `Dyn.variant` for variant and polymorphic variant types. Inline record
   arguments are converted using `Dyn.record` as well.
@@ -102,3 +101,81 @@ type t =
 The attribute can be attached to a core type or record field and accepts
 function identifier, partial function applications and anonymous functions as
 payload.
+
+#### `[@ignore]`
+
+It can be used as `[@ignore]`, `[@to_dyn.ignore]` or
+`[@ppx_deriving_dyn.to_dyn.ignore]` and allows you to exclude part of a tuple,
+record or variant arguments from the output of derived `to_dyn` function.
+
+For example, with the following type definition:
+```ocaml
+type t = int * (string[@ignore]) * bool
+[@@deriving dyn]
+```
+
+The generated dyn converter will ignore the string element of the tuple and
+return a `Dyn.t` value describing an `int * bool` pair. To clarify this a bit,
+the generated code will look roughly like this:
+```ocaml
+let to_dyn (x0, _, x2) = Dyn.Tuple [Dyn.int x0; Dyn.bool x2]
+```
+
+It can also be used to similarly ignore fields of a record:
+```ocaml
+type t =
+  { field_a : int
+  ; field_b : string [@ignore]
+  ; field_c : bool 
+  }
+[@@deriving dyn]
+```
+
+which will produce the following dyn converter:
+```ocaml
+let to_dyn {field_a; field_b = _; field_c} =
+  Dyn.record
+    [("field_a", (Dyn.int field_a)); ("field_c", (Dyn.bool field_c))]
+```
+
+Finally, you can use it on sum type constructor or polymorphic variant's
+arguments:
+```ocaml
+type t =
+  | A of int * (string [@ignore])
+[@@deriving dyn]
+```
+
+which will produce the following dyn converter:
+```ocaml
+let to_dyn = function
+  | A (x0, _) -> Dyn.variant "A" [Dyn.int x0]
+```
+
+Note that you cannot ignore all elements of a tuple or all fields of a record
+but you can ignore all arguments of a constructor, in which case the `to_dyn`
+function will treat it as if it had no argument, e.g.:
+```ocaml
+type t =
+  | A of (int[@ignore])
+[@@deriving dyn]
+```
+
+will derive:
+```ocaml
+let to_dyn = function
+  | A _ -> Dyn.variant "A" []
+```
+
+It is also worth noting that if you ignore all elements of a tuple but one,
+the dyn converter will treat it as it was just that type and not as a tuple
+anymore, e.g.:
+```ocaml
+type t = int * (string [@ignore])
+[@@deriving dyn]
+```
+
+will derive:
+```ocaml
+let to_dyn (x0, _) = Dyn.int x0
+```

deriver/attr.ml

@@ -42,3 +42,36 @@ module To_dyn = struct
     get_attr label_decl_attr label_declaration
   ;;
 end
+
+module Ignore = struct
+  let name = "ppx_deriving_dyn.to_dyn.ignore"
+
+  let payload_pattern =
+    let open Ast_pattern in
+    pstr nil
+  ;;
+
+  let has_ignore attr ast =
+    (* TODO: Switch to Attribute.has_flag once it's released *)
+    match Attribute.get_res attr ast with
+    | Ok (Some ()) -> Ok true
+    | Ok None -> Ok false
+    | Error (err, _) ->
+      let loc = Location.Error.get_location err in
+      Error (Location.Error.to_extension err, loc)
+  ;;
+
+  let core_type_attr =
+    (* TODO: Switch to Attribute.declare_flag once it's released *)
+    Attribute.declare name Attribute.Context.core_type payload_pattern ()
+  ;;
+
+  let core_type ct = has_ignore core_type_attr ct
+
+  let label_decl_attr =
+    (* TODO: Switch to Attribute.declare_flag once it's released *)
+    Attribute.declare name Attribute.Context.label_declaration payload_pattern ()
+  ;;
+
+  let label_declaration ld = has_ignore label_decl_attr ld
+end

deriver/attr.mli

@@ -12,3 +12,14 @@ module To_dyn : sig
   (** Return the user provided converter for the given record label, if any. *)
   val from_label_declaration : label_declaration -> expression option
 end
+
+module Ignore : sig
+  (** Attribute to exclude record fields or tuple elements from the [Dyn.t]
+      value produced by the derived converter. *)
+
+  (** Return whether a core_type is to be ignored *)
+  val core_type : core_type -> (bool, extension * Location.t) result
+
+  (** Return whether a record label is to be ignored *)
+  val label_declaration : label_declaration -> (bool, extension * Location.t) result
+end

deriver/error.ml

@@ -22,3 +22,7 @@ let unsupported_conjunctive_tag_arg ~loc =
     ~loc
     "cannot derive to_dyn for polymorphic variant tag with conjunctive type argument."
 ;;
+
+let cannot_ignore_all_elements ~loc =
+  error_extensionf ~loc "you cannot mark all elements of a tuple or record with [@ignore]"
+;;

deriver/error.mli

@@ -7,3 +7,4 @@ val unsupported_type : loc:Location.t -> extension
 val unsupported_gadt : loc:Location.t -> extension
 val unsupported_rinherit : loc:Location.t -> extension
 val unsupported_conjunctive_tag_arg : loc:Location.t -> extension
+val cannot_ignore_all_elements : loc:Location.t -> extension

deriver/ppx_deriving_dyn.ml

@@ -35,9 +35,13 @@ module Impl = struct
   ;;
 
   let tuple_pattern ~loc destructed =
-    let vars =
-      List.map (fun (name, _) -> Ast_builder.Default.pvar ~loc name) destructed
+    let elm_pattern (name, ct) =
+      match Attr.Ignore.core_type ct with
+      | Ok true -> Ast_builder.Default.ppat_any ~loc
+      | Ok false -> Ast_builder.Default.pvar ~loc name
+      | Error (extension, loc) -> Ast_builder.Default.ppat_extension ~loc extension
     in
+    let vars = List.map elm_pattern destructed in
     Ast_builder.Default.ppat_tuple ~loc vars
   ;;
 
@@ -65,25 +69,8 @@ module Impl = struct
     | { ptyp_desc = Ptyp_var s; _ }, None ->
       let pexp_ident = Ast_builder.Default.evar ~loc (to_dyn_name s) in
       fun_or_applied ~loc ~f:pexp_ident expr_opt
-    | { ptyp_desc = Ptyp_tuple (([ _; _ ] | [ _; _; _ ]) as core_types); _ }, None ->
-      let size = List.length core_types in
-      let f = if size = 2 then [%expr Dyn.pair] else [%expr Dyn.triple] in
-      let to_dyn_args =
-        List.map
-          (fun core_type -> Nolabel, core_type_to_dyn ~loc ~core_type None)
-          core_types
-      in
-      let args =
-        match expr_opt with
-        | None -> to_dyn_args
-        | Some expr -> to_dyn_args @ [ Nolabel, expr ]
-      in
-      Ast_builder.Default.pexp_apply ~loc f args
     | { ptyp_desc = Ptyp_tuple core_types; _ }, None ->
-      let destructed = destruct_tuple core_types in
-      let pat = tuple_pattern ~loc destructed in
-      let body = [%expr Dyn.Tuple [%e tuple_to_dyn_list ~loc destructed]] in
-      let to_dyn = [%expr fun [%p pat] -> [%e body]] in
+      let to_dyn = tuple_to_dyn ~loc core_types in
       fun_or_applied ~loc ~f:to_dyn expr_opt
     | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ }, None ->
       let to_dyn =
@@ -97,14 +84,30 @@ module Impl = struct
     List.map (fun core_type -> Nolabel, core_type_to_dyn ~loc ~core_type None) type_params
 
   and tuple_to_dyn_list ~loc destructed_tuple =
-    let to_dyn_list =
-      List.map
-        (fun (arg_name, core_type) ->
-          let arg = Ast_builder.Default.evar ~loc arg_name in
-          core_type_to_dyn ~loc ~core_type (Some arg))
-        destructed_tuple
+    let elm_expr (arg_name, core_type) =
+      match Attr.Ignore.core_type core_type with
+      | Ok true -> None
+      | Ok false ->
+        let arg = Ast_builder.Default.evar ~loc arg_name in
+        Some (core_type_to_dyn ~loc ~core_type (Some arg))
+      | Error (extension, loc) -> Some (Ast_builder.Default.pexp_extension ~loc extension)
     in
-    Ast_builder.Default.elist ~loc to_dyn_list
+    List.filter_map elm_expr destructed_tuple
+
+  and tuple_to_dyn ~loc core_types =
+    let destructed = destruct_tuple core_types in
+    let pat = tuple_pattern ~loc destructed in
+    let to_dyn_list = tuple_to_dyn_list ~loc destructed in
+    let body =
+      match to_dyn_list with
+      | [] ->
+        (* tuple_to_dyn_list returned an empty list meaning all elements were
+           marked with [[@ignore]] *)
+        Ast_builder.Default.pexp_extension ~loc (Error.cannot_ignore_all_elements ~loc)
+      | [ one ] -> one
+      | l -> [%expr Dyn.Tuple [%e Ast_builder.Default.elist ~loc l]]
+    in
+    [%expr fun [%p pat] -> [%e body]]
 
   and row_field_case ~loc { prf_desc; prf_loc; _ } =
     let pc_lhs, pc_rhs =
@@ -120,11 +123,7 @@ module Impl = struct
         let pc_rhs = variant_x_args ~loc ~variant_name:txt destructed in
         pc_lhs, pc_rhs
       | Rtag ({ txt; _ }, _, [ core_type ]) ->
-        let arg_name = String.uncapitalize_ascii txt in
-        let pat = Ast_builder.Default.pvar ~loc arg_name in
-        let pc_lhs = Ast_builder.Default.ppat_variant ~loc txt (Some pat) in
-        let pc_rhs = variant_one_arg ~loc ~arg_name ~variant_name:txt core_type in
-        pc_lhs, pc_rhs
+        variant_one_arg_case ~loc ~kind:`Polymorphic ~variant_name:txt core_type
       | Rtag (_, _, _) ->
         let pc_lhs =
           Ast_builder.Default.ppat_extension
@@ -154,37 +153,76 @@ module Impl = struct
 
   and variant_x_args ~loc ~variant_name destructed_tuple =
     let string_lit = Ast_builder.Default.estring ~loc variant_name in
-    [%expr Dyn.variant [%e string_lit] [%e tuple_to_dyn_list ~loc destructed_tuple]]
+    let args = tuple_to_dyn_list ~loc destructed_tuple in
+    [%expr Dyn.variant [%e string_lit] [%e Ast_builder.Default.elist ~loc args]]
+
+  (** Special case function for constructors with a single argument to avoid
+      emitting 1-uple patterns. *)
+  and variant_one_arg_case ~loc ~kind ~variant_name core_type =
+    let make_pat arg_pat =
+      match kind with
+      | `Polymorphic -> Ast_builder.Default.ppat_variant ~loc variant_name (Some arg_pat)
+      | `Regular ->
+        let lident = { txt = Lident variant_name; loc } in
+        Ast_builder.Default.ppat_construct ~loc lident (Some arg_pat)
+    in
+    match Attr.Ignore.core_type core_type with
+    | Ok true ->
+      let arg_pat = Ast_builder.Default.ppat_any ~loc in
+      let pc_lhs = make_pat arg_pat in
+      let pc_rhs = variant_no_arg ~loc ~variant_name in
+      pc_lhs, pc_rhs
+    | Ok false ->
+      let arg_name = String.uncapitalize_ascii variant_name in
+      let arg_pat = Ast_builder.Default.pvar ~loc arg_name in
+      let pc_lhs = make_pat arg_pat in
+      let pc_rhs = variant_one_arg ~loc ~arg_name ~variant_name core_type in
+      pc_lhs, pc_rhs
+    | Error (extension, loc) ->
+      let arg_pat = Ast_builder.Default.ppat_any ~loc in
+      let pc_lhs = make_pat arg_pat in
+      (* Embeds the error in the case right hand side *)
+      let pc_rhs = Ast_builder.Default.pexp_extension ~loc extension in
+      pc_lhs, pc_rhs
   ;;
 
   let destruct_record labels =
     List.map (fun ({ pld_name = { txt; _ }; _ } as pld) -> txt, pld) labels
   ;;
 
   let record_pattern ~loc destructed_record =
-    let fields =
-      List.map
-        (fun (field_name, _) ->
-          { txt = Lident field_name; loc }, Ast_builder.Default.pvar ~loc field_name)
-        destructed_record
+    let field_pat (field_name, pld) =
+      let lhs = { txt = Lident field_name; loc } in
+      let rhs =
+        match Attr.Ignore.label_declaration pld with
+        | Ok true -> Ast_builder.Default.ppat_any ~loc
+        | Ok false -> Ast_builder.Default.pvar ~loc field_name
+        | Error (extension, loc) -> Ast_builder.Default.ppat_extension ~loc extension
+      in
+      lhs, rhs
     in
+    let fields = List.map field_pat destructed_record in
     Ast_builder.Default.ppat_record ~loc fields Closed
   ;;
 
   let record_field_to_dyn ~loc (txt, pld) =
-    let string_lit = Ast_builder.Default.estring ~loc txt in
-    let field_var = Ast_builder.Default.evar ~loc txt in
-    let user_provided_to_dyn = Attr.To_dyn.from_label_declaration pld in
-    let expr =
-      match user_provided_to_dyn with
-      | None -> core_type_to_dyn ~loc ~core_type:pld.pld_type (Some field_var)
-      | Some expr -> Ast_builder.Default.pexp_apply ~loc expr [ Nolabel, field_var ]
-    in
-    Ast_builder.Default.pexp_tuple ~loc [ string_lit; expr ]
+    match Attr.Ignore.label_declaration pld with
+    | Ok true -> None
+    | Ok false ->
+      let string_lit = Ast_builder.Default.estring ~loc txt in
+      let field_var = Ast_builder.Default.evar ~loc txt in
+      let user_provided_to_dyn = Attr.To_dyn.from_label_declaration pld in
+      let expr =
+        match user_provided_to_dyn with
+        | None -> core_type_to_dyn ~loc ~core_type:pld.pld_type (Some field_var)
+        | Some expr -> Ast_builder.Default.pexp_apply ~loc expr [ Nolabel, field_var ]
+      in
+      Some (Ast_builder.Default.pexp_tuple ~loc [ string_lit; expr ])
+    | Error (extension, loc) -> Some (Ast_builder.Default.pexp_extension ~loc extension)
   ;;
 
   let record_to_dyn ~loc destructed_record =
-    let fields = List.map (record_field_to_dyn ~loc) destructed_record in
+    let fields = List.filter_map (record_field_to_dyn ~loc) destructed_record in
     [%expr Dyn.record [%e Ast_builder.Default.elist ~loc fields]]
   ;;
 
@@ -214,11 +252,7 @@ module Impl = struct
         let pc_rhs = variant_no_arg ~loc ~variant_name:txt in
         pc_lhs, pc_rhs
       | None, Pcstr_tuple [ core_type ] ->
-        let arg_name = String.uncapitalize_ascii txt in
-        let pat = Ast_builder.Default.pvar ~loc arg_name in
-        let pc_lhs = Ast_builder.Default.ppat_construct ~loc longident_loc (Some pat) in
-        let pc_rhs = variant_one_arg ~loc ~variant_name:txt ~arg_name core_type in
-        pc_lhs, pc_rhs
+        variant_one_arg_case ~loc ~kind:`Regular ~variant_name:txt core_type
       | None, Pcstr_tuple core_types ->
         let destructed = destruct_tuple core_types in
         let pat = tuple_pattern ~loc destructed in