update CCBitField to use first-class modules

src/data/CCBitField.ml

@@ -17,21 +17,28 @@ module type S = sig
   val empty : t
   (** Empty bitfields (all bits 0) *)
 
-  type 'a field
+  type _ field_kind =
-  (** Field of type ['a], with a given width and position within the
+    | Bool : bool field_kind
+    | Int : int field_kind
+
+  (** Field of type [value], with a given width and position within the
       bitfield type *)
+  module type FIELD = sig
+    type value
+    (** Values contained in the field *)
 
-  val get : 'a field -> t -> 'a
+    val get : t -> value
-  (** Get a field of type ['a] *)
 
-  val set : 'a field -> 'a -> t -> t
+    val set : value -> t -> t
-  (** Set a field of type ['a] *)
 
-  val width : _ field -> int
+    val width : int
-  (** Number of bits of the field *)
 
-  val name : _ field -> string
+    val name : string
-  (** Informal name of the field *)
+
+    val kind : value field_kind
+  end
+
+  type 'a field = (module FIELD with type value = 'a)
 
   val bool : ?name:string -> unit -> bool field
   (** New field of type bool
@@ -48,9 +55,10 @@ module type S = sig
       @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int : ?name:string -> width:int -> int field
+  val int : ?name:string -> width:int -> unit -> int field
   (** New field for [width] bits.
       @raise Frozen if [freeze ()] was called
+      @raise Invalid_argument if width is not [<= 1]
       @raise TooManyFields if there is no room *)
 
   val freeze : unit -> unit
@@ -60,7 +68,7 @@ module type S = sig
   val total_width : unit -> int
   (** Current width of the bitfield *)
 
-  type any_field = AnyField : 'a field -> any_field
+  type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field
 
   val iter_fields : (any_field -> unit) -> unit
   (** Iterate on all currently present fields *)
@@ -82,6 +90,17 @@ let rec all_bits_ acc w =
   all_bits_ 0 4 = 15
   *)
 
+(* increment and return previous value *)
+let get_then_incr n =
+  let x = !n in
+  incr n;
+  x
+
+let get_then_add n offset =
+  let x = !n in
+  n := !n + offset;
+  x
+
 module Make(X : EMPTY) : S = struct
   type t = int
 
@@ -91,97 +110,110 @@ module Make(X : EMPTY) : S = struct
     | Bool : bool field_kind
     | Int : int field_kind
 
-  type 'a field = {
+  module type FIELD = sig
-    kind : 'a field_kind;
+    type value
-    name : string;
+    (** Values contained in the field *)
-    width : int;
-    get : t -> 'a;
-    set : 'a -> t -> t;
-  }
 
-  type any_field = AnyField : 'a field -> any_field
+    val get : t -> value
+
+    val set : value -> t -> t
+
+    val width : int
+
+    val name : string
+
+    val kind : value field_kind
+  end
+
+  type 'a field = (module FIELD with type value = 'a)
+
+  type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field
 
   let width_ = ref 0
   let frozen_ = ref false
   let fields_ = Queue.create()
-  let register_ f = Queue.push (AnyField f) fields_
+  let register_
-
+    : type a. (module FIELD with type value = a) -> unit
-  let get f x = f.get x
+    = fun f ->
-  let set f v x = f.set v x
-  let width f = f.width
-  let name f = f.name
-
-  let make_field f =
       if !width_ > max_width then raise TooManyFields;
       if !frozen_ then raise Frozen;
-    register_ f;
+      let (module F) = f in
-    f
+      Queue.push (AnyField (f, F.kind)) fields_
 
   let new_name_ () =
     "field_" ^ string_of_int (Queue.length fields_)
 
-  let bool ?(name=new_name_()) () =
+  let bool ?(name=new_name_()) () : bool field =
-    let n = !width_ in
+    let module B = struct
-    incr width_;
+      type value = bool
-    let mask = 1 lsl n in
+      let n = get_then_incr width_
-    make_field {
+      let mask = 1 lsl n
-      kind = Bool;
+      let name = name
-      name;
+      let width = 1
-      width=1;
+      let get x = (x land mask) <> 0
-      get=(fun x -> (x land mask) <> 0);
+      let set b x =
-      set=(fun b x ->
         if b then x lor mask else x land (lnot mask)
-      );
+      let kind = Bool
-    }
+    end in
+    let f = (module B : FIELD with type value = bool) in
+    register_ f;
+    f
 
   let int2 ?(name=new_name_()) () =
-    let n = !width_ in
+    let module Int2 = struct
-    width_ := n+2;
+      type value = int
-    let mask = 3 lsl n in
+      let n = get_then_add width_ 2
-    make_field {
+      let name = name
-      kind = Int;
+      let mask = 3 lsl n
-      name;
+      let kind = Int
-      width=2;
+      let width=2
-      get=(fun x -> (x land mask) lsr n);
+      let get x = (x land mask) lsr n
-      set=(fun v x ->
+      let set v x =
         assert (x >= 0 && x < 4);
         let x = x land (lnot mask) in
         x lor (v lsl n)
-      )
+    end in
-    }
+    let f = (module Int2 : FIELD with type value = int) in
+    register_ f;
+    f
+
 
   let int3 ?(name=new_name_()) () =
-    let n = !width_ in
+    let module Int3 = struct
-    width_ := n+3;
+      type value = int
-    let mask = 7 lsl n in
+      let name = name
-    make_field {
+      let n = get_then_add width_ 3
-      kind = Int;
+      let mask = 7 lsl n
-      name;
+      let width = 3
-      width=3;
+      let kind = Int
-      get=(fun x -> (x land mask) lsr n);
+      let get x = (x land mask) lsr n
-      set=(fun v x ->
+      let set v x =
       assert (x >= 0 && x < 8);
       let x = x land (lnot mask) in
       x lor (v lsl n)
-      )
+    end in
-    }
+    let f = (module Int3 : FIELD with type value = int) in
+    register_ f;
+    f
 
-  let int ?(name=new_name_()) ~width:w =
+  let int ?(name=new_name_()) ~width:w () =
-    let n = !width_ in
+    let module F = struct
-    width_ := n+w;
+      type value = int
-    let mask_unshifted = all_bits_ 0 w in
+      let n = get_then_add width_ w
-    let mask = mask_unshifted lsl n in
+      let mask_unshifted = all_bits_ 0 w
-    make_field {
+      let mask = mask_unshifted lsl n
-      kind = Int;
+      let kind = Int
-      name;
+      let name = name
-      width=w;
+      let width = w
-      get=(fun x -> (x land mask) lsr n);
+      let get x = (x land mask) lsr n
-      set=(fun v x ->
+      let set v x =
       assert (x >= 0 && x <= mask_unshifted);
       let x = x land (lnot mask) in
       x lor (v lsl n)
-      )
+    end in
-    }
+    let f = (module F : FIELD with type value = int) in
+    register_ f;
+    f
 
   let freeze () = frozen_ := true
 
@@ -194,15 +226,15 @@ module Make(X : EMPTY) : S = struct
     ppf out "{@[<hv>";
     let first=ref true in
     Queue.iter
-      (fun (AnyField f) ->
+      (fun (AnyField ((module F), kind)) ->
         if !first then first := false else ppf out ",@ ";
-        match f.kind with
+        match kind with
         | Bool ->
-            let b = get f x in
+            let b = F.get x in
-            ppf out "%s=%b" f.name b
+            ppf out "%s=%b" F.name b
         | Int ->
-            let i = get f x in
+            let i = F.get x in
-            ppf out "%s=%u" f.name i
+            ppf out "%s=%u" F.name i
       ) fields_;
     ppf out "@]}"
 end

src/data/CCBitField.mli

@@ -11,20 +11,24 @@ module B = CCBitField.Make(struct end);;
 
 #install_printer B.pp;;
 
-let x = B.int ~name:"x" ~width:3;;
+module X = (val B.int ~name:"x" ~width:3 ());;
-let y = B.int ~name:"y" ~width:2;;
+module Y = (val B.int ~name:"y" ~width:2 ());;
-let z = B.bool ~name:"z" ();;
+module Z = (val B.bool ~name:"z" ());;
 
-let f = B.(empty |> set x 3 |> set y 1);;
+let f = B.empty |> X.set 3 |> Y.set 1;;
 
-B.get z f ;;
+Z.get f ;;
 
-B.(f |> set z true |> get z) ;;
+f |> Z.set true |> Z.get ;;
+
+Format.printf "f: %a@." B.pp f;;
 
 ]}
 
-  {b status: experimental}
+{b status: experimental}
-  @since NEXT_RELEASE *)
+
+@since NEXT_RELEASE
+*)
 
 exception TooManyFields
 (** Raised when too many fields are packed into one bitfield *)
