👍 fully supported decoder

src/ppx/astmisc.ml

@@ -30,12 +30,19 @@ let pint ?loc ?suffix x = Pat.constant ?loc (Const.int ?suffix x)
 let eint ?loc ?suffix x = Exp.constant ?loc (Const.int ?suffix x)
 let estring ?loc x = Exp.constant ?loc (Const.string x)
 
-let attr_base_type ~deriver ~loc attrs =
+let attr_base_type ~deriver attrs =
   let open Ppx_deriving in
-  match attr ~deriver "t" attrs with
-  | Some { attr_payload = PTyp core_type; _ } -> core_type
-  | _ -> Ppx_deriving.raise_errorf ~loc
-           "ppx_deriving_binary requires [@t: base_type] for variants or polymorphic variants"
+  match attr ~deriver "base_type" attrs with
+  | Some { attr_payload = PTyp core_type; _ } -> Some core_type
+  | _ -> None
+
+let attr_base_type_exn ~deriver ~loc attrs =
+  let open Ppx_deriving in
+  match attr_base_type ~deriver attrs with
+  | Some core_type -> core_type
+  | None ->
+    Ppx_deriving.raise_errorf ~loc
+      "ppx_deriving_binary requires [@base_type: t] for variants or polymorphic variants"
 
 let attr_length ~deriver attrs =
   Ppx_deriving.(attrs |> attr ~deriver "length" |> Arg.(get_attr ~deriver int))
@@ -47,6 +54,9 @@ let attr_length_exn ~deriver ~loc attrs =
     Ppx_deriving.raise_errorf ~loc
       "ppx_deriving_binary requires [@length] for string, bytes, list and array"
 
+let attr_offset ~deriver attrs =
+  Ppx_deriving.(attrs |> attr ~deriver "offset" |> Arg.(get_attr ~deriver int))
+
 (** Collect labelled arguments from an expression of
     form [fun ~lb1 ~lb2 ... -> ...]. *)
 let get_labelled_args_from_fun efun =

src/ppx/bitfield.ml

@@ -0,0 +1,56 @@
+(* ppx_deriving_cstruct
+
+   Copyright (c) 2021 Akinori Abe
+
+   Permission is hereby granted, free of charge, to any person obtaining a copy
+   of this software and associated documentation files (the "Software"), to deal
+   in the Software without restriction, including without limitation the rights
+   to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+   copies of the Software, and to permit persons to whom the Software is
+   furnished to do so, subject to the following conditions:
+
+   The above copyright notice and this permission notice shall be included in
+   all copies or substantial portions of the Software.
+
+   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+   SOFTWARE. *)
+
+open Ppx_deriving.Ast_convenience
+open Ppxlib
+open Ppxlib.Ast_helper
+
+type t =
+  {
+    rbf_name : string;
+    rbf_offset : int;
+    rbf_length : int;
+    rbf_mask : int;
+    rbf_loc : Location.t;
+  }
+
+let of_ocaml_label_declarations ~deriver label_decls =
+  let aux (default_ofs, acc) ld =
+    let ofs =
+      match Astmisc.attr_offset ~deriver ld.pld_attributes with
+      | Some n -> n
+      | None -> default_ofs in
+    let len =
+      match Astmisc.attr_length ~deriver ld.pld_attributes with
+      | Some n -> n
+      | None -> 1 in
+    let field = {
+      rbf_name = ld.pld_name.txt;
+      rbf_offset = ofs;
+      rbf_length = len;
+      rbf_mask = 1 lsl len - 1;
+      rbf_loc = ld.pld_loc;
+    } in
+    (ofs + len, field :: acc)
+  in
+  let _, rev_fields = List.fold_left aux (0, []) label_decls in
+  List.rev rev_fields

src/ppx/decoder.ml

@@ -110,11 +110,11 @@ and decoder_of_polymorphic_variant
     ~loc
     row_fields attrs
   =
-  let base_type = Astmisc.attr_base_type ~deriver ~loc attrs in
+  let base_type = Astmisc.attr_base_type_exn ~deriver ~loc attrs in
   Variant.constructors_of_ocaml_row_fields ~deriver row_fields
   |> decoder_of_constructors
     ~deriver ~path ~base_type ~loc
-    ~constructor:Exp.variant
+    ~constructor:(fun name -> Exp.variant name)
 
 and decoder_of_constructors
     ~deriver
@@ -174,3 +174,85 @@ and decoder_of_record ~deriver ~path ~constructor ~loc labels =
       labels
       [%expr ([%e record], _i)] in
   [%expr fun _b _i -> [%e body]]
