Skip to content

Commit

Permalink
Merge pull request #233 from emillon/ignore-underscore-fields
Browse files Browse the repository at this point in the history 
Ignore underscore fields
  • Loading branch information
@avsm
avsm authored Mar 10, 2019
2 parents 9437574 + 7dfd205 commit a6a768d
Show file tree
Hide file tree
Showing 3 changed files with 144 additions and 117 deletions.
239 changes: 123 additions & 116 deletions ppx/ppx_cstruct.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
5 changes: 5 additions & 0 deletions ppx_test/basic.expected
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,3 +8,8 @@ foo = {

}
"\007\000,\000\000\190\239abcdefgh"
with_ignored_field = {
a = 0x1
c = 0x3

}
17 changes: 16 additions & 1 deletion ppx_test/basic.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 ()

0 comments on commit a6a768d

Please sign in to comment.