Merge pull request #233 from emillon/ignore-underscore-fields

Ignore underscore fields

Author: avsm

ppx/ppx_cstruct.ml

@@ -45,6 +45,9 @@ type field = {
   off: int;
 }
 
+let field_is_ignored f =
+  String.get f.field 0 = '_'
+
 type t = {
   name: string;
   fields: field list;
@@ -150,154 +153,138 @@ let op_name s op =
 
 let op_pvar s op = Ast.pvar (op_name s op)
 let op_evar s op = Ast.evar (op_name s op)
-let op_val_typ loc s op ty =
-  Sig.value (Val.mk (Loc.mkloc (op_name s op) loc) ty)
 
-let output_get _loc s f =
-  let m = mode_mod _loc s.endian in
+let get_expr loc s f =
+  let m = mode_mod loc s.endian in
   let num x = Ast.int x in
   match f.ty with
   |Buffer (_, _) ->
     let len = width_of_field f in
-    [%str
-      let [%p op_pvar s (Op_get f)] =
-        fun src -> Cstruct.sub src [%e num f.off] [%e num len]
-
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_copy f)] =
-        fun src -> Cstruct.copy src [%e num f.off] [%e num len]
+    [%expr
+      fun src -> Cstruct.sub src [%e num f.off] [%e num len]
     ]
   |Prim prim ->
-    [%str
-      let [%p op_pvar s (Op_get f)] = fun v ->
+    [%expr
+      fun v ->
         [%e match prim with
             |Char -> [%expr Cstruct.get_char v [%e num f.off]]
             |UInt8 -> [%expr Cstruct.get_uint8 v [%e num f.off]]
             |UInt16 -> [%expr [%e m "get_uint16"] v [%e num f.off]]
             |UInt32 -> [%expr [%e m "get_uint32"] v [%e num f.off]]
             |UInt64 -> [%expr [%e m "get_uint64"] v [%e num f.off]]]]
 
-let output_get loc s f =
-  (output_get loc s f) [@metaloc loc]
-
 let type_of_int_field = function
   |Char -> [%type: char]
   |UInt8 -> [%type: Cstruct.uint8]
   |UInt16 -> [%type: Cstruct.uint16]
   |UInt32 -> [%type: Cstruct.uint32]
   |UInt64 -> [%type: Cstruct.uint64]
 
-let type_of_int_field _loc x =
-  type_of_int_field x [@metaloc loc]
-
-let output_get_sig loc s f =
-  match f.ty with
-  |Buffer (_,_) ->
-    [
-      op_val_typ loc s (Op_get f) [%type: Cstruct.t -> Cstruct.t];
-      op_val_typ loc s (Op_copy f) [%type: Cstruct.t -> string]
-    ]
-  |Prim prim ->
-    let retf = type_of_int_field loc prim in
-    [
-      op_val_typ loc s (Op_get f) [%type: Cstruct.t -> [%t retf]]
-    ]
-
-let output_get_sig _loc s f =
-  output_get_sig _loc s f [@metaloc _loc]
-
-let output_set _loc s f =
-  let m = mode_mod _loc s.endian in
+let set_expr loc s f =
+  let m = mode_mod loc s.endian in
   let num x = Ast.int x in
   match f.ty with
   |Buffer (_,_) ->
     let len = width_of_field f in
-    [%str
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_set f)] = fun src srcoff dst ->
-        Cstruct.blit_from_string src srcoff dst [%e num f.off] [%e num len]
-
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_blit f)] = fun src srcoff dst ->
-        Cstruct.blit src srcoff dst [%e num f.off] [%e num len]]
+    [%expr
+      fun src srcoff dst ->
+        Cstruct.blit_from_string src srcoff dst [%e num f.off] [%e num len]]
   |Prim prim ->
-    [%str
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_set f)] = fun v x ->
+    [%expr fun v x ->
         [%e match prim with
             |Char -> [%expr Cstruct.set_char v [%e num f.off] x]
             |UInt8 -> [%expr Cstruct.set_uint8 v [%e num f.off] x]
             |UInt16 -> [%expr [%e m "set_uint16"] v [%e num f.off] x]
             |UInt32 -> [%expr [%e m "set_uint32"] v [%e num f.off] x]
             |UInt64 -> [%expr [%e m "set_uint64"] v [%e num f.off] x]]]
 
-let output_set _loc s f =
-  output_set _loc s f [@metaloc _loc]
-
-let output_set_sig loc s f =
+let type_of_set f =
   match f.ty with
   |Buffer (_,_) ->