@@ -33,9 +37,10 @@ exception Frozen
 (** Raised when a frozen bitfield is modified *)
 
 module type EMPTY = sig end
+(** Used for generativity on versions of OCaml older than 4.02 *)
 
 val max_width : int
-(** System-dependent maximum width for a bitfield *)
+(** System-dependent maximum width for a bitfield, typically 30 or 62 *)
 
 (** {2 Bitfield Signature} *)
 module type S = sig
@@ -46,21 +51,28 @@ module type S = sig
   val empty : t
   (** Empty bitfields (all bits 0) *)
 
-  type 'a field
+  type _ field_kind =
-  (** Field of type ['a], with a given width and position within the
+    | Bool : bool field_kind
+    | Int : int field_kind
+
+  (** Field of type [value], with a given width and position within the
       bitfield type *)
+  module type FIELD = sig
+    type value
+    (** Values contained in the field *)
 
-  val get : 'a field -> t -> 'a
+    val get : t -> value
-  (** Get a field of type ['a] *)
 
-  val set : 'a field -> 'a -> t -> t
+    val set : value -> t -> t
-  (** Set a field of type ['a] *)
 
-  val width : _ field -> int
+    val width : int
-  (** Number of bits of the field *)
 
-  val name : _ field -> string
+    val name : string
-  (** Informal name of the field *)
+
+    val kind : value field_kind
+  end
+
+  type 'a field = (module FIELD with type value = 'a)
 
   val bool : ?name:string -> unit -> bool field
   (** New field of type bool
@@ -77,9 +89,10 @@ module type S = sig
       @raise Frozen if [freeze ()] was called
       @raise TooManyFields if there is no room *)
 
-  val int : ?name:string -> width:int -> int field
+  val int : ?name:string -> width:int -> unit -> int field
   (** New field for [width] bits.
       @raise Frozen if [freeze ()] was called
+      @raise Invalid_argument if width is not [<= 1]
       @raise TooManyFields if there is no room *)
 
   val freeze : unit -> unit
@@ -89,7 +102,7 @@ module type S = sig
   val total_width : unit -> int
   (** Current width of the bitfield *)
 
-  type any_field = AnyField : 'a field -> any_field
+  type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field
 
   val iter_fields : (any_field -> unit) -> unit
   (** Iterate on all currently present fields *)
@@ -104,31 +117,31 @@ module Make(X : EMPTY) : S
 (*$R
   let module B = CCBitField.Make(struct end) in
 
-  let x = B.bool () in
+  let module X = (val B.bool ()) in
-  let y = B.int2 () in
+  let module Y = (val B.int2 ()) in
-  let z = B.bool () in
+  let module Z = (val B.bool ()) in
-  let u = B.int 4 in
+  let module U = (val B.int ~width:4 ()) in
 
-  assert_equal 2 (B.width y) ;
+  assert_equal 2 Y.width ;
-  assert_equal 4 (B.width u) ;
+  assert_equal 4 U.width ;
 
   let f = B.empty
-  |> B.set y 3
+  |> Y.set 3
-  |> B.set z true
+  |> Z.set true
   in
 
   assert_equal 14 (f :> int) ;
 
-  assert_equal false (B.get x f) ;
+  assert_equal false (X.get f) ;
-  assert_equal 3 (B.get y f) ;
+  assert_equal 3 (Y.get f) ;
-  assert_equal true (B.get z f);
+  assert_equal true (Z.get f);
 
-  let f' = B.set u 13 f in
+  let f' = U.set 13 f in
 
-  assert_equal false (B.get x f') ;
+  assert_equal false (X.get f') ;
-  assert_equal 3 (B.get y f') ;
+  assert_equal 3 (Y.get f') ;
-  assert_equal true (B.get z f');
+  assert_equal true (Z.get f');
-  assert_equal 13 (B.get u f');
+  assert_equal 13 (U.get f');
 
   ()
 *)