diff --git a/src/repr/type.ml b/src/repr/type.ml index 9336da3e..c4120282 100644 --- a/src/repr/type.ml +++ b/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 () = diff --git a/src/repr/type_binary.ml b/src/repr/type_binary.ml index 505191e2..02aa8031 100644 --- a/src/repr/type_binary.ml +++ b/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 diff --git a/src/repr/type_binary.mli b/src/repr/type_binary.mli index 79c35f6b..8e4fc273 100644 --- a/src/repr/type_binary.mli +++ b/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 diff --git a/src/repr/type_core_intf.ml b/src/repr/type_core_intf.ml index 0650cf2c..3be2fcd2 100644 --- a/src/repr/type_core_intf.ml +++ b/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 } diff --git a/src/repr/type_json.ml b/src/repr/type_json.ml index 4f7f7cae..8e83a53e 100644 --- a/src/repr/type_json.ml +++ b/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 diff --git a/src/repr/type_ordered.ml b/src/repr/type_ordered.ml index b5c1d09d..98fa2f07 100644 --- a/src/repr/type_ordered.ml +++ b/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) diff --git a/src/repr/type_pp.ml b/src/repr/type_pp.ml index ec65e3f9..8fb55299 100644 --- a/src/repr/type_pp.ml +++ b/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 diff --git a/src/repr/type_random.ml b/src/repr/type_random.ml index b5e7248f..d94e11cf 100644 --- a/src/repr/type_random.ml +++ b/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) diff --git a/src/repr/type_size.ml b/src/repr/type_size.ml index e6cf2347..a06dc965 100644 --- a/src/repr/type_size.ml +++ b/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