+
+let decoder_of_variant ~deriver ~path ~loc type_decl constrs attrs =
+  Variant.assert_not_GADT type_decl constrs ;
+  let base_type = Astmisc.attr_base_type_exn ~deriver ~loc attrs in
+  Variant.constructors_of_ocaml_constructors ~deriver constrs
+  |> decoder_of_constructors
+    ~deriver
+    ~path
+    ~base_type
+    ~loc
+    ~constructor:(fun name -> Exp.construct (Astmisc.mklid name))
+
+let mk_record labels =
+  let label_bindings =
+    List.map
+      (fun ld -> (Astmisc.mklid ld.pld_name.txt, evar ld.pld_name.txt))
+      labels in
+  Exp.record label_bindings None
+
+let decoder_of_record_bitfield ~deriver ~path ~loc base_type labels =
+  let open Bitfield in
+  let mk_rec = mk_record labels in
+  let fields = Bitfield.of_ocaml_label_declarations ~deriver labels in
+  let dec =
+    List.fold_right
+      (fun field acc ->
+         let name = pvar field.rbf_name in
+         let loc = field.rbf_loc in
+         let ofs = Exp.constant (Const.int field.rbf_offset) in
+         let mask = Exp.constant (Const.int field.rbf_mask) in
+         let rhs = [%expr (_x lsr [%e ofs]) land [%e mask]] in
+         [%expr let [%p name] = [%e rhs] in [%e acc]])
+      fields mk_rec in
+  let base_decoder = decoder_of_core_type ~deriver ~path base_type in
+  [%expr
+    fun _cs _i ->
+      let _x, _i = [%e base_decoder] _cs _i in
+      ([%e dec], _i)]
+
+let str_decoder_of_type_decl ~deriver ~path type_decl =
+  let loc = type_decl.ptype_loc in
+  let path = String.concat "." path ^ "." ^ type_decl.ptype_name.txt in
+  let decoder = match type_decl.ptype_kind with
+    (* Record type declaration: *)
+    | Ptype_record labels ->
+      begin
+        match Astmisc.attr_base_type ~deriver type_decl.ptype_attributes with
+        | None ->
+          decoder_of_record
+            ~deriver ~path ~loc:type_decl.ptype_loc labels
+            ~constructor:(fun x -> x)
+        | Some base_type ->
+          decoder_of_record_bitfield ~deriver ~path ~loc base_type labels
+      end
+    (* (Non-polymorphics) varia nt type declarations: *)
+    | Ptype_variant constrs ->
+      decoder_of_variant ~deriver ~path ~loc type_decl constrs type_decl.ptype_attributes
+    (* Other types: *)
+    | Ptype_abstract | Ptype_open ->
+      match type_decl.ptype_manifest with
+      | Some typ -> decoder_of_core_type ~deriver ~path typ
+      | None ->
+        Ppx_deriving.raise_errorf
+          "ppx_deriving_cstruct does not support empty types: %s"
+          type_decl.ptype_name.txt in
+  (* Converts type parameters into function parameters *)
+  Astmisc.parametrize_expression type_decl.ptype_params decoder
+
+let type_decl_str ~deriver ~options:_ ~path type_decls =
+  [Astmisc.create_str_value
+     ~mkexp:(str_decoder_of_type_decl ~deriver ~path)
+     affix type_decls]
+
+let sig_decoder_of_type_decl type_decl =
+  Astmisc.create_sig_value
+    affix type_decl
+    ~mktype:(fun t ->
+        let loc = t.ptyp_loc in
+        [%type: Bytes.t -> int -> [%t t] * int])
+
+let type_decl_sig ~options:_ ~path:_ type_decls =
+  List.map (sig_decoder_of_type_decl) type_decls

src/ppx/dune

@@ -16,4 +16,5 @@
  (modules       Ppx_deriving_binary
                 Decoder
                 Variant
+                Bitfield
                 Astmisc))

src/ppx/ppx_deriving_binary.ml

@@ -22,7 +22,9 @@
 
 let () =
   let open Ppx_deriving in
+  let deriver = "of_binary_bytes" in
   register (create "of_binary_bytes" ()
               ~core_type:(Decoder.decoder_of_core_type
-                            ~deriver:"of_binary_bytes"
-                            ~path:"<abstract>"))
+                            ~deriver ~path:"<abstract>")
+              ~type_decl_str:(Decoder.type_decl_str ~deriver)
+              ~type_decl_sig:Decoder.type_decl_sig)