Implement Boxed annotation

src/repr/type.ml

@@ -61,7 +61,9 @@ let array ?(len = `Int) v = Array { v; len }
 let pair a b = Tuple (Pair (a, b))
 let triple a b c = Tuple (Triple (a, b, c))
 let option a = Option a
-let boxed t = Boxed t
+
+let boxed t =
+  annotate ~key:Type_binary.Boxed.attr ~data:(Type_binary.Boxed.inj ()) t
 
 let abstract ~pp ~of_string ~json ~bin ?unboxed_bin ~equal ~compare ~short_hash
     ~pre_hash () =

src/repr/type_binary.ml

@@ -18,6 +18,12 @@ open Type_core
 open Staging
 open Utils
 
+module Boxed = Attribute.Make1 (struct
+  type _ t = unit
+
+  let name = "boxed"
+end)
+
 module Encode = struct
   let chars =
     Array.init 256 (fun i -> Bytes.unsafe_to_string (Bytes.make 1 (Char.chr i)))
@@ -129,7 +135,6 @@ module Encode = struct
     | Custom c -> c.encode_bin
     | Map b -> map ~boxed:true b
     | Prim t -> prim ~boxed:true t
-    | Boxed b -> t b
     | Attributes { attr_type = x; _ } -> t x
     | List l -> list (t l.v) l.len
     | Array a -> array (t a.v) a.len
@@ -144,8 +149,8 @@ module Encode = struct
     | Custom c -> c.unboxed_encode_bin
     | Map b -> map ~boxed:false b
     | Prim t -> prim ~boxed:false t
-    | Boxed b -> t b
-    | Attributes { attr_type = x; _ } -> unboxed x
+    | Attributes { attr_type = x; attrs } -> (
+        match Boxed.find_attr attrs with Some () -> t x | None -> unboxed x)
     | List l -> list (t l.v) l.len
     | Array a -> array (t a.v) a.len
     | Tuple t -> tuple t
@@ -334,7 +339,6 @@ module Decode = struct
     | Custom c -> c.decode_bin
     | Map b -> map ~boxed:true b
     | Prim t -> prim ~boxed:true t
-    | Boxed b -> t b
     | Attributes { attr_type = x; _ } -> t x
     | List l -> list (t l.v) l.len
     | Array a -> array (t a.v) a.len
@@ -349,8 +353,8 @@ module Decode = struct
     | Custom c -> c.unboxed_decode_bin
     | Map b -> map ~boxed:false b
     | Prim t -> prim ~boxed:false t
-    | Boxed b -> t b
-    | Attributes { attr_type = x; _ } -> unboxed x
+    | Attributes { attr_type = x; attrs } -> (
+        match Boxed.find_attr attrs with Some () -> t x | None -> unboxed x)
     | List l -> list (t l.v) l.len
     | Array a -> array (t a.v) a.len
     | Tuple t -> tuple t

src/repr/type_binary.mli

@@ -16,6 +16,7 @@
 
 open Type_core
 open Staging
+module Boxed : Attribute.S1 with type _ t = unit
 
 val encode_bin : 'a t -> 'a encode_bin
 val decode_bin : 'a t -> 'a decode_bin

src/repr/type_core_intf.ml

@@ -31,7 +31,6 @@ module Types = struct
     | Option : 'a t -> 'a option t
     | Record : 'a record -> 'a t
     | Variant : 'a variant -> 'a t
-    | Boxed : 'a t -> 'a t
 
   and 'a len_v = { len : len; v : 'a t }
 

src/repr/type_json.ml

@@ -91,7 +91,6 @@ module Encode = struct
     | Self s -> t s.self_fix
     | Custom _ -> failwith "Unimplemented operation: encode_json"
     | Map b -> map b
-    | Boxed x -> t x
     | Attributes { attr_type = x; attrs } -> (
         match Attribute.Map.find attrs Encode_json.attr with
         | None -> t x
@@ -304,7 +303,6 @@ module Decode = struct
     | Self s -> t s.self_fix
     | Map b -> map b
     | Prim t -> prim t
-    | Boxed x -> t x
     | Attributes { attr_type = x; attrs } -> (
         match Attribute.Map.find attrs Decode_json.attr with
         | None -> t x

src/repr/type_ordered.ml

@@ -54,8 +54,6 @@ module Refl = struct
     | Variant a, Variant b -> Witness.eq a.vwit b.vwit
     | Var v, _ | _, Var v -> raise (Unbound_type_variable v)
     | Attributes a, Attributes b -> t a.attr_type b.attr_type
-    | Boxed a, b -> t a b
-    | a, Boxed b -> t a b
     | ( ( Map _ | Custom _ | Prim _ | Array _ | List _ | Tuple _ | Option _
         | Record _ | Variant _ | Attributes _ ),
         _ ) ->
@@ -137,7 +135,6 @@ module Equal = struct
     | Custom c -> c.equal
     | Map m -> map m
     | Attributes { attr_type = x; _ } -> t x
-    | Boxed x -> t x
     | Prim p -> prim p
     | List l -> list (t l.v)
     | Array x -> array (t x.v)
@@ -287,7 +284,6 @@ module Compare = struct
     | Self s -> self s
     | Custom c -> c.compare
     | Map m -> map m
-    | Boxed x -> t x
     | Attributes { attr_type = x; _ } -> t x
     | Prim p -> (prim [@inlined]) p
     | List l -> list (t l.v)

src/repr/type_pp.ml

@@ -72,7 +72,6 @@ let dump t =
         match Attr.find_attr attrs with
         | None -> aux t ppf x
         | Some pp -> pp ppf x)
-    | Boxed t -> aux t ppf x
   and map : type a b. (a, b) map -> b pp = fun l ppf x -> aux l.x ppf (l.g x)
   and prim : type a. a prim -> a pp =
    fun t ppf x ->
@@ -169,7 +168,6 @@ let ty : type a. a t Fmt.t =
         Fmt.pf ppf "@[Attributes<%a> (%a)@]"
           Fmt.(list ~sep:semi string)
           names ty t
-    | Boxed b -> Fmt.pf ppf "@[Boxed (%a)@]" ty b
     | Map m -> Fmt.pf ppf "@[Map (%a)@]" ty m.x
     | Prim p -> Fmt.pf ppf "@[%a@]" prim p
     | List l -> Fmt.pf ppf "@[%a list%a@]" ty l.v len l.len

src/repr/type_random.ml

@@ -69,7 +69,6 @@ let rec t : type a. a t -> a random = function
   | Record x -> record x
   | Variant x -> variant x
   | Attributes { attr_type; _ } -> t attr_type
-  | Boxed x -> t x
   | Self x -> stage (fun s -> (* improperly staged *) unstage (t x.self_fix) s)
   | Custom _ -> failwith "Cannot generate random instance of Custom type"
   | Var v -> raise (Unbound_type_variable v)

src/repr/type_size.ml

@@ -107,7 +107,6 @@ let rec t : type a. a t -> a size_of = function
   | Map b -> map ~boxed:true b
   | Prim t -> prim ~boxed:true t
   | Attributes { attr_type; _ } -> t attr_type
-  | Boxed b -> t b
   | List l -> list (t l.v) l.len
   | Array a -> array (t a.v) a.len
   | Tuple t -> tuple t
@@ -122,7 +121,6 @@ and unboxed : type a. a t -> a size_of = function
   | Map b -> map ~boxed:false b
   | Prim t -> prim ~boxed:false t
   | Attributes { attr_type; _ } -> t attr_type
-  | Boxed b -> t b
   | List l -> list (t l.v) l.len
   | Array a -> array (t a.v) a.len
   | Tuple t -> tuple t