-    [
-      op_val_typ loc s (Op_set f) [%type: string -> int -> Cstruct.t -> unit];
-      op_val_typ loc s (Op_blit f) [%type: Cstruct.t -> int -> Cstruct.t -> unit]
-    ] [@metaloc loc]
+    [%type: string -> int -> Cstruct.t -> unit]
   |Prim prim ->
-    let retf = type_of_int_field loc prim in
-    [
-      op_val_typ loc s (Op_set f) [%type: Cstruct.t -> [%t retf] -> unit]
-    ] [@metaloc loc]
-
-let output_sizeof _loc s =
-  [%stri
-    let [%p op_pvar s Op_sizeof] = [%e Ast.int s.len]] [@metaloc _loc]
-
-let output_sizeof_sig loc s =
-  op_val_typ loc s Op_sizeof [%type: int]
-
-let output_hexdump _loc s =
-  let hexdump =
-    List.fold_left (fun a f ->
-        let get_f = op_evar s (Op_get f) in
-        [%expr
-          [%e a]; Buffer.add_string _buf [%e Ast.str ("  "^f.field^" = ")];
-          [%e match f.ty with
-              |Prim Char ->
-                [%expr Printf.bprintf _buf "%c\n" ([%e get_f] v)]
-              |Prim (UInt8|UInt16) ->
-                [%expr Printf.bprintf _buf "0x%x\n" ([%e get_f] v)]
-              |Prim UInt32 ->
-                [%expr Printf.bprintf _buf "0x%lx\n" ([%e get_f] v)]
-              |Prim UInt64 ->
-                [%expr Printf.bprintf _buf "0x%Lx\n" ([%e get_f] v)]
-              |Buffer (_,_) ->
-                [%expr Printf.bprintf _buf "<buffer %s>"
-                         [%e Ast.str (field_to_string f)];
-                         Cstruct.hexdump_to_buffer _buf ([%e get_f] v)]
-          ]]
-      ) (Ast.unit ()) s.fields
-  in
-  [
-    [%stri
-      let [%p op_pvar s Op_hexdump_to_buffer] = fun _buf v ->
-        [%e hexdump]];
-    [%stri
-      let[@ocaml.warning "-32"] [%p op_pvar s Op_hexdump] = fun v ->
-        let _buf = Buffer.create 128 in
-        Buffer.add_string _buf [%e Ast.str (s.name ^ " = {\n")];
-        [%e op_evar s Op_hexdump_to_buffer] _buf v;
-        print_endline (Buffer.contents _buf);
-        print_endline "}"
-    ]
-  ] [@metaloc _loc]
-
-let output_hexdump_sig loc s =
-  [
-    op_val_typ loc s Op_hexdump_to_buffer [%type: Buffer.t -> Cstruct.t -> unit];
-    op_val_typ loc s Op_hexdump [%type: Cstruct.t -> unit];
+    let retf = type_of_int_field prim in
+    [%type: Cstruct.t -> [%t retf] -> unit]
+
+let hexdump_expr s =
+  [%expr fun v ->
+    let buf = Buffer.create 128 in
+    Buffer.add_string buf [%e Ast.str (s.name ^ " = {\n")];
+    [%e op_evar s Op_hexdump_to_buffer] buf v;
+    print_endline (Buffer.contents buf);
+    print_endline "}"
   ]
 
-let output_struct_one_endian _loc s =
-  (* Generate functions of the form {get/set}_<struct>_<field> *)
-  let expr = List.fold_left (fun a f ->
-      a @ output_get _loc s f @ output_set _loc s f
-    ) [output_sizeof _loc s] s.fields
-  in expr @ output_hexdump _loc s
+let hexdump_to_buffer_expr s =
+  let prim_format_string = function
+    | Char -> [%expr "%c\n"]
+    | UInt8 | UInt16 -> [%expr "0x%x\n"]
+    | UInt32 -> [%expr "0x%lx\n"]
+    | UInt64 -> [%expr "0x%Lx\n"]
+  in
+  let hexdump_field f =
+    if field_is_ignored f then
+      [%expr ()]
+    else
+      let get_f = op_evar s (Op_get f) in
+      let expr =
+        match f.ty with
+        |Prim p ->
+          [%expr Printf.bprintf buf [%e prim_format_string p] ([%e get_f] v)]
+        |Buffer (_,_) ->
+          [%expr Printf.bprintf buf "<buffer %s>" [%e Ast.str (field_to_string f)];
+            Cstruct.hexdump_to_buffer buf ([%e get_f] v)]
+    in
+    [%expr
+      Printf.bprintf buf "  %s = " [%e Ast.str f.field];
+      [%e expr]]
+  in
+  [%expr fun buf v -> [%e Ast.sequence (List.map hexdump_field s.fields)]]
+
+let op_expr loc s = function
+  | Op_sizeof -> Ast.int s.len
+  | Op_hexdump -> hexdump_expr s
+  | Op_hexdump_to_buffer -> hexdump_to_buffer_expr s
+  | Op_get f -> get_expr loc s f
+  | Op_set f -> set_expr loc s f
+  | Op_copy f ->
+    let len = width_of_field f in
+    [%expr fun src -> Cstruct.copy src [%e Ast.int f.off] [%e Ast.int len] ]
+  | Op_blit f ->
+    let len = width_of_field f in
+    [%expr fun src srcoff dst ->
+      Cstruct.blit src srcoff dst [%e Ast.int f.off] [%e Ast.int len]]
+
+let field_ops_for f =
+  if field_is_ignored f then
+    []
+  else
+    let if_buffer x =
+      match f.ty with
+      |Buffer (_,_) -> [x]
+      |Prim _ -> []
+    in
+    List.concat
+      [ [Op_get f]
+      ; if_buffer (Op_copy f)
+      ; [Op_set f]
+      ; if_buffer (Op_blit f)
+      ]
+
+let ops_for s =
+  ( [Op_sizeof]
+  @ List.concat (List.map field_ops_for s.fields)
+  @ [Op_hexdump_to_buffer;
+     Op_hexdump;
+    ])
+
+(** Generate functions of the form {get/set}_<struct>_<field> *)
+let output_struct_one_endian loc s =
+  List.map
+    (fun op ->
+       [%stri let[@ocaml.warning "-32"] [%p op_pvar s op] =
+                [%e op_expr loc s op]])
+    (ops_for s)
 
 let output_struct _loc s =
   match s.endian with
@@ -315,12 +302,32 @@ let output_struct _loc s =
         ]
   | _ -> output_struct_one_endian _loc s
 
