From eb83002a8edcaf2540e59ed7d919d2b65fedb687 Mon Sep 17 00:00:00 2001
From: Craig Ferguson <me@craigfe.io>
Date: Tue, 8 Jun 2021 23:45:17 +0100
Subject: [PATCH] Revert "Implement Boxed annotation"

This reverts commit b09dddf23f02d52b7d6d4168bc23ef26ef87882e.

Implementing boxing in terms of annotations is conceptually correct, but
interacts with an existing bug in the definition of `pre_hash` (see
https://github.com/mirage/repr/issues/39) that makes this change
breaking inside Irmin.

Pending a solution to https://github.com/mirage/repr/issues/39, we
should avoid changing the behaviour of `pre_hash` in this way. This
restores compatibility with Irmin `master`.
---
 src/repr/type.ml           |  2 +-
 src/repr/type_binary.ml    | 16 ++++++----------
 src/repr/type_binary.mli   |  1 -
 src/repr/type_core_intf.ml |  1 +
 src/repr/type_json.ml      |  2 ++
 src/repr/type_ordered.ml   |  4 ++++
 src/repr/type_pp.ml        |  2 ++
 src/repr/type_random.ml    |  4 ++--
 src/repr/type_size.ml      |  2 ++
 9 files changed, 20 insertions(+), 14 deletions(-)

diff --git a/src/repr/type.ml b/src/repr/type.ml
index a0522955..a4685fcd 100644
--- a/src/repr/type.ml
+++ b/src/repr/type.ml
@@ -58,7 +58,7 @@ 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 = annotate ~add:Type_binary.Boxed.add ~data:() t
+let boxed t = Boxed 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 2045783f..505191e2 100644
--- a/src/repr/type_binary.ml
+++ b/src/repr/type_binary.ml
@@ -18,12 +18,6 @@ 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)))
@@ -135,6 +129,7 @@ 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
@@ -149,8 +144,8 @@ module Encode = struct
     | Custom c -> c.unboxed_encode_bin
     | Map b -> map ~boxed:false b
     | Prim t -> prim ~boxed:false t
-    | Attributes { attr_type = x; attrs } -> (
-        match Boxed.find attrs with Some () -> t x | None -> unboxed x)
+    | Boxed b -> t b
+    | Attributes { attr_type = x; _ } -> unboxed x
     | List l -> list (t l.v) l.len
     | Array a -> array (t a.v) a.len
     | Tuple t -> tuple t
@@ -339,6 +334,7 @@ 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
@@ -353,8 +349,8 @@ module Decode = struct
     | Custom c -> c.unboxed_decode_bin
     | Map b -> map ~boxed:false b
     | Prim t -> prim ~boxed:false t
-    | Attributes { attr_type = x; attrs } -> (
-        match Boxed.find attrs with Some () -> t x | None -> unboxed x)
+    | Boxed b -> t b
+    | Attributes { attr_type = x; _ } -> 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 8e4fc273..79c35f6b 100644
--- a/src/repr/type_binary.mli
+++ b/src/repr/type_binary.mli
@@ -16,7 +16,6 @@
 
 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 e65aa470..2718d9f0 100644
--- a/src/repr/type_core_intf.ml
+++ b/src/repr/type_core_intf.ml
@@ -30,6 +30,7 @@ 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 ea235554..eab7e434 100644
--- a/src/repr/type_json.ml
+++ b/src/repr/type_json.ml
@@ -91,6 +91,7 @@ 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 Encode_json.find attrs with None -> t x | Some t -> t)
     | Prim t -> prim t
@@ -301,6 +302,7 @@ 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 Decode_json.find attrs with None -> t x | Some f -> f)
     | List l -> list (t l.v)
diff --git a/src/repr/type_ordered.ml b/src/repr/type_ordered.ml
index 98fa2f07..b5c1d09d 100644
--- a/src/repr/type_ordered.ml
+++ b/src/repr/type_ordered.ml
@@ -54,6 +54,8 @@ 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 _ ),
         _ ) ->
@@ -135,6 +137,7 @@ 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)
@@ -284,6 +287,7 @@ 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 19bafc32..8f7658a7 100644
--- a/src/repr/type_pp.ml
+++ b/src/repr/type_pp.ml
@@ -68,6 +68,7 @@ let dump t =
     | Tuple t -> tuple t ppf x
     | Record r -> record r ppf x
     | Variant v -> variant v ppf x
+    | Boxed t -> aux t ppf x
     | Attributes { attrs; attr_type = t } -> (
         match Attr.find attrs with None -> aux t ppf x | Some pp -> pp ppf x)
   and map : type a b. (a, b) map -> b pp = fun l ppf x -> aux l.x ppf (l.g x)
@@ -166,6 +167,7 @@ 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 6728f324..a57198bc 100644
--- a/src/repr/type_random.ml
+++ b/src/repr/type_random.ml
@@ -74,8 +74,8 @@ let rec t : type a. a t -> a random = function
   | Option x -> option x
   | Record x -> record x
   | Variant x -> variant x
-  | Attributes { attr_type; attrs } -> (
-      match Attr.find attrs with None -> t attr_type | Some f -> stage f)
+  | 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 a06dc965..e6cf2347 100644
--- a/src/repr/type_size.ml
+++ b/src/repr/type_size.ml
@@ -107,6 +107,7 @@ 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
@@ -121,6 +122,7 @@ 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