-let output_struct_sig _loc s =
-  (* Generate signaturs of the form {get/set}_<struct>_<field> *)
-  let expr = List.fold_left (fun a f ->
-      a @ output_get_sig _loc s f @ output_set_sig _loc s f
-    ) [output_sizeof_sig _loc s] s.fields
-  in expr @ output_hexdump_sig _loc s
+let type_of_get f =
+  match f.ty with
+  |Buffer (_,_) ->
+    [%type: Cstruct.t -> Cstruct.t]
+  |Prim prim ->
+    let retf = type_of_int_field prim in
+    [%type: Cstruct.t -> [%t retf]]
+
+let op_typ = function
+  | Op_sizeof -> [%type: int]
+  | Op_hexdump_to_buffer -> [%type: Buffer.t -> Cstruct.t -> unit]
+  | Op_hexdump -> [%type: Cstruct.t -> unit]
+  | Op_get f -> type_of_get f
+  | Op_set f -> type_of_set f
+  | Op_copy _ -> [%type: Cstruct.t -> string]
+  | Op_blit _ -> [%type: Cstruct.t -> int -> Cstruct.t -> unit]
+
+(** Generate signatures of the form {get/set}_<struct>_<field> *)
+let output_struct_sig loc s =
+  List.map
+    (fun op ->
+       Sig.value
+         (Val.mk
+            (Loc.mkloc (op_name s op) loc)
+            (op_typ op)))
+    (ops_for s)
 
 let output_enum _loc name fields width ~sexp =
   let intfn,pattfn = match ty_of_string width with

ppx_test/basic.expected

@@ -8,3 +8,8 @@ foo = {
 
 }
 "\007\000,\000\000\190\239abcdefgh"
+with_ignored_field = {
+  a = 0x1
+  c = 0x3
+
+}

ppx_test/basic.ml

@@ -72,6 +72,20 @@ type unused = {
 } [@@big_endian]
 ]
 
+let set_with_ignored_field__b = true
+
+let _ : bool = set_with_ignored_field__b
+
+[%%cstruct
+type with_ignored_field = {
+  a : uint8_t;
+  _b : uint8_t;
+  c : uint8_t;
+} [@@little_endian]
+]
+
+let _ : bool = set_with_ignored_field__b
+
 let tests () =
   (* Test basic set/get functions *)
   let be = Cstruct.of_bigarray (Bigarray.(Array1.create char c_layout sizeof_foo)) in
@@ -151,6 +165,7 @@ let tests () =
   assert(get_foo_b be = 44);
   assert(get_foo_a be = 7);
   hexdump_foo be;
-  print_endline (Sexplib.Sexp.to_string_hum (Cstruct.sexp_of_t be))
+  print_endline (Sexplib.Sexp.to_string_hum (Cstruct.sexp_of_t be));
+  hexdump_with_ignored_field (Cstruct.of_hex "010203")
 
 let () = tests ()