From 42e57be004532ecc75a4c002196a061ee358df57 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 28 Jul 2021 17:02:53 +0200
Subject: [PATCH 01/69] Proto: compile compare_comparable to Coq

---
 .../lib_protocol/script_comparable.ml         | 82 +++++++++++--------
 1 file changed, 49 insertions(+), 33 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml
index 394285268528..3b2b09b80504 100644
--- a/src/proto_alpha/lib_protocol/script_comparable.ml
+++ b/src/proto_alpha/lib_protocol/script_comparable.ml
@@ -42,48 +42,63 @@ type compare_comparable_cont =
       -> compare_comparable_cont
   | Compare_comparable_return : compare_comparable_cont
 
-let compare_comparable : type a. a comparable_ty -> a -> a -> int =
-  let rec compare_comparable :
+module Compare_comparable = struct
+  let[@coq_struct "kind_value"] rec compare_comparable :
       type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int =
    fun kind k x y ->
-    match (kind, x, y) with
-    | (Unit_t, (), ()) -> (apply [@tailcall]) 0 k
+    match[@coq_match_gadt] [@coq_match_with_default] (kind, x, y) with
+    | (Unit_t, _, _) -> (apply [@tailcall]) 0 k
     | (Never_t, _, _) -> .
-    | (Signature_t, x, y) ->
+    | (Signature_t, (x : signature), (y : signature)) ->
         (apply [@tailcall]) (Script_signature.compare x y) k
-    | (String_t, x, y) -> (apply [@tailcall]) (Script_string.compare x y) k
-    | (Bool_t, x, y) -> (apply [@tailcall]) (Compare.Bool.compare x y) k
-    | (Mutez_t, x, y) -> (apply [@tailcall]) (Tez.compare x y) k
-    | (Key_hash_t, x, y) ->
+    | (String_t, (x : Script_string.t), (y : Script_string.t)) ->
+        (apply [@tailcall]) (Script_string.compare x y) k
+    | (Bool_t, (x : bool), (y : bool)) ->
+        (apply [@tailcall]) (Compare.Bool.compare x y) k
+    | (Mutez_t, (x : Tez.t), (y : Tez.t)) ->
+        (apply [@tailcall]) (Tez.compare x y) k
+    | (Key_hash_t, (x : public_key_hash), (y : public_key_hash)) ->
         (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k
-    | (Key_t, x, y) -> (apply [@tailcall]) (Signature.Public_key.compare x y) k
-    | (Int_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k
-    | (Nat_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k
-    | (Timestamp_t, x, y) ->
+    | (Key_t, (x : public_key), (y : public_key)) ->
+        (apply [@tailcall]) (Signature.Public_key.compare x y) k
+    | (Int_t, (x : _ Script_int.num), (y : _ Script_int.num)) ->
+        (apply [@tailcall]) (Script_int.compare x y) k
+    | (Nat_t, (x : _ Script_int.num), (y : _ Script_int.num)) ->
+        (apply [@tailcall]) (Script_int.compare x y) k
+    | (Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t)) ->
         (apply [@tailcall]) (Script_timestamp.compare x y) k
-    | (Address_t, x, y) -> (apply [@tailcall]) (compare_address x y) k
-    | (Tx_rollup_l2_address_t, x, y) ->
+    | (Address_t, (x : address), (y : address)) ->
+        (apply [@tailcall]) (compare_address x y) k
+    | ( Tx_rollup_l2_address_t,
+        (x : tx_rollup_l2_address),
+        (y : tx_rollup_l2_address) ) ->
         (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k
-    | (Bytes_t, x, y) -> (apply [@tailcall]) (Compare.Bytes.compare x y) k
-    | (Chain_id_t, x, y) -> (apply [@tailcall]) (Script_chain_id.compare x y) k
-    | (Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry)) ->
+    | (Bytes_t, (x : bytes), (y : bytes)) ->
+        (apply [@tailcall]) (Compare.Bytes.compare x y) k
+    | (Chain_id_t, (x : Script_chain_id.t), (y : Script_chain_id.t)) ->
+        (apply [@tailcall]) (Script_chain_id.compare x y) k
+    | (Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _)) ->
+        let (lx, rx) = x in
+        let (ly, ry) = y in
         (compare_comparable [@tailcall])
           tl
           (Compare_comparable (tr, rx, ry, k))
           lx
           ly
-    | (Union_t (tl, _, _, YesYes), L x, L y) ->
-        (compare_comparable [@tailcall]) tl k x y
-    | (Union_t _, L _, R _) -> -1
-    | (Union_t _, R _, L _) -> 1
-    | (Union_t (_, tr, _, YesYes), R x, R y) ->
-        (compare_comparable [@tailcall]) tr k x y
-    | (Option_t _, None, None) -> (apply [@tailcall]) 0 k
-    | (Option_t _, None, Some _) -> -1
-    | (Option_t _, Some _, None) -> 1
-    | (Option_t (t, _, Yes), Some x, Some y) ->
-        (compare_comparable [@tailcall]) t k x y
-  and apply ret k =
+    | (Union_t (tl, tr, _, YesYes), (x : (_, _) union), (y : (_, _) union)) -> (
+        match (x, y) with
+        | (L x, L y) -> (compare_comparable [@tailcall]) tl k x y
+        | (L _, R _) -> -1
+        | (R _, L _) -> 1
+        | (R x, R y) -> (compare_comparable [@tailcall]) tr k x y)
+    | (Option_t (t, _, _), (x : _ option), (y : _ option)) -> (
+        match (x, y) with
+        | (None, None) -> (apply [@tailcall]) 0 k
+        | (None, Some _) -> -1
+        | (Some _, None) -> 1
+        | (Some x, Some y) -> (compare_comparable [@tailcall]) t k x y)
+
+  and[@coq_mutual_as_notation] apply ret k =
     match (ret, k) with
     | (0, Compare_comparable (ty, x, y, k)) ->
         (compare_comparable [@tailcall]) ty k x y
@@ -91,6 +106,7 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int =
     | (ret, _) ->
         (* ret <> 0, we perform an early exit *)
         if Compare.Int.(ret > 0) then 1 else -1
-  in
-  fun t -> compare_comparable t Compare_comparable_return
-  [@@coq_axiom_with_reason "non top-level mutually recursive function"]
+end
+
+let compare_comparable : type a. a comparable_ty -> a -> a -> int =
+ fun t -> Compare_comparable.compare_comparable t Compare_comparable_return
-- 
GitLab


From 9f76ecfe9046cc1ec4d11def9cabda483e39e392 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 11 Aug 2021 17:05:49 +0200
Subject: [PATCH 02/69] Proto: add annotations for recursive functions in
 coq-of-ocaml

---
 src/proto_alpha/lib_protocol/global_constants_storage.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml
index 429b454d44f1..89c6cca985cd 100644
--- a/src/proto_alpha/lib_protocol/global_constants_storage.ml
+++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml
@@ -225,7 +225,7 @@ let expand context expr =
     with [Expression_too_deep] if greater than
     [max_allowed_global_constant_depth].*)
 let check_depth node =
-  let rec advance node depth k =
+  let[@coq_struct "node"] rec advance node depth k =
     if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth)
     then error Expression_too_deep
     else
-- 
GitLab


From 501e7d884c88a7f77d44d111c3912e8ef1d5f530 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 11 Aug 2021 17:44:06 +0200
Subject: [PATCH 03/69] Proto: make micheline_fold_aux less polymorphic to
 simplify proofs

---
 src/proto_alpha/lib_protocol/global_constants_storage.ml | 2 +-
 src/proto_alpha/lib_protocol/script_repr.ml              | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml
index 89c6cca985cd..19eac66ef258 100644
--- a/src/proto_alpha/lib_protocol/global_constants_storage.ml
+++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml
@@ -225,7 +225,7 @@ let expand context expr =
     with [Expression_too_deep] if greater than
     [max_allowed_global_constant_depth].*)
 let check_depth node =
-  let[@coq_struct "node"] rec advance node depth k =
+  let[@coq_struct "node_value"] rec advance node depth k =
     if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth)
     then error Expression_too_deep
     else
diff --git a/src/proto_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml
index 681d6d7c627a..aed2abd3de13 100644
--- a/src/proto_alpha/lib_protocol/script_repr.ml
+++ b/src/proto_alpha/lib_protocol/script_repr.ml
@@ -312,7 +312,7 @@ let is_unit_parameter =
     ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes)
     ~fun_combine:(fun res _ -> res)
 
-let[@coq_struct "node"] rec strip_annotations node =
+let[@coq_struct "node_value"] rec strip_annotations node =
   let open Micheline in
   match node with
   | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> leaf
@@ -320,7 +320,7 @@ let[@coq_struct "node"] rec strip_annotations node =
       Prim (loc, name, List.map strip_annotations args, [])
   | Seq (loc, args) -> Seq (loc, List.map strip_annotations args)
 
-let rec micheline_fold_aux node f acc k =
+let rec micheline_fold_aux (node : _ michelson_node) f acc k =
   match node with
   | Micheline.Int (_, _) -> k (f acc node)
   | Micheline.String (_, _) -> k (f acc node)
-- 
GitLab


From e09c149911be2ac6eec193595c2083c303920015 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Mon, 30 Aug 2021 14:38:04 +0200
Subject: [PATCH 04/69] Proto: add a phantom type annotation for coq-of-ocaml

---
 src/proto_alpha/lib_protocol/script_typed_ir.ml  | 2 +-
 src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index cb9b0ab5f7c1..1683aedf4754 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -241,7 +241,7 @@ module type TYPE_SIZE = sig
         submodule), the type is abstract but we have access to unsafe
         constructors that can break the invariant.
   *)
-  type 'a t
+  type 'a t [@@coq_phantom]
 
   val check_eq :
     error_details:'error_trace Script_tc_errors.error_details ->
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli
index 7d69f8ada1e6..1651e995e13d 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.mli
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli
@@ -174,7 +174,7 @@ type empty_cell = EmptyCell
 type end_of_stack = empty_cell * empty_cell
 
 module Type_size : sig
-  type 'a t
+  type 'a t [@@coq_phantom]
 
   val check_eq :
     error_details:'error_trace Script_tc_errors.error_details ->
-- 
GitLab


From e29cacfd5170188efeceff200af1b03ae413d82d Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 15 Sep 2021 16:24:09 +0200
Subject: [PATCH 05/69] Proto: add module type annotation to help coq-of-ocaml

---
 src/proto_alpha/lib_protocol/script_map.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml
index 5a96396a518b..e3fa0e966c7b 100644
--- a/src/proto_alpha/lib_protocol/script_map.ml
+++ b/src/proto_alpha/lib_protocol/script_map.ml
@@ -49,7 +49,7 @@ let empty_from : type a b c. (a, b) map -> (a, c) map =
 
 let empty : type a b. a comparable_ty -> (a, b) map =
  fun ty ->
-  let module OPS = struct
+  let module OPS : Boxed_map_OPS with type key = a = struct
     let key_size = Gas_comparable_input_size.size_of_comparable_value ty
 
     include Map.Make (struct
-- 
GitLab


From d9f7b16005e1f7c7a13d3a11394379e21cafb345 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 15 Sep 2021 16:24:57 +0200
Subject: [PATCH 06/69] Proto: add Coq annotation for incomplete match

---
 src/proto_alpha/lib_protocol/script_typed_ir.ml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index 1683aedf4754..63bd85175566 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -2440,5 +2440,6 @@ let value_traverse (type t tc) (ty : ((t, tc) ty, t comparable_ty) union)
   | R cty -> aux' init cty x (fun accu -> accu)
   [@@coq_axiom_with_reason "local mutually recursive definition not handled"]
 
-let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function
+let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c =
+  function[@coq_match_with_default]
   | Item_t (ty, _) -> Ty_ex_c ty
-- 
GitLab


From 920dfaa487b74350c4fe24b74a2e97b3a211027f Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 15 Sep 2021 21:41:43 +0200
Subject: [PATCH 07/69] Proto: split function couples for Coq

---
 .../lib_protocol/script_typed_ir.ml           | 20 ++++++++----
 .../lib_protocol/script_typed_ir_size.ml      | 32 ++++++++++---------
 2 files changed, 30 insertions(+), 22 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index 63bd85175566..7dc9ec48bb08 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -2233,7 +2233,7 @@ type 'a ty_traverse = {
   apply_comparable : 't. 'a -> 't comparable_ty -> 'a;
 }
 
-let (ty_traverse, comparable_ty_traverse) =
+module Ty_traverse = struct
   let rec aux :
       type t ret accu.
       accu ty_traverse -> accu -> t comparable_ty -> (accu -> ret) -> ret =
@@ -2257,7 +2257,8 @@ let (ty_traverse, comparable_ty_traverse) =
     | Pair_t (ty1, ty2, _, YesYes) -> (next2 [@ocaml.tailcall]) ty1 ty2
     | Union_t (ty1, ty2, _, YesYes) -> (next2 [@ocaml.tailcall]) ty1 ty2
     | Option_t (ty, _, Yes) -> (next [@ocaml.tailcall]) ty
-  and aux' :
+
+  let rec aux' :
       type ret t tc accu.
       accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret =
    fun f accu ty continue ->
@@ -2287,7 +2288,8 @@ let (ty_traverse, comparable_ty_traverse) =
         (aux [@ocaml.tailcall]) f accu cty @@ fun accu ->
         (next' [@ocaml.tailcall]) f accu ty1 continue
     | Contract_t (ty1, _) -> (next' [@ocaml.tailcall]) f accu ty1 continue
-  and next2' :
+
+  and[@coq_mutual_as_notation] next2' :
       type a ac b bc ret accu.
       accu ty_traverse ->
       accu ->
@@ -2299,15 +2301,19 @@ let (ty_traverse, comparable_ty_traverse) =
     (aux' [@ocaml.tailcall]) f accu ty1 @@ fun accu ->
     (aux' [@ocaml.tailcall]) f accu ty2 @@ fun accu ->
     (continue [@ocaml.tailcall]) accu
-  and next' :
+
+  and[@coq_mutual_as_notation] next' :
       type a ac ret accu.
       accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret =
    fun f accu ty1 continue ->
     (aux' [@ocaml.tailcall]) f accu ty1 @@ fun accu ->
     (continue [@ocaml.tailcall]) accu
-  in
-  ( (fun ty init f -> aux' f init ty (fun accu -> accu)),
-    fun cty init f -> aux f init cty (fun accu -> accu) )
+end
+
+let comparable_ty_traverse cty init f =
+  Ty_traverse.aux f init cty (fun accu -> accu)
+
+let ty_traverse ty init f = Ty_traverse.aux' f init ty (fun accu -> accu)
 
 type 'accu stack_ty_traverse = {
   apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu;
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index c9c336381960..086fe1394168 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -32,15 +32,16 @@ let script_string_size s = Script_string.to_string s |> string_size
 (* Memo-sizes are 16-bit integers *)
 let sapling_memo_size_size = !!0
 
-let ty_traverse_f =
-  let base_basic =
-    !!0
-    (* Basic types count for 0 because they are all static values, hence shared
-       and not counted by `reachable_words`.
-       On the other hand compound types are functions, hence not shared. *)
-  in
-  let base_compound_no_meta = header_size in
-  let base_compound _meta = h1w in
+module Ty_size = struct
+  let base_basic = !!0
+  (* Basic types count for 0 because they are all static values, hence shared
+     and not counted by `reachable_words`.
+     On the other hand compound types are functions, hence not shared. *)
+
+  let base_compound_no_meta = header_size
+
+  let base_compound _meta = h1w
+
   let apply_comparable :
       type a. nodes_and_size -> a comparable_ty -> nodes_and_size =
    fun accu cty ->
@@ -66,7 +67,8 @@ let ty_traverse_f =
         ret_succ_adding accu @@ (base_compound a +! (word_size *? 3))
     | Option_t (_ty, a, Yes) ->
         ret_succ_adding accu @@ (base_compound a +! (word_size *? 2))
-  and apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size =
+
+  let apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size =
    fun accu ty ->
     match ty with
     | Unit_t -> ret_succ_adding accu base_basic
@@ -117,14 +119,14 @@ let ty_traverse_f =
         @@ (base_compound_no_meta +! sapling_memo_size_size +! word_size)
     | Ticket_t (_cty, a) ->
         ret_succ_adding accu @@ (base_compound a +! word_size)
-  in
-  ({apply; apply_comparable} : nodes_and_size ty_traverse)
 
-let comparable_ty_size : type a. a comparable_ty -> nodes_and_size =
- fun cty -> comparable_ty_traverse cty zero ty_traverse_f
+  let f = ({apply; apply_comparable} : nodes_and_size ty_traverse)
+end
+
+let comparable_ty_size cty = comparable_ty_traverse cty zero Ty_size.f
 
 let ty_size : type a ac. (a, ac) ty -> nodes_and_size =
- fun ty -> ty_traverse ty zero ty_traverse_f
+ fun ty -> ty_traverse ty zero Ty_size.f
 
 let stack_ty_size s =
   let apply : type a s. nodes_and_size -> (a, s) stack_ty -> nodes_and_size =
-- 
GitLab


From 422a6807c942875973ec90ef80a41c2a4423a56e Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 27 Oct 2021 16:33:56 +0200
Subject: [PATCH 08/69] TEMP: add match existential annotations

---
 src/proto_alpha/lib_protocol/apply_results.ml | 111 ++++++++++--------
 .../lib_protocol/operation_repr.ml            |  17 +--
 2 files changed, 70 insertions(+), 58 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 4e35cdd42129..d25a4ddb06d7 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -1074,26 +1074,26 @@ let internal_manager_operation_result_encoding :
   let make (type kind)
       (Manager_result.MCase res_case : kind Manager_result.case)
       (Internal_result.MCase ires_case : kind Internal_result.case) =
-    let (Operation.Encoding.Manager_operations.MCase op_case) =
-      res_case.op_case
-    in
-    case
-      (Tag op_case.tag)
-      ~title:op_case.name
-      (merge_objs
-         (obj3
-            (req "kind" (constant op_case.name))
-            (req "source" Contract.encoding)
-            (req "nonce" uint16))
-         (merge_objs ires_case.encoding (obj1 (req "result" res_case.t))))
-      (fun op ->
-        match ires_case.iselect op with
-        | Some (op, res) ->
-            Some (((), op.source, op.nonce), (ires_case.proj op.operation, res))
-        | None -> None)
-      (fun (((), source, nonce), (op, res)) ->
-        let op = {source; operation = ires_case.inj op; nonce} in
-        Internal_manager_operation_result (op, res))
+    match[@coq_grab_existentials] res_case.op_case with
+    | Operation.Encoding.Manager_operations.MCase op_case ->
+        case
+          (Tag op_case.tag)
+          ~title:op_case.name
+          (merge_objs
+             (obj3
+                (req "kind" (constant op_case.name))
+                (req "source" Contract.encoding)
+                (req "nonce" uint16))
+             (merge_objs ires_case.encoding (obj1 (req "result" res_case.t))))
+          (fun op ->
+            match ires_case.iselect op with
+            | Some (op, res) ->
+                Some
+                  (((), op.source, op.nonce), (ires_case.proj op.operation, res))
+            | None -> None)
+          (fun (((), source, nonce), (op, res)) ->
+            let op = {source; operation = ires_case.inj op; nonce} in
+            Internal_manager_operation_result (op, res))
   in
   def "apply_results.alpha.operation_result"
   @@ union
@@ -1105,20 +1105,23 @@ let internal_manager_operation_result_encoding :
 
 let successful_manager_operation_result_encoding :
     packed_successful_manager_operation_result Data_encoding.t =
-  let make (type kind)
-      (Manager_result.MCase res_case : kind Manager_result.case) =
-    let (Operation.Encoding.Manager_operations.MCase op_case) =
-      res_case.op_case
-    in
-    case
-      (Tag op_case.tag)
-      ~title:op_case.name
-      (merge_objs (obj1 (req "kind" (constant op_case.name))) res_case.encoding)
-      (fun res ->
-        match res_case.select res with
-        | Some res -> Some ((), res_case.proj res)
-        | None -> None)
-      (fun ((), res) -> Successful_manager_result (res_case.inj res))
+  let make (type kind) (mcase : kind Manager_result.case) =
+    match[@coq_grab_existentials] mcase with
+    | Manager_result.MCase res_case ->
+        let (Operation.Encoding.Manager_operations.MCase op_case) =
+          res_case.op_case
+        in
+        case
+          (Tag op_case.tag)
+          ~title:op_case.name
+          (merge_objs
+             (obj1 (req "kind" (constant op_case.name)))
+             res_case.encoding)
+          (fun res ->
+            match res_case.select res with
+            | Some res -> Some ((), res_case.proj res)
+            | None -> None)
+          (fun ((), res) -> Successful_manager_result (res_case.inj res))
   in
   def "operation.alpha.successful_manager_operation_result"
   @@ union
@@ -1732,8 +1735,9 @@ end
 
 let contents_result_encoding =
   let open Encoding in
-  let make
-      (Case
+  let make case_description =
+    match[@coq_grab_existentials] case_description with
+    | Case
         {
           op_case = Operation.Encoding.Case {tag; name; _};
           encoding;
@@ -1741,10 +1745,12 @@ let contents_result_encoding =
           select;
           proj;
           inj;
-        }) =
-    let proj x = match select x with None -> None | Some x -> Some (proj x) in
-    let inj x = Contents_result (inj x) in
-    tagged_case (Tag tag) name encoding proj inj
+        } ->
+        let proj x =
+          match select x with None -> None | Some x -> Some (proj x)
+        in
+        let inj x = Contents_result (inj x) in
+        tagged_case (Tag tag) name encoding proj inj
   in
   def "operation.alpha.contents_result"
   @@ union
@@ -1780,8 +1786,9 @@ let contents_result_encoding =
 
 let contents_and_result_encoding =
   let open Encoding in
-  let make
-      (Case
+  let make case_description =
+    match[@coq_grab_existentials] case_description with
+    | Case
         {
           op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
           mselect;
@@ -1789,15 +1796,17 @@ let contents_and_result_encoding =
           proj = meta_proj;
           inj = meta_inj;
           _;
-        }) =
-    let proj c =
-      match mselect c with
-      | Some (op, res) -> Some (proj op, meta_proj res)
-      | _ -> None
-    in
-    let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
-    let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
-    tagged_case (Tag tag) name encoding proj inj
+        } ->
+        let proj c =
+          match mselect c with
+          | Some (op, res) -> Some (proj op, meta_proj res)
+          | _ -> None
+        in
+        let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
+        let encoding =
+          merge_objs encoding (obj1 (req "metadata" meta_encoding))
+        in
+        tagged_case (Tag tag) name encoding proj inj
   in
   def "operation.alpha.operation_contents_and_result"
   @@ union
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index e2805c4506e1..0b8e05e70d4f 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -1288,13 +1288,16 @@ module Encoding = struct
       Manager_operations.sc_rollup_publish_case
 
   let contents_encoding =
-    let make (Case {tag; name; encoding; select; proj; inj}) =
-      case
-        (Tag tag)
-        name
-        encoding
-        (fun o -> match select o with None -> None | Some o -> Some (proj o))
-        (fun x -> Contents (inj x))
+    let make case_description =
+      match[@coq_grab_existentials] case_description with
+      | Case {tag; name; encoding; select; proj; inj} ->
+          case
+            (Tag tag)
+            name
+            encoding
+            (fun o ->
+              match select o with None -> None | Some o -> Some (proj o))
+            (fun x -> Contents (inj x))
     in
     def "operation.alpha.contents"
     @@ union
-- 
GitLab


From 60309b22ccb6f9707260bbf4e1b54bb542c5d854 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 5 Nov 2021 16:58:43 +0100
Subject: [PATCH 09/69] Proto: use algebraic types for tokens for Coq

---
 Makefile                                      |   6 +-
 src/proto_alpha/lib_plugin/plugin.ml          |   4 +-
 .../lib_protocol/alpha_context.mli            |  64 +--
 src/proto_alpha/lib_protocol/apply.ml         |  74 ++-
 .../lib_protocol/bootstrap_storage.ml         |  11 +-
 .../lib_protocol/delegate_storage.ml          |  46 +-
 src/proto_alpha/lib_protocol/fees_storage.ml  |   4 +-
 src/proto_alpha/lib_protocol/init_storage.ml  |   4 +-
 .../liquidity_baking_migration.ml             |   8 +-
 .../test/integration/test_frozen_bonds.ml     |  85 +++-
 .../test/integration/test_token.ml            | 435 +++++++++++-------
 src/proto_alpha/lib_protocol/token.ml         | 147 +++---
 src/proto_alpha/lib_protocol/token.mli        |  58 +--
 13 files changed, 578 insertions(+), 368 deletions(-)

diff --git a/Makefile b/Makefile
index 8cee1b5c8ef4..ae9ff86d1d6b 100644
--- a/Makefile
+++ b/Makefile
@@ -69,9 +69,9 @@ $(TEZOS_BIN): generate_dune
 	cp -f _build/install/default/bin/$@ ./
 
 build: generate_dune
-ifneq (${current_ocaml_version},${ocaml_version})
-	$(error Unexpected ocaml version (found: ${current_ocaml_version}, expected: ${ocaml_version}))
-endif
+# ifneq (${current_ocaml_version},${ocaml_version})
+# 	$(error Unexpected ocaml version (found: ${current_ocaml_version}, expected: ${ocaml_version}))
+# endif
 	@dune build --profile=$(PROFILE) $(COVERAGE_OPTIONS) \
 		$(foreach b, $(TEZOS_BIN), _build/install/default/bin/${b}) \
 		@copy-parameters
diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml
index 6967251399eb..4f16ae4bd8c9 100644
--- a/src/proto_alpha/lib_plugin/plugin.ml
+++ b/src/proto_alpha/lib_plugin/plugin.ml
@@ -2204,8 +2204,8 @@ module RPC = struct
         Token.transfer
           ~origin:Simulation
           ctxt
-          `Minted
-          (`Contract dummy_contract)
+          (Source_infinite Minted)
+          (Sink_container (Contract dummy_contract))
           balance
         >>=? fun (ctxt, _) -> return (ctxt, dummy_contract)
       in
diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index c39229e56d6e..9ccb72c125b2 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -3375,34 +3375,38 @@ end
 (** See 'token.mli' for more explanation. *)
 module Token : sig
   type container =
-    [ `Contract of Contract.t
-    | `Collected_commitments of Blinded_public_key_hash.t
-    | `Delegate_balance of Signature.Public_key_hash.t
-    | `Frozen_deposits of Signature.Public_key_hash.t
-    | `Block_fees
-    | `Frozen_bonds of Contract.t * Bond_id.t ]
+    | Contract of Contract.t
+    | Collected_commitments of Blinded_public_key_hash.t
+    | Delegate_balance of Signature.Public_key_hash.t
+    | Frozen_deposits of Signature.Public_key_hash.t
+    | Block_fees
+    | Frozen_bonds of Contract.t * Bond_id.t
+
+  type infinite_source =
+    | Invoice
+    | Bootstrap
+    | Initial_commitments
+    | Revelation_rewards
+    | Double_signing_evidence_rewards
+    | Endorsing_rewards
+    | Baking_rewards
+    | Baking_bonuses
+    | Minted
+    | Liquidity_baking_subsidies
+    | Tx_rollup_rejection_rewards
 
   type source =
-    [ `Invoice
-    | `Bootstrap
-    | `Initial_commitments
-    | `Revelation_rewards
-    | `Double_signing_evidence_rewards
-    | `Endorsing_rewards
-    | `Baking_rewards
-    | `Baking_bonuses
-    | `Minted
-    | `Liquidity_baking_subsidies
-    | `Tx_rollup_rejection_rewards
-    | container ]
-
-  type sink =
-    [ `Storage_fees
-    | `Double_signing_punishments
-    | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
-    | `Burned
-    | `Tx_rollup_rejection_punishments
-    | container ]
+    | Source_infinite of infinite_source
+    | Source_container of container
+
+  type infinite_sink =
+    | Storage_fees
+    | Double_signing_punishments
+    | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
+    | Burned
+    | Tx_rollup_rejection_punishments
+
+  type sink = Sink_infinite of infinite_sink | Sink_container of container
 
   val allocated : context -> container -> (context * bool) tzresult Lwt.t
 
@@ -3411,15 +3415,15 @@ module Token : sig
   val transfer_n :
     ?origin:Receipt.update_origin ->
     context ->
-    ([< source] * Tez.t) list ->
-    [< sink] ->
+    (source * Tez.t) list ->
+    sink ->
     (context * Receipt.balance_updates) tzresult Lwt.t
 
   val transfer :
     ?origin:Receipt.update_origin ->
     context ->
-    [< source] ->
-    [< sink] ->
+    source ->
+    sink ->
     Tez.t ->
     (context * Receipt.balance_updates) tzresult Lwt.t
 end
diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index a6527475ca07..a295baea2ea6 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -931,7 +931,11 @@ let apply_transaction ~ctxt ~parameter ~source ~contract ~amount ~entrypoint
          the next transfer of tokens will allocate it. *)
       Contract.allocated ctxt contract >|=? not)
   >>=? fun allocated_destination_contract ->
-  Token.transfer ctxt (`Contract source) (`Contract contract) amount
+  Token.transfer
+    ctxt
+    (Source_container (Contract source))
+    (Sink_container (Contract contract))
+    amount
   >>=? fun (ctxt, balance_updates) ->
   Script_cache.find ctxt contract >>=? fun (ctxt, cache_key, script) ->
   match script with
@@ -1027,8 +1031,8 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~amount
     Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost ->
     Token.transfer
       ctxt
-      (`Contract (Contract.implicit_contract payer))
-      `Burned
+      (Source_container (Contract (Contract.implicit_contract payer)))
+      (Sink_infinite Burned)
       cost
     >>=? fun (ctxt, balance_updates) ->
     Tx_rollup_inbox.append_message ctxt dst_rollup state deposit
@@ -1084,7 +1088,11 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code ~contract
   | None -> return ctxt
   | Some delegate -> Delegate.init ctxt contract delegate)
   >>=? fun ctxt ->
-  Token.transfer ctxt (`Contract source) (`Contract contract) credit
+  Token.transfer
+    ctxt
+    (Source_container (Contract source))
+    (Sink_container (Contract contract))
+    credit
   >>=? fun (ctxt, balance_updates) ->
   Fees.record_paid_storage_space ctxt contract ~ticket_table_size_diff:Z.zero
   >|=? fun (ctxt, size, paid_storage_size_diff) ->
@@ -1543,7 +1551,11 @@ let apply_external_manager_operation_content :
       >>=? fun (ctxt, state, paid_storage_size_diff) ->
       Tx_rollup_state.burn_cost ~limit:burn_limit state message_size
       >>?= fun cost ->
-      Token.transfer ctxt (`Contract source_contract) `Burned cost
+      Token.transfer
+        ctxt
+        (Source_container (Contract source_contract))
+        (Sink_infinite Burned)
+        cost
       >>=? fun (ctxt, balance_updates) ->
       Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt ->
       let result =
@@ -1563,8 +1575,8 @@ let apply_external_manager_operation_content :
           let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in
           Token.transfer
             ctxt
-            (`Contract source_contract)
-            (`Frozen_bonds (source_contract, bond_id))
+            (Source_container (Contract source_contract))
+            (Sink_container (Frozen_bonds (source_contract, bond_id)))
             (Constants.tx_rollup_commitment_bond ctxt)
         else return (ctxt, []) )
       >>=? fun (ctxt, balance_updates) ->
@@ -1583,12 +1595,12 @@ let apply_external_manager_operation_content :
   | Tx_rollup_return_bond {tx_rollup} ->
       Tx_rollup_commitment.remove_bond ctxt tx_rollup source >>=? fun ctxt ->
       let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in
-      Token.balance ctxt (`Frozen_bonds (source_contract, bond_id))
+      Token.balance ctxt (Frozen_bonds (source_contract, bond_id))
       >>=? fun (ctxt, bond) ->
       Token.transfer
         ctxt
-        (`Frozen_bonds (source_contract, bond_id))
-        (`Contract source_contract)
+        (Source_container (Frozen_bonds (source_contract, bond_id)))
+        (Sink_container (Contract source_contract))
         bond
       >>=? fun (ctxt, balance_updates) ->
       let result =
@@ -1698,19 +1710,19 @@ let apply_external_manager_operation_content :
       (if slashed then
        let committer = Contract.implicit_contract commitment.committer in
        let bid = Bond_id.Tx_rollup_bond_id tx_rollup in
-       Token.balance ctxt (`Frozen_bonds (committer, bid))
+       Token.balance ctxt (Frozen_bonds (committer, bid))
        >>=? fun (ctxt, burn) ->
        Tez.(burn /? 2L) >>?= fun reward ->
        Token.transfer
          ctxt
-         (`Frozen_bonds (committer, bid))
-         `Tx_rollup_rejection_punishments
+         (Source_container (Frozen_bonds (committer, bid)))
+         (Sink_infinite Tx_rollup_rejection_punishments)
          burn
        >>=? fun (ctxt, burn_update) ->
        Token.transfer
          ctxt
-         `Tx_rollup_rejection_rewards
-         (`Contract source_contract)
+         (Source_infinite Tx_rollup_rejection_rewards)
+         (Sink_container (Contract source_contract))
          reward
        >>=? fun (ctxt, reward_update) ->
        return (ctxt, burn_update @ reward_update)
@@ -1924,7 +1936,11 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents)
       assert_sc_rollup_feature_enabled ctxt >|=? fun () -> ctxt)
   >>=? fun ctxt ->
   Contract.increment_counter ctxt source >>=? fun ctxt ->
-  Token.transfer ctxt (`Contract source_contract) `Block_fees fee
+  Token.transfer
+    ctxt
+    (Source_container (Contract source_contract))
+    (Sink_container Block_fees)
+    fee
   >|=? fun (ctxt, balance_updates) ->
   let consumed_gas = Gas.consumed ~since:ctxt_before ~until:ctxt in
   (ctxt, {balance_updates; consumed_gas})
@@ -1942,7 +1958,9 @@ let burn_storage_fees :
     payer:public_key_hash ->
     (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t =
  fun ctxt smopr ~storage_limit ~payer ->
-  let payer = `Contract (Contract.implicit_contract payer) in
+  let payer =
+    Token.Source_container (Contract (Contract.implicit_contract payer))
+  in
   match smopr with
   | Transaction_result (Transaction_to_contract_result payload) ->
       let consumed = payload.paid_storage_size_diff in
@@ -2696,8 +2714,8 @@ let punish_delegate ctxt delegate level mistake mk_result ~payload_producer =
   | Ok reward ->
       Token.transfer
         ctxt
-        `Double_signing_evidence_rewards
-        (`Contract (Contract.implicit_contract payload_producer))
+        (Source_infinite Double_signing_evidence_rewards)
+        (Sink_container (Contract (Contract.implicit_contract payload_producer)))
         reward
   | Error _ -> (* reward is Tez.zero *) return (ctxt, []))
   >|=? fun (ctxt, reward_balance_updates) ->
@@ -2910,7 +2928,11 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode
       Nonce.reveal ctxt level nonce >>=? fun ctxt ->
       let tip = Constants.seed_nonce_revelation_tip ctxt in
       let contract = Contract.implicit_contract payload_producer in
-      Token.transfer ctxt `Revelation_rewards (`Contract contract) tip
+      Token.transfer
+        ctxt
+        (Source_infinite Revelation_rewards)
+        (Sink_container (Contract contract))
+        tip
       >|=? fun (ctxt, balance_updates) ->
       (ctxt, Single_result (Seed_nonce_revelation_result balance_updates))
   | Single (Double_preendorsement_evidence {op1; op2}) ->
@@ -2935,12 +2957,16 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode
       let blinded_pkh =
         Blinded_public_key_hash.of_ed25519_pkh activation_code pkh
       in
-      let src = `Collected_commitments blinded_pkh in
+      let src = Token.Collected_commitments blinded_pkh in
       Token.allocated ctxt src >>=? fun (ctxt, src_exists) ->
       fail_unless src_exists (Invalid_activation {pkh}) >>=? fun () ->
       let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in
       Token.balance ctxt src >>=? fun (ctxt, amount) ->
-      Token.transfer ctxt src (`Contract contract) amount
+      Token.transfer
+        ctxt
+        (Source_container src)
+        (Sink_container (Contract contract))
+        amount
       >>=? fun (ctxt, bupds) ->
       return (ctxt, Single_result (Activate_account_result bupds))
   | Single (Proposals {source; period; proposals}) ->
@@ -3064,8 +3090,8 @@ let apply_liquidity_baking_subsidy ctxt ~toggle_vote =
        Token.transfer
          ~origin:Subsidy
          ctxt
-         `Liquidity_baking_subsidies
-         (`Contract liquidity_baking_cpmm_contract)
+         (Source_infinite Liquidity_baking_subsidies)
+         (Sink_container (Contract liquidity_baking_cpmm_contract))
          liquidity_baking_subsidy
        >>=? fun (ctxt, balance_updates) ->
        Script_cache.find ctxt liquidity_baking_cpmm_contract
diff --git a/src/proto_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml
index 3636d5f1793e..1ca42e9246db 100644
--- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml
+++ b/src/proto_alpha/lib_protocol/bootstrap_storage.ml
@@ -30,8 +30,8 @@ let init_account (ctxt, balance_updates)
   Token.transfer
     ~origin:Protocol_migration
     ctxt
-    `Bootstrap
-    (`Contract contract)
+    (Source_infinite Bootstrap)
+    (Sink_container (Contract contract))
     amount
   >>=? fun (ctxt, new_balance_updates) ->
   (match public_key with
@@ -60,7 +60,12 @@ let init_contract ~typecheck (ctxt, balance_updates)
   | Some delegate -> Delegate_storage.init ctxt contract delegate)
   >>=? fun ctxt ->
   let origin = Receipt_repr.Protocol_migration in
-  Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount
+  Token.transfer
+    ~origin
+    ctxt
+    (Source_infinite Bootstrap)
+    (Sink_container (Contract contract))
+    amount
   >|=? fun (ctxt, new_balance_updates) ->
   (ctxt, new_balance_updates @ balance_updates)
 
diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml
index 37110cf1f2d2..366a6d3fd0d3 100644
--- a/src/proto_alpha/lib_protocol/delegate_storage.ml
+++ b/src/proto_alpha/lib_protocol/delegate_storage.ml
@@ -362,8 +362,8 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces =
        (* Sufficient participation: we pay the rewards *)
        Token.transfer
          ctxt
-         `Endorsing_rewards
-         (`Contract delegate_contract)
+         (Source_infinite Endorsing_rewards)
+         (Sink_container (Contract delegate_contract))
          rewards
        >|=? fun (ctxt, payed_rewards_receipts) ->
        (ctxt, payed_rewards_receipts @ balance_updates)
@@ -371,9 +371,10 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces =
         (* Insufficient participation or unrevealed nonce: no rewards *)
         Token.transfer
           ctxt
-          `Endorsing_rewards
-          (`Lost_endorsing_rewards
-            (delegate, not sufficient_participation, not has_revealed_nonces))
+          (Source_infinite Endorsing_rewards)
+          (Sink_infinite
+             (Lost_endorsing_rewards
+                (delegate, not sufficient_participation, not has_revealed_nonces)))
           rewards
         >|=? fun (ctxt, payed_rewards_receipts) ->
         (ctxt, payed_rewards_receipts @ balance_updates))
@@ -477,8 +478,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle
         Token.transfer
           ~origin
           ctxt
-          (`Frozen_deposits delegate)
-          (`Delegate_balance delegate)
+          (Source_container (Frozen_deposits delegate))
+          (Sink_container (Delegate_balance delegate))
           to_reimburse
         >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates)
       else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then
@@ -498,8 +499,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle
         Token.transfer
           ~origin
           ctxt
-          (`Delegate_balance delegate)
-          (`Frozen_deposits delegate)
+          (Source_container (Delegate_balance delegate))
+          (Sink_container (Frozen_deposits delegate))
           to_freeze
         >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates)
       else return (ctxt, balance_updates))
@@ -525,8 +526,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle
         Token.transfer
           ~origin
           ctxt
-          (`Frozen_deposits delegate)
-          (`Delegate_balance delegate)
+          (Source_container (Frozen_deposits delegate))
+          (Sink_container (Delegate_balance delegate))
           frozen_deposits.current_amount
         >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates)
       else return (ctxt, balance_updates))
@@ -832,8 +833,8 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) =
   in
   Token.transfer
     ctxt
-    (`Frozen_deposits delegate)
-    `Double_signing_punishments
+    (Source_container (Frozen_deposits delegate))
+    (Sink_infinite Double_signing_punishments)
     amount_to_burn
   >>=? fun (ctxt, balance_updates) ->
   Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt ->
@@ -863,8 +864,8 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) =
   in
   Token.transfer
     ctxt
-    (`Frozen_deposits delegate)
-    `Double_signing_punishments
+    (Source_container (Frozen_deposits delegate))
+    (Sink_infinite Double_signing_punishments)
     amount_to_burn
   >>=? fun (ctxt, balance_updates) ->
   Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt ->
@@ -943,15 +944,22 @@ let record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer
   >>=? fun ctxt ->
   let pay_payload_producer ctxt delegate =
     let contract = Contract_repr.implicit_contract delegate in
-    Token.balance ctxt `Block_fees >>=? fun (ctxt, block_fees) ->
+    Token.balance ctxt Block_fees >>=? fun (ctxt, block_fees) ->
     Token.transfer_n
       ctxt
-      [(`Block_fees, block_fees); (`Baking_rewards, baking_reward)]
-      (`Contract contract)
+      [
+        (Source_container Block_fees, block_fees);
+        (Source_infinite Baking_rewards, baking_reward);
+      ]
+      (Sink_container (Contract contract))
   in
   let pay_block_producer ctxt delegate bonus =
     let contract = Contract_repr.implicit_contract delegate in
-    Token.transfer ctxt `Baking_bonuses (`Contract contract) bonus
+    Token.transfer
+      ctxt
+      (Source_infinite Baking_bonuses)
+      (Sink_container (Contract contract))
+      bonus
   in
   pay_payload_producer ctxt payload_producer
   >>=? fun (ctxt, balance_updates_payload_producer) ->
diff --git a/src/proto_alpha/lib_protocol/fees_storage.ml b/src/proto_alpha/lib_protocol/fees_storage.ml
index 9ebd70f7d199..8bed5b4c687e 100644
--- a/src/proto_alpha/lib_protocol/fees_storage.ml
+++ b/src/proto_alpha/lib_protocol/fees_storage.ml
@@ -82,7 +82,7 @@ let record_paid_storage_space ctxt contract ~ticket_table_size_diff =
 
 let source_must_exist c src =
   match src with
-  | `Contract src -> Contract_storage.must_exist c src
+  | Token.Source_container (Contract src) -> Contract_storage.must_exist c src
   | _ -> return_unit
 
 let burn_storage_fees ?(origin = Receipt_repr.Block_application) c
@@ -101,7 +101,7 @@ let burn_storage_fees ?(origin = Receipt_repr.Block_application) c
       trace
         Cannot_pay_storage_fee
         ( source_must_exist c payer >>=? fun () ->
-          Token.transfer ~origin c payer `Storage_fees to_burn
+          Token.transfer ~origin c payer (Sink_infinite Storage_fees) to_burn
           >>=? fun (ctxt, balance_updates) ->
           return (ctxt, remaining, balance_updates) )
 
diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml
index a3b2b2997bb8..94a16adc2813 100644
--- a/src/proto_alpha/lib_protocol/init_storage.ml
+++ b/src/proto_alpha/lib_protocol/init_storage.ml
@@ -116,8 +116,8 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp =
           Commitment_repr.{blinded_public_key_hash; amount} =
         Token.transfer
           ctxt
-          `Initial_commitments
-          (`Collected_commitments blinded_public_key_hash)
+          (Source_infinite Initial_commitments)
+          (Sink_container (Collected_commitments blinded_public_key_hash))
           amount
         >>=? fun (ctxt, new_balance_updates) ->
         return (ctxt, new_balance_updates @ balance_updates)
diff --git a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml
index bdc133bd0134..68a4d450ec90 100644
--- a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml
+++ b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml
@@ -122,20 +122,20 @@ let originate ctxt address ~balance script =
     ~origin:Protocol_migration
     ctxt
     ~storage_limit:(Z.of_int64 Int64.max_int)
-    ~payer:`Liquidity_baking_subsidies
+    ~payer:(Source_infinite Liquidity_baking_subsidies)
   >>=? fun (ctxt, _, origination_updates) ->
   Fees_storage.burn_storage_fees
     ~origin:Protocol_migration
     ctxt
     ~storage_limit:(Z.of_int64 Int64.max_int)
-    ~payer:`Liquidity_baking_subsidies
+    ~payer:(Source_infinite Liquidity_baking_subsidies)
     size
   >>=? fun (ctxt, _, storage_updates) ->
   Token.transfer
     ~origin:Protocol_migration
     ctxt
-    `Liquidity_baking_subsidies
-    (`Contract address)
+    (Source_infinite Liquidity_baking_subsidies)
+    (Sink_container (Contract address))
     balance
   >>=? fun (ctxt, transfer_updates) ->
   let balance_updates =
diff --git a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml
index 532e3894a6bb..1f720c2882ba 100644
--- a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml
+++ b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml
@@ -76,19 +76,26 @@ let init_test ~user_is_delegate =
   create_context () >>=? fun (ctxt, _) ->
   let (delegate, delegate_pk, _) = Signature.generate_key () in
   let delegate_contract = Contract.implicit_contract delegate in
-  let delegate_account = `Contract (Contract.implicit_contract delegate) in
+  let delegate_account =
+    Token.Sink_container (Contract (Contract.implicit_contract delegate))
+  in
   let user_contract =
     if user_is_delegate then delegate_contract
     else
       let (user, _, _) = Signature.generate_key () in
       Contract.implicit_contract user
   in
-  let user_account = `Contract user_contract in
+  let user_account = Token.Contract user_contract in
   (* Allocate contracts for user and delegate. *)
   let user_balance = big_random_amount () in
-  Token.transfer ctxt `Minted user_account user_balance >>>=? fun (ctxt, _) ->
+  Token.transfer
+    ctxt
+    (Source_infinite Minted)
+    (Sink_container user_account)
+    user_balance
+  >>>=? fun (ctxt, _) ->
   let delegate_balance = big_random_amount () in
-  Token.transfer ctxt `Minted delegate_account delegate_balance
+  Token.transfer ctxt (Source_infinite Minted) delegate_account delegate_balance
   >>>=? fun (ctxt, _) ->
   (* Configure delegate, as a delegate by self-delegation, for which
      revealing its manager key is a prerequisite. *)
@@ -118,8 +125,12 @@ let test_delegate_then_freeze_deposit () =
   let (tx_rollup, _) = mk_tx_rollup () in
   let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in
   let deposit_amount = small_random_amount () in
-  let deposit_account = `Frozen_bonds (user_contract, bond_id) in
-  Token.transfer ctxt user_account deposit_account deposit_amount
+  let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in
+  Token.transfer
+    ctxt
+    (Source_container user_account)
+    (Sink_container deposit_account)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Fetch staking balance after freeze. *)
   Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' ->
@@ -136,7 +147,11 @@ let test_delegate_then_freeze_deposit () =
     (staking_balance' -! user_balance)
   >>=? fun () ->
   (* Unfreeze the deposit. *)
-  Token.transfer ctxt deposit_account user_account deposit_amount
+  Token.transfer
+    ctxt
+    (Source_container deposit_account)
+    (Sink_container user_account)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Fetch staking balance of delegate. *)
   Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' ->
@@ -166,8 +181,12 @@ let test_freeze_deposit_then_delegate () =
   let (tx_rollup, _) = mk_tx_rollup () in
   let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in
   let deposit_amount = small_random_amount () in
-  let deposit_account = `Frozen_bonds (user_contract, bond_id) in
-  Token.transfer ctxt user_account deposit_account deposit_amount
+  let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in
+  Token.transfer
+    ctxt
+    (Source_container user_account)
+    (Sink_container deposit_account)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Here, user balance has decreased.
      Now, fetch staking balance before delegation and after freeze. *)
@@ -183,7 +202,11 @@ let test_freeze_deposit_then_delegate () =
     (user_balance +! staking_balance)
   >>=? fun () ->
   (* Unfreeze the deposit. *)
-  Token.transfer ctxt deposit_account user_account deposit_amount
+  Token.transfer
+    ctxt
+    (Source_container deposit_account)
+    (Sink_container user_account)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Fetch staking balance after unfreeze. *)
   Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' ->
@@ -220,8 +243,12 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () =
   let (tx_rollup, _) = mk_tx_rollup () in
   let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in
   let deposit_amount = user_balance in
-  let deposit_account = `Frozen_bonds (user_contract, bond_id) in
-  Token.transfer ctxt user_account deposit_account deposit_amount
+  let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in
+  Token.transfer
+    ctxt
+    (Source_container user_account)
+    (Sink_container deposit_account)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Check that user contract is still allocated, despite a null balance. *)
   Token.balance ctxt user_account >>>=? fun (ctxt, balance) ->
@@ -231,7 +258,11 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () =
   Assert.equal_bool ~loc:__LOC__ (user_allocated && dep_allocated) true
   >>=? fun () ->
   (* Punish the user contract. *)
-  Token.transfer ctxt deposit_account `Burned deposit_amount
+  Token.transfer
+    ctxt
+    (Source_container deposit_account)
+    (Sink_infinite Burned)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Check that user and deposit accounts have been unallocated. *)
   Token.allocated ctxt user_account >>>=? fun (ctxt, user_allocated) ->
@@ -259,11 +290,19 @@ let test_total_stake ~user_is_delegate () =
   let (tx_rollup, _) = mk_tx_rollup ~nonce () in
   let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup in
   let deposit_amount = small_random_amount () in
-  let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in
-  Token.transfer ctxt user_account deposit_account1 deposit_amount
+  let deposit_account1 = Token.Frozen_bonds (user_contract, bond_id1) in
+  Token.transfer
+    ctxt
+    (Source_container user_account)
+    (Sink_container deposit_account1)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
-  let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in
-  Token.transfer ctxt user_account deposit_account2 deposit_amount
+  let deposit_account2 = Token.Frozen_bonds (user_contract, bond_id2) in
+  Token.transfer
+    ctxt
+    (Source_container user_account)
+    (Sink_container deposit_account2)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Test folding on bond ids. *)
   Contract.fold_on_bond_ids
@@ -289,7 +328,11 @@ let test_total_stake ~user_is_delegate () =
   Assert.equal_tez ~loc:__LOC__ (stake -! balance) (deposit_amount *! 2L)
   >>=? fun () ->
   (* Punish for one deposit. *)
-  Token.transfer ctxt deposit_account2 `Burned deposit_amount
+  Token.transfer
+    ctxt
+    (Source_container deposit_account2)
+    (Sink_infinite Burned)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Check that stake of contract is balance + deposit. *)
   Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake ->
@@ -297,7 +340,11 @@ let test_total_stake ~user_is_delegate () =
   Assert.equal_tez ~loc:__LOC__ (stake -! balance) frozen_bonds >>=? fun () ->
   Assert.equal_tez ~loc:__LOC__ (stake -! balance) deposit_amount >>=? fun () ->
   (* Punish for the other deposit. *)
-  Token.transfer ctxt deposit_account1 `Burned deposit_amount
+  Token.transfer
+    ctxt
+    (Source_container deposit_account1)
+    (Sink_infinite Burned)
+    deposit_amount
   >>>=? fun (ctxt, _) ->
   (* Check that stake of contract is equal to balance. *)
   Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake ->
diff --git a/src/proto_alpha/lib_protocol/test/integration/test_token.ml b/src/proto_alpha/lib_protocol/test/integration/test_token.ml
index 7b4294e4fccf..71880469632f 100644
--- a/src/proto_alpha/lib_protocol/test/integration/test_token.ml
+++ b/src/proto_alpha/lib_protocol/test/integration/test_token.ml
@@ -60,11 +60,12 @@ let mk_rollup () = Tx_rollup.Internal_for_tests.originated_tx_rollup nonce
 let test_simple_balances () =
   Random.init 0 ;
   create_context () >>=? fun (ctxt, pkh) ->
-  let src = `Contract (Contract.implicit_contract pkh) in
+  let src = Token.Contract (Contract.implicit_contract pkh) in
   let (pkh, _pk, _sk) = Signature.generate_key () in
-  let dest = `Contract (Contract.implicit_contract pkh) in
+  let dest = Token.Contract (Contract.implicit_contract pkh) in
   let amount = Tez.one in
-  wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) ->
+  wrap (Token.transfer ctxt (Source_container src) (Sink_container dest) amount)
+  >>=? fun (ctxt', _) ->
   wrap (Token.balance ctxt src) >>=? fun (ctxt, bal_src) ->
   wrap (Token.balance ctxt' src) >>=? fun (ctxt', bal_src') ->
   wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) ->
@@ -83,7 +84,12 @@ let test_simple_balance_updates () =
   let (pkh, _pk, _sk) = Signature.generate_key () in
   let dest = Contract.implicit_contract pkh in
   let amount = Tez.one in
-  wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount)
+  wrap
+    (Token.transfer
+       ctxt
+       (Source_container (Contract src))
+       (Sink_container (Contract dest))
+       amount)
   >>=? fun (_, bal_updates) ->
   Alcotest.(
     check
@@ -109,11 +115,19 @@ let test_allocated_and_deallocated ctxt dest initial_status status_when_empty =
   wrap (Token.allocated ctxt dest) >>=? fun (ctxt, allocated) ->
   Assert.equal_bool ~loc:__LOC__ allocated initial_status >>=? fun () ->
   let amount = Tez.one in
-  wrap (Token.transfer ctxt `Minted dest amount) >>=? fun (ctxt', _) ->
+  wrap
+    (Token.transfer ctxt (Source_infinite Minted) (Sink_container dest) amount)
+  >>=? fun (ctxt', _) ->
   wrap (Token.allocated ctxt' dest) >>=? fun (ctxt', allocated) ->
   Assert.equal_bool ~loc:__LOC__ allocated true >>=? fun () ->
   wrap (Token.balance ctxt' dest) >>=? fun (ctxt', bal_dest') ->
-  wrap (Token.transfer ctxt' dest `Burned bal_dest') >>=? fun (ctxt', _) ->
+  wrap
+    (Token.transfer
+       ctxt'
+       (Source_container dest)
+       (Sink_infinite Burned)
+       bal_dest')
+  >>=? fun (ctxt', _) ->
   wrap (Token.allocated ctxt' dest) >>=? fun (_, allocated) ->
   Assert.equal_bool ~loc:__LOC__ allocated status_when_empty >>=? fun () ->
   return_unit
@@ -127,20 +141,20 @@ let test_allocated_and_still_allocated_when_empty ctxt dest initial_status =
 let test_allocated () =
   Random.init 0 ;
   create_context () >>=? fun (ctxt, pkh) ->
-  let dest = `Delegate_balance pkh in
+  let dest = Token.Delegate_balance pkh in
   test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ ->
   let (pkh, _pk, _sk) = Signature.generate_key () in
-  let dest = `Contract (Contract.implicit_contract pkh) in
+  let dest = Token.Contract (Contract.implicit_contract pkh) in
   test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ ->
-  let dest = `Collected_commitments Blinded_public_key_hash.zero in
+  let dest = Token.Collected_commitments Blinded_public_key_hash.zero in
   test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ ->
-  let dest = `Frozen_deposits pkh in
+  let dest = Token.Frozen_deposits pkh in
   test_allocated_and_still_allocated_when_empty ctxt dest false >>=? fun _ ->
-  let dest = `Block_fees in
+  let dest = Token.Block_fees in
   test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ ->
   let dest =
     let bond_id = Bond_id.Tx_rollup_bond_id (mk_rollup ()) in
-    `Frozen_bonds (Contract.implicit_contract pkh, bond_id)
+    Token.Frozen_bonds (Contract.implicit_contract pkh, bond_id)
   in
   test_allocated_and_deallocated_when_empty ctxt dest
 
@@ -155,20 +169,31 @@ let check_sink_balances ctxt ctxt' dest amount =
    (`Contract pkh) instead. *)
 let force_allocation_if_need_be ctxt account =
   match account with
-  | `Delegate_balance pkh ->
-      let account = `Contract (Contract.implicit_contract pkh) in
-      wrap (Token.transfer ctxt `Minted account Tez.one_mutez) >|=? fst
+  | Token.Delegate_balance pkh ->
+      let account =
+        Token.Sink_container (Contract (Contract.implicit_contract pkh))
+      in
+      wrap (Token.transfer ctxt (Source_infinite Minted) account Tez.one_mutez)
+      >|=? fst
   | _ -> return ctxt
 
 let test_transferring_to_sink ctxt sink amount expected_bupds =
   (* Transferring zero must be a noop, and must not return balance updates. *)
-  wrap (Token.transfer ctxt `Minted sink Tez.zero) >>=? fun (ctxt', bupds) ->
+  wrap
+    (Token.transfer
+       ctxt
+       (Source_infinite Minted)
+       (Sink_container sink)
+       Tez.zero)
+  >>=? fun (ctxt', bupds) ->
   Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true
   >>=? fun _ ->
   (* Force the allocation of [dest] if need be. *)
   force_allocation_if_need_be ctxt sink >>=? fun ctxt ->
   (* Test transferring a non null amount. *)
-  wrap (Token.transfer ctxt `Minted sink amount) >>=? fun (ctxt', bupds) ->
+  wrap
+    (Token.transfer ctxt (Source_infinite Minted) (Sink_container sink) amount)
+  >>=? fun (ctxt', bupds) ->
   check_sink_balances ctxt ctxt' sink amount >>=? fun _ ->
   let expected_bupds =
     Receipt.(Minted, Debited amount, Block_application) :: expected_bupds
@@ -178,7 +203,9 @@ let test_transferring_to_sink ctxt sink amount expected_bupds =
   (* Test transferring to go beyond capacity. *)
   wrap (Token.balance ctxt' sink) >>=? fun (ctxt', bal) ->
   let amount = Tez.of_mutez_exn Int64.max_int -! bal +! Tez.one_mutez in
-  wrap (Token.transfer ctxt' `Minted sink amount) >>= fun res ->
+  wrap
+    (Token.transfer ctxt' (Source_infinite Minted) (Sink_container sink) amount)
+  >>= fun res ->
   Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition"
 
 let test_transferring_to_contract ctxt =
@@ -187,7 +214,7 @@ let test_transferring_to_contract ctxt =
   let amount = random_amount () in
   test_transferring_to_sink
     ctxt
-    (`Contract dest)
+    (Contract dest)
     amount
     [(Contract dest, Credited amount, Block_application)]
 
@@ -196,7 +223,7 @@ let test_transferring_to_collected_commitments ctxt =
   let bpkh = Blinded_public_key_hash.zero in
   test_transferring_to_sink
     ctxt
-    (`Collected_commitments bpkh)
+    (Collected_commitments bpkh)
     amount
     [(Commitments bpkh, Credited amount, Block_application)]
 
@@ -206,7 +233,7 @@ let test_transferring_to_delegate_balance ctxt =
   let amount = random_amount () in
   test_transferring_to_sink
     ctxt
-    (`Delegate_balance pkh)
+    (Delegate_balance pkh)
     amount
     [(Contract dest, Credited amount, Block_application)]
 
@@ -215,7 +242,7 @@ let test_transferring_to_frozen_deposits ctxt =
   let amount = random_amount () in
   test_transferring_to_sink
     ctxt
-    (`Frozen_deposits pkh)
+    (Frozen_deposits pkh)
     amount
     [(Deposits pkh, Credited amount, Block_application)]
 
@@ -223,26 +250,39 @@ let test_transferring_to_collected_fees ctxt =
   let amount = random_amount () in
   test_transferring_to_sink
     ctxt
-    `Block_fees
+    Block_fees
     amount
     [(Block_fees, Credited amount, Block_application)]
 
 let test_transferring_to_burned ctxt =
   let amount = random_amount () in
   let minted_bupd = Receipt.(Minted, Debited amount, Block_application) in
-  wrap (Token.transfer ctxt `Minted `Burned amount) >>=? fun (_, bupds) ->
+  wrap
+    (Token.transfer ctxt (Source_infinite Minted) (Sink_infinite Burned) amount)
+  >>=? fun (_, bupds) ->
   Assert.equal_bool
     ~loc:__LOC__
     (bupds = [minted_bupd; (Burned, Credited amount, Block_application)])
     true
   >>=? fun () ->
-  wrap (Token.transfer ctxt `Minted `Storage_fees amount) >>=? fun (_, bupds) ->
+  wrap
+    (Token.transfer
+       ctxt
+       (Source_infinite Minted)
+       (Sink_infinite Storage_fees)
+       amount)
+  >>=? fun (_, bupds) ->
   Assert.equal_bool
     ~loc:__LOC__
     (bupds = [minted_bupd; (Storage_fees, Credited amount, Block_application)])
     true
   >>=? fun () ->
-  wrap (Token.transfer ctxt `Minted `Double_signing_punishments amount)
+  wrap
+    (Token.transfer
+       ctxt
+       (Source_infinite Minted)
+       (Sink_infinite Double_signing_punishments)
+       amount)
   >>=? fun (_, bupds) ->
   Assert.equal_bool
     ~loc:__LOC__
@@ -256,7 +296,11 @@ let test_transferring_to_burned ctxt =
   let pkh = Signature.Public_key_hash.zero in
   let (p, r) = (Random.bool (), Random.bool ()) in
   wrap
-    (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount)
+    (Token.transfer
+       ctxt
+       (Source_infinite Minted)
+       (Sink_infinite (Lost_endorsing_rewards (pkh, p, r)))
+       amount)
   >>=? fun (_, bupds) ->
   Assert.equal_bool
     ~loc:__LOC__
@@ -275,7 +319,7 @@ let test_transferring_to_frozen_bonds ctxt =
   let amount = random_amount () in
   test_transferring_to_sink
     ctxt
-    (`Frozen_bonds (contract, bond_id))
+    (Frozen_bonds (contract, bond_id))
     amount
     [(Frozen_bonds (contract, bond_id), Credited amount, Block_application)]
 
@@ -298,11 +342,13 @@ let check_src_balances ctxt ctxt' src amount =
 
 let test_transferring_from_unbounded_source ctxt src expected_bupds =
   (* Transferring zero must not return balance updates. *)
-  wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (_, bupds) ->
+  wrap (Token.transfer ctxt src (Sink_infinite Burned) Tez.zero)
+  >>=? fun (_, bupds) ->
   Assert.equal_bool ~loc:__LOC__ (bupds = []) true >>=? fun () ->
   (* Test transferring a non null amount. *)
   let amount = random_amount () in
-  wrap (Token.transfer ctxt src `Burned amount) >>=? fun (_, bupds) ->
+  wrap (Token.transfer ctxt src (Sink_infinite Burned) amount)
+  >>=? fun (_, bupds) ->
   let expected_bupds =
     expected_bupds amount
     @ Receipt.[(Burned, Credited amount, Block_application)]
@@ -321,48 +367,76 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds =
   balance_no_fail ctxt src >>=? fun (ctxt, balance) ->
   Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () ->
   (* Test transferring from an empty account. *)
-  wrap (Token.transfer ctxt src `Burned Tez.one) >>= fun res ->
+  wrap
+    (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.one)
+  >>= fun res ->
   let error_title =
     match src with
-    | `Contract _ -> "Balance too low"
-    | `Delegate_balance _ | `Frozen_deposits _ | `Frozen_bonds _ ->
+    | Contract _ -> "Balance too low"
+    | Delegate_balance _ | Frozen_deposits _ | Frozen_bonds _ ->
         "Storage error (fatal internal error)"
     | _ -> "Underflowing tez subtraction"
   in
   Assert.proto_error_with_info ~loc:__LOC__ res error_title >>=? fun () ->
   (* Transferring zero must be a noop, and must not return balance updates. *)
-  wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (ctxt', bupds) ->
+  wrap
+    (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.zero)
+  >>=? fun (ctxt', bupds) ->
   Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true
   >>=? fun _ ->
   (* Force the allocation of [dest] if need be. *)
   force_allocation_if_need_be ctxt src >>=? fun ctxt ->
   (* Test transferring everything. *)
-  wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) ->
+  wrap
+    (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount)
+  >>=? fun (ctxt, _) ->
+  wrap
+    (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) amount)
+  >>=? fun (ctxt', bupds) ->
   check_src_balances ctxt ctxt' src amount >>=? fun _ ->
   let expected_bupds =
     expected_bupds @ Receipt.[(Burned, Credited amount, Block_application)]
   in
   Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true >>=? fun () ->
   (* Test transferring a smaller amount. *)
-  wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) ->
+  wrap
+    (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount)
+  >>=? fun (ctxt, _) ->
   (match src with
-  | `Frozen_bonds _ ->
-      wrap (Token.transfer ctxt src `Burned amount) >>= fun res ->
+  | Frozen_bonds _ ->
+      wrap
+        (Token.transfer
+           ctxt
+           (Source_container src)
+           (Sink_infinite Burned)
+           amount)
+      >>= fun res ->
       let error_title = "Partial spending of frozen bonds" in
       Assert.proto_error_with_info ~loc:__LOC__ res error_title
   | _ ->
-      wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) ->
+      wrap
+        (Token.transfer
+           ctxt
+           (Source_container src)
+           (Sink_infinite Burned)
+           amount)
+      >>=? fun (ctxt', bupds) ->
       check_src_balances ctxt ctxt' src amount >>=? fun _ ->
       Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true)
   >>=? fun () ->
   (* Test transferring more than available. *)
   wrap (Token.balance ctxt src) >>=? fun (ctxt, balance) ->
-  wrap (Token.transfer ctxt src `Burned (balance +! Tez.one)) >>= fun res ->
+  wrap
+    (Token.transfer
+       ctxt
+       (Source_container src)
+       (Sink_infinite Burned)
+       (balance +! Tez.one))
+  >>= fun res ->
   let error_title =
     match src with
-    | `Contract _ -> "Balance too low"
-    | `Frozen_bonds _ -> "Partial spending of frozen bonds"
+    | Contract _ -> "Balance too low"
+    | Frozen_bonds _ -> "Partial spending of frozen bonds"
     | _ -> "Underflowing tez subtraction"
   in
   Assert.proto_error_with_info ~loc:__LOC__ res error_title
@@ -373,7 +447,7 @@ let test_transferring_from_contract ctxt =
   let amount = random_amount () in
   test_transferring_from_bounded_source
     ctxt
-    (`Contract src)
+    (Contract src)
     amount
     [(Contract src, Debited amount, Block_application)]
 
@@ -382,7 +456,7 @@ let test_transferring_from_collected_commitments ctxt =
   let bpkh = Blinded_public_key_hash.zero in
   test_transferring_from_bounded_source
     ctxt
-    (`Collected_commitments bpkh)
+    (Collected_commitments bpkh)
     amount
     [(Commitments bpkh, Debited amount, Block_application)]
 
@@ -392,7 +466,7 @@ let test_transferring_from_delegate_balance ctxt =
   let src = Contract.implicit_contract pkh in
   test_transferring_from_bounded_source
     ctxt
-    (`Delegate_balance pkh)
+    (Delegate_balance pkh)
     amount
     [(Contract src, Debited amount, Block_application)]
 
@@ -401,7 +475,7 @@ let test_transferring_from_frozen_deposits ctxt =
   let amount = random_amount () in
   test_transferring_from_bounded_source
     ctxt
-    (`Frozen_deposits pkh)
+    (Frozen_deposits pkh)
     amount
     [(Deposits pkh, Debited amount, Block_application)]
 
@@ -409,7 +483,7 @@ let test_transferring_from_collected_fees ctxt =
   let amount = random_amount () in
   test_transferring_from_bounded_source
     ctxt
-    `Block_fees
+    Block_fees
     amount
     [(Block_fees, Debited amount, Block_application)]
 
@@ -421,46 +495,62 @@ let test_transferring_from_frozen_bonds ctxt =
   let amount = random_amount () in
   test_transferring_from_bounded_source
     ctxt
-    (`Frozen_bonds (contract, bond_id))
+    (Frozen_bonds (contract, bond_id))
     amount
     [(Frozen_bonds (contract, bond_id), Debited amount, Block_application)]
 
 let test_transferring_from_source () =
   Random.init 0 ;
   create_context () >>=? fun (ctxt, _) ->
-  test_transferring_from_unbounded_source ctxt `Invoice (fun am ->
-      [(Invoice, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Invoice)
+    (fun am -> [(Invoice, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Bootstrap (fun am ->
-      [(Bootstrap, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Bootstrap)
+    (fun am -> [(Bootstrap, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Initial_commitments (fun am ->
-      [(Initial_commitments, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Initial_commitments)
+    (fun am -> [(Initial_commitments, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Revelation_rewards (fun am ->
-      [(Nonce_revelation_rewards, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Revelation_rewards)
+    (fun am -> [(Nonce_revelation_rewards, Debited am, Block_application)])
   >>=? fun _ ->
   test_transferring_from_unbounded_source
     ctxt
-    `Double_signing_evidence_rewards
+    (Source_infinite Double_signing_evidence_rewards)
     (fun am ->
       [(Double_signing_evidence_rewards, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Endorsing_rewards (fun am ->
-      [(Endorsing_rewards, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Endorsing_rewards)
+    (fun am -> [(Endorsing_rewards, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Baking_rewards (fun am ->
-      [(Baking_rewards, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Baking_rewards)
+    (fun am -> [(Baking_rewards, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Baking_bonuses (fun am ->
-      [(Baking_bonuses, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Baking_bonuses)
+    (fun am -> [(Baking_bonuses, Debited am, Block_application)])
   >>=? fun _ ->
-  test_transferring_from_unbounded_source ctxt `Minted (fun am ->
-      [(Minted, Debited am, Block_application)])
+  test_transferring_from_unbounded_source
+    ctxt
+    (Source_infinite Minted)
+    (fun am -> [(Minted, Debited am, Block_application)])
   >>=? fun _ ->
   test_transferring_from_unbounded_source
     ctxt
-    `Liquidity_baking_subsidies
+    (Source_infinite Liquidity_baking_subsidies)
     (fun am -> [(Liquidity_baking_subsidies, Debited am, Block_application)])
   >>=? fun _ ->
   test_transferring_from_contract ctxt >>=? fun _ ->
@@ -484,23 +574,25 @@ let cast_to_container_type x =
 (** Generates all combinations of constructors. *)
 let build_test_cases () =
   create_context () >>=? fun (ctxt, pkh) ->
-  let origin = `Contract (Contract.implicit_contract pkh) in
+  let origin =
+    Token.Source_container (Contract (Contract.implicit_contract pkh))
+  in
   let (user1, _, _) = Signature.generate_key () in
-  let user1c = `Contract (Contract.implicit_contract user1) in
+  let user1c = Token.Contract (Contract.implicit_contract user1) in
   let (user2, _, _) = Signature.generate_key () in
-  let user2c = `Contract (Contract.implicit_contract user2) in
+  let user2c = Token.Contract (Contract.implicit_contract user2) in
   let (baker1, baker1_pk, _) = Signature.generate_key () in
-  let baker1c = `Contract (Contract.implicit_contract baker1) in
+  let baker1c = Token.Contract (Contract.implicit_contract baker1) in
   let (baker2, baker2_pk, _) = Signature.generate_key () in
-  let baker2c = `Contract (Contract.implicit_contract baker2) in
+  let baker2c = Token.Contract (Contract.implicit_contract baker2) in
   (* Allocate contracts for user1, user2, baker1, and baker2. *)
-  wrap (Token.transfer ctxt origin user1c (random_amount ()))
+  wrap (Token.transfer ctxt origin (Sink_container user1c) (random_amount ()))
   >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt origin user2c (random_amount ()))
+  wrap (Token.transfer ctxt origin (Sink_container user2c) (random_amount ()))
   >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt origin baker1c (random_amount ()))
+  wrap (Token.transfer ctxt origin (Sink_container baker1c) (random_amount ()))
   >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt origin baker2c (random_amount ()))
+  wrap (Token.transfer ctxt origin (Sink_container baker2c) (random_amount ()))
   >>=? fun (ctxt, _) ->
   (* Configure baker1, and baker2 as delegates by self-delegation, for which
      revealing their manager key is a prerequisite. *)
@@ -521,82 +613,90 @@ let build_test_cases () =
   let baker2ic = Contract.implicit_contract baker2 in
   let src_list =
     [
-      (`Invoice, random_amount ());
-      (`Bootstrap, random_amount ());
-      (`Initial_commitments, random_amount ());
-      (`Minted, random_amount ());
-      (`Liquidity_baking_subsidies, random_amount ());
-      (`Collected_commitments Blinded_public_key_hash.zero, random_amount ());
-      (`Delegate_balance baker1, random_amount ());
-      (`Delegate_balance baker2, random_amount ());
-      (`Block_fees, random_amount ());
-      (user1c, random_amount ());
-      (user2c, random_amount ());
-      (baker1c, random_amount ());
-      (baker2c, random_amount ());
-      (`Frozen_bonds (user1ic, bond_id1), random_amount ());
-      (`Frozen_bonds (baker2ic, bond_id2), random_amount ());
+      (Token.Source_infinite Invoice, random_amount ());
+      (Source_infinite Bootstrap, random_amount ());
+      (Source_infinite Initial_commitments, random_amount ());
+      (Source_infinite Minted, random_amount ());
+      (Source_infinite Liquidity_baking_subsidies, random_amount ());
+      ( Source_container (Collected_commitments Blinded_public_key_hash.zero),
+        random_amount () );
+      (Source_container (Delegate_balance baker1), random_amount ());
+      (Source_container (Delegate_balance baker2), random_amount ());
+      (Source_container Block_fees, random_amount ());
+      (Source_container user1c, random_amount ());
+      (Source_container user2c, random_amount ());
+      (Source_container baker1c, random_amount ());
+      (Source_container baker2c, random_amount ());
+      (Source_container (Frozen_bonds (user1ic, bond_id1)), random_amount ());
+      (Source_container (Frozen_bonds (baker2ic, bond_id2)), random_amount ());
     ]
   in
   let dest_list =
     [
-      `Collected_commitments Blinded_public_key_hash.zero;
-      `Delegate_balance baker1;
-      `Delegate_balance baker2;
-      `Block_fees;
-      user1c;
-      user2c;
-      baker1c;
-      baker2c;
-      `Frozen_bonds (user1ic, bond_id1);
-      `Frozen_bonds (baker2ic, bond_id2);
-      `Burned;
+      Token.Sink_container (Collected_commitments Blinded_public_key_hash.zero);
+      Sink_container (Delegate_balance baker1);
+      Sink_container (Delegate_balance baker2);
+      Sink_container Block_fees;
+      Sink_container user1c;
+      Sink_container user2c;
+      Sink_container baker1c;
+      Sink_container baker2c;
+      Sink_container (Frozen_bonds (user1ic, bond_id1));
+      Sink_container (Frozen_bonds (baker2ic, bond_id2));
+      Sink_infinite Burned;
     ]
   in
   return (ctxt, List.product src_list dest_list)
 
-let check_src_balances ctxt ctxt' src amount =
-  match cast_to_container_type src with
-  | None -> return_unit
-  | Some src -> check_src_balances ctxt ctxt' src amount
-
-let check_sink_balances ctxt ctxt' dest amount =
-  match cast_to_container_type dest with
-  | None -> return_unit
-  | Some dest -> check_sink_balances ctxt ctxt' dest amount
-
 let rec check_balances ctxt ctxt' src dest amount =
-  match (cast_to_container_type src, cast_to_container_type dest) with
-  | (None, None) -> return_unit
-  | (Some (`Delegate_balance d), Some (`Contract c as contract))
+  match (src, dest) with
+  | ( Token.Source_container (Delegate_balance d),
+      Token.Sink_container (Contract c as contract) )
     when Contract.implicit_contract d = c ->
       (* src and dest are in fact referring to the same contract *)
-      check_balances ctxt ctxt' contract contract amount
-  | (Some (`Contract c as contract), Some (`Delegate_balance d))
+      check_balances
+        ctxt
+        ctxt'
+        (Source_container contract)
+        (Sink_container contract)
+        amount
+  | ( Source_container (Contract c as contract),
+      Sink_container (Delegate_balance d) )
     when Contract.implicit_contract d = c ->
       (* src and dest are in fact referring to the same contract *)
-      check_balances ctxt ctxt' contract contract amount
-  | (Some src, Some dest) when src = dest ->
+      check_balances
+        ctxt
+        ctxt'
+        (Source_container contract)
+        (Sink_container contract)
+        amount
+  | (Source_container src, Sink_container dest) when src = dest ->
       (* src and dest are the same contract *)
       wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) ->
       wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') ->
       Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest'
-  | (Some src, None) -> check_src_balances ctxt ctxt' src amount
-  | (None, Some dest) -> check_sink_balances ctxt ctxt' dest amount
-  | (Some src, Some dest) ->
+  | (Source_container src, Sink_container dest) ->
       check_src_balances ctxt ctxt' src amount >>=? fun _ ->
       check_sink_balances ctxt ctxt' dest amount
+  | (Source_container src, _) -> check_src_balances ctxt ctxt' src amount
+  | (_, Sink_container dest) -> check_sink_balances ctxt ctxt' dest amount
+  | (_, _) -> return_unit
 
 let test_all_combinations_of_sources_and_sinks () =
   Random.init 0 ;
   build_test_cases () >>=? fun (ctxt, cases) ->
   List.iter_es
     (fun ((src, amount), dest) ->
-      (match cast_to_container_type src with
-      | None -> return ctxt
-      | Some src ->
-          wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) ->
-          return ctxt)
+      (match src with
+      | Token.Source_container src ->
+          wrap
+            (Token.transfer
+               ctxt
+               (Source_infinite Minted)
+               (Sink_container src)
+               amount)
+          >>=? fun (ctxt, _) -> return ctxt
+      | _ -> return ctxt)
       >>=? fun ctxt ->
       wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) ->
       check_balances ctxt ctxt' src dest amount)
@@ -631,15 +731,20 @@ let coalesce_balance_updates bu1 bu2 =
 
 (** Check that elt has the same balance in ctxt1 and ctxt2. *)
 let check_balances_are_consistent ctxt1 ctxt2 elt =
-  match elt with
-  | #Token.container as elt ->
-      Token.balance ctxt1 elt >>=? fun (_, elt_bal1) ->
-      Token.balance ctxt2 elt >>=? fun (_, elt_bal2) ->
-      assert (elt_bal1 = elt_bal2) ;
-      return_unit
-  | `Invoice | `Bootstrap | `Initial_commitments | `Minted
-  | `Liquidity_baking_subsidies | `Burned ->
-      return_unit
+  Token.balance ctxt1 elt >>=? fun (_, elt_bal1) ->
+  Token.balance ctxt2 elt >>=? fun (_, elt_bal2) ->
+  assert (elt_bal1 = elt_bal2) ;
+  return_unit
+
+let check_balances_are_consistent_source ctxt1 ctxt2 src =
+  match src with
+  | Token.Source_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt
+  | _ -> return_unit
+
+let check_balances_are_consistent_dest ctxt1 ctxt2 dest =
+  match dest with
+  | Token.Sink_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt
+  | _ -> return_unit
 
 (** Test that [transfer_n] is equivalent to n debits followed by n credits. *)
 let test_transfer_n ctxt src dest =
@@ -648,29 +753,29 @@ let test_transfer_n ctxt src dest =
   (* Debit all sources. *)
   List.fold_left_es
     (fun (ctxt, bal_updates) (src, am) ->
-      Token.transfer ctxt src `Burned am >>=? fun (ctxt, debit_logs) ->
-      return (ctxt, bal_updates @ debit_logs))
+      Token.transfer ctxt src (Sink_infinite Burned) am
+      >>=? fun (ctxt, debit_logs) -> return (ctxt, bal_updates @ debit_logs))
     (ctxt, [])
     src
   >>=? fun (ctxt, debit_logs) ->
   (* remove burning balance updates *)
   let debit_logs =
     List.filter
-      (fun b -> match b with (Receipt.Burned, _, _) -> false | _ -> true)
+      (fun b -> match b with (Receipt.(Burned), _, _) -> false | _ -> true)
       debit_logs
   in
   (* Credit the sink for each source. *)
   List.fold_left_es
     (fun (ctxt, bal_updates) (_, am) ->
-      Token.transfer ctxt `Minted dest am >>=? fun (ctxt, credit_logs) ->
-      return (ctxt, bal_updates @ credit_logs))
+      Token.transfer ctxt (Source_infinite Minted) dest am
+      >>=? fun (ctxt, credit_logs) -> return (ctxt, bal_updates @ credit_logs))
     (ctxt, [])
     src
   >>=? fun (ctxt2, credit_logs) ->
   (* remove minting balance updates *)
   let credit_logs =
     List.filter
-      (fun b -> match b with (Receipt.Minted, _, _) -> false | _ -> true)
+      (fun b -> match b with (Receipt.(Minted), _, _) -> false | _ -> true)
       credit_logs
   in
   (* Check equivalence of balance updates. *)
@@ -681,46 +786,56 @@ let test_transfer_n ctxt src dest =
   in
   assert (bal_updates1 = debit_logs @ credit_logs) ;
   (* Check balances are the same in ctxt1 and ctxt2. *)
-  List.(iter_es (check_balances_are_consistent ctxt1 ctxt2) (map fst src))
-  >>=? fun _ -> check_balances_are_consistent ctxt1 ctxt2 dest
+  List.(
+    iter_es (check_balances_are_consistent_source ctxt1 ctxt2) (map fst src))
+  >>=? fun _ -> check_balances_are_consistent_dest ctxt1 ctxt2 dest
 
 let test_transfer_n_with_empty_source () =
   Random.init 0 ;
   create_context () >>=? fun (ctxt, pkh) ->
-  wrap (test_transfer_n ctxt [] `Block_fees) >>=? fun _ ->
-  let dest = `Delegate_balance pkh in
+  wrap (test_transfer_n ctxt [] (Sink_container Block_fees)) >>=? fun _ ->
+  let dest = Token.Sink_container (Delegate_balance pkh) in
   wrap (test_transfer_n ctxt [] dest)
 
 let test_transfer_n_with_non_empty_source () =
   Random.init 0 ;
   create_context () >>=? fun (ctxt, pkh) ->
-  let origin = `Contract (Contract.implicit_contract pkh) in
+  let origin =
+    Token.Source_container (Contract (Contract.implicit_contract pkh))
+  in
   let (user1, _, _) = Signature.generate_key () in
-  let user1c = `Contract (Contract.implicit_contract user1) in
+  let user1c = Token.Contract (Contract.implicit_contract user1) in
   let (user2, _, _) = Signature.generate_key () in
-  let user2c = `Contract (Contract.implicit_contract user2) in
+  let user2c = Token.Contract (Contract.implicit_contract user2) in
   let (user3, _, _) = Signature.generate_key () in
-  let user3c = `Contract (Contract.implicit_contract user3) in
+  let user3c = Token.Contract (Contract.implicit_contract user3) in
   let (user4, _, _) = Signature.generate_key () in
-  let user4c = `Contract (Contract.implicit_contract user4) in
+  let user4c = Token.Contract (Contract.implicit_contract user4) in
   (* Allocate contracts for user1, user2, user3, and user4. *)
   let amount =
     match Tez.of_mutez 1000L with None -> assert false | Some x -> x
   in
-  wrap (Token.transfer ctxt origin user1c amount) >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt origin user2c amount) >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt origin user3c amount) >>=? fun (ctxt, _) ->
-  wrap (Token.transfer ctxt origin user4c (random_amount ()))
+  wrap (Token.transfer ctxt origin (Sink_container user1c) amount)
+  >>=? fun (ctxt, _) ->
+  wrap (Token.transfer ctxt origin (Sink_container user2c) amount)
+  >>=? fun (ctxt, _) ->
+  wrap (Token.transfer ctxt origin (Sink_container user3c) amount)
+  >>=? fun (ctxt, _) ->
+  wrap (Token.transfer ctxt origin (Sink_container user4c) (random_amount ()))
   >>=? fun (ctxt, _) ->
   let sources =
     [
-      (user2c, random_amount ());
-      (user3c, random_amount ());
-      (user4c, random_amount ());
+      (Token.Source_container user2c, random_amount ());
+      (Source_container user3c, random_amount ());
+      (Source_container user4c, random_amount ());
     ]
   in
-  wrap (test_transfer_n ctxt sources user1c) >>=? fun _ ->
-  wrap (test_transfer_n ctxt ((user1c, random_amount ()) :: sources) user1c)
+  wrap (test_transfer_n ctxt sources (Sink_container user1c)) >>=? fun _ ->
+  wrap
+    (test_transfer_n
+       ctxt
+       ((Source_container user1c, random_amount ()) :: sources)
+       (Sink_container user1c))
 
 let tests =
   Tztest.
diff --git a/src/proto_alpha/lib_protocol/token.ml b/src/proto_alpha/lib_protocol/token.ml
index 67f1083a0039..a25df1764101 100644
--- a/src/proto_alpha/lib_protocol/token.ml
+++ b/src/proto_alpha/lib_protocol/token.ml
@@ -24,70 +24,72 @@
 (*****************************************************************************)
 
 type container =
-  [ `Contract of Contract_repr.t
-  | `Collected_commitments of Blinded_public_key_hash.t
-  | `Delegate_balance of Signature.Public_key_hash.t
-  | `Frozen_deposits of Signature.Public_key_hash.t
-  | `Block_fees
-  | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ]
+  | Contract of Contract_repr.t
+  | Collected_commitments of Blinded_public_key_hash.t
+  | Delegate_balance of Signature.Public_key_hash.t
+  | Frozen_deposits of Signature.Public_key_hash.t
+  | Block_fees
+  | Frozen_bonds of Contract_repr.t * Bond_id_repr.t
 
 type infinite_source =
-  [ `Invoice
-  | `Bootstrap
-  | `Initial_commitments
-  | `Revelation_rewards
-  | `Double_signing_evidence_rewards
-  | `Endorsing_rewards
-  | `Baking_rewards
-  | `Baking_bonuses
-  | `Minted
-  | `Liquidity_baking_subsidies
-  | `Tx_rollup_rejection_rewards ]
+  | Invoice
+  | Bootstrap
+  | Initial_commitments
+  | Revelation_rewards
+  | Double_signing_evidence_rewards
+  | Endorsing_rewards
+  | Baking_rewards
+  | Baking_bonuses
+  | Minted
+  | Liquidity_baking_subsidies
+  | Tx_rollup_rejection_rewards
 
-type source = [infinite_source | container]
+type source =
+  | Source_infinite of infinite_source
+  | Source_container of container
 
 type infinite_sink =
-  [ `Storage_fees
-  | `Double_signing_punishments
-  | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
-  | `Tx_rollup_rejection_punishments
-  | `Burned ]
+  | Storage_fees
+  | Double_signing_punishments
+  | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
+  | Burned
+  | Tx_rollup_rejection_punishments
 
-type sink = [infinite_sink | container]
+type sink = Sink_infinite of infinite_sink | Sink_container of container
 
 let allocated ctxt stored =
   match stored with
-  | `Contract contract ->
+  | Contract contract ->
       Contract_storage.allocated ctxt contract >|=? fun allocated ->
       (ctxt, allocated)
-  | `Collected_commitments bpkh ->
+  | Collected_commitments bpkh ->
       Commitment_storage.exists ctxt bpkh >|= ok >|=? fun allocated ->
       (ctxt, allocated)
-  | `Delegate_balance delegate ->
+  | Delegate_balance delegate ->
       let contract = Contract_repr.implicit_contract delegate in
       Contract_storage.allocated ctxt contract >|=? fun allocated ->
       (ctxt, allocated)
-  | `Frozen_deposits delegate ->
+  | Frozen_deposits delegate ->
       let contract = Contract_repr.implicit_contract delegate in
       Frozen_deposits_storage.allocated ctxt contract >|= fun allocated ->
       ok (ctxt, allocated)
-  | `Block_fees -> return (ctxt, true)
-  | `Frozen_bonds (contract, bond_id) ->
+  | Block_fees -> return (ctxt, true)
+  | Frozen_bonds (contract, bond_id) ->
       Contract_storage.bond_allocated ctxt contract bond_id
 
 let balance ctxt stored =
   match stored with
-  | `Contract contract ->
+  | Contract contract ->
       Contract_storage.get_balance ctxt contract >|=? fun balance ->
       (ctxt, balance)
-  | `Collected_commitments bpkh ->
+  | Collected_commitments bpkh ->
       Commitment_storage.committed_amount ctxt bpkh >|=? fun balance ->
       (ctxt, balance)
-  | `Delegate_balance delegate ->
+  | Delegate_balance delegate ->
       let contract = Contract_repr.implicit_contract delegate in
       Storage.Contract.Spendable_balance.get ctxt contract >|=? fun balance ->
       (ctxt, balance)
-  | `Frozen_deposits delegate ->
+  | Frozen_deposits delegate ->
       let contract = Contract_repr.implicit_contract delegate in
       Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits ->
       let balance =
@@ -96,44 +98,44 @@ let balance ctxt stored =
         | Some frozen_deposits -> frozen_deposits.current_amount
       in
       (ctxt, balance)
-  | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt)
-  | `Frozen_bonds (contract, bond_id) ->
+  | Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt)
+  | Frozen_bonds (contract, bond_id) ->
       Contract_storage.find_bond ctxt contract bond_id
       >|=? fun (ctxt, balance_opt) ->
       (ctxt, Option.value ~default:Tez_repr.zero balance_opt)
 
-let credit ctxt dest amount origin =
+let credit ctxt (dest : sink) amount origin =
   let open Receipt_repr in
   (match dest with
-  | #infinite_sink as infinite_sink ->
+  | Sink_infinite infinite_sink ->
       let sink =
         match infinite_sink with
-        | `Storage_fees -> Storage_fees
-        | `Double_signing_punishments -> Double_signing_punishments
-        | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r)
-        | `Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments
-        | `Burned -> Burned
+        | Storage_fees -> Storage_fees
+        | Double_signing_punishments -> Double_signing_punishments
+        | Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r)
+        | Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments
+        | Burned -> Burned
       in
       return (ctxt, sink)
-  | #container as container -> (
+  | Sink_container container -> (
       match container with
-      | `Contract dest ->
+      | Contract dest ->
           Contract_storage.credit_only_call_from_token ctxt dest amount
           >|=? fun ctxt -> (ctxt, Contract dest)
-      | `Collected_commitments bpkh ->
+      | Collected_commitments bpkh ->
           Commitment_storage.increase_commitment_only_call_from_token
             ctxt
             bpkh
             amount
           >|=? fun ctxt -> (ctxt, Commitments bpkh)
-      | `Delegate_balance delegate ->
+      | Delegate_balance delegate ->
           let contract = Contract_repr.implicit_contract delegate in
           Contract_storage.increase_balance_only_call_from_token
             ctxt
             contract
             amount
           >|=? fun ctxt -> (ctxt, Contract contract)
-      | `Frozen_deposits delegate as dest ->
+      | Frozen_deposits delegate as dest ->
           allocated ctxt dest >>=? fun (ctxt, allocated) ->
           (if not allocated then Frozen_deposits_storage.init ctxt delegate
           else return ctxt)
@@ -143,10 +145,10 @@ let credit ctxt dest amount origin =
             delegate
             amount
           >|=? fun ctxt -> (ctxt, Deposits delegate)
-      | `Block_fees ->
+      | Block_fees ->
           Raw_context.credit_collected_fees_only_call_from_token ctxt amount
           >>?= fun ctxt -> return (ctxt, Block_fees)
-      | `Frozen_bonds (contract, bond_id) ->
+      | Frozen_bonds (contract, bond_id) ->
           Contract_storage.credit_bond_only_call_from_token
             ctxt
             contract
@@ -155,53 +157,53 @@ let credit ctxt dest amount origin =
           >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id))))
   >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin))
 
-let spend ctxt src amount origin =
+let spend ctxt (src : source) amount origin =
   let open Receipt_repr in
   (match src with
-  | #infinite_source as infinite_source ->
+  | Source_infinite infinite_source ->
       let src =
         match infinite_source with
-        | `Bootstrap -> Bootstrap
-        | `Invoice -> Invoice
-        | `Initial_commitments -> Initial_commitments
-        | `Minted -> Minted
-        | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies
-        | `Revelation_rewards -> Nonce_revelation_rewards
-        | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards
-        | `Endorsing_rewards -> Endorsing_rewards
-        | `Baking_rewards -> Baking_rewards
-        | `Baking_bonuses -> Baking_bonuses
-        | `Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards
+        | Bootstrap -> Bootstrap
+        | Invoice -> Invoice
+        | Initial_commitments -> Initial_commitments
+        | Minted -> Minted
+        | Liquidity_baking_subsidies -> Liquidity_baking_subsidies
+        | Revelation_rewards -> Nonce_revelation_rewards
+        | Double_signing_evidence_rewards -> Double_signing_evidence_rewards
+        | Endorsing_rewards -> Endorsing_rewards
+        | Baking_rewards -> Baking_rewards
+        | Baking_bonuses -> Baking_bonuses
+        | Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards
       in
       return (ctxt, src)
-  | #container as container -> (
+  | Source_container container -> (
       match container with
-      | `Contract src ->
+      | Contract src ->
           Contract_storage.spend_only_call_from_token ctxt src amount
           >|=? fun ctxt -> (ctxt, Contract src)
-      | `Collected_commitments bpkh ->
+      | Collected_commitments bpkh ->
           Commitment_storage.decrease_commitment_only_call_from_token
             ctxt
             bpkh
             amount
           >|=? fun ctxt -> (ctxt, Commitments bpkh)
-      | `Delegate_balance delegate ->
+      | Delegate_balance delegate ->
           let contract = Contract_repr.implicit_contract delegate in
           Contract_storage.decrease_balance_only_call_from_token
             ctxt
             contract
             amount
           >|=? fun ctxt -> (ctxt, Contract contract)
-      | `Frozen_deposits delegate ->
+      | Frozen_deposits delegate ->
           Frozen_deposits_storage.spend_only_call_from_token
             ctxt
             delegate
             amount
           >|=? fun ctxt -> (ctxt, Deposits delegate)
-      | `Block_fees ->
+      | Block_fees ->
           Raw_context.spend_collected_fees_only_call_from_token ctxt amount
           >>?= fun ctxt -> return (ctxt, Block_fees)
-      | `Frozen_bonds (contract, bond_id) ->
+      | Frozen_bonds (contract, bond_id) ->
           Contract_storage.spend_bond_only_call_from_token
             ctxt
             contract
@@ -234,9 +236,10 @@ let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest =
       List.fold_left_es
         (fun ctxt (source, _amount) ->
           match source with
-          | `Contract contract | `Frozen_bonds (contract, _) ->
+          | Source_container (Contract contract)
+          | Source_container (Frozen_bonds (contract, _)) ->
               Contract_storage.ensure_deallocated_if_empty ctxt contract
-          | #source -> return ctxt)
+          | _ -> return ctxt)
         ctxt
         sources
       >|=? fun ctxt ->
diff --git a/src/proto_alpha/lib_protocol/token.mli b/src/proto_alpha/lib_protocol/token.mli
index 2fe5f2cb8446..fcbc3b0e396f 100644
--- a/src/proto_alpha/lib_protocol/token.mli
+++ b/src/proto_alpha/lib_protocol/token.mli
@@ -43,42 +43,44 @@
     stake. *)
 
 type container =
-  [ `Contract of Contract_repr.t
-  | `Collected_commitments of Blinded_public_key_hash.t
-  | `Delegate_balance of Signature.Public_key_hash.t
-  | `Frozen_deposits of Signature.Public_key_hash.t
-  | `Block_fees
-  | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ]
+  | Contract of Contract_repr.t
+  | Collected_commitments of Blinded_public_key_hash.t
+  | Delegate_balance of Signature.Public_key_hash.t
+  | Frozen_deposits of Signature.Public_key_hash.t
+  | Block_fees
+  | Frozen_bonds of Contract_repr.t * Bond_id_repr.t
 
 (** [infinite_source] defines types of tokens provides which are considered to be
  ** of infinite capacity. *)
 type infinite_source =
-  [ `Invoice
-  | `Bootstrap
-  | `Initial_commitments
-  | `Revelation_rewards
-  | `Double_signing_evidence_rewards
-  | `Endorsing_rewards
-  | `Baking_rewards
-  | `Baking_bonuses
-  | `Minted
-  | `Liquidity_baking_subsidies
-  | `Tx_rollup_rejection_rewards ]
+  | Invoice
+  | Bootstrap
+  | Initial_commitments
+  | Revelation_rewards
+  | Double_signing_evidence_rewards
+  | Endorsing_rewards
+  | Baking_rewards
+  | Baking_bonuses
+  | Minted
+  | Liquidity_baking_subsidies
+  | Tx_rollup_rejection_rewards
 
 (** [source] is the type of token providers. Token providers that are not
     containers are considered to have infinite capacity. *)
-type source = [infinite_source | container]
+type source =
+  | Source_infinite of infinite_source
+  | Source_container of container
 
 type infinite_sink =
-  [ `Storage_fees
-  | `Double_signing_punishments
-  | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
-  | `Tx_rollup_rejection_punishments
-  | `Burned ]
+  | Storage_fees
+  | Double_signing_punishments
+  | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool
+  | Burned
+  | Tx_rollup_rejection_punishments
 
 (** [sink] is the type of token receivers. Token receivers that are not
     containers are considered to have infinite capacity. *)
-type sink = [infinite_sink | container]
+type sink = Sink_infinite of infinite_sink | Sink_container of container
 
 (** [allocated ctxt container] returns a new context because of possible access
     to carbonated data, and a boolean that is [true] when
@@ -109,8 +111,8 @@ val balance :
 val transfer_n :
   ?origin:Receipt_repr.update_origin ->
   Raw_context.t ->
-  ([< source] * Tez_repr.t) list ->
-  [< sink] ->
+  (source * Tez_repr.t) list ->
+  sink ->
   (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t
 
 (** [transfer ?origin ctxt src dest amount] transfers [amount] Tez from source
@@ -137,7 +139,7 @@ val transfer_n :
 val transfer :
   ?origin:Receipt_repr.update_origin ->
   Raw_context.t ->
-  [< source] ->
-  [< sink] ->
+  source ->
+  sink ->
   Tez_repr.t ->
   (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t
-- 
GitLab


From 572a3af60552d8255c2aca5c28cccac357d47264 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 5 Nov 2021 17:51:06 +0100
Subject: [PATCH 10/69] Proto: expand match on extensible type for coq-of-ocaml

---
 src/proto_alpha/lib_protocol/cache_repr.ml | 20 +++++++++++---------
 1 file changed, 11 insertions(+), 9 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/cache_repr.ml b/src/proto_alpha/lib_protocol/cache_repr.ml
index 1fb43b8739c3..2359480d4dc0 100644
--- a/src/proto_alpha/lib_protocol/cache_repr.ml
+++ b/src/proto_alpha/lib_protocol/cache_repr.ml
@@ -264,15 +264,17 @@ let register_exn (type cvalue)
       >>?= fun ctxt ->
       Admin.find ctxt (mk ~id) >>= function
       | None -> return None
-      | Some (K v) -> return (Some v)
-      | _ ->
-          (* This execution path is impossible because all the keys of
-             C's namespace (which is unique to C) are constructed with
-             [K]. This [assert false] could have been pushed into the
-             environment in exchange for extra complexity. The
-             argument that justifies this [assert false] seems
-             simple enough to keep the current design though. *)
-          assert false
+      | Some value -> (
+          match value with
+          | K v -> return (Some v)
+          | _ ->
+              (* This execution path is impossible because all the keys of
+                 C's namespace (which is unique to C) are constructed with
+                 [K]. This [assert false] could have been pushed into the
+                 environment in exchange for extra complexity. The
+                 argument that justifies this [assert false] seems
+                 simple enough to keep the current design though. *)
+              assert false)
 
     let list_identifiers ctxt =
       Admin.list_keys ctxt ~cache_index:C.cache_index |> function
-- 
GitLab


From b4d7501f529e7edd7774348b691efd520659ed8e Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 5 Nov 2021 18:53:11 +0100
Subject: [PATCH 11/69] Proto: add coq-of-ocaml annotations

---
 src/proto_alpha/lib_protocol/round_repr.ml           | 2 +-
 src/proto_alpha/lib_protocol/script_typed_ir_size.ml | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml
index 8a60fa317684..fb355745b3a4 100644
--- a/src/proto_alpha/lib_protocol/round_repr.ml
+++ b/src/proto_alpha/lib_protocol/round_repr.ml
@@ -107,7 +107,7 @@ let encoding =
     (fun i -> i)
     (fun i ->
       match of_int32 i with
-      | Ok _ as res -> res
+      | Ok _ as res -> res [@coq_cast]
       | Error _ -> Error "Round_repr.encoding: negative round")
     Data_encoding.int32
 
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index 086fe1394168..67d992bf5b8b 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -34,10 +34,10 @@ let sapling_memo_size_size = !!0
 
 module Ty_size = struct
   let base_basic = !!0
+
   (* Basic types count for 0 because they are all static values, hence shared
      and not counted by `reachable_words`.
      On the other hand compound types are functions, hence not shared. *)
-
   let base_compound_no_meta = header_size
 
   let base_compound _meta = h1w
-- 
GitLab


From f4146c6e9af34971810e119d9aecb438bfd9a751 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 5 Nov 2021 21:19:25 +0100
Subject: [PATCH 12/69] Proto: add fixpoint annotation for coq-of-ocaml

---
 src/proto_alpha/lib_protocol/sampler.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml
index b390b6dcf54b..6f42b1da9ad1 100644
--- a/src/proto_alpha/lib_protocol/sampler.ml
+++ b/src/proto_alpha/lib_protocol/sampler.ml
@@ -74,7 +74,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct
     alias : int FallbackArray.t;
   }
 
-  let rec init_loop total p alias small large =
+  let[@coq_struct "small"] rec init_loop total p alias small large =
     match (small, large) with
     | ([], _) -> List.iter (fun (_, i) -> FallbackArray.set p i total) large
     | (_, []) ->
-- 
GitLab


From 6cda15ddb36f0269be9c8bef8c5d24acc0aed06d Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 5 Nov 2021 21:19:41 +0100
Subject: [PATCH 13/69] Proto: namespace similar constructors for Coq

---
 .../client_baking_denunciation.ml             |  6 ++--
 .../lib_protocol/alpha_context.mli            | 21 +++++++------
 src/proto_alpha/lib_protocol/apply.ml         |  8 ++---
 .../lib_protocol/operation_repr.ml            | 31 ++++++++++---------
 .../lib_protocol/operation_repr.mli           | 21 +++++++------
 5 files changed, 45 insertions(+), 42 deletions(-)

diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml
index 8fef9976c501..97f85664b1fb 100644
--- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml
+++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml
@@ -113,7 +113,7 @@ let get_block_offset level =
       Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs)
       >>= fun () -> Lwt.return (`Head 0)
 
-let get_payload_hash (type kind) (op_kind : kind consensus_operation_type)
+let get_payload_hash (type kind) (op_kind : kind Consensus_operation_type.t)
     (op : kind Operation.t) =
   match (op_kind, op.protocol_data.contents) with
   | (Preendorsement, Single (Preendorsement consensus_content))
@@ -122,7 +122,7 @@ let get_payload_hash (type kind) (op_kind : kind consensus_operation_type)
   | _ -> .
 
 let double_consensus_op_evidence (type kind) :
-    kind consensus_operation_type ->
+    kind Consensus_operation_type.t ->
     #Protocol_client_context.full ->
     'a ->
     branch:Block_hash.t ->
@@ -134,7 +134,7 @@ let double_consensus_op_evidence (type kind) :
   | Preendorsement -> Plugin.RPC.Forge.double_preendorsement_evidence
 
 let process_consensus_op (type kind) cctxt
-    (op_kind : kind consensus_operation_type) (new_op : kind Operation.t)
+    (op_kind : kind Consensus_operation_type.t) (new_op : kind Operation.t)
     chain_id level round slot ops_table =
   let map =
     Option.value ~default:Slot_Map.empty
diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 9ccb72c125b2..97c0caca81c1 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -2789,12 +2789,13 @@ module Kind : sig
     | Sc_rollup_publish_manager_kind : sc_rollup_publish manager
 end
 
-type 'a consensus_operation_type =
-  | Endorsement : Kind.endorsement consensus_operation_type
-  | Preendorsement : Kind.preendorsement consensus_operation_type
+module Consensus_operation_type : sig
+  type 'a t =
+    | Endorsement : Kind.endorsement t
+    | Preendorsement : Kind.preendorsement t
 
-val pp_operation_kind :
-  Format.formatter -> 'kind consensus_operation_type -> unit
+  val pp : Format.formatter -> 'kind t -> unit
+end
 
 type consensus_content = {
   slot : Slot.t;
@@ -3007,13 +3008,13 @@ module Operation : sig
 
   type nonrec packed_protocol_data = packed_protocol_data
 
-  type consensus_watermark =
-    | Endorsement of Chain_id.t
-    | Preendorsement of Chain_id.t
+  module Consensus_watermark : sig
+    type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t
+  end
 
-  val to_watermark : consensus_watermark -> Signature.watermark
+  val to_watermark : Consensus_watermark.t -> Signature.watermark
 
-  val of_watermark : Signature.watermark -> consensus_watermark option
+  val of_watermark : Signature.watermark -> Consensus_watermark.t option
 
   val protocol_data_encoding : packed_protocol_data Data_encoding.t
 
diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index a295baea2ea6..132621ecb366 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2471,7 +2471,7 @@ type 'consensus_op_kind expected_consensus_content = {
 let compute_expected_consensus_content (type consensus_op_kind)
     ~(current_level : Level.t) ~(proposal_level : Level.t) (ctxt : context)
     (application_mode : apply_mode)
-    (operation_kind : consensus_op_kind consensus_operation_type)
+    (operation_kind : consensus_op_kind Consensus_operation_type.t)
     (operation_round : Round.t) (operation_level : Raw_level.t) :
     (context * consensus_op_kind expected_consensus_content) tzresult Lwt.t =
   match operation_kind with
@@ -2576,7 +2576,7 @@ let check_operation_branch ~expected ~provided =
     (Block_hash.equal expected provided)
     (Wrong_consensus_operation_branch (expected, provided))
 
-let check_round (type kind) (operation_kind : kind consensus_operation_type)
+let check_round (type kind) (operation_kind : kind Consensus_operation_type.t)
     (apply_mode : apply_mode) ~(expected : Round.t) ~(provided : Round.t) :
     unit tzresult =
   match apply_mode with
@@ -2602,7 +2602,7 @@ let check_round (type kind) (operation_kind : kind consensus_operation_type)
 
 let check_consensus_content (type kind) (apply_mode : apply_mode)
     (content : consensus_content) (operation_branch : Block_hash.t)
-    (operation_kind : kind consensus_operation_type)
+    (operation_kind : kind Consensus_operation_type.t)
     (expected_content : kind expected_consensus_content) : unit tzresult =
   let expected_level = expected_content.level.level in
   let provided_level = content.level in
@@ -2630,7 +2630,7 @@ let check_consensus_content (type kind) (apply_mode : apply_mode)
    a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to
    propagate for a subsequent proposal using it as a locked_round evidence. *)
 let validate_consensus_contents (type kind) ctxt chain_id
-    (operation_kind : kind consensus_operation_type)
+    (operation_kind : kind Consensus_operation_type.t)
     (operation : kind operation) (apply_mode : apply_mode)
     (content : consensus_content) :
     (context * public_key_hash * int) tzresult Lwt.t =
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index 0b8e05e70d4f..d56bb8397dcf 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -118,15 +118,16 @@ module Kind = struct
     | Sc_rollup_publish_manager_kind : sc_rollup_publish manager
 end
 
-type 'a consensus_operation_type =
-  | Endorsement : Kind.endorsement consensus_operation_type
-  | Preendorsement : Kind.preendorsement consensus_operation_type
-
-let pp_operation_kind (type kind) ppf
-    (operation_kind : kind consensus_operation_type) =
-  match operation_kind with
-  | Endorsement -> Format.fprintf ppf "Endorsement"
-  | Preendorsement -> Format.fprintf ppf "Preendorsement"
+module Consensus_operation_type = struct
+  type 'a t =
+    | Endorsement : Kind.endorsement t
+    | Preendorsement : Kind.preendorsement t
+
+  let pp (type kind) ppf (operation_kind : kind t) =
+    match operation_kind with
+    | Endorsement -> Format.fprintf ppf "Endorsement"
+    | Preendorsement -> Format.fprintf ppf "Preendorsement"
+end
 
 type consensus_content = {
   slot : Slot_repr.t;
@@ -167,12 +168,12 @@ let pp_consensus_content ppf content =
     Block_payload_hash.pp_short
     content.block_payload_hash
 
-type consensus_watermark =
-  | Endorsement of Chain_id.t
-  | Preendorsement of Chain_id.t
+module Consensus_watermark = struct
+  type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t
+end
 
 let bytes_of_consensus_watermark = function
-  | Preendorsement chain_id ->
+  | Consensus_watermark.Preendorsement chain_id ->
       Bytes.cat (Bytes.of_string "\x12") (Chain_id.to_bytes chain_id)
   | Endorsement chain_id ->
       Bytes.cat (Bytes.of_string "\x13") (Chain_id.to_bytes chain_id)
@@ -185,11 +186,11 @@ let of_watermark = function
         match Bytes.get b 0 with
         | '\x12' ->
             Option.map
-              (fun chain_id -> Endorsement chain_id)
+              (fun chain_id -> Consensus_watermark.Endorsement chain_id)
               (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1)))
         | '\x13' ->
             Option.map
-              (fun chain_id -> Preendorsement chain_id)
+              (fun chain_id -> Consensus_watermark.Preendorsement chain_id)
               (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1)))
         | _ -> None
       else None
diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli
index 5fafe68f10d5..7666ac1248c6 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.mli
+++ b/src/proto_alpha/lib_protocol/operation_repr.mli
@@ -146,12 +146,13 @@ module Kind : sig
     | Sc_rollup_publish_manager_kind : sc_rollup_publish manager
 end
 
-type 'a consensus_operation_type =
-  | Endorsement : Kind.endorsement consensus_operation_type
-  | Preendorsement : Kind.preendorsement consensus_operation_type
+module Consensus_operation_type : sig
+  type 'a t =
+    | Endorsement : Kind.endorsement t
+    | Preendorsement : Kind.preendorsement t
 
-val pp_operation_kind :
-  Format.formatter -> 'kind consensus_operation_type -> unit
+  val pp : Format.formatter -> 'kind t -> unit
+end
 
 type consensus_content = {
   slot : Slot_repr.t;
@@ -168,13 +169,13 @@ val consensus_content_encoding : consensus_content Data_encoding.t
 
 val pp_consensus_content : Format.formatter -> consensus_content -> unit
 
-type consensus_watermark =
-  | Endorsement of Chain_id.t
-  | Preendorsement of Chain_id.t
+module Consensus_watermark : sig
+  type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t
+end
 
-val to_watermark : consensus_watermark -> Signature.watermark
+val to_watermark : Consensus_watermark.t -> Signature.watermark
 
-val of_watermark : Signature.watermark -> consensus_watermark option
+val of_watermark : Signature.watermark -> Consensus_watermark.t option
 
 type raw = Operation.t = {shell : Operation.shell_header; proto : bytes}
 
-- 
GitLab


From 2dff71cd11fb1ff3aa192f893f54d7e67216b908 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 5 Nov 2021 22:01:20 +0100
Subject: [PATCH 14/69] Proto: add coq-of-ocaml annotations to compile
 operation_repr

---
 .../lib_protocol/operation_repr.ml            | 22 +++++++++----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index d56bb8397dcf..245e3873a3f7 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -954,7 +954,9 @@ module Encoding = struct
         encoding = consensus_content_encoding;
         select =
           (function Contents (Preendorsement _ as op) -> Some op | _ -> None);
-        proj = (fun (Preendorsement preendorsement) -> preendorsement);
+        proj =
+          (fun [@coq_match_with_default] (Preendorsement preendorsement) ->
+            preendorsement);
         inj = (fun preendorsement -> Preendorsement preendorsement);
       }
 
@@ -984,19 +986,17 @@ module Encoding = struct
                   @@ union [make preendorsement_case]))
                (varopt "signature" Signature.encoding)))
 
-  let endorsement_encoding =
-    obj4
-      (req "slot" Slot_repr.encoding)
-      (req "level" Raw_level_repr.encoding)
-      (req "round" Round_repr.encoding)
-      (req "block_payload_hash" Block_payload_hash.encoding)
-
   let endorsement_case =
     Case
       {
         tag = 21;
         name = "endorsement";
-        encoding = endorsement_encoding;
+        encoding =
+          obj4
+            (req "slot" Slot_repr.encoding)
+            (req "level" Raw_level_repr.encoding)
+            (req "round" Round_repr.encoding)
+            (req "block_payload_hash" Block_payload_hash.encoding);
         select =
           (function Contents (Endorsement _ as op) -> Some op | _ -> None);
         proj =
@@ -1386,7 +1386,7 @@ let raw ({shell; protocol_data} : _ operation) =
 
 let acceptable_passes (op : packed_operation) =
   let (Operation_data protocol_data) = op.protocol_data in
-  match protocol_data.contents with
+  match[@coq_match_with_default] protocol_data.contents with
   | Single (Failing_noop _) -> []
   | Single (Preendorsement _) -> [0]
   | Single (Endorsement _) -> [0]
@@ -1457,7 +1457,7 @@ let check_signature (type kind) key chain_id
   match protocol_data.signature with
   | None -> error Missing_signature
   | Some signature -> (
-      match protocol_data.contents with
+      match[@coq_match_with_default] protocol_data.contents with
       | Single (Preendorsement _) as contents ->
           check
             ~watermark:(to_watermark (Preendorsement chain_id))
-- 
GitLab


From 10c22359e4afc4dc8ee4e7a3a03865c2966ca6a1 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Sat, 6 Nov 2021 00:37:49 +0100
Subject: [PATCH 15/69] Proto: add coq-of-ocaml attributes

---
 src/proto_alpha/lib_protocol/apply.ml         | 28 +++++++++++--------
 src/proto_alpha/lib_protocol/apply_results.ml |  2 +-
 src/proto_alpha/lib_protocol/baking.ml        |  2 +-
 3 files changed, 18 insertions(+), 14 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 132621ecb366..0146e8233da1 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2181,7 +2181,7 @@ let skipped_operation_result :
               : kind successful_manager_operation_result)
       | _ -> Skipped (manager_kind operation))
 
-let rec mark_skipped :
+let[@coq_axiom_with_reason "gadts"] rec mark_skipped :
     type kind.
     payload_producer:Signature.Public_key_hash.t ->
     Level.t ->
@@ -2311,7 +2311,7 @@ let check_manager_signature ctxt chain_id (op : _ Kind.manager contents_list)
   >>=? fun public_key ->
   Lwt.return (Operation.check_signature public_key chain_id raw_operation)
 
-let rec apply_manager_contents_list_rec :
+let[@coq_axiom_with_reason "gadts"] rec apply_manager_contents_list_rec :
     type kind.
     context ->
     Script_ir_translator.unparsing_mode ->
@@ -2447,7 +2447,7 @@ let get_predecessor_level = function
       predecessor_level
 
 let record_operation (type kind) ctxt (operation : kind operation) : context =
-  match operation.protocol_data.contents with
+  match[@coq_match_with_default] operation.protocol_data.contents with
   | Single (Preendorsement _) -> ctxt
   | Single (Endorsement _) -> ctxt
   | Single
@@ -2629,8 +2629,8 @@ let check_consensus_content (type kind) (apply_mode : apply_mode)
    to the grandfather: the block hash used in the payload_hash. Otherwise we could produce
    a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to
    propagate for a subsequent proposal using it as a locked_round evidence. *)
-let validate_consensus_contents (type kind) ctxt chain_id
-    (operation_kind : kind Consensus_operation_type.t)
+let[@coq_axiom_with_reason "bug in coq-of-ocaml"] validate_consensus_contents
+    (type kind) ctxt chain_id (operation_kind : kind Consensus_operation_type.t)
     (operation : kind operation) (apply_mode : apply_mode)
     (content : consensus_content) :
     (context * public_key_hash * int) tzresult Lwt.t =
@@ -2697,13 +2697,15 @@ let check_denunciation_age ctxt kind given_level =
     (Outdated_denunciation
        {kind; level = given_level; last_cycle = last_slashable_cycle})
 
+type mistake = Double_baking | Double_endorsing
+
 let punish_delegate ctxt delegate level mistake mk_result ~payload_producer =
   let (already_slashed, punish) =
     match mistake with
-    | `Double_baking ->
+    | Double_baking ->
         ( Delegate.already_slashed_for_double_baking,
           Delegate.punish_double_baking )
-    | `Double_endorsing ->
+    | Double_endorsing ->
         ( Delegate.already_slashed_for_double_endorsing,
           Delegate.punish_double_endorsing )
   in
@@ -2731,13 +2733,15 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id
     Lwt.t =
   let mk_result (balance_updates : Receipt.balance_updates) :
       kind Kind.double_consensus_operation_evidence contents_result =
-    match op1.protocol_data.contents with
+    match[@coq_match_with_default] op1.protocol_data.contents with
     | Single (Preendorsement _) ->
         Double_preendorsement_evidence_result balance_updates
     | Single (Endorsement _) ->
         Double_endorsement_evidence_result balance_updates
   in
-  match (op1.protocol_data.contents, op2.protocol_data.contents) with
+  match[@coq_match_with_default]
+    (op1.protocol_data.contents, op2.protocol_data.contents)
+  with
   | (Single (Preendorsement e1), Single (Preendorsement e2))
   | (Single (Endorsement e1), Single (Endorsement e2)) ->
       let kind = if preendorsement then Preendorsement else Endorsement in
@@ -2773,7 +2777,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id
         ctxt
         delegate
         level
-        `Double_endorsing
+        Double_endorsing
         mk_result
         ~payload_producer
 
@@ -2816,7 +2820,7 @@ let punish_double_baking ctxt chain_id bh1 bh2 ~payload_producer =
     ctxt
     delegate
     level
-    `Double_baking
+    Double_baking
     ~payload_producer
     (fun balance_updates -> Double_baking_evidence_result balance_updates)
 
@@ -2837,7 +2841,7 @@ let is_parent_endorsement ctxt ~proposal_level ~grand_parent_round
 
 let validate_grand_parent_endorsement ctxt chain_id
     (op : Kind.endorsement operation) =
-  match op.protocol_data.contents with
+  match[@coq_match_with_default] op.protocol_data.contents with
   | Single (Endorsement e) ->
       let level = Level.from_raw ctxt e.level in
       Stake_distribution.slot_owner ctxt level e.slot
diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index d25a4ddb06d7..fe954ecd1300 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -581,7 +581,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Set_deposits_limit_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Set_deposits_limit_result {consumed_gas} ->
             (Gas.Arith.ceil consumed_gas, consumed_gas))
       ~inj:(fun (consumed_gas, consumed_milligas) ->
diff --git a/src/proto_alpha/lib_protocol/baking.ml b/src/proto_alpha/lib_protocol/baking.ml
index eb10613fe00d..b3fd2f26f4b8 100644
--- a/src/proto_alpha/lib_protocol/baking.ml
+++ b/src/proto_alpha/lib_protocol/baking.ml
@@ -70,7 +70,7 @@ let bonus_baking_reward ctxt ~endorsing_power =
   Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_endorsing_power)
 
 let baking_rights c level =
-  let rec f c round =
+  let[@coq_struct "round"] rec f c round =
     Stake_distribution.baking_rights_owner c level ~round
     >>=? fun (c, _slot, (delegate, _)) ->
     return (LCons (delegate, fun () -> f c (Round.succ round)))
-- 
GitLab


From 05f4b7d1958a182234ff88c53d64389d1f5dc65b Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Sat, 6 Nov 2021 01:07:55 +0100
Subject: [PATCH 16/69] Proto: add attributes to compile in Coq

---
 .../lib_protocol/ticket_scanner.ml            | 40 +++++++++----------
 1 file changed, 20 insertions(+), 20 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml
index 2956a01816d1..77096a85b495 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.ml
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml
@@ -143,7 +143,7 @@ module Ticket_inspection = struct
      The returned value matches the given shape of the [ty] value, except
      it collapses whole branches where no types embed tickets to [False_ht].
   *)
-  let rec has_tickets_of_ty :
+  let rec has_tickets_of_ty_aux :
       type a ac ret.
       (a, ac) Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult =
    fun ty k ->
@@ -180,11 +180,11 @@ module Ticket_inspection = struct
            a packable type and tickets are not packable. *)
         (k [@ocaml.tailcall]) False_ht
     | Option_t (ty, _, _) ->
-        (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht ->
+        (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht ->
             let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in
             (k [@ocaml.tailcall]) opt_hty)
     | List_t (ty, _) ->
-        (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht ->
+        (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht ->
             let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in
             (k [@ocaml.tailcall]) list_hty)
     | Set_t (key_ty, _) ->
@@ -219,7 +219,7 @@ module Ticket_inspection = struct
     | Chest_t -> (k [@ocaml.tailcall]) False_ht
     | Chest_key_t -> (k [@ocaml.tailcall]) False_ht
 
-  and has_tickets_of_pair :
+  and[@coq_mutual_as_notation] has_tickets_of_pair :
       type a ac b bc c ret.
       (a, ac) Script_typed_ir.ty ->
       (b, bc) Script_typed_ir.ty ->
@@ -227,11 +227,11 @@ module Ticket_inspection = struct
       (c, ret) continuation ->
       ret tzresult =
    fun ty1 ty2 ~pair k ->
-    (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 ->
-        (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 ->
+    (has_tickets_of_ty_aux [@ocaml.tailcall]) ty1 (fun ht1 ->
+        (has_tickets_of_ty_aux [@ocaml.tailcall]) ty2 (fun ht2 ->
             (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2)))
 
-  and has_tickets_of_key_and_value :
+  and[@coq_mutual_as_notation] has_tickets_of_key_and_value :
       type k v vc t ret.
       k Script_typed_ir.comparable_ty ->
       (v, vc) Script_typed_ir.ty ->
@@ -240,12 +240,12 @@ module Ticket_inspection = struct
       ret tzresult =
    fun key_ty val_ty ~pair k ->
     (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 ->
-        (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 ->
+        (has_tickets_of_ty_aux [@ocaml.tailcall]) val_ty (fun ht2 ->
             (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2)))
 
   let has_tickets_of_ty ctxt ty =
     Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt ->
-    has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt)
+    has_tickets_of_ty_aux ty ok >|? fun ht -> (ht, ctxt)
 end
 
 module Ticket_collection = struct
@@ -307,7 +307,7 @@ module Ticket_collection = struct
        comparable. *)
     (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k
 
-  let rec tickets_of_value :
+  let[@coq_axiom_with_reason "gadts"] rec tickets_of_value_aux :
       type a ac ret.
       include_lazy:bool ->
       Alpha_context.context ->
@@ -324,7 +324,7 @@ module Ticket_collection = struct
     | (False_ht, _) -> (k [@ocaml.tailcall]) ctxt acc
     | (Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _)) ->
         let (l, r) = x in
-        (tickets_of_value [@ocaml.tailcall])
+        (tickets_of_value_aux [@ocaml.tailcall])
           ~include_lazy
           ctxt
           hty1
@@ -332,7 +332,7 @@ module Ticket_collection = struct
           l
           acc
           (fun ctxt acc ->
-            (tickets_of_value [@ocaml.tailcall])
+            (tickets_of_value_aux [@ocaml.tailcall])
               ~include_lazy
               ctxt
               hty2
@@ -343,7 +343,7 @@ module Ticket_collection = struct
     | (Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _)) -> (
         match x with
         | L v ->
-            (tickets_of_value [@ocaml.tailcall])
+            (tickets_of_value_aux [@ocaml.tailcall])
               ~include_lazy
               ctxt
               htyl
@@ -352,7 +352,7 @@ module Ticket_collection = struct
               acc
               k
         | R v ->
-            (tickets_of_value [@ocaml.tailcall])
+            (tickets_of_value_aux [@ocaml.tailcall])
               ~include_lazy
               ctxt
               htyr
@@ -363,7 +363,7 @@ module Ticket_collection = struct
     | (Option_ht el_hty, Option_t (el_ty, _, _)) -> (
         match x with
         | Some x ->
-            (tickets_of_value [@ocaml.tailcall])
+            (tickets_of_value_aux [@ocaml.tailcall])
               ~include_lazy
               ctxt
               el_hty
@@ -405,7 +405,7 @@ module Ticket_collection = struct
     | (True_ht, Ticket_t (comp_ty, _)) ->
         (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc)
 
-  and tickets_of_list :
+  and[@coq_axiom_with_reason "gadts"] tickets_of_list :
       type a ac ret.
       Alpha_context.context ->
       include_lazy:bool ->
@@ -419,7 +419,7 @@ module Ticket_collection = struct
     consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt ->
     match elements with
     | elem :: elems ->
-        (tickets_of_value [@ocaml.tailcall])
+        (tickets_of_value_aux [@ocaml.tailcall])
           ~include_lazy
           ctxt
           el_hty
@@ -437,7 +437,7 @@ module Ticket_collection = struct
               k)
     | [] -> (k [@ocaml.tailcall]) ctxt acc
 
-  and tickets_of_map :
+  and[@coq_axiom_with_reason "gadts"] tickets_of_map :
       type k v vc ret.
       include_lazy:bool ->
       Alpha_context.context ->
@@ -462,7 +462,7 @@ module Ticket_collection = struct
       acc
       k
 
-  and tickets_of_big_map :
+  and[@coq_axiom_with_reason "gadts"] tickets_of_big_map :
       type k v ret.
       Alpha_context.context ->
       v Ticket_inspection.has_tickets ->
@@ -509,7 +509,7 @@ module Ticket_collection = struct
           | None -> (k [@ocaml.tailcall]) ctxt acc)
 
   let tickets_of_value ctxt ~include_lazy ht ty x =
-    tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets ->
+    tickets_of_value_aux ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets ->
         return (ex_tickets, ctxt))
 end
 
-- 
GitLab


From 626772e6e465939afd234c5977346af1bc6fc691 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 18 Nov 2021 18:10:12 +0100
Subject: [PATCH 17/69] Proto: do an explicit cast for Coq

---
 src/proto_alpha/lib_protocol/round_repr.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml
index fb355745b3a4..8a0f59d8ab96 100644
--- a/src/proto_alpha/lib_protocol/round_repr.ml
+++ b/src/proto_alpha/lib_protocol/round_repr.ml
@@ -107,7 +107,7 @@ let encoding =
     (fun i -> i)
     (fun i ->
       match of_int32 i with
-      | Ok _ as res -> res [@coq_cast]
+      | Ok round -> Ok round
       | Error _ -> Error "Round_repr.encoding: negative round")
     Data_encoding.int32
 
-- 
GitLab


From 2168f213c45bc47bef3564df23ba84be8d5bb557 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 26 Nov 2021 12:56:43 +0100
Subject: [PATCH 18/69] Proto: name the order type for coq-of-ocaml

---
 src/lib_context/sigs/context.ml                  | 4 ++++
 src/lib_protocol_environment/sigs/v4/context.mli | 6 +++++-
 2 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml
index 341c915a8e9d..0c53f4353558 100644
--- a/src/lib_context/sigs/context.ml
+++ b/src/lib_context/sigs/context.ml
@@ -26,6 +26,10 @@
 (** The tree depth of a fold. See the [fold] function for more information. *)
 type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int]
 
+(** The order in which we fold over elements. See the [View.fold] function for
+    more information. *)
+type order = [`Sorted | `Undefined]
+
 module type VIEW = sig
   (** The type for context views. *)
   type t
diff --git a/src/lib_protocol_environment/sigs/v4/context.mli b/src/lib_protocol_environment/sigs/v4/context.mli
index 6114a50ed394..6447c03f7e1b 100644
--- a/src/lib_protocol_environment/sigs/v4/context.mli
+++ b/src/lib_protocol_environment/sigs/v4/context.mli
@@ -31,6 +31,10 @@
 (** The tree depth of a fold. See the [fold] function for more information. *)
 type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int]
 
+(** The order in which we fold over elements. See the [fold] function for more
+    information. *)
+type order = [`Sorted | `Undefined]
+
 module type VIEW = sig
   (** The type for context views. *)
   type t
@@ -113,7 +117,7 @@ module type VIEW = sig
     ?depth:depth ->
     t ->
     key ->
-    order:[`Sorted | `Undefined] ->
+    order:order ->
     init:'a ->
     f:(key -> tree -> 'a -> 'a Lwt.t) ->
     'a Lwt.t
-- 
GitLab


From c9e7261c00631de2ff789e369894d25964986c3a Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Mon, 29 Nov 2021 22:45:00 +0100
Subject: [PATCH 19/69] Proto: LARGE CHANGE: compile script_interpreter_defs to
 Coq

---
 src/proto_alpha/lib_protocol/sapling_repr.ml  |   2 +
 .../lib_protocol/script_interpreter_defs.ml   | 440 +++++++++---------
 2 files changed, 211 insertions(+), 231 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/sapling_repr.ml b/src/proto_alpha/lib_protocol/sapling_repr.ml
index 0b472fea5c28..414854256b37 100644
--- a/src/proto_alpha/lib_protocol/sapling_repr.ml
+++ b/src/proto_alpha/lib_protocol/sapling_repr.ml
@@ -25,6 +25,8 @@
 
 type transaction = Sapling.UTXO.transaction
 
+type legacy_transaction = Sapling.UTXO.Legacy.transaction
+
 let transaction_encoding = Sapling.UTXO.transaction_encoding
 
 (* The two data structures in the state are all ordered by position, a diff
diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
index d50a1b9e15ad..76ef53d97279 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
@@ -54,291 +54,269 @@ module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter
 
 let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost =
  fun i accu stack ->
-  match i with
-  | IList_map _ ->
-      let list = accu in
-      Interp_costs.list_map list
-  | IList_iter _ ->
-      let list = accu in
-      Interp_costs.list_iter list
-  | ISet_iter _ ->
-      let set = accu in
-      Interp_costs.set_iter set
-  | ISet_mem _ ->
-      let v = accu and (set, _) = stack in
+  match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with
+  | (IList_map _, (list : _ boxed_list), _) -> Interp_costs.list_map list
+  | (IList_iter _, (list : _ boxed_list), _) -> Interp_costs.list_iter list
+  | (ISet_iter _, (set : _ set), _) -> Interp_costs.set_iter set
+  | (ISet_mem _, v, (stack : _ * _)) ->
+      let (set, _) = stack in
       Interp_costs.set_mem v set
-  | ISet_update _ ->
-      let v = accu and (_, (set, _)) = stack in
+  | (ISet_update _, v, (stack : _ * (_ * _))) ->
+      let (_, (set, _)) = stack in
       Interp_costs.set_update v set
-  | IMap_map _ ->
-      let map = accu in
-      Interp_costs.map_map map
-  | IMap_iter _ ->
-      let map = accu in
-      Interp_costs.map_iter map
-  | IMap_mem _ ->
-      let v = accu and (map, _) = stack in
+  | (IMap_map _, (map : (_, _) map), _) -> Interp_costs.map_map map
+  | (IMap_iter _, (map : (_, _) map), _) -> Interp_costs.map_iter map
+  | (IMap_mem _, v, (stack : (a, _) map * _)) ->
+      let (map, _) = stack in
       Interp_costs.map_mem v map
-  | IMap_get _ ->
-      let v = accu and (map, _) = stack in
+  | (IMap_get _, v, (stack : (a, _) map * _)) ->
+      let (map, _) = stack in
       Interp_costs.map_get v map
-  | IMap_update _ ->
-      let k = accu and (_, (map, _)) = stack in
+  | (IMap_update _, k, (stack : _ * ((a, _) map * _))) ->
+      let (_, (map, _)) = stack in
       Interp_costs.map_update k map
-  | IMap_get_and_update _ ->
-      let k = accu and (_, (map, _)) = stack in
+  | (IMap_get_and_update _, k, (stack : _ * ((a, _) map * _))) ->
+      let (_, (map, _)) = stack in
       Interp_costs.map_get_and_update k map
-  | IBig_map_mem _ ->
+  | (IBig_map_mem _, _, (stack : (a, _) big_map * _)) ->
       let (Big_map map, _) = stack in
       Interp_costs.big_map_mem map.diff
-  | IBig_map_get _ ->
+  | (IBig_map_get _, _, (stack : (a, _) big_map * _)) ->
       let (Big_map map, _) = stack in
       Interp_costs.big_map_get map.diff
-  | IBig_map_update _ ->
+  | (IBig_map_update _, _, (stack : _ * ((a, _) big_map * _))) ->
       let (_, (Big_map map, _)) = stack in
       Interp_costs.big_map_update map.diff
-  | IBig_map_get_and_update _ ->
+  | (IBig_map_get_and_update _, _, (stack : _ * ((a, _) big_map * _))) ->
       let (_, (Big_map map, _)) = stack in
       Interp_costs.big_map_get_and_update map.diff
-  | IAdd_seconds_to_timestamp _ ->
-      let n = accu and (t, _) = stack in
+  | ( IAdd_seconds_to_timestamp _,
+      (n : _ Script_int.num),
+      (stack : Script_timestamp.t * _) ) ->
+      let (t, _) = stack in
       Interp_costs.add_seconds_timestamp n t
-  | IAdd_timestamp_to_seconds _ ->
-      let t = accu and (n, _) = stack in
+  | ( IAdd_timestamp_to_seconds _,
+      (t : Script_timestamp.t),
+      (stack : _ Script_int.num * _) ) ->
+      let (n, _) = stack in
       Interp_costs.add_timestamp_seconds t n
-  | ISub_timestamp_seconds _ ->
-      let t = accu and (n, _) = stack in
+  | ( ISub_timestamp_seconds _,
+      (t : Script_timestamp.t),
+      (stack : _ Script_int.num * _) ) ->
+      let (n, _) = stack in
       Interp_costs.sub_timestamp_seconds t n
-  | IDiff_timestamps _ ->
-      let t1 = accu and (t2, _) = stack in
+  | ( IDiff_timestamps _,
+      (t1 : Script_timestamp.t),
+      (stack : Script_timestamp.t * _) ) ->
+      let (t2, _) = stack in
       Interp_costs.diff_timestamps t1 t2
-  | IConcat_string_pair _ ->
-      let x = accu and (y, _) = stack in
+  | (IConcat_string_pair _, (x : Script_string.t), (stack : Script_string.t * _))
+    ->
+      let (y, _) = stack in
       Interp_costs.concat_string_pair x y
-  | IConcat_string _ ->
-      let ss = accu in
+  | (IConcat_string _, (ss : _ boxed_list), _) ->
       Interp_costs.concat_string_precheck ss
-  | ISlice_string _ ->
-      let _offset = accu in
+  | ( ISlice_string _,
+      _offset,
+      (stack : _ Script_int.num * (Script_string.t * _)) ) ->
       let (_length, (s, _)) = stack in
       Interp_costs.slice_string s
-  | IConcat_bytes_pair _ ->
-      let x = accu and (y, _) = stack in
+  | (IConcat_bytes_pair _, (x : bytes), (stack : bytes * _)) ->
+      let (y, _) = stack in
       Interp_costs.concat_bytes_pair x y
-  | IConcat_bytes _ ->
-      let ss = accu in
+  | (IConcat_bytes _, (ss : _ boxed_list), _) ->
       Interp_costs.concat_string_precheck ss
-  | ISlice_bytes _ ->
+  | (ISlice_bytes _, _, (stack : _ * (bytes * _))) ->
       let (_, (s, _)) = stack in
       Interp_costs.slice_bytes s
-  | IMul_teznat _ -> Interp_costs.mul_teznat
-  | IMul_nattez _ -> Interp_costs.mul_nattez
-  | IAbs_int _ ->
-      let x = accu in
-      Interp_costs.abs_int x
-  | INeg _ ->
-      let x = accu in
-      Interp_costs.neg x
-  | IAdd_int _ ->
-      let x = accu and (y, _) = stack in
+  | (IMul_teznat _, _, _) -> Interp_costs.mul_teznat
+  | (IMul_nattez _, _, _) -> Interp_costs.mul_nattez
+  | (IAbs_int _, (x : _ Script_int.num), _) -> Interp_costs.abs_int x
+  | (INeg _, (x : _ Script_int.num), _) -> Interp_costs.neg x
+  | (IAdd_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.add_int x y
-  | IAdd_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (IAdd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.add_nat x y
-  | ISub_int _ ->
-      let x = accu and (y, _) = stack in
+  | (ISub_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.sub_int x y
-  | IMul_int _ ->
-      let x = accu and (y, _) = stack in
+  | (IMul_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.mul_int x y
-  | IMul_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (IMul_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.mul_nat x y
-  | IEdiv_teznat _ ->
-      let x = accu and (y, _) = stack in
+  | (IEdiv_teznat _, x, (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.ediv_teznat x y
-  | IEdiv_int _ ->
-      let x = accu and (y, _) = stack in
+  | (IEdiv_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.ediv_int x y
-  | IEdiv_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (IEdiv_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.ediv_nat x y
-  | ILsl_nat _ ->
-      let x = accu in
-      Interp_costs.lsl_nat x
-  | ILsr_nat _ ->
-      let x = accu in
-      Interp_costs.lsr_nat x
-  | IOr_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (ILsl_nat _, (x : _ Script_int.num), _) -> Interp_costs.lsl_nat x
+  | (ILsr_nat _, (x : _ Script_int.num), _) -> Interp_costs.lsr_nat x
+  | (IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.or_nat x y
-  | IAnd_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.and_nat x y
-  | IAnd_int_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.and_int_nat x y
-  | IXor_nat _ ->
-      let x = accu and (y, _) = stack in
+  | (IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) ->
+      let (y, _) = stack in
       Interp_costs.xor_nat x y
-  | INot_int _ ->
-      let x = accu in
-      Interp_costs.not_int x
-  | ICompare (_, ty, _) ->
-      let a = accu and (b, _) = stack in
+  | (INot_int _, (x : _ Script_int.num), _) -> Interp_costs.not_int x
+  | (ICompare (_, ty, _), a, (stack : a * _)) ->
+      let (b, _) = stack in
       Interp_costs.compare ty a b
-  | ICheck_signature _ ->
-      let key = accu and (_, (message, _)) = stack in
+  | (ICheck_signature _, (key : public_key), (stack : _ * (bytes * _))) ->
+      let (_, (message, _)) = stack in
       Interp_costs.check_signature key message
-  | IHash_key _ ->
-      let pk = accu in
-      Interp_costs.hash_key pk
-  | IBlake2b _ ->
-      let bytes = accu in
-      Interp_costs.blake2b bytes
-  | ISha256 _ ->
-      let bytes = accu in
-      Interp_costs.sha256 bytes
-  | ISha512 _ ->
-      let bytes = accu in
-      Interp_costs.sha512 bytes
-  | IKeccak _ ->
-      let bytes = accu in
-      Interp_costs.keccak bytes
-  | ISha3 _ ->
-      let bytes = accu in
-      Interp_costs.sha3 bytes
-  | IPairing_check_bls12_381 _ ->
-      let pairs = accu in
+  | (IHash_key _, (pk : public_key), _) -> Interp_costs.hash_key pk
+  | (IBlake2b _, (bytes : bytes), _) -> Interp_costs.blake2b bytes
+  | (ISha256 _, (bytes : bytes), _) -> Interp_costs.sha256 bytes
+  | (ISha512 _, (bytes : bytes), _) -> Interp_costs.sha512 bytes
+  | (IKeccak _, (bytes : bytes), _) -> Interp_costs.keccak bytes
+  | (ISha3 _, (bytes : bytes), _) -> Interp_costs.sha3 bytes
+  | (IPairing_check_bls12_381 _, (pairs : _ boxed_list), _) ->
       Interp_costs.pairing_check_bls12_381 pairs
-  | ISapling_verify_update _ ->
+  | (ISapling_verify_update _, (accu : Sapling_repr.transaction), _) ->
       let tx = accu in
       let inputs = Gas_input_size.sapling_transaction_inputs tx in
       let outputs = Gas_input_size.sapling_transaction_outputs tx in
       let bound_data = Gas_input_size.sapling_transaction_bound_data tx in
       Interp_costs.sapling_verify_update ~inputs ~outputs ~bound_data
-  | ISapling_verify_update_deprecated _ ->
+  | ( ISapling_verify_update_deprecated _,
+      (accu : Sapling_repr.legacy_transaction),
+      _ ) ->
       let tx = accu in
       let inputs = List.length tx.inputs in
       let outputs = List.length tx.outputs in
       Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs
-  | ISplit_ticket _ ->
+  | (ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _)) ->
       let ticket = accu and ((amount_a, amount_b), _) = stack in
       Interp_costs.split_ticket ticket.amount amount_a amount_b
-  | IJoin_tickets (_, ty, _) ->
-      let (ticket_a, ticket_b) = accu in
+  | (IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _) ->
+      let (ticket_a, ticket_b) = ticket_a_b in
       Interp_costs.join_tickets ty ticket_a ticket_b
-  | IHalt _ -> Interp_costs.halt
-  | IDrop _ -> Interp_costs.drop
-  | IDup _ -> Interp_costs.dup
-  | ISwap _ -> Interp_costs.swap
-  | IConst _ -> Interp_costs.const
-  | ICons_some _ -> Interp_costs.cons_some
-  | ICons_none _ -> Interp_costs.cons_none
-  | IIf_none _ -> Interp_costs.if_none
-  | IOpt_map _ -> Interp_costs.opt_map
-  | ICons_pair _ -> Interp_costs.cons_pair
-  | IUnpair _ -> Interp_costs.unpair
-  | ICar _ -> Interp_costs.car
-  | ICdr _ -> Interp_costs.cdr
-  | ICons_left _ -> Interp_costs.cons_left
-  | ICons_right _ -> Interp_costs.cons_right
-  | IIf_left _ -> Interp_costs.if_left
-  | ICons_list _ -> Interp_costs.cons_list
-  | INil _ -> Interp_costs.nil
-  | IIf_cons _ -> Interp_costs.if_cons
-  | IList_size _ -> Interp_costs.list_size
-  | IEmpty_set _ -> Interp_costs.empty_set
-  | ISet_size _ -> Interp_costs.set_size
-  | IEmpty_map _ -> Interp_costs.empty_map
-  | IMap_size _ -> Interp_costs.map_size
-  | IEmpty_big_map _ -> Interp_costs.empty_big_map
-  | IString_size _ -> Interp_costs.string_size
-  | IBytes_size _ -> Interp_costs.bytes_size
-  | IAdd_tez _ -> Interp_costs.add_tez
-  | ISub_tez _ -> Interp_costs.sub_tez
-  | ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy
-  | IOr _ -> Interp_costs.bool_or
-  | IAnd _ -> Interp_costs.bool_and
-  | IXor _ -> Interp_costs.bool_xor
-  | INot _ -> Interp_costs.bool_not
-  | IIs_nat _ -> Interp_costs.is_nat
-  | IInt_nat _ -> Interp_costs.int_nat
-  | IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr
-  | IEdiv_tez _ -> Interp_costs.ediv_tez
-  | IIf _ -> Interp_costs.if_
-  | ILoop _ -> Interp_costs.loop
-  | ILoop_left _ -> Interp_costs.loop_left
-  | IDip _ -> Interp_costs.dip
-  | IExec _ -> Interp_costs.exec
-  | IApply _ -> Interp_costs.apply
-  | ILambda _ -> Interp_costs.lambda
-  | IFailwith _ -> Gas.free
-  | IEq _ -> Interp_costs.eq
-  | INeq _ -> Interp_costs.neq
-  | ILt _ -> Interp_costs.lt
-  | ILe _ -> Interp_costs.le
-  | IGt _ -> Interp_costs.gt
-  | IGe _ -> Interp_costs.ge
-  | IPack _ -> Gas.free
-  | IUnpack _ ->
+  | (IHalt _, _, _) -> Interp_costs.halt
+  | (IDrop _, _, _) -> Interp_costs.drop
+  | (IDup _, _, _) -> Interp_costs.dup
+  | (ISwap _, _, _) -> Interp_costs.swap
+  | (IConst _, _, _) -> Interp_costs.const
+  | (ICons_some _, _, _) -> Interp_costs.cons_some
+  | (ICons_none _, _, _) -> Interp_costs.cons_none
+  | (IIf_none _, _, _) -> Interp_costs.if_none
+  | (IOpt_map _, _, _) -> Interp_costs.opt_map
+  | (ICons_pair _, _, _) -> Interp_costs.cons_pair
+  | (IUnpair _, _, _) -> Interp_costs.unpair
+  | (ICar _, _, _) -> Interp_costs.car
+  | (ICdr _, _, _) -> Interp_costs.cdr
+  | (ICons_left _, _, _) -> Interp_costs.cons_left
+  | (ICons_right _, _, _) -> Interp_costs.cons_right
+  | (IIf_left _, _, _) -> Interp_costs.if_left
+  | (ICons_list _, _, _) -> Interp_costs.cons_list
+  | (INil _, _, _) -> Interp_costs.nil
+  | (IIf_cons _, _, _) -> Interp_costs.if_cons
+  | (IList_size _, _, _) -> Interp_costs.list_size
+  | (IEmpty_set _, _, _) -> Interp_costs.empty_set
+  | (ISet_size _, _, _) -> Interp_costs.set_size
+  | (IEmpty_map _, _, _) -> Interp_costs.empty_map
+  | (IMap_size _, _, _) -> Interp_costs.map_size
+  | (IEmpty_big_map _, _, _) -> Interp_costs.empty_big_map
+  | (IString_size _, _, _) -> Interp_costs.string_size
+  | (IBytes_size _, _, _) -> Interp_costs.bytes_size
+  | (IAdd_tez _, _, _) -> Interp_costs.add_tez
+  | (ISub_tez _, _, _) -> Interp_costs.sub_tez
+  | (ISub_tez_legacy _, _, _) -> Interp_costs.sub_tez_legacy
+  | (IOr _, _, _) -> Interp_costs.bool_or
+  | (IAnd _, _, _) -> Interp_costs.bool_and
+  | (IXor _, _, _) -> Interp_costs.bool_xor
+  | (INot _, _, _) -> Interp_costs.bool_not
+  | (IIs_nat _, _, _) -> Interp_costs.is_nat
+  | (IInt_nat _, _, _) -> Interp_costs.int_nat
+  | (IInt_bls12_381_fr _, _, _) -> Interp_costs.int_bls12_381_fr
+  | (IEdiv_tez _, _, _) -> Interp_costs.ediv_tez
+  | (IIf _, _, _) -> Interp_costs.if_
+  | (ILoop _, _, _) -> Interp_costs.loop
+  | (ILoop_left _, _, _) -> Interp_costs.loop_left
+  | (IDip _, _, _) -> Interp_costs.dip
+  | (IExec _, _, _) -> Interp_costs.exec
+  | (IApply _, _, _) -> Interp_costs.apply
+  | (ILambda _, _, _) -> Interp_costs.lambda
+  | (IFailwith _, _, _) -> Gas.free
+  | (IEq _, _, _) -> Interp_costs.eq
+  | (INeq _, _, _) -> Interp_costs.neq
+  | (ILt _, _, _) -> Interp_costs.lt
+  | (ILe _, _, _) -> Interp_costs.le
+  | (IGt _, _, _) -> Interp_costs.gt
+  | (IGe _, _, _) -> Interp_costs.ge
+  | (IPack _, _, _) -> Gas.free
+  | (IUnpack _, (accu : bytes), _) ->
       let b = accu in
       Interp_costs.unpack b
-  | IAddress _ -> Interp_costs.address
-  | IContract _ -> Interp_costs.contract
-  | ITransfer_tokens _ -> Interp_costs.transfer_tokens
-  | IView _ -> Interp_costs.view
-  | IImplicit_account _ -> Interp_costs.implicit_account
-  | ISet_delegate _ -> Interp_costs.set_delegate
-  | IBalance _ -> Interp_costs.balance
-  | ILevel _ -> Interp_costs.level
-  | INow _ -> Interp_costs.now
-  | IMin_block_time _ -> Interp_costs.min_block_time
-  | ISapling_empty_state _ -> Interp_costs.sapling_empty_state
-  | ISource _ -> Interp_costs.source
-  | ISender _ -> Interp_costs.sender
-  | ISelf _ -> Interp_costs.self
-  | ISelf_address _ -> Interp_costs.self_address
-  | IAmount _ -> Interp_costs.amount
-  | IDig (_, n, _, _) -> Interp_costs.dign n
-  | IDug (_, n, _, _) -> Interp_costs.dugn n
-  | IDipn (_, n, _, _, _) -> Interp_costs.dipn n
-  | IDropn (_, n, _, _) -> Interp_costs.dropn n
-  | IChainId _ -> Interp_costs.chain_id
-  | ICreate_contract _ -> Interp_costs.create_contract
-  | INever _ -> ( match accu with _ -> .)
-  | IVoting_power _ -> Interp_costs.voting_power
-  | ITotal_voting_power _ -> Interp_costs.total_voting_power
-  | IAdd_bls12_381_g1 _ -> Interp_costs.add_bls12_381_g1
-  | IAdd_bls12_381_g2 _ -> Interp_costs.add_bls12_381_g2
-  | IAdd_bls12_381_fr _ -> Interp_costs.add_bls12_381_fr
-  | IMul_bls12_381_g1 _ -> Interp_costs.mul_bls12_381_g1
-  | IMul_bls12_381_g2 _ -> Interp_costs.mul_bls12_381_g2
-  | IMul_bls12_381_fr _ -> Interp_costs.mul_bls12_381_fr
-  | INeg_bls12_381_g1 _ -> Interp_costs.neg_bls12_381_g1
-  | INeg_bls12_381_g2 _ -> Interp_costs.neg_bls12_381_g2
-  | INeg_bls12_381_fr _ -> Interp_costs.neg_bls12_381_fr
-  | IMul_bls12_381_fr_z _ ->
+  | (IAddress _, _, _) -> Interp_costs.address
+  | (IContract _, _, _) -> Interp_costs.contract
+  | (ITransfer_tokens _, _, _) -> Interp_costs.transfer_tokens
+  | (IView _, _, _) -> Interp_costs.view
+  | (IImplicit_account _, _, _) -> Interp_costs.implicit_account
+  | (ISet_delegate _, _, _) -> Interp_costs.set_delegate
+  | (IBalance _, _, _) -> Interp_costs.balance
+  | (ILevel _, _, _) -> Interp_costs.level
+  | (INow _, _, _) -> Interp_costs.now
+  | (IMin_block_time _, _, _) -> Interp_costs.min_block_time
+  | (ISapling_empty_state _, _, _) -> Interp_costs.sapling_empty_state
+  | (ISource _, _, _) -> Interp_costs.source
+  | (ISender _, _, _) -> Interp_costs.sender
+  | (ISelf _, _, _) -> Interp_costs.self
+  | (ISelf_address _, _, _) -> Interp_costs.self_address
+  | (IAmount _, _, _) -> Interp_costs.amount
+  | (IDig (_, n, _, _), _, _) -> Interp_costs.dign n
+  | (IDug (_, n, _, _), _, _) -> Interp_costs.dugn n
+  | (IDipn (_, n, _, _, _), _, _) -> Interp_costs.dipn n
+  | (IDropn (_, n, _, _), _, _) -> Interp_costs.dropn n
+  | (IChainId _, _, _) -> Interp_costs.chain_id
+  | (ICreate_contract _, _, _) -> Interp_costs.create_contract
+  | (INever _, _, _) -> .
+  | (IVoting_power _, _, _) -> Interp_costs.voting_power
+  | (ITotal_voting_power _, _, _) -> Interp_costs.total_voting_power
+  | (IAdd_bls12_381_g1 _, _, _) -> Interp_costs.add_bls12_381_g1
+  | (IAdd_bls12_381_g2 _, _, _) -> Interp_costs.add_bls12_381_g2
+  | (IAdd_bls12_381_fr _, _, _) -> Interp_costs.add_bls12_381_fr
+  | (IMul_bls12_381_g1 _, _, _) -> Interp_costs.mul_bls12_381_g1
+  | (IMul_bls12_381_g2 _, _, _) -> Interp_costs.mul_bls12_381_g2
+  | (IMul_bls12_381_fr _, _, _) -> Interp_costs.mul_bls12_381_fr
+  | (INeg_bls12_381_g1 _, _, _) -> Interp_costs.neg_bls12_381_g1
+  | (INeg_bls12_381_g2 _, _, _) -> Interp_costs.neg_bls12_381_g2
+  | (INeg_bls12_381_fr _, _, _) -> Interp_costs.neg_bls12_381_fr
+  | (IMul_bls12_381_fr_z _, _, _) ->
       let z = accu in
       Interp_costs.mul_bls12_381_fr_z z
-  | IMul_bls12_381_z_fr _ ->
+  | (IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _)) ->
       let (z, _) = stack in
       Interp_costs.mul_bls12_381_z_fr z
-  | IDup_n (_, n, _, _) -> Interp_costs.dupn n
-  | IComb (_, n, _, _) -> Interp_costs.comb n
-  | IUncomb (_, n, _, _) -> Interp_costs.uncomb n
-  | IComb_get (_, n, _, _) -> Interp_costs.comb_get n
-  | IComb_set (_, n, _, _) -> Interp_costs.comb_set n
-  | ITicket _ -> Interp_costs.ticket
-  | IRead_ticket _ -> Interp_costs.read_ticket
-  | IOpen_chest _ ->
-      let _chest_key = accu and (chest, (time, _)) = stack in
+  | (IDup_n (_, n, _, _), _, _) -> Interp_costs.dupn n
+  | (IComb (_, n, _, _), _, _) -> Interp_costs.comb n
+  | (IUncomb (_, n, _, _), _, _) -> Interp_costs.uncomb n
+  | (IComb_get (_, n, _, _), _, _) -> Interp_costs.comb_get n
+  | (IComb_set (_, n, _, _), _, _) -> Interp_costs.comb_set n
+  | (ITicket _, _, _) -> Interp_costs.ticket
+  | (IRead_ticket _, _, _) -> Interp_costs.read_ticket
+  | ( IOpen_chest _,
+      _chest_key,
+      (stack : Script_timelock.chest * (_ Script_int.num * _)) ) ->
+      let (chest, (time, _)) = stack in
       Interp_costs.open_chest
         ~chest
         ~time:(Alpha_context.Script_int.to_zint time)
-  | ILog _ -> Gas.free
+  | (ILog _, _, _) -> Gas.free
  [@@ocaml.inline always]
- [@@coq_axiom_with_reason "unreachable expression `.` not handled"]
 
 let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost =
  fun ks ->
@@ -444,7 +422,7 @@ let id x = x [@@inline]
 
 (* The following function pops n elements from the stack
    and push their reintroduction in the continuations stack. *)
-let rec kundip :
+let[@coq_struct "w"] rec kundip :
     type a s e z c u d w b t.
     (a, s, e, z, c, u, d, w) stack_prefix_preservation_witness ->
     c ->
@@ -452,18 +430,18 @@ let rec kundip :
     (d, w, b, t) kinstr ->
     a * s * (e, z, b, t) kinstr =
  fun w accu stack k ->
-  match w with
-  | KPrefix (kinfo, w) ->
+  match[@coq_match_gadt] (w, accu, stack) with
+  | (KPrefix (kinfo, w), _, (stack : _ * _)) ->
       let k = IConst (kinfo, accu, k) in
       let (accu, stack) = stack in
       kundip w accu stack k
-  | KRest -> (accu, stack, k)
+  | (KRest, (accu : a), (stack : s)) -> (accu, stack, k)
 
 (* [apply ctxt gas ty v lam] specializes [lam] by fixing its first
    formal argument to [v]. The type of [v] is represented by [ty]. *)
 let apply ctxt gas capture_ty capture lam =
   let (Lam (descr, expr)) = lam in
-  let (Item_t (full_arg_ty, _)) = descr.kbef in
+  let[@coq_match_with_default] (Item_t (full_arg_ty, _)) = descr.kbef in
   let ctxt = update_context gas ctxt in
   unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) ->
   let loc = Micheline.dummy_location in
@@ -660,7 +638,7 @@ let unpack ctxt ~ty ~bytes =
    a well-typed operation [f] under some prefix of the A-stack
    exploiting [w] to justify that the shape of the stack is
    preserved. *)
-let rec interp_stack_prefix_preserving_operation :
+let[@coq_struct "n"] rec interp_stack_prefix_preserving_operation :
     type a s b t c u d w result.
     (a -> s -> (b * t) * result) ->
     (a, s, b, t, c, u, d, w) stack_prefix_preservation_witness ->
@@ -668,11 +646,11 @@ let rec interp_stack_prefix_preserving_operation :
     u ->
     (d * w) * result =
  fun f n accu stk ->
-  match (n, stk) with
-  | (KPrefix (_, n), rest) ->
+  match[@coq_match_gadt_with_result] (n, accu, stk) with
+  | (KPrefix (_, n), _, (rest : _ * _)) ->
       interp_stack_prefix_preserving_operation f n (fst rest) (snd rest)
       |> fun ((v, rest'), result) -> ((accu, (v, rest')), result)
-  | (KRest, v) -> f accu v
+  | (KRest, (accu : a), (v : s)) -> f accu v
 
 (*
 
-- 
GitLab


From 4029246a5132ffe56763f09b5987657953c13c59 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 2 Dec 2021 19:46:19 +0100
Subject: [PATCH 20/69] Protocol: name a polymorphic variant for Coq

---
 src/proto_alpha/lib_protocol/script_repr.ml | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml
index aed2abd3de13..139f9cc215b0 100644
--- a/src/proto_alpha/lib_protocol/script_repr.ml
+++ b/src/proto_alpha/lib_protocol/script_repr.ml
@@ -254,11 +254,13 @@ let force_decode_cost lexpr =
     ~fun_combine:(fun _ _ -> Gas_limit_repr.free)
     lexpr
 
+type 'a bytes_or_value = Only_value of 'a | Has_bytes of bytes
+
 let stable_force_decode_cost lexpr =
   let has_bytes =
     Data_encoding.apply_lazy
-      ~fun_value:(fun v -> `Only_value v)
-      ~fun_bytes:(fun b -> `Has_bytes b)
+      ~fun_value:(fun v -> Only_value v)
+      ~fun_bytes:(fun b -> Has_bytes b)
       ~fun_combine:(fun _v b ->
         (* When the lazy_expr contains both a deserialized version
            and a serialized one, we compute the cost from the
@@ -267,8 +269,8 @@ let stable_force_decode_cost lexpr =
       lexpr
   in
   match has_bytes with
-  | `Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b)
-  | `Only_value v ->
+  | Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b)
+  | Only_value v ->
       (* This code path should not be reached in theory because values that are
          decoded should have been encoded before.
          Here we use Data_encoding.Binary.length, which yields the same results
-- 
GitLab


From e3dd0a6d4ad8d3b23ff4e72d9d866c7f9e013895 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 2 Dec 2021 22:46:54 +0100
Subject: [PATCH 21/69] Proto: LARGE CHANGE: replace 'let and' by 'let in' in
 the interpreter

---
 .../lib_protocol/script_interpreter.ml        | 90 ++++++++++++-------
 1 file changed, 60 insertions(+), 30 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index a47fa7de1b54..a60ccc289428 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -435,14 +435,16 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type =
 
 and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type =
  fun logger g gas (kinfo, k) ks accu stack ->
-  let x = accu and (y, stack) = stack in
+  let x = accu in
+  let (y, stack) = stack in
   match Script_int.shift_left_n x y with
   | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log))
   | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack
 
 and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type =
  fun logger g gas (kinfo, k) ks accu stack ->
-  let x = accu and (y, stack) = stack in
+  let x = accu in
+  let (y, stack) = stack in
   match Script_int.shift_right_n x y with
   | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log))
   | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack
@@ -461,7 +463,8 @@ and ifailwith : ifailwith_type =
 
 and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type =
  fun logger g gas k ks accu stack ->
-  let arg = accu and (code, stack) = stack in
+  let arg = accu in
+  let (code, stack) = stack in
   let (Lam (code, _)) = code in
   let code =
     match logger with
@@ -710,7 +713,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let s = Script_string.concat ss.elements in
           (step [@ocaml.tailcall]) g gas k ks s stack
       | ISlice_string (_, k) ->
-          let offset = accu and (length, (s, stack)) = stack in
+          let offset = accu in
+          let (length, (s, stack)) = stack in
           let s_length = Z.of_int (Script_string.length s) in
           let offset = Script_int.to_zint offset in
           let length = Script_int.to_zint length in
@@ -742,7 +746,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let s = Bytes.concat Bytes.empty ss.elements in
           (step [@ocaml.tailcall]) g gas k ks s stack
       | ISlice_bytes (_, k) ->
-          let offset = accu and (length, (s, stack)) = stack in
+          let offset = accu in
+          let (length, (s, stack)) = stack in
           let s_length = Z.of_int (Bytes.length s) in
           let offset = Script_int.to_zint offset in
           let length = Script_int.to_zint length in
@@ -810,27 +815,33 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let res = Script_int.neg x in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IAdd_int (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.add x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IAdd_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.add_n x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | ISub_int (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.sub x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IMul_int (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.mul x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IMul_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.mul_n x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IEdiv_teznat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let x = Script_int.of_int64 (Tez.to_mutez x) in
           let result =
             match Script_int.ediv x y with
@@ -847,7 +858,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           in
           (step [@ocaml.tailcall]) g gas k ks result stack
       | IEdiv_tez (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
           let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
           let result =
@@ -863,29 +875,35 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           in
           (step [@ocaml.tailcall]) g gas k ks result stack
       | IEdiv_int (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.ediv x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IEdiv_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.ediv_n x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack
       | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack
       | IOr_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.logor x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IAnd_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.logand x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IAnd_int_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.logand x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IXor_nat (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let res = Script_int.logxor x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | INot_int (_, k) ->
@@ -1176,7 +1194,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let new_stack = (accu, stack) in
           (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack
       | ICheck_signature (_, k) ->
-          let key = accu and (signature, (message, stack)) = stack in
+          let key = accu in
+          let (signature, (message, stack)) = stack in
           let res = Script_signature.check key signature message in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IHash_key (_, k) ->
@@ -1326,36 +1345,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let hash = Raw_hashes.sha3_256 bytes in
           (step [@ocaml.tailcall]) g gas k ks hash stack
       | IAdd_bls12_381_g1 (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let accu = Script_bls.G1.add x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IAdd_bls12_381_g2 (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let accu = Script_bls.G2.add x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IAdd_bls12_381_fr (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let accu = Script_bls.Fr.add x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IMul_bls12_381_g1 (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let accu = Script_bls.G1.mul x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IMul_bls12_381_g2 (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let accu = Script_bls.G2.mul x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IMul_bls12_381_fr (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let accu = Script_bls.Fr.mul x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IMul_bls12_381_fr_z (_, k) ->
-          let x = accu and (y, stack) = stack in
+          let x = accu in
+          let (y, stack) = stack in
           let x = Script_bls.Fr.of_z (Script_int.to_zint x) in
           let res = Script_bls.Fr.mul x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | IMul_bls12_381_z_fr (_, k) ->
-          let y = accu and (x, stack) = stack in
+          let y = accu in
+          let (x, stack) = stack in
           let x = Script_bls.Fr.of_z (Script_int.to_zint x) in
           let res = Script_bls.Fr.mul x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
@@ -1419,7 +1446,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let accu = aux witness comb in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | IComb_set (_, _, witness, k) ->
-          let value = accu and (comb, stack) = stack in
+          let value = accu in
+          let (comb, stack) = stack in
           let rec aux :
               type value before after.
               (value, before, after) comb_set_gadt_witness ->
@@ -1449,7 +1477,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           (step [@ocaml.tailcall]) g gas k ks accu stack
       (* Tickets *)
       | ITicket (_, k) ->
-          let contents = accu and (amount, stack) = stack in
+          let contents = accu in
+          let (amount, stack) = stack in
           let ticketer = sc.self in
           let accu = {ticketer; contents; amount} in
           (step [@ocaml.tailcall]) g gas k ks accu stack
@@ -1461,7 +1490,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           let accu = (addr, (contents, amount)) in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       | ISplit_ticket (_, k) ->
-          let ticket = accu and ((amount_a, amount_b), stack) = stack in
+          let ticket = accu in
+          let ((amount_a, amount_b), stack) = stack in
           let result =
             if
               Compare.Int.(
-- 
GitLab


From 58396564d70b516980375ae357911e7609c84746 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 3 Dec 2021 15:50:04 +0100
Subject: [PATCH 22/69] Proto: update single letter names for coq-of-ocaml

---
 src/proto_alpha/lib_protocol/level_storage.ml           | 4 ++--
 src/proto_alpha/lib_protocol/misc.ml                    | 6 +++---
 src/proto_alpha/lib_protocol/script_interpreter_defs.ml | 4 ++--
 src/proto_alpha/lib_protocol/seed_repr.ml               | 2 +-
 4 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/level_storage.ml b/src/proto_alpha/lib_protocol/level_storage.ml
index 526e64e96388..53f5a4640255 100644
--- a/src/proto_alpha/lib_protocol/level_storage.ml
+++ b/src/proto_alpha/lib_protocol/level_storage.ml
@@ -73,7 +73,7 @@ let last_level_in_cycle ctxt c =
 
 let levels_in_cycle ctxt cycle =
   let first = first_level_in_cycle ctxt cycle in
-  let[@coq_struct "n"] rec loop (n : Level_repr.t) acc =
+  let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc =
     if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)
     else acc
   in
@@ -89,7 +89,7 @@ let levels_in_current_cycle ctxt ?(offset = 0l) () =
 
 let levels_with_commitments_in_cycle ctxt c =
   let first = first_level_in_cycle ctxt c in
-  let[@coq_struct "n"] rec loop (n : Level_repr.t) acc =
+  let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc =
     if Cycle_repr.(n.cycle = first.cycle) then
       if n.expected_commitment then loop (succ ctxt n) (n :: acc)
       else loop (succ ctxt n) acc
diff --git a/src/proto_alpha/lib_protocol/misc.ml b/src/proto_alpha/lib_protocol/misc.ml
index bd350a5ef85b..2fe3e7075f44 100644
--- a/src/proto_alpha/lib_protocol/misc.ml
+++ b/src/proto_alpha/lib_protocol/misc.ml
@@ -31,15 +31,15 @@ type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt
 
 type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t
 
-let[@coq_struct "i"] rec ( --> ) i j =
+let[@coq_struct "i_value"] rec ( --> ) i j =
   (* [i; i+1; ...; j] *)
   if Compare.Int.(i > j) then [] else i :: (succ i --> j)
 
-let[@coq_struct "j"] rec ( <-- ) i j =
+let[@coq_struct "j_value"] rec ( <-- ) i j =
   (* [j; j-1; ...; i] *)
   if Compare.Int.(i > j) then [] else j :: (i <-- pred j)
 
-let[@coq_struct "i"] rec ( ---> ) i j =
+let[@coq_struct "i_value"] rec ( ---> ) i j =
   (* [i; i+1; ...; j] *)
   if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)
 
diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
index 76ef53d97279..f6a23e91f5f6 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
@@ -422,7 +422,7 @@ let id x = x [@@inline]
 
 (* The following function pops n elements from the stack
    and push their reintroduction in the continuations stack. *)
-let[@coq_struct "w"] rec kundip :
+let[@coq_struct "w_value"] rec kundip :
     type a s e z c u d w b t.
     (a, s, e, z, c, u, d, w) stack_prefix_preservation_witness ->
     c ->
@@ -638,7 +638,7 @@ let unpack ctxt ~ty ~bytes =
    a well-typed operation [f] under some prefix of the A-stack
    exploiting [w] to justify that the shape of the stack is
    preserved. *)
-let[@coq_struct "n"] rec interp_stack_prefix_preserving_operation :
+let[@coq_struct "n_value"] rec interp_stack_prefix_preserving_operation :
     type a s b t c u d w result.
     (a -> s -> (b * t) * result) ->
     (a, s, b, t, c, u, d, w) stack_prefix_preservation_witness ->
diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml
index b9f6d85160c8..68e4e4452f0d 100644
--- a/src/proto_alpha/lib_protocol/seed_repr.ml
+++ b/src/proto_alpha/lib_protocol/seed_repr.ml
@@ -153,7 +153,7 @@ let initial_nonce_hash_0 = hash initial_nonce_0
 let deterministic_seed seed = nonce seed zero_bytes
 
 let initial_seeds ?initial_seed n =
-  let[@coq_struct "i"] rec loop acc elt i =
+  let[@coq_struct "i_value"] rec loop acc elt i =
     if Compare.Int.(i = 1) then List.rev (elt :: acc)
     else loop (elt :: acc) (deterministic_seed elt) (i - 1)
   in
-- 
GitLab


From a0bf33e93c2bcd59fe3004fdd4553d15001c3bac Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 3 Dec 2021 22:09:44 +0100
Subject: [PATCH 23/69] Proto: LARGE CHANGE: translate the interpreter

---
 .../lib_protocol/script_interpreter.ml        | 814 +++++++++++-------
 .../lib_protocol/script_interpreter.mli       |   2 +-
 .../lib_protocol/script_interpreter_defs.ml   |  77 +-
 .../michelson/test_interpretation.ml          |   4 +-
 4 files changed, 557 insertions(+), 340 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index a60ccc289428..1d78daf85fe7 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -247,7 +247,7 @@ let () =
     evaluation rules depending on the continuation at stake.
 
  *)
-let rec kmap_exit :
+let[@coq_struct "gas"] rec kmap_exit :
     type a b c d e f g h m n o. (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type
     =
  fun mk g gas (body, xs, ys, yk) ks accu stack ->
@@ -257,7 +257,8 @@ let rec kmap_exit :
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type =
+and[@coq_struct "gas"] kmap_enter :
+    type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type =
  fun mk g gas (body, xs, ys) ks accu stack ->
   match xs with
   | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack)
@@ -268,14 +269,16 @@ and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type =
       (step [@ocaml.tailcall]) g gas body ks res stack
  [@@inline]
 
-and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type =
+and[@coq_struct "gas"] klist_exit :
+    type a b c d i j. (a, b, c, d, i, j) klist_exit_type =
  fun mk g gas (body, xs, ys, len) ks accu stack ->
   let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in
   let (accu, stack) = stack in
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type =
+and[@coq_struct "gas"] klist_enter :
+    type a b c d e j. (a, b, c, d, e, j) klist_enter_type =
  fun mk g gas (body, xs, ys, len) ks' accu stack ->
   match xs with
   | [] ->
@@ -286,22 +289,23 @@ and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type =
       (step [@ocaml.tailcall]) g gas body ks x (accu, stack)
  [@@inline]
 
-and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type
-    =
+and[@coq_struct "gas"] kloop_in_left :
+    type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type =
  fun g gas ks0 ki ks' accu stack ->
   match accu with
   | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack
   | R v -> (next [@ocaml.tailcall]) g gas ks' v stack
  [@@inline]
 
-and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type =
+and[@coq_struct "gas"] kloop_in :
+    type a b c r f s. (a, b, c, r, f, s) kloop_in_type =
  fun g gas ks0 ki ks' accu stack ->
   let (accu', stack') = stack in
   if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack'
   else (next [@ocaml.tailcall]) g gas ks' accu' stack'
  [@@inline]
 
-and kiter : type a b s r f. (a, b, s, r, f) kiter_type =
+and[@coq_struct "gas"] kiter : type a b s r f. (a, b, s, r, f) kiter_type =
  fun mk g gas (body, xs) ks accu stack ->
   match xs with
   | [] -> (next [@ocaml.tailcall]) g gas ks accu stack
@@ -310,7 +314,7 @@ and kiter : type a b s r f. (a, b, s, r, f) kiter_type =
       (step [@ocaml.tailcall]) g gas body ks x (accu, stack)
  [@@inline]
 
-and next :
+and[@coq_struct "function_parameter"] next :
     type a s r f.
     outdated_context * step_constants ->
     local_gas_counter ->
@@ -322,34 +326,38 @@ and next :
   match consume_control gas ks0 with
   | None -> fail Gas.Operation_quota_exceeded
   | Some gas -> (
-      match ks0 with
-      | KLog (ks, logger) ->
+      match[@coq_match_gadt] (ks0, accu, stack) with
+      | (KLog (ks, logger), _, _) ->
           (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack
-      | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas))
-      | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack
-      | KLoop_in (ki, ks') ->
+      | (KNil, (accu : r), (stack : f)) ->
+          Lwt.return (Ok (accu, stack, ctxt, gas))
+      | (KCons (k, ks), _, _) -> (step [@ocaml.tailcall]) g gas k ks accu stack
+      | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) ->
           (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack
-      | KReturn (stack', ks) -> (next [@ocaml.tailcall]) g gas ks accu stack'
-      | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack
-      | KLoop_in_left (ki, ks') ->
+      | (KReturn (stack', ks), _, _) ->
+          (next [@ocaml.tailcall]) g gas ks accu stack'
+      | (KMap_head (f, ks), _, _) ->
+          (next [@ocaml.tailcall]) g gas ks (f accu) stack
+      | (KLoop_in_left (ki, ks'), (accu : _ union), _) ->
           (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack
-      | KUndip (x, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack)
-      | KIter (body, xs, ks) ->
+      | (KUndip (x, ks), _, _) ->
+          (next [@ocaml.tailcall]) g gas ks x (accu, stack)
+      | (KIter (body, xs, ks), _, _) ->
           let extra = (body, xs) in
           (kiter [@ocaml.tailcall]) id g gas extra ks accu stack
-      | KList_enter_body (body, xs, ys, len, ks) ->
+      | (KList_enter_body (body, xs, ys, len, ks), _, _) ->
           let extra = (body, xs, ys, len) in
           (klist_enter [@ocaml.tailcall]) id g gas extra ks accu stack
-      | KList_exit_body (body, xs, ys, len, ks) ->
+      | (KList_exit_body (body, xs, ys, len, ks), _, (stack : _ * _)) ->
           let extra = (body, xs, ys, len) in
           (klist_exit [@ocaml.tailcall]) id g gas extra ks accu stack
-      | KMap_enter_body (body, xs, ys, ks) ->
+      | (KMap_enter_body (body, xs, ys, ks), _, _) ->
           let extra = (body, xs, ys) in
           (kmap_enter [@ocaml.tailcall]) id g gas extra ks accu stack
-      | KMap_exit_body (body, xs, ys, yk, ks) ->
+      | (KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _)) ->
           let extra = (body, xs, ys, yk) in
           (kmap_exit [@ocaml.tailcall]) id g gas extra ks accu stack
-      | KView_exit (orig_step_constants, ks) ->
+      | (KView_exit (orig_step_constants, ks), _, _) ->
           let g = (fst g, orig_step_constants) in
           (next [@ocaml.tailcall]) g gas ks accu stack)
 
@@ -366,10 +374,11 @@ and next :
    instructions.
 
 *)
-and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type =
+and[@coq_struct "gas"] ilist_map :
+    type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type =
  fun log_if_needed g gas (body, k) ks accu stack ->
   let xs = accu.elements in
-  let ys = [] in
+  let ys = (([] [@coq_type_annotation]) : f list) in
   let len = accu.length in
   let ks =
     log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks)))
@@ -378,7 +387,8 @@ and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type =
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type =
+and[@coq_struct "gas"] ilist_iter :
+    type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type =
  fun log_if_needed g gas (body, k) ks accu stack ->
   let xs = accu.elements in
   let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in
@@ -386,7 +396,8 @@ and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type =
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type =
+and[@coq_struct "gas"] iset_iter :
+    type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type =
  fun log_if_needed g gas (body, k) ks accu stack ->
   let set = accu in
   let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in
@@ -395,8 +406,8 @@ and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type =
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type
-    =
+and[@coq_struct "gas"] imap_map :
+    type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type =
  fun log_if_needed g gas (body, k) ks accu stack ->
   let map = accu in
   let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in
@@ -406,7 +417,8 @@ and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type =
+and[@coq_struct "gas"] imap_iter :
+    type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type =
  fun log_if_needed g gas (body, k) ks accu stack ->
   let map = accu in
   let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in
@@ -415,7 +427,8 @@ and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type =
   (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
 
-and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type =
+and[@coq_struct "gas"] imul_teznat :
+    type a b c d e f. (a, b, c, d, e, f) imul_teznat_type =
  fun logger g gas (kinfo, k) ks accu stack ->
   let x = accu in
   let (y, stack) = stack in
@@ -424,7 +437,8 @@ and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type =
   | Some y ->
       Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack
 
-and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type =
+and[@coq_struct "gas"] imul_nattez :
+    type a b c d e f. (a, b, c, d, e, f) imul_nattez_type =
  fun logger g gas (kinfo, k) ks accu stack ->
   let y = accu in
   let (x, stack) = stack in
@@ -433,7 +447,8 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type =
   | Some y ->
       Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack
 
-and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type =
+and[@coq_struct "gas"] ilsl_nat :
+    type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type =
  fun logger g gas (kinfo, k) ks accu stack ->
   let x = accu in
   let (y, stack) = stack in
@@ -441,7 +456,8 @@ and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type =
   | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log))
   | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack
 
-and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type =
+and[@coq_struct "gas"] ilsr_nat :
+    type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type =
  fun logger g gas (kinfo, k) ks accu stack ->
   let x = accu in
   let (y, stack) = stack in
@@ -449,7 +465,7 @@ and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type =
   | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log))
   | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack
 
-and ifailwith : ifailwith_type =
+and[@coq_struct "function_parameter"] ifailwith : ifailwith_type =
   {
     ifailwith =
       (fun logger (ctxt, _) gas kloc tv accu ->
@@ -461,7 +477,8 @@ and ifailwith : ifailwith_type =
         get_log logger >>=? fun log -> fail (Reject (kloc, v, log)));
   }
 
-and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type =
+and[@coq_struct "gas"] iexec :
+    type a b c d e f g. (a, b, c, d, e, f, g) iexec_type =
  fun logger g gas k ks accu stack ->
   let arg = accu in
   let (code, stack) = stack in
@@ -474,30 +491,41 @@ and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type =
   let ks = KReturn (stack, KCons (k, ks)) in
   (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell)
 
-and step : type a s b t r f. (a, s, b, t, r, f) step_type =
+and[@coq_struct "function_parameter"] step :
+    type a s b t r f. (a, s, b, t, r, f) step_type =
  fun ((ctxt, sc) as g) gas i ks accu stack ->
   match consume_instr gas i accu stack with
   | None -> fail Gas.Operation_quota_exceeded
   | Some gas -> (
-      match i with
-      | ILog (_, event, logger, k) ->
+      match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with
+      | (ILog (_, event, logger, k), _, _) ->
           (log [@ocaml.tailcall]) (logger, event) g gas k ks accu stack
-      | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack
+      | (IHalt _, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack
       (* stack ops *)
-      | IDrop (_, k) ->
+      | (IDrop (_, k), _, (stack : _ * _)) ->
           let (accu, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack)
-      | ISwap (_, k) ->
+      | (IDup (_, k), _, _) ->
+          (step [@ocaml.tailcall]) g gas k ks accu (accu, stack)
+      | (ISwap (_, k), _, (stack : _ * _)) ->
           let (top, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks top (accu, stack)
-      | IConst (_, v, k) -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack)
+      | (IConst (_, v, k), _, _) ->
+          (step [@ocaml.tailcall]) g gas k ks v (accu, stack)
       (* options *)
-      | ICons_some (_, k) ->
+      | (ICons_some (_, k), _, _) ->
           (step [@ocaml.tailcall]) g gas k ks (Some accu) stack
-      | ICons_none (_, k) ->
-          (step [@ocaml.tailcall]) g gas k ks None (accu, stack)
-      | IIf_none {branch_if_none; branch_if_some; k; _} -> (
+      | (ICons_none (_, k), _, _) ->
+          (step [@ocaml.tailcall])
+            g
+            gas
+            k
+            ks
+            (None [@coq_type_annotation])
+            (accu, stack)
+      | ( IIf_none {branch_if_none; branch_if_some; k; _},
+          (accu : _ option),
+          (stack : _ * _) ) -> (
           match accu with
           | None ->
               let (accu, stack) = stack in
@@ -516,29 +544,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                 (KCons (k, ks))
                 v
                 stack)
-      | IOpt_map {body; k; kinfo = _} -> (
+      | (IOpt_map {body; k; kinfo = _}, (accu : _ option), _) -> (
           match accu with
-          | None -> (step [@ocaml.tailcall]) g gas k ks None stack
+          | None ->
+              (step [@ocaml.tailcall])
+                g
+                gas
+                k
+                ks
+                (None [@coq_type_annotation])
+                stack
           | Some v ->
-              let ks' = KMap_head (Option.some, KCons (k, ks)) in
+              let ks' =
+                KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks))
+              in
               (step [@ocaml.tailcall]) g gas body ks' v stack)
       (* pairs *)
-      | ICons_pair (_, k) ->
+      | (ICons_pair (_, k), _, (stack : _ * _)) ->
           let (b, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks (accu, b) stack
-      | IUnpair (_, k) ->
+      | (IUnpair (_, k), (accu : _ * _), _) ->
           let (a, b) = accu in
           (step [@ocaml.tailcall]) g gas k ks a (b, stack)
-      | ICar (_, k) ->
+      | (ICar (_, k), (accu : _ * _), _) ->
           let (a, _) = accu in
           (step [@ocaml.tailcall]) g gas k ks a stack
-      | ICdr (_, k) ->
+      | (ICdr (_, k), (accu : _ * _), _) ->
           let (_, b) = accu in
           (step [@ocaml.tailcall]) g gas k ks b stack
       (* unions *)
-      | ICons_left (_, k) -> (step [@ocaml.tailcall]) g gas k ks (L accu) stack
-      | ICons_right (_, k) -> (step [@ocaml.tailcall]) g gas k ks (R accu) stack
-      | IIf_left {branch_if_left; branch_if_right; k; _} -> (
+      | (ICons_left (_, k), _, _) ->
+          (step [@ocaml.tailcall])
+            g
+            gas
+            k
+            ks
+            (L accu [@coq_type_annotation])
+            stack
+      | (ICons_right (_, k), _, _) ->
+          (step [@ocaml.tailcall])
+            g
+            gas
+            k
+            ks
+            (R accu [@coq_type_annotation])
+            stack
+      | (IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _)
+        -> (
           match accu with
           | L v ->
               (step [@ocaml.tailcall])
@@ -557,15 +609,23 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                 v
                 stack)
       (* lists *)
-      | ICons_list (_, k) ->
+      | (ICons_list (_, k), _, (stack : _ * _)) ->
           let (tl, stack) = stack in
           let accu = Script_list.cons accu tl in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | INil (_, k) ->
+      | (INil (_, k), _, _) ->
           let stack = (accu, stack) in
           let accu = Script_list.empty in
-          (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> (
+          (step [@ocaml.tailcall])
+            g
+            gas
+            k
+            ks
+            (accu [@coq_implicit "(E := __INil_'b)"])
+            stack
+      | ( IIf_cons {branch_if_cons; branch_if_nil; k; _},
+          (accu : _ boxed_list),
+          (stack : _ * _) ) -> (
           match accu.elements with
           | [] ->
               let (accu, stack) = stack in
@@ -585,88 +645,105 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                 (KCons (k, ks))
                 hd
                 (tl, stack))
-      | IList_map (_, body, k) ->
-          (ilist_map [@ocaml.tailcall]) id g gas (body, k) ks accu stack
-      | IList_size (_, k) ->
+      | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) ->
+          (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b)"])
+            id
+            g
+            gas
+            (body, k)
+            ks
+            accu
+            stack
+      | (IList_size (_, k), (accu : _ boxed_list), _) ->
           let list = accu in
           let len = Script_int.(abs (of_int list.length)) in
           (step [@ocaml.tailcall]) g gas k ks len stack
-      | IList_iter (_, body, k) ->
+      | (IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _)) ->
           (ilist_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack
       (* sets *)
-      | IEmpty_set (_, ty, k) ->
-          let res = Script_set.empty ty in
+      | (IEmpty_set (_, ty, k), _, _) ->
+          let res = (Script_set.empty [@coq_type_annotation]) ty in
           let stack = (accu, stack) in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ISet_iter (_, body, k) ->
+      | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) ->
           (iset_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack
-      | ISet_mem (_, k) ->
+      | (ISet_mem (_, k), _, (stack : _ * _)) ->
           let (set, stack) = stack in
           let res = Script_set.mem accu set in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ISet_update (_, k) ->
+      | (ISet_update (_, k), _, (stack : _ * (_ * _))) ->
           let (presence, (set, stack)) = stack in
           let res = Script_set.update accu presence set in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ISet_size (_, k) ->
+      | (ISet_size (_, k), (accu : _ set), _) ->
           let res = Script_set.size accu in
           (step [@ocaml.tailcall]) g gas k ks res stack
       (* maps *)
-      | IEmpty_map (_, ty, k) ->
-          let res = Script_map.empty ty and stack = (accu, stack) in
+      | (IEmpty_map (_, ty, k), _, _) ->
+          let stack = (accu, stack) in
+          let res = (Script_map.empty [@coq_type_annotation]) ty in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMap_map (_, body, k) ->
-          (imap_map [@ocaml.tailcall]) id g gas (body, k) ks accu stack
-      | IMap_iter (_, body, k) ->
+      | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) ->
+          (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c)"])
+            id
+            g
+            gas
+            (body, k)
+            ks
+            accu
+            stack
+      | (IMap_iter (_, body, k), (accu : _ map), (stack : _ * _)) ->
           (imap_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack
-      | IMap_mem (_, k) ->
+      | (IMap_mem (_, k), _, (stack : _ * _)) ->
           let (map, stack) = stack in
           let res = Script_map.mem accu map in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMap_get (_, k) ->
+      | (IMap_get (_, k), _, (stack : _ * _)) ->
           let (map, stack) = stack in
           let res = Script_map.get accu map in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMap_update (_, k) ->
+      | (IMap_update (_, k), _, (stack : _ * (_ * _))) ->
           let (v, (map, stack)) = stack in
           let key = accu in
           let res = Script_map.update key v map in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMap_get_and_update (_, k) ->
+      | (IMap_get_and_update (_, k), _, (stack : _ * (_ * _))) ->
           let key = accu in
           let (v, (map, rest)) = stack in
           let map' = Script_map.update key v map in
           let v' = Script_map.get key map in
           (step [@ocaml.tailcall]) g gas k ks v' (map', rest)
-      | IMap_size (_, k) ->
+      | (IMap_size (_, k), (accu : _ map), _) ->
           let res = Script_map.size accu in
           (step [@ocaml.tailcall]) g gas k ks res stack
       (* Big map operations *)
-      | IEmpty_big_map (_, tk, tv, k) ->
-          let ebm = Script_ir_translator.empty_big_map tk tv in
+      | (IEmpty_big_map (_, tk, tv, k), _, _) ->
+          let ebm =
+            (Script_ir_translator.empty_big_map [@coq_type_annotation]) tk tv
+          in
           (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack)
-      | IBig_map_mem (_, k) ->
+      | (IBig_map_mem (_, k), _, (stack : _ * _)) ->
           let (map, stack) = stack in
           let key = accu in
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
             Script_ir_translator.big_map_mem ctxt key map )
           >>=? fun (res, ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack
-      | IBig_map_get (_, k) ->
+      | (IBig_map_get (_, k), _, (stack : _ * _)) ->
           let (map, stack) = stack in
           let key = accu in
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
             Script_ir_translator.big_map_get ctxt key map )
           >>=? fun (res, ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack
-      | IBig_map_update (_, k) ->
+      | (IBig_map_update (_, k), _, (stack : _ * (_ * _))) ->
           let key = accu in
           let (maybe_value, (map, stack)) = stack in
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
             Script_ir_translator.big_map_update ctxt key maybe_value map )
           >>=? fun (big_map, ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack
-      | IBig_map_get_and_update (_, k) ->
+      | (IBig_map_get_and_update (_, k), _, (stack : _ * (_ * _))) ->
           let key = accu in
           let (v, (map, stack)) = stack in
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
@@ -674,33 +751,41 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           >>=? fun ((v', map'), ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack)
       (* timestamp operations *)
-      | IAdd_seconds_to_timestamp (_, k) ->
+      | ( IAdd_seconds_to_timestamp (_, k),
+          (accu : _ Script_int.num),
+          (stack : _ * _) ) ->
           let n = accu in
           let (t, stack) = stack in
           let result = Script_timestamp.add_delta t n in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | IAdd_timestamp_to_seconds (_, k) ->
+      | ( IAdd_timestamp_to_seconds (_, k),
+          (accu : Script_timestamp.t),
+          (stack : _ * _) ) ->
           let t = accu in
           let (n, stack) = stack in
           let result = Script_timestamp.add_delta t n in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | ISub_timestamp_seconds (_, k) ->
+      | ( ISub_timestamp_seconds (_, k),
+          (accu : Script_timestamp.t),
+          (stack : _ * _) ) ->
           let t = accu in
           let (s, stack) = stack in
           let result = Script_timestamp.sub_delta t s in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | IDiff_timestamps (_, k) ->
+      | (IDiff_timestamps (_, k), (accu : Script_timestamp.t), (stack : _ * _))
+        ->
           let t1 = accu in
           let (t2, stack) = stack in
           let result = Script_timestamp.diff t1 t2 in
           (step [@ocaml.tailcall]) g gas k ks result stack
       (* string operations *)
-      | IConcat_string_pair (_, k) ->
+      | (IConcat_string_pair (_, k), (accu : Script_string.t), (stack : _ * _))
+        ->
           let x = accu in
           let (y, stack) = stack in
           let s = Script_string.concat_pair x y in
           (step [@ocaml.tailcall]) g gas k ks s stack
-      | IConcat_string (_, k) ->
+      | (IConcat_string (_, k), (accu : _ boxed_list), _) ->
           let ss = accu in
           (* The cost for this fold_left has been paid upfront *)
           let total_length =
@@ -712,7 +797,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           consume gas (Interp_costs.concat_string total_length) >>?= fun gas ->
           let s = Script_string.concat ss.elements in
           (step [@ocaml.tailcall]) g gas k ks s stack
-      | ISlice_string (_, k) ->
+      | ( ISlice_string (_, k),
+          (accu : _ Script_int.num),
+          (stack : _ * (Script_string.t * _)) ) ->
           let offset = accu in
           let (length, (s, stack)) = stack in
           let s_length = Z.of_int (Script_string.length s) in
@@ -722,18 +809,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           then
             let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in
             (step [@ocaml.tailcall]) g gas k ks (Some s) stack
-          else (step [@ocaml.tailcall]) g gas k ks None stack
-      | IString_size (_, k) ->
+          else
+            (step [@ocaml.tailcall])
+              g
+              gas
+              k
+              ks
+              (None [@coq_type_annotation])
+              stack
+      | (IString_size (_, k), (accu : Script_string.t), _) ->
           let s = accu in
           let result = Script_int.(abs (of_int (Script_string.length s))) in
           (step [@ocaml.tailcall]) g gas k ks result stack
       (* bytes operations *)
-      | IConcat_bytes_pair (_, k) ->
+      | (IConcat_bytes_pair (_, k), (accu : bytes), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let s = Bytes.cat x y in
           (step [@ocaml.tailcall]) g gas k ks s stack
-      | IConcat_bytes (_, k) ->
+      | (IConcat_bytes (_, k), (accu : _ boxed_list), _) ->
           let ss = accu in
           (* The cost for this fold_left has been paid upfront *)
           let total_length =
@@ -745,7 +839,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           consume gas (Interp_costs.concat_string total_length) >>?= fun gas ->
           let s = Bytes.concat Bytes.empty ss.elements in
           (step [@ocaml.tailcall]) g gas k ks s stack
-      | ISlice_bytes (_, k) ->
+      | (ISlice_bytes (_, k), (accu : _ Script_int.num), (stack : _ * (_ * _)))
+        ->
           let offset = accu in
           let (length, (s, stack)) = stack in
           let s_length = Z.of_int (Bytes.length s) in
@@ -755,91 +850,100 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           then
             let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in
             (step [@ocaml.tailcall]) g gas k ks (Some s) stack
-          else (step [@ocaml.tailcall]) g gas k ks None stack
-      | IBytes_size (_, k) ->
+          else
+            (step [@ocaml.tailcall])
+              g
+              gas
+              k
+              ks
+              (None [@coq_type_annotation])
+              stack
+      | (IBytes_size (_, k), (accu : bytes), _) ->
           let s = accu in
           let result = Script_int.(abs (of_int (Bytes.length s))) in
           (step [@ocaml.tailcall]) g gas k ks result stack
       (* currency operations *)
-      | IAdd_tez (_, k) ->
+      | (IAdd_tez (_, k), (accu : Tez.t), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           Tez.(x +? y) >>?= fun res ->
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ISub_tez (_, k) ->
+      | (ISub_tez (_, k), (accu : Tez.t), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Tez.sub_opt x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ISub_tez_legacy (_, k) ->
+      | (ISub_tez_legacy (_, k), (accu : Tez.t), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           Tez.(x -? y) >>?= fun res ->
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMul_teznat (kinfo, k) ->
+      | (IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _))
+        ->
           imul_teznat None g gas (kinfo, k) ks accu stack
-      | IMul_nattez (kinfo, k) ->
+      | (IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _))
+        ->
           imul_nattez None g gas (kinfo, k) ks accu stack
       (* boolean operations *)
-      | IOr (_, k) ->
+      | (IOr (_, k), (accu : bool), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks (x || y) stack
-      | IAnd (_, k) ->
+      | (IAnd (_, k), (accu : bool), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks (x && y) stack
-      | IXor (_, k) ->
+      | (IXor (_, k), (accu : bool), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Compare.Bool.(x <> y) in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | INot (_, k) ->
+      | (INot (_, k), (accu : bool), _) ->
           let x = accu in
           (step [@ocaml.tailcall]) g gas k ks (not x) stack
       (* integer operations *)
-      | IIs_nat (_, k) ->
+      | (IIs_nat (_, k), (accu : _ Script_int.num), _) ->
           let x = accu in
           let res = Script_int.is_nat x in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IAbs_int (_, k) ->
+      | (IAbs_int (_, k), (accu : _ Script_int.num), _) ->
           let x = accu in
           let res = Script_int.abs x in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IInt_nat (_, k) ->
+      | (IInt_nat (_, k), (accu : _ Script_int.num), _) ->
           let x = accu in
           let res = Script_int.int x in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | INeg (_, k) ->
+      | (INeg (_, k), (accu : _ Script_int.num), _) ->
           let x = accu in
           let res = Script_int.neg x in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IAdd_int (_, k) ->
+      | (IAdd_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.add x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IAdd_nat (_, k) ->
+      | (IAdd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.add_n x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ISub_int (_, k) ->
+      | (ISub_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.sub x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMul_int (_, k) ->
+      | (IMul_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.mul x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMul_nat (_, k) ->
+      | (IMul_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.mul_n x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IEdiv_teznat (_, k) ->
+      | (IEdiv_teznat (_, k), (accu : Tez.t), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let x = Script_int.of_int64 (Tez.to_mutez x) in
@@ -857,7 +961,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                 | _ -> assert false)
           in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | IEdiv_tez (_, k) ->
+      | (IEdiv_tez (_, k), (accu : Tez.t), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
@@ -874,44 +978,54 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                     | Some r -> Some (q, r)))
           in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | IEdiv_int (_, k) ->
+      | ( IEdiv_int (_, k),
+          (accu : _ Script_int.num),
+          (stack : _ Script_int.num * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.ediv x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IEdiv_nat (_, k) ->
+      | (IEdiv_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.ediv_n x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack
-      | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack
-      | IOr_nat (_, k) ->
+      | ( ILsl_nat (kinfo, k),
+          (accu : _ Script_int.num),
+          (stack : _ Script_int.num * _) ) ->
+          ilsl_nat None g gas (kinfo, k) ks accu stack
+      | ( ILsr_nat (kinfo, k),
+          (accu : _ Script_int.num),
+          (stack : _ Script_int.num * _) ) ->
+          ilsr_nat None g gas (kinfo, k) ks accu stack
+      | (IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.logor x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IAnd_nat (_, k) ->
+      | (IAnd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.logand x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IAnd_int_nat (_, k) ->
+      | (IAnd_int_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.logand x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IXor_nat (_, k) ->
+      | (IXor_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) ->
           let x = accu in
           let (y, stack) = stack in
           let res = Script_int.logxor x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | INot_int (_, k) ->
+      | (INot_int (_, k), (accu : _ Script_int.num), _) ->
           let x = accu in
           let res = Script_int.lognot x in
           (step [@ocaml.tailcall]) g gas k ks res stack
       (* control *)
-      | IIf {branch_if_true; branch_if_false; k; _} ->
+      | ( IIf {branch_if_true; branch_if_false; k; _},
+          (accu : bool),
+          (stack : _ * _) ) ->
           let (res, stack) = stack in
           if accu then
             (step [@ocaml.tailcall])
@@ -929,30 +1043,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               (KCons (k, ks))
               res
               stack
-      | ILoop (_, body, k) ->
+      | (ILoop (_, body, k), _, _) ->
           let ks = KLoop_in (body, KCons (k, ks)) in
           (next [@ocaml.tailcall]) g gas ks accu stack
-      | ILoop_left (_, bl, br) ->
+      | (ILoop_left (_, bl, br), _, _) ->
           let ks = KLoop_in_left (bl, KCons (br, ks)) in
           (next [@ocaml.tailcall]) g gas ks accu stack
-      | IDip (_, b, k) ->
+      | (IDip (_, b, k), _, (stack : _ * _)) ->
           let ign = accu in
           let ks = KUndip (ign, KCons (k, ks)) in
           let (accu, stack) = stack in
           (step [@ocaml.tailcall]) g gas b ks accu stack
-      | IExec (_, k) -> iexec None g gas k ks accu stack
-      | IApply (_, capture_ty, k) ->
+      | (IExec (_, k), _, (stack : _ lambda * _)) ->
+          iexec None g gas k ks accu stack
+      | (IApply (_, capture_ty, k), _, (stack : _ lambda * _)) ->
           let capture = accu in
           let (lam, stack) = stack in
           apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack
-      | ILambda (_, lam, k) ->
+      | (ILambda (_, lam, k), _, _) ->
           (step [@ocaml.tailcall]) g gas k ks lam (accu, stack)
-      | IFailwith (_, kloc, tv) ->
+      | (IFailwith (_, kloc, tv), _, _) ->
           let {ifailwith} = ifailwith in
           ifailwith None g gas kloc tv accu
       (* comparison *)
-      | ICompare (_, ty, k) ->
+      | (ICompare (_, ty, k), _, (stack : _ * _)) ->
           let a = accu in
           let (b, stack) = stack in
           let r =
@@ -960,53 +1075,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           in
           (step [@ocaml.tailcall]) g gas k ks r stack
       (* comparators *)
-      | IEq (_, k) ->
+      | (IEq (_, k), (accu : _ Script_int.num), _) ->
           let a = accu in
           let a = Script_int.compare a Script_int.zero in
           let a = Compare.Int.(a = 0) in
           (step [@ocaml.tailcall]) g gas k ks a stack
-      | INeq (_, k) ->
+      | (INeq (_, k), (accu : _ Script_int.num), _) ->
           let a = accu in
           let a = Script_int.compare a Script_int.zero in
           let a = Compare.Int.(a <> 0) in
           (step [@ocaml.tailcall]) g gas k ks a stack
-      | ILt (_, k) ->
+      | (ILt (_, k), (accu : _ Script_int.num), _) ->
           let a = accu in
           let a = Script_int.compare a Script_int.zero in
           let a = Compare.Int.(a < 0) in
           (step [@ocaml.tailcall]) g gas k ks a stack
-      | ILe (_, k) ->
+      | (ILe (_, k), (accu : _ Script_int.num), _) ->
           let a = accu in
           let a = Script_int.compare a Script_int.zero in
           let a = Compare.Int.(a <= 0) in
           (step [@ocaml.tailcall]) g gas k ks a stack
-      | IGt (_, k) ->
+      | (IGt (_, k), (accu : _ Script_int.num), _) ->
           let a = accu in
           let a = Script_int.compare a Script_int.zero in
           let a = Compare.Int.(a > 0) in
           (step [@ocaml.tailcall]) g gas k ks a stack
-      | IGe (_, k) ->
+      | (IGe (_, k), (accu : _ Script_int.num), _) ->
           let a = accu in
           let a = Script_int.compare a Script_int.zero in
           let a = Compare.Int.(a >= 0) in
           (step [@ocaml.tailcall]) g gas k ks a stack
       (* packing *)
-      | IPack (_, ty, k) ->
+      | (IPack (_, ty, k), _, _) ->
           let value = accu in
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
             Script_ir_translator.pack_data ctxt ty value )
           >>=? fun (bytes, ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack
-      | IUnpack (_, ty, k) ->
+      | (IUnpack (_, ty, k), (accu : bytes), _) ->
           let bytes = accu in
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
-            unpack ctxt ~ty ~bytes )
+            (unpack [@coq_type_annotation]) ctxt ~ty ~bytes )
           >>=? fun (opt, ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack
-      | IAddress (_, k) ->
+      | (IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _) ->
           let (Typed_contract {address; _}) = accu in
           (step [@ocaml.tailcall]) g gas k ks address stack
-      | IContract (kinfo, t, entrypoint, k) -> (
+      | (IContract (kinfo, t, entrypoint, k), (accu : address), _) -> (
           let addr = accu in
           let entrypoint_opt =
             if Entrypoint.is_default addr.entrypoint then Some entrypoint
@@ -1026,8 +1141,16 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
               let accu = maybe_contract in
               (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack
-          | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)
-      | ITransfer_tokens (kinfo, k) ->
+          | None ->
+              (step [@ocaml.tailcall])
+                (ctxt, sc)
+                gas
+                k
+                ks
+                (None [@coq_type_annotation])
+                stack)
+      | (ITransfer_tokens (kinfo, k), _, (stack : _ * (_ typed_contract * _)))
+        ->
           let p = accu in
           let (amount, (Typed_contract {arg_ty; address}, stack)) = stack in
           let {destination; entrypoint} = address in
@@ -1042,7 +1165,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
             entrypoint
           >>=? fun (accu, ctxt, gas) ->
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack
-      | IImplicit_account (_, k) ->
+      | (IImplicit_account (_, k), (accu : public_key_hash), _) ->
           let key = accu in
           let arg_ty = unit_t in
           let address =
@@ -1053,7 +1176,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           in
           let res = Typed_contract {arg_ty; address} in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IView (_, View_signature {name; input_ty; output_ty}, k) -> (
+      | ( IView (_, View_signature {name; input_ty; output_ty}, k),
+          _,
+          (stack : address * _) ) -> (
           let input = accu in
           let (addr, stack) = stack in
           let c = addr.destination in
@@ -1073,8 +1198,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                     ~allow_forged_in_storage:true
                     ctxt
                     script
-                  >>=? fun ( Ex_script (Script {storage; storage_type; views; _}),
-                             ctxt ) ->
+                  >>=? fun [@coq_match_gadt] ( Ex_script
+                                                 (Script
+                                                   {
+                                                     storage;
+                                                     storage_type;
+                                                     views;
+                                                     _;
+                                                   }),
+                                               ctxt ) ->
                   Gas.consume ctxt (Interp_costs.view_get name views)
                   >>?= fun ctxt ->
                   match Script_map.get name views with
@@ -1093,7 +1225,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                             (Micheline.strip_locations view.view_code, []))
                         view_result
                       >>=? fun (Ex_view f, ctxt) ->
-                      match f with
+                      match[@coq_match_with_default] f with
                       | Lam
                           ( {
                               kloc;
@@ -1124,7 +1256,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                               (return_none [@ocaml.tailcall]) ctxt
                           | Ok (Eq, Eq) -> (
                               let kkinfo = kinfo_of_kinstr k in
-                              match kkinfo.kstack_ty with
+                              match[@coq_match_with_default]
+                                kkinfo.kstack_ty
+                              with
                               | Item_t (_, s) ->
                                   let kstack_ty = Item_t (output_ty, s) in
                                   let kkinfo = {kkinfo with kstack_ty} in
@@ -1155,7 +1289,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
                                     (input, storage)
                                     (EmptyCell, EmptyCell))))))
           | Tx_rollup _ -> (return_none [@ocaml.tailcall]) ctxt)
-      | ICreate_contract {storage_type; code; k; kinfo = _} ->
+      | ( ICreate_contract {storage_type; code; k; kinfo = _},
+          (accu : public_key_hash option),
+          (stack : _ * (_ * _)) ) ->
           (* Removed the instruction's arguments manager, spendable and delegatable *)
           let delegate = accu in
           let (credit, (init, stack)) = stack in
@@ -1166,24 +1302,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               stack )
           in
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack
-      | ISet_delegate (_, k) ->
+      | (ISet_delegate (_, k), (accu : public_key_hash option), _) ->
           let delegate = accu in
           let operation = Delegation delegate in
           let ctxt = update_context gas ctxt in
           fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->
           let piop = Internal_operation {source = sc.self; operation; nonce} in
-          let res = {piop; lazy_storage_diff = None} in
+          let res =
+            {
+              piop;
+              lazy_storage_diff =
+                (None [@coq_type_annotation] : Lazy_storage.diffs option);
+            }
+          in
           let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack
-      | IBalance (_, k) ->
+      | (IBalance (_, k), _, _) ->
           let ctxt = update_context gas ctxt in
           let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
           let g = (ctxt, sc) in
           (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack)
-      | ILevel (_, k) ->
+      | (ILevel (_, k), _, _) ->
           (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack)
-      | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack)
-      | IMin_block_time (_, k) ->
+      | (INow (_, k), _, _) ->
+          (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack)
+      | (IMin_block_time (_, k), _, _) ->
           let ctxt = update_context gas ctxt in
           let min_block_time =
             Alpha_context.Constants.minimal_block_delay ctxt
@@ -1193,48 +1336,49 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
           in
           let new_stack = (accu, stack) in
           (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack
-      | ICheck_signature (_, k) ->
+      | (ICheck_signature (_, k), (accu : public_key), (stack : _ * (_ * _))) ->
           let key = accu in
           let (signature, (message, stack)) = stack in
           let res = Script_signature.check key signature message in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IHash_key (_, k) ->
+      | (IHash_key (_, k), (accu : public_key), _) ->
           let key = accu in
           let res = Signature.Public_key.hash key in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IBlake2b (_, k) ->
+      | (IBlake2b (_, k), (accu : bytes), _) ->
           let bytes = accu in
           let hash = Raw_hashes.blake2b bytes in
           (step [@ocaml.tailcall]) g gas k ks hash stack
-      | ISha256 (_, k) ->
+      | (ISha256 (_, k), (accu : bytes), _) ->
           let bytes = accu in
           let hash = Raw_hashes.sha256 bytes in
           (step [@ocaml.tailcall]) g gas k ks hash stack
-      | ISha512 (_, k) ->
+      | (ISha512 (_, k), (accu : bytes), _) ->
           let bytes = accu in
           let hash = Raw_hashes.sha512 bytes in
           (step [@ocaml.tailcall]) g gas k ks hash stack
-      | ISource (_, k) ->
+      | (ISource (_, k), _, _) ->
           let destination : Destination.t = Contract sc.payer in
           let res = {destination; entrypoint = Entrypoint.default} in
           (step [@ocaml.tailcall]) g gas k ks res (accu, stack)
-      | ISender (_, k) ->
+      | (ISender (_, k), _, _) ->
           let destination : Destination.t = Contract sc.source in
           let res = {destination; entrypoint = Entrypoint.default} in
           (step [@ocaml.tailcall]) g gas k ks res (accu, stack)
-      | ISelf (_, ty, entrypoint, k) ->
+      | (ISelf (_, ty, entrypoint, k), _, _) ->
           let destination : Destination.t = Contract sc.self in
           let address = {destination; entrypoint} in
           let res = Typed_contract {arg_ty = ty; address} in
           (step [@ocaml.tailcall]) g gas k ks res (accu, stack)
-      | ISelf_address (_, k) ->
+      | (ISelf_address (_, k), _, _) ->
           let destination : Destination.t = Contract sc.self in
           let res = {destination; entrypoint = Entrypoint.default} in
           (step [@ocaml.tailcall]) g gas k ks res (accu, stack)
-      | IAmount (_, k) ->
-          let accu = sc.amount and stack = (accu, stack) in
+      | (IAmount (_, k), _, _) ->
+          let stack = (accu, stack) in
+          let accu = sc.amount in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IDig (_, _n, n', k) ->
+      | (IDig (_, _n, n', k), _, _) ->
           let ((accu, stack), x) =
             interp_stack_prefix_preserving_operation
               (fun v stack -> (stack, v))
@@ -1242,9 +1386,10 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               accu
               stack
           in
-          let accu = x and stack = (accu, stack) in
+          let stack = ((accu, stack) [@coq_type_annotation]) in
+          let accu = x in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IDug (_, _n, n', k) ->
+      | (IDug (_, _n, n', k), _, (stack : _ * _)) ->
           let v = accu in
           let (accu, stack) = stack in
           let ((accu, stack), ()) =
@@ -1254,34 +1399,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               accu
               stack
           in
-          (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IDipn (_, _n, n', b, k) ->
-          let (accu, stack, restore_prefix) = kundip n' accu stack k in
+          (step [@ocaml.tailcall])
+            g
+            gas
+            k
+            ks
+            (accu [@coq_type_annotation])
+            (stack [@coq_type_annotation])
+      | (IDipn (_, _n, n', b, k), _, _) ->
+          let (accu, stack, restore_prefix) =
+            (kundip [@coq_type_annotation]) n' accu stack k
+          in
           let ks = KCons (restore_prefix, ks) in
           (step [@ocaml.tailcall]) g gas b ks accu stack
-      | IDropn (_, _n, n', k) ->
+      | (IDropn (_, _n, n', k), _, _) ->
           let stack =
-            let rec aux :
+            let[@coq_struct "w_value"] rec aux :
                 type a s b t.
                 (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness ->
                 a ->
                 s ->
                 b * t =
              fun w accu stack ->
-              match w with
-              | KRest -> (accu, stack)
-              | KPrefix (_, w) ->
+              match[@coq_match_gadt] (w, accu, stack) with
+              | (KRest, (accu : b), (stack : t)) -> (accu, stack)
+              | (KPrefix (_, w), _, (stack : _ * _)) ->
                   let (accu, stack) = stack in
                   aux w accu stack
             in
-            aux n' accu stack
+            (aux [@coq_type_annotation]) n' accu stack
           in
           let (accu, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | ISapling_empty_state (_, memo_size, k) ->
+      | (ISapling_empty_state (_, memo_size, k), _, _) ->
           let state = Sapling.empty_state ~memo_size () in
           (step [@ocaml.tailcall]) g gas k ks state (accu, stack)
-      | ISapling_verify_update (_, k) -> (
+      | ( ISapling_verify_update (_, k),
+          (accu : Sapling.transaction),
+          (stack : _ * _) ) -> (
           let transaction = accu in
           let (state, stack) = stack in
           let address = Contract.to_b58check sc.self in
@@ -1301,7 +1456,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               in
               (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack
           | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)
-      | ISapling_verify_update_deprecated (_, k) -> (
+      | ( ISapling_verify_update_deprecated (_, k),
+          (accu : Sapling_repr.legacy_transaction),
+          (stack : _ * _) ) -> (
           let transaction = accu in
           let (state, stack) = stack in
           let address = Contract.to_b58check sc.self in
@@ -1317,179 +1474,213 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
               let state = Some (Script_int.of_int64 balance, state) in
               (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack
           | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)
-      | IChainId (_, k) ->
-          let accu = Script_chain_id.make sc.chain_id
-          and stack = (accu, stack) in
+      | (IChainId (_, k), _, _) ->
+          let stack = (accu, stack) in
+          let accu = Script_chain_id.make sc.chain_id in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | INever _ -> ( match accu with _ -> .)
-      | IVoting_power (_, k) ->
+      | (INever _, _, _) -> .
+      | (IVoting_power (_, k), (accu : public_key_hash), _) ->
           let key_hash = accu in
           let ctxt = update_context gas ctxt in
           Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) ->
           let power = Script_int.(abs (of_int64 power)) in
           let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
           (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack
-      | ITotal_voting_power (_, k) ->
+      | (ITotal_voting_power (_, k), _, _) ->
           let ctxt = update_context gas ctxt in
           Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) ->
           let power = Script_int.(abs (of_int64 power)) in
           let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
           let g = (ctxt, sc) in
           (step [@ocaml.tailcall]) g gas k ks power (accu, stack)
-      | IKeccak (_, k) ->
+      | (IKeccak (_, k), (accu : bytes), _) ->
           let bytes = accu in
           let hash = Raw_hashes.keccak256 bytes in
           (step [@ocaml.tailcall]) g gas k ks hash stack
-      | ISha3 (_, k) ->
+      | (ISha3 (_, k), (accu : bytes), _) ->
           let bytes = accu in
           let hash = Raw_hashes.sha3_256 bytes in
           (step [@ocaml.tailcall]) g gas k ks hash stack
-      | IAdd_bls12_381_g1 (_, k) ->
+      | ( IAdd_bls12_381_g1 (_, k),
+          (accu : Script_bls.G1.t),
+          (stack : Script_bls.G1.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let accu = Script_bls.G1.add x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IAdd_bls12_381_g2 (_, k) ->
+      | ( IAdd_bls12_381_g2 (_, k),
+          (accu : Script_bls.G2.t),
+          (stack : Script_bls.G2.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let accu = Script_bls.G2.add x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IAdd_bls12_381_fr (_, k) ->
+      | ( IAdd_bls12_381_fr (_, k),
+          (accu : Script_bls.Fr.t),
+          (stack : Script_bls.Fr.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let accu = Script_bls.Fr.add x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IMul_bls12_381_g1 (_, k) ->
+      | ( IMul_bls12_381_g1 (_, k),
+          (accu : Script_bls.G1.t),
+          (stack : Script_bls.Fr.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let accu = Script_bls.G1.mul x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IMul_bls12_381_g2 (_, k) ->
+      | ( IMul_bls12_381_g2 (_, k),
+          (accu : Script_bls.G2.t),
+          (stack : Script_bls.Fr.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let accu = Script_bls.G2.mul x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IMul_bls12_381_fr (_, k) ->
+      | ( IMul_bls12_381_fr (_, k),
+          (accu : Script_bls.Fr.t),
+          (stack : Script_bls.Fr.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let accu = Script_bls.Fr.mul x y in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IMul_bls12_381_fr_z (_, k) ->
+      | ( IMul_bls12_381_fr_z (_, k),
+          (accu : _ Script_int.num),
+          (stack : Script_bls.Fr.t * _) ) ->
           let x = accu in
           let (y, stack) = stack in
           let x = Script_bls.Fr.of_z (Script_int.to_zint x) in
           let res = Script_bls.Fr.mul x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IMul_bls12_381_z_fr (_, k) ->
+      | ( IMul_bls12_381_z_fr (_, k),
+          (accu : Script_bls.Fr.t),
+          (stack : _ Script_int.num * _) ) ->
           let y = accu in
           let (x, stack) = stack in
           let x = Script_bls.Fr.of_z (Script_int.to_zint x) in
           let res = Script_bls.Fr.mul x y in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | IInt_bls12_381_fr (_, k) ->
+      | (IInt_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _) ->
           let x = accu in
           let res = Script_int.of_zint (Script_bls.Fr.to_z x) in
           (step [@ocaml.tailcall]) g gas k ks res stack
-      | INeg_bls12_381_g1 (_, k) ->
+      | (INeg_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), _) ->
           let x = accu in
           let accu = Script_bls.G1.negate x in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | INeg_bls12_381_g2 (_, k) ->
+      | (INeg_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), _) ->
           let x = accu in
           let accu = Script_bls.G2.negate x in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | INeg_bls12_381_fr (_, k) ->
+      | (INeg_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _) ->
           let x = accu in
           let accu = Script_bls.Fr.negate x in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IPairing_check_bls12_381 (_, k) ->
+      | (IPairing_check_bls12_381 (_, k), (accu : _ boxed_list), _) ->
           let pairs = accu in
           let check = Script_bls.pairing_check pairs.elements in
           (step [@ocaml.tailcall]) g gas k ks check stack
-      | IComb (_, _, witness, k) ->
-          let rec aux :
+      | (IComb (_, _, witness, k), _, _) ->
+          let[@coq_struct "witness"] rec aux :
               type before after.
               (before, after) comb_gadt_witness -> before -> after =
            fun witness stack ->
-            match (witness, stack) with
-            | (Comb_one, stack) -> stack
-            | (Comb_succ witness', (a, tl)) ->
-                let (b, tl') = aux witness' tl in
-                ((a, b), tl')
+            match[@coq_match_gadt] (witness, stack) with
+            | (Comb_one, (stack : after)) -> stack
+            | (Comb_succ witness', (stack : _ * _)) ->
+                let (a, tl) = stack in
+                let (b, tl') = (aux [@coq_type_annotation]) witness' tl in
+                ((((a, b), tl') [@coq_cast]) : after)
           in
-          let stack = aux witness (accu, stack) in
+          let stack = (aux [@coq_type_annotation]) witness (accu, stack) in
           let (accu, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IUncomb (_, _, witness, k) ->
-          let rec aux :
+      | (IUncomb (_, _, witness, k), _, _) ->
+          let[@coq_struct "witness"] rec aux :
               type before after.
               (before, after) uncomb_gadt_witness -> before -> after =
            fun witness stack ->
-            match (witness, stack) with
-            | (Uncomb_one, stack) -> stack
-            | (Uncomb_succ witness', ((a, b), tl)) -> (a, aux witness' (b, tl))
+            match[@coq_match_gadt] (witness, stack) with
+            | (Uncomb_one, (stack : after)) -> stack
+            | (Uncomb_succ witness', (stack : (_ * _) * _)) ->
+                let ((a, b), tl) = stack in
+                (((a, (aux [@coq_type_annotation]) witness' (b, tl))
+                 [@coq_cast])
+                  : after)
           in
-          let stack = aux witness (accu, stack) in
+          let stack = (aux [@coq_type_annotation]) witness (accu, stack) in
           let (accu, stack) = stack in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IComb_get (_, _, witness, k) ->
+      | (IComb_get (_, _, witness, k), _, _) ->
           let comb = accu in
-          let rec aux :
+          let[@coq_struct "witness"] rec aux :
               type before after.
               (before, after) comb_get_gadt_witness -> before -> after =
            fun witness comb ->
-            match (witness, comb) with
-            | (Comb_get_zero, v) -> v
-            | (Comb_get_one, (a, _)) -> a
-            | (Comb_get_plus_two witness', (_, b)) -> aux witness' b
+            match[@coq_match_gadt] (witness, comb) with
+            | (Comb_get_zero, (v : after)) -> v
+            | (Comb_get_one, (comb : after * _)) ->
+                let (a, _) = comb in
+                a
+            | (Comb_get_plus_two witness', (comb : _ * _)) ->
+                let (_, b) = comb in
+                aux witness' b
           in
-          let accu = aux witness comb in
+          let accu = (aux [@coq_type_annotation]) witness comb in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IComb_set (_, _, witness, k) ->
+      | (IComb_set (_, _, witness, k), _, (stack : _ * _)) ->
           let value = accu in
           let (comb, stack) = stack in
-          let rec aux :
+          let[@coq_struct "witness"] rec aux :
               type value before after.
               (value, before, after) comb_set_gadt_witness ->
               value ->
               before ->
               after =
            fun witness value item ->
-            match (witness, item) with
-            | (Comb_set_zero, _) -> value
-            | (Comb_set_one, (_hd, tl)) -> (value, tl)
-            | (Comb_set_plus_two witness', (hd, tl)) ->
-                (hd, aux witness' value tl)
+            match[@coq_match_gadt] (witness, value, item) with
+            | (Comb_set_zero, (value : after), _) -> value
+            | (Comb_set_one, _, (item : _ * _)) ->
+                let (_hd, tl) = item in
+                (((value, tl) [@coq_cast]) : after)
+            | (Comb_set_plus_two witness', _, (item : _ * _)) ->
+                let (hd, tl) = item in
+                (((hd, (aux [@coq_type_annotation]) witness' value tl)
+                 [@coq_cast])
+                  : after)
           in
-          let accu = aux witness value comb in
+          let accu = (aux [@coq_type_annotation]) witness value comb in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IDup_n (_, _, witness, k) ->
-          let rec aux :
+      | (IDup_n (_, _, witness, k), _, _) ->
+          let[@coq_struct "witness"] rec aux :
               type before after.
               (before, after) dup_n_gadt_witness -> before -> after =
            fun witness stack ->
-            match (witness, stack) with
-            | (Dup_n_zero, (a, _)) -> a
-            | (Dup_n_succ witness', (_, tl)) -> aux witness' tl
+            match[@coq_match_gadt] (witness, stack) with
+            | (Dup_n_zero, (stack : after * _)) ->
+                let (a, _) = stack in
+                a
+            | (Dup_n_succ witness', (stack : _ * _)) ->
+                let (_, tl) = stack in
+                aux witness' tl
           in
           let stack = (accu, stack) in
-          let accu = aux witness stack in
+          let accu = (aux [@coq_type_annotation]) witness stack in
           (step [@ocaml.tailcall]) g gas k ks accu stack
       (* Tickets *)
-      | ITicket (_, k) ->
+      | (ITicket (_, k), _, (stack : _ * _)) ->
           let contents = accu in
           let (amount, stack) = stack in
           let ticketer = sc.self in
           let accu = {ticketer; contents; amount} in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | IRead_ticket (_, k) ->
+      | (IRead_ticket (_, k), (accu : _ ticket), _) ->
           let {ticketer; contents; amount} = accu in
           let stack = (accu, stack) in
           let destination : Destination.t = Contract ticketer in
           let addr = {destination; entrypoint = Entrypoint.default} in
           let accu = (addr, (contents, amount)) in
           (step [@ocaml.tailcall]) g gas k ks accu stack
-      | ISplit_ticket (_, k) ->
+      | (ISplit_ticket (_, k), (accu : _ ticket), (stack : (_ * _) * _)) ->
           let ticket = accu in
           let ((amount_a, amount_b), stack) = stack in
           let result =
@@ -1503,7 +1694,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
             else None
           in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | IJoin_tickets (_, contents_ty, k) ->
+      | (IJoin_tickets (_, contents_ty, k), (accu : _ ticket * _ ticket), _) ->
           let (ticket_a, ticket_b) = accu in
           let result =
             if
@@ -1524,7 +1715,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
             else None
           in
           (step [@ocaml.tailcall]) g gas k ks result stack
-      | IOpen_chest (_, k) ->
+      | ( IOpen_chest (_, k),
+          (accu : Script_timelock.chest_key),
+          (stack : Script_timelock.chest * (_ Script_int.num * _)) ) ->
           let open Timelock in
           let chest_key = accu in
           let (chest, (time_z, stack)) = stack in
@@ -1566,7 +1759,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type =
    that starts the evaluation.
 
 *)
-and log :
+and[@coq_struct "function_parameter"] log :
     type a s b t r f. logger * logging_event -> (a, s, b, t, r, f) step_type =
  fun (logger, event) ((ctxt, _) as g) gas k ks accu stack ->
   (match (k, event) with
@@ -1575,44 +1768,62 @@ and log :
   | (_, LogExit prev_kinfo) -> log_exit logger ctxt gas prev_kinfo k accu stack) ;
   let k = log_next_kinstr logger k in
   let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in
-  match k with
-  | IList_map (_, body, k) ->
-      (ilist_map [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack
-  | IList_iter (_, body, k) ->
+  match[@coq_match_gadt] (k, accu, stack) with
+  | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) ->
+      (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b2)"])
+        with_log
+        g
+        gas
+        (body, k)
+        ks
+        accu
+        stack
+  | (IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _)) ->
       (ilist_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack
-  | ISet_iter (_, body, k) ->
+  | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) ->
       (iset_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack
-  | IMap_map (_, body, k) ->
-      (imap_map [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack
-  | IMap_iter (_, body, k) ->
+  | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) ->
+      (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c2)"])
+        with_log
+        g
+        gas
+        (body, k)
+        ks
+        accu
+        stack
+  | (IMap_iter (_, body, k), (accu : _ map), (stack : _ * _)) ->
       (imap_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack
-  | ILoop (_, body, k) ->
+  | (ILoop (_, body, k), _, _) ->
       let ks = with_log (KLoop_in (body, KCons (k, ks))) in
       (next [@ocaml.tailcall]) g gas ks accu stack
-  | ILoop_left (_, bl, br) ->
+  | (ILoop_left (_, bl, br), _, _) ->
       let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in
       (next [@ocaml.tailcall]) g gas ks accu stack
-  | IMul_teznat (kinfo, k) ->
+  | (IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _)) ->
       let extra = (kinfo, k) in
       (imul_teznat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack
-  | IMul_nattez (kinfo, k) ->
+  | (IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _)) ->
       let extra = (kinfo, k) in
       (imul_nattez [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack
-  | ILsl_nat (kinfo, k) ->
+  | ( ILsl_nat (kinfo, k),
+      (accu : _ Script_int.num),
+      (stack : _ Script_int.num * _) ) ->
       let extra = (kinfo, k) in
       (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack
-  | ILsr_nat (kinfo, k) ->
+  | ( ILsr_nat (kinfo, k),
+      (accu : _ Script_int.num),
+      (stack : _ Script_int.num * _) ) ->
       let extra = (kinfo, k) in
       (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack
-  | IFailwith (_, kloc, tv) ->
+  | (IFailwith (_, kloc, tv), _, _) ->
       let {ifailwith} = ifailwith in
       (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu
-  | IExec (_, k) ->
+  | (IExec (_, k), _, (stack : _ lambda * _)) ->
       (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack
   | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack
  [@@inline]
 
-and klog :
+and[@coq_struct "gas"] klog :
     type a s r f.
     logger ->
     outdated_context * step_constants ->
@@ -1626,51 +1837,52 @@ and klog :
   (match ks with KLog _ -> () | _ -> log_control logger ks) ;
   let enable_log ki = log_kinstr logger ki in
   let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in
-  match ks with
-  | KCons (ki, ks') ->
+  match[@coq_match_gadt] (ks, accu, stack) with
+  | (KCons (ki, ks'), _, _) ->
       let log = enable_log ki in
       let ks = mk ks' in
       (step [@ocaml.tailcall]) g gas log ks accu stack
-  | KNil -> (next [@ocaml.tailcall]) g gas ks accu stack
-  | KLoop_in (ki, ks') ->
+  | (KNil, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack
+  | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) ->
       let ks' = mk ks' in
       let ki = enable_log ki in
       (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack
-  | KReturn (stack', ks') ->
+  | (KReturn (stack', ks'), _, _) ->
       let ks' = mk ks' in
       let ks = KReturn (stack', ks') in
       (next [@ocaml.tailcall]) g gas ks accu stack
-  | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack
-  | KLoop_in_left (ki, ks') ->
+  | (KMap_head (f, ks), _, _) ->
+      (next [@ocaml.tailcall]) g gas ks (f accu) stack
+  | (KLoop_in_left (ki, ks'), (accu : _ union), _) ->
       let ks' = mk ks' in
       let ki = enable_log ki in
       (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack
-  | KUndip (x, ks') ->
+  | (KUndip (x, ks'), _, _) ->
       let ks' = mk ks' in
       let ks = KUndip (x, ks') in
       (next [@ocaml.tailcall]) g gas ks accu stack
-  | KIter (body, xs, ks') ->
+  | (KIter (body, xs, ks'), _, _) ->
       let ks' = mk ks' in
       let body = enable_log body in
       (kiter [@ocaml.tailcall]) mk g gas (body, xs) ks' accu stack
-  | KList_enter_body (body, xs, ys, len, ks') ->
+  | (KList_enter_body (body, xs, ys, len, ks'), _, _) ->
       let ks' = mk ks' in
       let extra = (body, xs, ys, len) in
       (klist_enter [@ocaml.tailcall]) mk g gas extra ks' accu stack
-  | KList_exit_body (body, xs, ys, len, ks') ->
+  | (KList_exit_body (body, xs, ys, len, ks'), _, (stack : _ * _)) ->
       let ks' = mk ks' in
       let extra = (body, xs, ys, len) in
       (klist_exit [@ocaml.tailcall]) mk g gas extra ks' accu stack
-  | KMap_enter_body (body, xs, ys, ks') ->
+  | (KMap_enter_body (body, xs, ys, ks'), _, _) ->
       let ks' = mk ks' in
       (kmap_enter [@ocaml.tailcall]) mk g gas (body, xs, ys) ks' accu stack
-  | KMap_exit_body (body, xs, ys, yk, ks') ->
+  | (KMap_exit_body (body, xs, ys, yk, ks'), _, (stack : _ * _)) ->
       let ks' = mk ks' in
       (kmap_exit [@ocaml.tailcall]) mk g gas (body, xs, ys, yk) ks' accu stack
-  | KView_exit (orig_step_constants, ks') ->
+  | (KView_exit (orig_step_constants, ks'), _, _) ->
       let g = (fst g, orig_step_constants) in
       (next [@ocaml.tailcall]) g gas ks' accu stack
-  | KLog (_, _) ->
+  | (KLog (_, _), _, _) ->
       (* This case should never happen. *)
       (next [@ocaml.tailcall]) g gas ks accu stack
  [@@inline]
@@ -1715,7 +1927,7 @@ let kstep logger ctxt step_constants kinstr accu stack =
 let internal_step ctxt step_constants gas kinstr accu stack =
   step (ctxt, step_constants) gas kinstr KNil accu stack
 
-let step logger ctxt step_constants descr stack =
+let test_step logger ctxt step_constants descr stack =
   step_descr ~log_now:false logger (ctxt, step_constants) descr stack
 
 (*
@@ -1769,18 +1981,18 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal
         ~legacy:true
         ~allow_forged_in_storage:true
   | Some ex_script -> return (ex_script, ctxt))
-  >>=? fun ( Ex_script
-               (Script
-                 {
-                   code_size;
-                   code;
-                   arg_type;
-                   storage = old_storage;
-                   storage_type;
-                   entrypoints;
-                   views;
-                 }),
-             ctxt ) ->
+  >>=? fun [@coq_match_gadt] ( Ex_script
+                                 (Script
+                                   {
+                                     code_size;
+                                     code;
+                                     arg_type;
+                                     storage = old_storage;
+                                     storage_type;
+                                     entrypoints;
+                                     views;
+                                   }),
+                               ctxt ) ->
   Gas_monad.run
     ctxt
     (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint)
@@ -1811,7 +2023,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal
   >>=? fun (storage, lazy_storage_diff, ctxt) ->
   trace
     Cannot_serialize_storage
-    ( unparse_data ctxt mode storage_type storage
+    ( (unparse_data [@coq_type_annotation]) ctxt mode storage_type storage
     >>=? fun (unparsed_storage, ctxt) ->
       Lwt.return
         ( Gas.consume ctxt (Script.strip_locations_cost unparsed_storage)
diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli
index c57869e469d0..3d23a61529ef 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.mli
+++ b/src/proto_alpha/lib_protocol/script_interpreter.mli
@@ -70,7 +70,7 @@ type step_constants = Script_typed_ir.step_constants = {
   level : Script_int.n Script_int.num;
 }
 
-val step :
+val test_step :
   logger option ->
   context ->
   Script_typed_ir.step_constants ->
diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
index f6a23e91f5f6..aedb940d85b1 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
@@ -441,42 +441,47 @@ let[@coq_struct "w_value"] rec kundip :
    formal argument to [v]. The type of [v] is represented by [ty]. *)
 let apply ctxt gas capture_ty capture lam =
   let (Lam (descr, expr)) = lam in
-  let[@coq_match_with_default] (Item_t (full_arg_ty, _)) = descr.kbef in
-  let ctxt = update_context gas ctxt in
-  unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) ->
-  let loc = Micheline.dummy_location in
-  unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) ->
-  match full_arg_ty with
-  | Pair_t (capture_ty, arg_ty, _, _) ->
-      let arg_stack_ty = Item_t (arg_ty, Bot_t) in
-      let full_descr =
-        {
-          kloc = descr.kloc;
-          kbef = arg_stack_ty;
-          kaft = descr.kaft;
-          kinstr =
-            (let kinfo_const = {iloc = descr.kloc; kstack_ty = arg_stack_ty} in
-             let kinfo_pair =
-               {
-                 iloc = descr.kloc;
-                 kstack_ty = Item_t (capture_ty, arg_stack_ty);
-               }
-             in
-             IConst (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr)));
-        }
-      in
-      let full_expr =
-        Micheline.Seq
-          ( loc,
-            [
-              Prim (loc, I_PUSH, [ty_expr; const_expr], []);
-              Prim (loc, I_PAIR, [], []);
-              expr;
-            ] )
-      in
-      let lam' = Lam (full_descr, full_expr) in
-      let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
-      return (lam', ctxt, gas)
+  match[@coq_match_with_default] descr.kbef with
+  | Item_t (full_arg_ty, _) -> (
+      let ctxt = update_context gas ctxt in
+      unparse_data ctxt Optimized capture_ty capture
+      >>=? fun (const_expr, ctxt) ->
+      let loc = Micheline.dummy_location in
+      unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) ->
+      match full_arg_ty with
+      | Pair_t (capture_ty, arg_ty, _, _) ->
+          let arg_stack_ty = Item_t (arg_ty, Bot_t) in
+          let full_descr =
+            {
+              kloc = descr.kloc;
+              kbef = arg_stack_ty;
+              kaft = descr.kaft;
+              kinstr =
+                (let kinfo_const =
+                   {iloc = descr.kloc; kstack_ty = arg_stack_ty}
+                 in
+                 let kinfo_pair =
+                   {
+                     iloc = descr.kloc;
+                     kstack_ty = Item_t (capture_ty, arg_stack_ty);
+                   }
+                 in
+                 IConst
+                   (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr)));
+            }
+          in
+          let full_expr =
+            Micheline.Seq
+              ( loc,
+                [
+                  Prim (loc, I_PUSH, [ty_expr; const_expr], []);
+                  Prim (loc, I_PAIR, [], []);
+                  expr;
+                ] )
+          in
+          let lam' = Lam (full_descr, full_expr) in
+          let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
+          return (lam', ctxt, gas))
 
 (* [transfer (ctxt, sc) gas tez parameters_ty parameters destination entrypoint]
    creates an operation that transfers an amount of [tez] to
diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml
index 2736fa2f42ac..027f83b15edd 100644
--- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml
+++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml
@@ -56,9 +56,9 @@ let logger =
 let run_step ctxt code accu stack =
   let open Script_interpreter in
   let open Contract_helpers in
-  step None ctxt default_step_constants code accu stack
+  test_step None ctxt default_step_constants code accu stack
   >>=? fun ((_, _, ctxt') as r) ->
-  step (Some logger) ctxt default_step_constants code accu stack
+  test_step (Some logger) ctxt default_step_constants code accu stack
   >>=? fun (_, _, ctxt'') ->
   if Gas.(remaining_operation_gas ctxt' <> remaining_operation_gas ctxt'') then
     Alcotest.failf "Logging should not have an impact on gas consumption." ;
-- 
GitLab


From 8d2a7cf91998edf5b6c06d56be885362716d1a95 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 8 Dec 2021 16:06:22 +0100
Subject: [PATCH 24/69] Protocol: INTERNAL: use an explicit module to represent
 Raw_context

---
 src/proto_alpha/lib_protocol/raw_context.ml  | 69 ++++++++++++++++++++
 src/proto_alpha/lib_protocol/raw_context.mli |  2 +
 src/proto_alpha/lib_protocol/storage.ml      | 42 ++++++------
 3 files changed, 92 insertions(+), 21 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml
index 502ed8486379..055867558c29 100644
--- a/src/proto_alpha/lib_protocol/raw_context.ml
+++ b/src/proto_alpha/lib_protocol/raw_context.ml
@@ -1381,3 +1381,72 @@ module Sc_rollup_in_memory_inbox = struct
     let back = {ctxt.back with sc_rollup_current_messages} in
     {ctxt with back}
 end
+
+(** Explicit module to present this file as a record in Coq and reduce the size
+    of the generated Coq code. *)
+module M : T with type t = root = struct
+  type t = root
+
+  type error += Block_quota_exceeded = Block_quota_exceeded
+
+  type error += Operation_quota_exceeded = Operation_quota_exceeded
+
+  let mem = mem
+
+  let mem_tree = mem_tree
+
+  let get = get
+
+  let get_tree = get_tree
+
+  let find = find
+
+  let find_tree = find_tree
+
+  let list = list
+
+  let init = init
+
+  let init_tree = init_tree
+
+  let update = update
+
+  let update_tree = update_tree
+
+  let add = add
+
+  let add_tree = add_tree
+
+  let remove = remove
+
+  let remove_existing = remove_existing
+
+  let remove_existing_tree = remove_existing_tree
+
+  let add_or_remove = add_or_remove
+
+  let add_or_remove_tree = add_or_remove_tree
+
+  let fold = fold
+
+  let config = config
+
+  module Tree = Tree
+  module Proof = Proof
+
+  let verify_tree_proof = verify_tree_proof
+
+  let verify_stream_proof = verify_stream_proof
+
+  let equal_config = equal_config
+
+  let project : t -> root = project
+
+  let absolute_key : t -> key -> key = absolute_key
+
+  let consume_gas = consume_gas
+
+  let check_enough_gas = check_enough_gas
+
+  let description : t Storage_description.t = description
+end
diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli
index fae1a0821da2..c72697cdfcb4 100644
--- a/src/proto_alpha/lib_protocol/raw_context.mli
+++ b/src/proto_alpha/lib_protocol/raw_context.mli
@@ -370,3 +370,5 @@ module Sc_rollup_in_memory_inbox : sig
 
   val set_current_messages : t -> Sc_rollup_repr.t -> Context.tree -> t
 end
+
+module M : T with type t = root
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 7dd72760ddad..c94ae186188b 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -93,7 +93,7 @@ module type Simple_single_data_storage = sig
 end
 
 module Block_round : Simple_single_data_storage with type value = Round_repr.t =
-  Make_single_data_storage (Registered) (Raw_context)
+  Make_single_data_storage (Registered) (Raw_context.M)
     (struct
       let name = ["block_round"]
     end)
@@ -101,7 +101,7 @@ module Block_round : Simple_single_data_storage with type value = Round_repr.t =
 
 module Tenderbake = struct
   module First_level_legacy =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["first_level_of_Tenderbake"]
       end)
@@ -125,14 +125,14 @@ module Tenderbake = struct
   end
 
   module Endorsement_branch =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["endorsement_branch"]
       end)
       (Branch)
 
   module Grand_parent_branch =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["grand_parent_branch"]
       end)
@@ -171,7 +171,7 @@ end
 
 module Contract = struct
   module Raw_context =
-    Make_subcontext (Registered) (Raw_context)
+    Make_subcontext (Registered) (Raw_context.M)
       (struct
         let name = ["contracts"]
       end)
@@ -397,7 +397,7 @@ module Global_constants = struct
        and type key = Script_expr_hash.t
        and type value = Script_repr.expr =
     Make_indexed_carbonated_data_storage
-      (Make_subcontext (Registered) (Raw_context)
+      (Make_subcontext (Registered) (Raw_context.M)
          (struct
            let name = ["global_constant"]
          end))
@@ -415,7 +415,7 @@ module Big_map = struct
   type id = Lazy_storage_kind.Big_map.Id.t
 
   module Raw_context =
-    Make_subcontext (Registered) (Raw_context)
+    Make_subcontext (Registered) (Raw_context.M)
       (struct
         let name = ["big_maps"]
       end)
@@ -550,7 +550,7 @@ module Sapling = struct
   type id = Lazy_storage_kind.Sapling_state.Id.t
 
   module Raw_context =
-    Make_subcontext (Registered) (Raw_context)
+    Make_subcontext (Registered) (Raw_context.M)
       (struct
         let name = ["sapling"]
       end)
@@ -906,7 +906,7 @@ end
 
 module Delegates =
   Make_data_set_storage
-    (Make_subcontext (Registered) (Raw_context)
+    (Make_subcontext (Registered) (Raw_context.M)
        (struct
          let name = ["delegates"]
        end))
@@ -932,7 +932,7 @@ end
 module Cycle = struct
   module Indexed_context =
     Make_indexed_subcontext
-      (Make_subcontext (Registered) (Raw_context)
+      (Make_subcontext (Registered) (Raw_context.M)
          (struct
            let name = ["cycle"]
          end))
@@ -1047,7 +1047,7 @@ module Slashed_deposits = Cycle.Slashed_deposits
 module Stake = struct
   module Staking_balance =
     Make_indexed_data_snapshotable_storage
-      (Make_subcontext (Registered) (Raw_context)
+      (Make_subcontext (Registered) (Raw_context.M)
          (struct
            let name = ["staking_balance"]
          end))
@@ -1057,7 +1057,7 @@ module Stake = struct
 
   module Active_delegate_with_one_roll =
     Make_indexed_data_snapshotable_storage
-      (Make_subcontext (Registered) (Raw_context)
+      (Make_subcontext (Registered) (Raw_context.M)
          (struct
            let name = ["active_delegate_with_one_roll"]
          end))
@@ -1087,7 +1087,7 @@ module Stake = struct
      The ratio above (blocks_per_cycle / blocks_per_stake_snapshot) is checked
      in {!val:Constants_repr.check_constants} to fit in a UInt16. *)
   module Last_snapshot =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["last_snapshot"]
       end)
@@ -1101,7 +1101,7 @@ module Delegate_sampler_state = Cycle.Delegate_sampler_state
 
 module Vote = struct
   module Raw_context =
-    Make_subcontext (Registered) (Raw_context)
+    Make_subcontext (Registered) (Raw_context.M)
       (struct
         let name = ["votes"]
       end)
@@ -1268,7 +1268,7 @@ end
 
 module Commitments =
   Make_indexed_data_storage
-    (Make_subcontext (Registered) (Raw_context)
+    (Make_subcontext (Registered) (Raw_context.M)
        (struct
          let name = ["commitments"]
        end))
@@ -1286,7 +1286,7 @@ module Ramp_up = struct
 
   module Rewards =
     Make_indexed_data_storage
-      (Make_subcontext (Registered) (Raw_context)
+      (Make_subcontext (Registered) (Raw_context.M)
          (struct
            let name = ["ramp_up"; "rewards"]
          end))
@@ -1322,7 +1322,7 @@ end
 
 module Pending_migration = struct
   module Balance_updates =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["pending_migration_balance_updates"]
       end)
@@ -1333,7 +1333,7 @@ module Pending_migration = struct
       end)
 
   module Operation_results =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["pending_migration_operation_results"]
       end)
@@ -1368,7 +1368,7 @@ end
 
 module Liquidity_baking = struct
   module Toggle_ema =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         (* The old "escape" name is kept here to avoid migrating this. *)
         let name = ["liquidity_baking_escape_ema"]
@@ -1376,7 +1376,7 @@ module Liquidity_baking = struct
       (Encoding.Int32)
 
   module Cpmm_address =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["liquidity_baking_cpmm_address"]
       end)
@@ -1396,7 +1396,7 @@ end
 
 module Tx_rollup = struct
   module Raw_context =
-    Make_subcontext (Registered) (Raw_context)
+    Make_subcontext (Registered) (Raw_context.M)
       (struct
         let name = ["tx_rollup"]
       end)
-- 
GitLab


From e190f53f2b73ad5547c80de8f67a2b2e6c8235be Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 10 Dec 2021 08:51:45 +0100
Subject: [PATCH 25/69] Protocol: remove type abstractions for coq-of-ocaml

---
 src/proto_alpha/lib_protocol/alpha_context.mli | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 97c0caca81c1..e5d145e0d957 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -101,9 +101,9 @@ module Slot : sig
 end
 
 module Tez : sig
-  type repr
+  type repr = Tez_repr.repr
 
-  type t = Tez_tag of repr [@@ocaml.unboxed]
+  type t = Tez_repr.t = Tez_tag of repr [@@ocaml.unboxed]
 
   include BASIC_DATA with type t := t
 
-- 
GitLab


From bd2ea0827a3b31d26a04020b9e26c8de890f6cbc Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 16 Dec 2021 18:50:46 +0100
Subject: [PATCH 26/69] Proto: WIP: current changes

---
 src/proto_alpha/lib_protocol/alpha_context.ml | 1 -
 src/proto_alpha/lib_protocol/gas_monad.ml     | 2 +-
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml
index ed0c40bb8c33..c87c209f6bb8 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.ml
+++ b/src/proto_alpha/lib_protocol/alpha_context.ml
@@ -150,7 +150,6 @@ end
 
 module Round = struct
   include Round_repr
-  module Durations = Durations
 
   type round_durations = Durations.t
 
diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml
index 1ab7a6149545..7f5c435abbe6 100644
--- a/src/proto_alpha/lib_protocol/gas_monad.ml
+++ b/src/proto_alpha/lib_protocol/gas_monad.ml
@@ -47,7 +47,7 @@ let ( >>?? ) m f =
 
 let bind m f gas =
   m gas >>?? fun (res, gas) ->
-  match res with Ok y -> f y gas | Error _ as err -> of_result err gas
+  match res with Ok y -> f y gas | Error err -> of_result (Error err) gas
   [@@ocaml.inline always]
 
 let map f m gas =
-- 
GitLab


From cd311825e19673cfa96e13be5d7b53a58dbf5d7a Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Mon, 20 Dec 2021 15:49:02 +0100
Subject: [PATCH 27/69] Proto: add annotations to remove GADT axioms in Coq

---
 src/proto_alpha/lib_protocol/apply_results.ml | 101 ++++++++++--------
 .../lib_protocol/operation_repr.ml            |  95 +++++++++-------
 2 files changed, 114 insertions(+), 82 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index fe954ecd1300..197d34942844 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -329,7 +329,7 @@ module Manager_result = struct
     in
     MCase {op_case; encoding; kind; select; proj; inj; t}
 
-  let[@coq_axiom_with_reason "gadt"] reveal_case =
+  let reveal_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.reveal_case
       ~encoding:
@@ -341,14 +341,14 @@ module Manager_result = struct
         | Successful_manager_result (Reveal_result _ as op) -> Some op
         | _ -> None)
       ~kind:Kind.Reveal_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Reveal_result {consumed_gas} ->
             (Gas.Arith.ceil consumed_gas, consumed_gas))
       ~inj:(fun (consumed_gas, consumed_milligas) ->
         assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ;
         Reveal_result {consumed_gas = consumed_milligas})
 
-  let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases =
+  let transaction_contract_variant_cases =
     union
       [
         case
@@ -447,7 +447,7 @@ module Manager_result = struct
               });
       ]
 
-  let[@coq_axiom_with_reason "gadt"] transaction_case =
+  let transaction_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.transaction_case
       ~encoding:transaction_contract_variant_cases
@@ -455,10 +455,10 @@ module Manager_result = struct
         | Successful_manager_result (Transaction_result _ as op) -> Some op
         | _ -> None)
       ~kind:Kind.Transaction_manager_kind
-      ~proj:(function Transaction_result x -> x)
+      ~proj:(function[@coq_match_with_default] Transaction_result x -> x)
       ~inj:(fun x -> Transaction_result x)
 
-  let[@coq_axiom_with_reason "gadt"] origination_case =
+  let origination_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.origination_case
       ~encoding:
@@ -473,7 +473,7 @@ module Manager_result = struct
       ~select:(function
         | Successful_manager_result (Origination_result _ as op) -> Some op
         | _ -> None)
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Origination_result
             {
               lazy_storage_diff;
@@ -510,7 +510,7 @@ module Manager_result = struct
             paid_storage_size_diff;
           })
 
-  let[@coq_axiom_with_reason "gadt"] register_global_constant_case =
+  let register_global_constant_case =
     make
       ~op_case:
         Operation.Encoding.Manager_operations.register_global_constant_case
@@ -525,7 +525,7 @@ module Manager_result = struct
         | Successful_manager_result (Register_global_constant_result _ as op) ->
             Some op
         | _ -> None)
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Register_global_constant_result
             {balance_updates; consumed_gas; size_of_constant; global_address} ->
             ( balance_updates,
@@ -588,7 +588,7 @@ module Manager_result = struct
         assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ;
         Set_deposits_limit_result {consumed_gas = consumed_milligas})
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case =
+  let tx_rollup_origination_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.tx_rollup_origination_case
       ~encoding:
@@ -603,7 +603,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_origination_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_origination_result
             {balance_updates; consumed_gas; originated_tx_rollup} ->
             ( balance_updates,
@@ -1271,7 +1271,7 @@ module Encoding = struct
       (fun x -> match proj x with None -> None | Some x -> Some ((), x))
       (fun ((), x) -> inj x)
 
-  let[@coq_axiom_with_reason "gadt"] preendorsement_case =
+  let preendorsement_case =
     Case
       {
         op_case = Operation.Encoding.preendorsement_case;
@@ -1289,7 +1289,7 @@ module Encoding = struct
           | Contents_and_result ((Preendorsement _ as op), res) -> Some (op, res)
           | _ -> None);
         proj =
-          (function
+          (function[@coq_match_with_default]
           | Preendorsement_result
               {balance_updates; delegate; preendorsement_power} ->
               (balance_updates, delegate, preendorsement_power));
@@ -1299,7 +1299,7 @@ module Encoding = struct
               {balance_updates; delegate; preendorsement_power});
       }
 
-  let[@coq_axiom_with_reason "gadt"] endorsement_case =
+  let endorsement_case =
     Case
       {
         op_case = Operation.Encoding.endorsement_case;
@@ -1316,7 +1316,7 @@ module Encoding = struct
           | Contents_and_result ((Endorsement _ as op), res) -> Some (op, res)
           | _ -> None);
         proj =
-          (function
+          (function[@coq_match_with_default]
           | Endorsement_result {balance_updates; delegate; endorsement_power} ->
               (balance_updates, delegate, endorsement_power));
         inj =
@@ -1324,7 +1324,7 @@ module Encoding = struct
             Endorsement_result {balance_updates; delegate; endorsement_power});
       }
 
-  let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case =
+  let seed_nonce_revelation_case =
     Case
       {
         op_case = Operation.Encoding.seed_nonce_revelation_case;
@@ -1339,11 +1339,13 @@ module Encoding = struct
           | Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
               Some (op, res)
           | _ -> None);
-        proj = (fun (Seed_nonce_revelation_result bus) -> bus);
+        proj =
+          (fun [@coq_match_with_default] (Seed_nonce_revelation_result bus) ->
+            bus);
         inj = (fun bus -> Seed_nonce_revelation_result bus);
       }
 
-  let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case =
+  let double_endorsement_evidence_case =
     Case
       {
         op_case = Operation.Encoding.double_endorsement_evidence_case;
@@ -1359,11 +1361,14 @@ module Encoding = struct
           | Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
               Some (op, res)
           | _ -> None);
-        proj = (fun (Double_endorsement_evidence_result bus) -> bus);
+        proj =
+          (fun [@coq_match_with_default] (Double_endorsement_evidence_result
+                                           bus) ->
+            bus);
         inj = (fun bus -> Double_endorsement_evidence_result bus);
       }
 
-  let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case =
+  let double_preendorsement_evidence_case =
     Case
       {
         op_case = Operation.Encoding.double_preendorsement_evidence_case;
@@ -1380,11 +1385,14 @@ module Encoding = struct
             ->
               Some (op, res)
           | _ -> None);
-        proj = (fun (Double_preendorsement_evidence_result bus) -> bus);
+        proj =
+          (fun [@coq_match_with_default] (Double_preendorsement_evidence_result
+                                           bus) ->
+            bus);
         inj = (fun bus -> Double_preendorsement_evidence_result bus);
       }
 
-  let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case =
+  let double_baking_evidence_case =
     Case
       {
         op_case = Operation.Encoding.double_baking_evidence_case;
@@ -1399,11 +1407,13 @@ module Encoding = struct
           | Contents_and_result ((Double_baking_evidence _ as op), res) ->
               Some (op, res)
           | _ -> None);
-        proj = (fun (Double_baking_evidence_result bus) -> bus);
+        proj =
+          (fun [@coq_match_with_default] (Double_baking_evidence_result bus) ->
+            bus);
         inj = (fun bus -> Double_baking_evidence_result bus);
       }
 
-  let[@coq_axiom_with_reason "gadt"] activate_account_case =
+  let activate_account_case =
     Case
       {
         op_case = Operation.Encoding.activate_account_case;
@@ -1418,11 +1428,12 @@ module Encoding = struct
           | Contents_and_result ((Activate_account _ as op), res) ->
               Some (op, res)
           | _ -> None);
-        proj = (fun (Activate_account_result bus) -> bus);
+        proj =
+          (fun [@coq_match_with_default] (Activate_account_result bus) -> bus);
         inj = (fun bus -> Activate_account_result bus);
       }
 
-  let[@coq_axiom_with_reason "gadt"] proposals_case =
+  let proposals_case =
     Case
       {
         op_case = Operation.Encoding.proposals_case;
@@ -1434,11 +1445,11 @@ module Encoding = struct
           (function
           | Contents_and_result ((Proposals _ as op), res) -> Some (op, res)
           | _ -> None);
-        proj = (fun Proposals_result -> ());
+        proj = (fun [@coq_match_with_default] Proposals_result -> ());
         inj = (fun () -> Proposals_result);
       }
 
-  let[@coq_axiom_with_reason "gadt"] ballot_case =
+  let ballot_case =
     Case
       {
         op_case = Operation.Encoding.ballot_case;
@@ -1450,11 +1461,11 @@ module Encoding = struct
           (function
           | Contents_and_result ((Ballot _ as op), res) -> Some (op, res)
           | _ -> None);
-        proj = (fun Ballot_result -> ());
+        proj = (fun [@coq_match_with_default] Ballot_result -> ());
         inj = (fun () -> Ballot_result);
       }
 
-  let[@coq_axiom_with_reason "gadt"] make_manager_case (type kind)
+  let make_manager_case (type kind)
       (Operation.Encoding.Case op_case :
         kind Kind.manager Operation.Encoding.case)
       (Manager_result.MCase res_case : kind Manager_result.case) mselect =
@@ -1518,12 +1529,12 @@ module Encoding = struct
           | Contents_result Proposals_result -> None);
         mselect;
         proj =
-          (fun (Manager_operation_result
-                 {
-                   balance_updates = bus;
-                   operation_result = r;
-                   internal_operation_results = rs;
-                 }) ->
+          (fun [@coq_match_with_default] (Manager_operation_result
+                                           {
+                                             balance_updates = bus;
+                                             operation_result = r;
+                                             internal_operation_results = rs;
+                                           }) ->
             (bus, r, rs));
         inj =
           (fun (bus, r, rs) ->
@@ -1535,7 +1546,7 @@ module Encoding = struct
               });
       }
 
-  let[@coq_axiom_with_reason "gadt"] reveal_case =
+  let reveal_case =
     make_manager_case
       Operation.Encoding.reveal_case
       Manager_result.reveal_case
@@ -1545,7 +1556,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] transaction_case =
+  let transaction_case =
     make_manager_case
       Operation.Encoding.transaction_case
       Manager_result.transaction_case
@@ -1555,7 +1566,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] origination_case =
+  let origination_case =
     make_manager_case
       Operation.Encoding.origination_case
       Manager_result.origination_case
@@ -1565,7 +1576,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] delegation_case =
+  let delegation_case =
     make_manager_case
       Operation.Encoding.delegation_case
       Manager_result.delegation_case
@@ -1575,7 +1586,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] register_global_constant_case =
+  let register_global_constant_case =
     make_manager_case
       Operation.Encoding.register_global_constant_case
       Manager_result.register_global_constant_case
@@ -1587,7 +1598,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case =
+  let set_deposits_limit_case =
     make_manager_case
       Operation.Encoding.set_deposits_limit_case
       Manager_result.set_deposits_limit_case
@@ -1598,7 +1609,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case =
+  let tx_rollup_origination_case =
     make_manager_case
       Operation.Encoding.tx_rollup_origination_case
       Manager_result.tx_rollup_origination_case
@@ -2454,13 +2465,13 @@ let rec kind_equal_list :
           | Some Eq -> Some Eq))
   | _ -> None
 
-let[@coq_axiom_with_reason "gadt"] rec pack_contents_list :
+let rec pack_contents_list :
     type kind.
     kind contents_list ->
     kind contents_result_list ->
     kind contents_and_result_list =
  fun contents res ->
-  match (contents, res) with
+  match[@coq_match_with_default] (contents, res) with
   | (Single op, Single_result res) -> Single_and_result (op, res)
   | (Cons (op, ops), Cons_result (res, ress)) ->
       Cons_and_result (op, res, pack_contents_list ops ress)
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index 245e3873a3f7..b3a09f1bb27b 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -42,6 +42,7 @@ module Kind = struct
 
   type 'a double_consensus_operation_evidence =
     | Double_consensus_operation_evidence
+  [@@coq_force_gadt]
 
   type double_endorsement_evidence =
     endorsement_consensus_kind double_consensus_operation_evidence
@@ -494,20 +495,20 @@ module Encoding = struct
           -> 'kind case
     [@@coq_force_gadt]
 
-    let[@coq_axiom_with_reason "gadt"] reveal_case =
+    let reveal_case =
       MCase
         {
           tag = 0;
           name = "reveal";
           encoding = obj1 (req "public_key" Signature.Public_key.encoding);
           select = (function Manager (Reveal _ as op) -> Some op | _ -> None);
-          proj = (function Reveal pkh -> pkh);
+          proj = (function[@coq_match_with_default] Reveal pkh -> pkh);
           inj = (fun pkh -> Reveal pkh);
         }
 
     let transaction_tag = 1
 
-    let[@coq_axiom_with_reason "gadt"] transaction_case =
+    let transaction_case =
       MCase
         {
           tag = transaction_tag;
@@ -524,7 +525,7 @@ module Encoding = struct
           select =
             (function Manager (Transaction _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Transaction {amount; destination; parameters; entrypoint} ->
                 let parameters =
                   if
@@ -546,7 +547,7 @@ module Encoding = struct
 
     let origination_tag = 2
 
-    let[@coq_axiom_with_reason "gadt"] origination_case =
+    let origination_case =
       MCase
         {
           tag = origination_tag;
@@ -559,7 +560,7 @@ module Encoding = struct
           select =
             (function Manager (Origination _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Origination {credit; delegate; script} ->
                 (credit, delegate, script));
           inj =
@@ -569,7 +570,7 @@ module Encoding = struct
 
     let delegation_tag = 3
 
-    let[@coq_axiom_with_reason "gadt"] delegation_case =
+    let delegation_case =
       MCase
         {
           tag = delegation_tag;
@@ -577,11 +578,11 @@ module Encoding = struct
           encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
           select =
             (function Manager (Delegation _ as op) -> Some op | _ -> None);
-          proj = (function Delegation key -> key);
+          proj = (function[@coq_match_with_default] Delegation key -> key);
           inj = (fun key -> Delegation key);
         }
 
-    let[@coq_axiom_with_reason "gadt"] register_global_constant_case =
+    let register_global_constant_case =
       MCase
         {
           tag = 4;
@@ -590,11 +591,13 @@ module Encoding = struct
           select =
             (function
             | Manager (Register_global_constant _ as op) -> Some op | _ -> None);
-          proj = (function Register_global_constant {value} -> value);
+          proj =
+            (function[@coq_match_with_default]
+            | Register_global_constant {value} -> value);
           inj = (fun value -> Register_global_constant {value});
         }
 
-    let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case =
+    let set_deposits_limit_case =
       MCase
         {
           tag = 5;
@@ -603,11 +606,12 @@ module Encoding = struct
           select =
             (function
             | Manager (Set_deposits_limit _ as op) -> Some op | _ -> None);
-          proj = (function Set_deposits_limit key -> key);
+          proj =
+            (function[@coq_match_with_default] Set_deposits_limit key -> key);
           inj = (fun key -> Set_deposits_limit key);
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case =
+    let tx_rollup_origination_case =
       MCase
         {
           tag = tx_rollup_operation_origination_tag;
@@ -616,7 +620,8 @@ module Encoding = struct
           select =
             (function
             | Manager (Tx_rollup_origination as op) -> Some op | _ -> None);
-          proj = (function Tx_rollup_origination -> ());
+          proj =
+            (function[@coq_match_with_default] Tx_rollup_origination -> ());
           inj = (fun () -> Tx_rollup_origination);
         }
 
@@ -961,10 +966,12 @@ module Encoding = struct
       }
 
   let preendorsement_encoding =
-    let make (Case {tag; name; encoding; select = _; proj; inj}) =
+    let make =
+     fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) ->
       case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
     in
-    let to_list : Kind.preendorsement contents_list -> _ = function
+    let to_list : Kind.preendorsement contents_list -> _ =
+      function[@coq_match_with_default]
       | Single o -> o
     in
     let of_list : Kind.preendorsement contents -> _ = function
@@ -1010,11 +1017,14 @@ module Encoding = struct
             Endorsement {slot; level; round; block_payload_hash});
       }
 
-  let[@coq_axiom_with_reason "gadt"] endorsement_encoding =
-    let make (Case {tag; name; encoding; select = _; proj; inj}) =
+  let endorsement_encoding =
+    let make =
+     fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) ->
       case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
     in
-    let to_list : Kind.endorsement contents_list -> _ = fun (Single o) -> o in
+    let to_list : Kind.endorsement contents_list -> _ =
+     fun [@coq_match_with_default] (Single o) -> o
+    in
     let of_list : Kind.endorsement contents -> _ = fun o -> Single o in
     def "inlined.endorsement"
     @@ conv
@@ -1032,7 +1042,7 @@ module Encoding = struct
                   @@ union [make endorsement_case]))
                (varopt "signature" Signature.encoding)))
 
-  let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case =
+  let seed_nonce_revelation_case =
     Case
       {
         tag = 1;
@@ -1044,11 +1054,13 @@ module Encoding = struct
         select =
           (function
           | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None);
-        proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce));
+        proj =
+          (fun [@coq_match_with_default] (Seed_nonce_revelation {level; nonce}) ->
+            (level, nonce));
         inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce});
       }
 
-  let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case :
+  let double_preendorsement_evidence_case :
       Kind.double_preendorsement_evidence case =
     Case
       {
@@ -1062,12 +1074,14 @@ module Encoding = struct
           (function
           | Contents (Double_preendorsement_evidence _ as op) -> Some op
           | _ -> None);
-        proj = (fun (Double_preendorsement_evidence {op1; op2}) -> (op1, op2));
+        proj =
+          (fun [@coq_match_with_default] (Double_preendorsement_evidence
+                                           {op1; op2}) ->
+            (op1, op2));
         inj = (fun (op1, op2) -> Double_preendorsement_evidence {op1; op2});
       }
 
-  let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case :
-      Kind.double_endorsement_evidence case =
+  let double_endorsement_evidence_case : Kind.double_endorsement_evidence case =
     Case
       {
         tag = 2;
@@ -1080,11 +1094,14 @@ module Encoding = struct
           (function
           | Contents (Double_endorsement_evidence _ as op) -> Some op
           | _ -> None);
-        proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2));
+        proj =
+          (fun [@coq_match_with_default] (Double_endorsement_evidence
+                                           {op1; op2}) ->
+            (op1, op2));
         inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2});
       }
 
-  let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case =
+  let double_baking_evidence_case =
     Case
       {
         tag = 3;
@@ -1096,11 +1113,13 @@ module Encoding = struct
         select =
           (function
           | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None);
-        proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2));
+        proj =
+          (fun [@coq_match_with_default] (Double_baking_evidence {bh1; bh2}) ->
+            (bh1, bh2));
         inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2});
       }
 
-  let[@coq_axiom_with_reason "gadt"] activate_account_case =
+  let activate_account_case =
     Case
       {
         tag = 4;
@@ -1113,13 +1132,14 @@ module Encoding = struct
           (function
           | Contents (Activate_account _ as op) -> Some op | _ -> None);
         proj =
-          (fun (Activate_account {id; activation_code}) ->
+          (fun [@coq_match_with_default] (Activate_account
+                                           {id; activation_code}) ->
             (id, activation_code));
         inj =
           (fun (id, activation_code) -> Activate_account {id; activation_code});
       }
 
-  let[@coq_axiom_with_reason "gadt"] proposals_case =
+  let proposals_case =
     Case
       {
         tag = 5;
@@ -1132,14 +1152,14 @@ module Encoding = struct
         select =
           (function Contents (Proposals _ as op) -> Some op | _ -> None);
         proj =
-          (fun (Proposals {source; period; proposals}) ->
+          (fun [@coq_match_with_default] (Proposals {source; period; proposals}) ->
             (source, period, proposals));
         inj =
           (fun (source, period, proposals) ->
             Proposals {source; period; proposals});
       }
 
-  let[@coq_axiom_with_reason "gadt"] ballot_case =
+  let ballot_case =
     Case
       {
         tag = 6;
@@ -1152,7 +1172,7 @@ module Encoding = struct
             (req "ballot" Vote_repr.ballot_encoding);
         select = (function Contents (Ballot _ as op) -> Some op | _ -> None);
         proj =
-          (function
+          (function[@coq_match_with_default]
           | Ballot {source; period; proposal; ballot} ->
               (source, period, proposal, ballot));
         inj =
@@ -1191,8 +1211,9 @@ module Encoding = struct
     Manager_operation
       {source; fee; counter; gas_limit; storage_limit; operation}
 
-  let[@coq_axiom_with_reason "gadt"] make_manager_case tag (type kind)
-      (Manager_operations.MCase mcase : kind Manager_operations.case) =
+  let make_manager_case tag (type kind) =
+   fun [@coq_match_gadt] (Manager_operations.MCase mcase :
+                           kind Manager_operations.case) ->
     Case
       {
         tag;
@@ -1206,7 +1227,7 @@ module Encoding = struct
               | Some operation -> Some (Manager_operation {op with operation}))
           | _ -> None);
         proj =
-          (function
+          (function[@coq_match_with_default]
           | Manager_operation {operation; _} as op ->
               (extract op, mcase.proj operation));
         inj = (fun (op, contents) -> rebuild op (mcase.inj contents));
-- 
GitLab


From 8004dd59e1938dd317a31a49fff3cd74409d5880 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 22 Dec 2021 18:24:23 +0100
Subject: [PATCH 28/69] Proto: WIP: changes to compile in Coq

---
 src/proto_alpha/lib_protocol/sc_rollup_repr.ml  | 6 ++++--
 src/proto_alpha/lib_protocol/sc_rollup_repr.mli | 1 +
 src/proto_alpha/lib_protocol/storage.ml         | 2 +-
 3 files changed, 6 insertions(+), 3 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml
index 82174159d320..411a3f4bfb6c 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml
@@ -167,9 +167,11 @@ let () =
     (fun loc -> Invalid_sc_rollup_address loc)
 
 let of_b58check s =
+  let error () = Error (Format.sprintf "Invalid_sc_rollup_address %s" s) in
   match Base58.decode s with
-  | Some (Address.Data hash) -> ok hash
-  | _ -> Error (Format.sprintf "Invalid_sc_rollup_address %s" s)
+  | Some data -> (
+      match data with Address.Data hash -> ok hash | _ -> error ())
+  | _ -> error ()
 
 let pp = Address.pp
 
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
index 72807ac004a5..ccfff22d9534 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
+++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
@@ -149,3 +149,4 @@ module Kind : sig
 
   val pp : Format.formatter -> t -> unit
 end
+[@@coq_plain_module]
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index c94ae186188b..624e50ecdb28 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1510,7 +1510,7 @@ end
 
 module Sc_rollup = struct
   module Raw_context =
-    Make_subcontext (Registered) (Raw_context)
+    Make_subcontext (Registered) (Raw_context.M)
       (struct
         let name = ["sc_rollup"]
       end)
-- 
GitLab


From 14cf8082d7fe146d6ca93eeb5892a6b1872e9b26 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 30 Dec 2021 18:14:40 +0100
Subject: [PATCH 29/69] Proto: WIP: compile more files

---
 src/proto_alpha/lib_protocol/apply_results.ml |  42 ++--
 .../lib_protocol/operation_repr.ml            | 176 +++++++-------
 .../lib_protocol/operation_repr.mli           | 222 +++++++++---------
 3 files changed, 222 insertions(+), 218 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 197d34942844..98b1d054d534 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -623,7 +623,7 @@ module Manager_result = struct
             originated_tx_rollup;
           })
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case =
+  let tx_rollup_submit_batch_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.tx_rollup_submit_batch_case
       ~encoding:
@@ -638,7 +638,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_submit_batch_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_submit_batch_result
             {balance_updates; consumed_gas; paid_storage_size_diff} ->
             ( balance_updates,
@@ -658,7 +658,7 @@ module Manager_result = struct
             paid_storage_size_diff;
           })
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case =
+  let tx_rollup_commit_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.tx_rollup_commit_case
       ~encoding:
@@ -672,7 +672,7 @@ module Manager_result = struct
         | Successful_manager_result (Tx_rollup_commit_result _ as op) -> Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_commit_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_commit_result
             {balance_updates; consumed_gas; paid_storage_size_diff} ->
             ( balance_updates,
@@ -692,7 +692,7 @@ module Manager_result = struct
             paid_storage_size_diff;
           })
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case =
+  let tx_rollup_return_bond_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.tx_rollup_return_bond_case
       ~encoding:
@@ -714,7 +714,7 @@ module Manager_result = struct
         Tx_rollup_return_bond_result
           {balance_updates; consumed_gas = consumed_milligas})
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case =
+  let tx_rollup_finalize_commitment_case =
     make
       ~op_case:
         Operation.Encoding.Manager_operations.tx_rollup_finalize_commitment_case
@@ -755,7 +755,7 @@ module Manager_result = struct
             paid_storage_size_diff;
           })
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case =
+  let tx_rollup_remove_commitment_case =
     make
       ~op_case:
         Operation.Encoding.Manager_operations.tx_rollup_remove_commitment_case
@@ -781,7 +781,7 @@ module Manager_result = struct
         Tx_rollup_remove_commitment_result
           {balance_updates; consumed_gas = consumed_milligas; level})
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case =
+  let tx_rollup_rejection_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.tx_rollup_rejection_case
       ~encoding:
@@ -803,7 +803,7 @@ module Manager_result = struct
         Tx_rollup_rejection_result
           {balance_updates; consumed_gas = consumed_milligas})
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_withdraw_case =
+  let tx_rollup_withdraw_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.tx_rollup_withdraw_case
       ~encoding:
@@ -818,7 +818,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_withdraw_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_withdraw_result
             {balance_updates; consumed_gas; paid_storage_size_diff} ->
             ( balance_updates,
@@ -838,7 +838,7 @@ module Manager_result = struct
             paid_storage_size_diff;
           })
 
-  let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case =
+  let sc_rollup_originate_case =
     make
       ~op_case:Operation.Encoding.Manager_operations.sc_rollup_originate_case
       ~encoding:
@@ -852,7 +852,7 @@ module Manager_result = struct
         | Successful_manager_result (Sc_rollup_originate_result _ as op) ->
             Some op
         | _ -> None)
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Sc_rollup_originate_result
             {balance_updates; address; consumed_gas; size} ->
             ( balance_updates,
@@ -1620,7 +1620,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case =
+  let tx_rollup_submit_batch_case =
     make_manager_case
       Operation.Encoding.tx_rollup_submit_batch_case
       Manager_result.tx_rollup_submit_batch_case
@@ -1631,7 +1631,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case =
+  let tx_rollup_commit_case =
     make_manager_case
       Operation.Encoding.tx_rollup_commit_case
       Manager_result.tx_rollup_commit_case
@@ -1642,7 +1642,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case =
+  let tx_rollup_return_bond_case =
     make_manager_case
       Operation.Encoding.tx_rollup_return_bond_case
       Manager_result.tx_rollup_return_bond_case
@@ -1653,7 +1653,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case =
+  let tx_rollup_finalize_commitment_case =
     make_manager_case
       Operation.Encoding.tx_rollup_finalize_commitment_case
       Manager_result.tx_rollup_finalize_commitment_case
@@ -1665,7 +1665,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case =
+  let tx_rollup_remove_commitment_case =
     make_manager_case
       Operation.Encoding.tx_rollup_remove_commitment_case
       Manager_result.tx_rollup_remove_commitment_case
@@ -1677,7 +1677,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case =
+  let tx_rollup_rejection_case =
     make_manager_case
       Operation.Encoding.tx_rollup_rejection_case
       Manager_result.tx_rollup_rejection_case
@@ -1688,7 +1688,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] tx_rollup_withdraw_case =
+  let tx_rollup_withdraw_case =
     make_manager_case
       Operation.Encoding.tx_rollup_withdraw_case
       Manager_result.tx_rollup_withdraw_case
@@ -1699,7 +1699,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case =
+  let sc_rollup_originate_case =
     make_manager_case
       Operation.Encoding.sc_rollup_originate_case
       Manager_result.sc_rollup_originate_case
@@ -1710,7 +1710,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case =
+  let sc_rollup_add_messages_case =
     make_manager_case
       Operation.Encoding.sc_rollup_add_messages_case
       Manager_result.sc_rollup_add_messages_case
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index b3a09f1bb27b..37afcd847230 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -214,75 +214,7 @@ type origination = {
   credit : Tez_repr.tez;
 }
 
-type 'kind operation = {
-  shell : Operation.shell_header;
-  protocol_data : 'kind protocol_data;
-}
-
-and 'kind protocol_data = {
-  contents : 'kind contents_list;
-  signature : Signature.t option;
-}
-
-and _ contents_list =
-  | Single : 'kind contents -> 'kind contents_list
-  | Cons :
-      'kind Kind.manager contents * 'rest Kind.manager contents_list
-      -> ('kind * 'rest) Kind.manager contents_list
-
-and _ contents =
-  | Preendorsement : consensus_content -> Kind.preendorsement contents
-  | Endorsement : consensus_content -> Kind.endorsement contents
-  | Seed_nonce_revelation : {
-      level : Raw_level_repr.t;
-      nonce : Seed_repr.nonce;
-    }
-      -> Kind.seed_nonce_revelation contents
-  | Double_preendorsement_evidence : {
-      op1 : Kind.preendorsement operation;
-      op2 : Kind.preendorsement operation;
-    }
-      -> Kind.double_preendorsement_evidence contents
-  | Double_endorsement_evidence : {
-      op1 : Kind.endorsement operation;
-      op2 : Kind.endorsement operation;
-    }
-      -> Kind.double_endorsement_evidence contents
-  | Double_baking_evidence : {
-      bh1 : Block_header_repr.t;
-      bh2 : Block_header_repr.t;
-    }
-      -> Kind.double_baking_evidence contents
-  | Activate_account : {
-      id : Ed25519.Public_key_hash.t;
-      activation_code : Blinded_public_key_hash.activation_code;
-    }
-      -> Kind.activate_account contents
-  | Proposals : {
-      source : Signature.Public_key_hash.t;
-      period : int32;
-      proposals : Protocol_hash.t list;
-    }
-      -> Kind.proposals contents
-  | Ballot : {
-      source : Signature.Public_key_hash.t;
-      period : int32;
-      proposal : Protocol_hash.t;
-      ballot : Vote_repr.ballot;
-    }
-      -> Kind.ballot contents
-  | Failing_noop : string -> Kind.failing_noop contents
-  | Manager_operation : {
-      source : Signature.public_key_hash;
-      fee : Tez_repr.tez;
-      counter : counter;
-      operation : 'kind manager_operation;
-      gas_limit : Gas_limit_repr.Arith.integral;
-      storage_limit : Z.t;
-    }
-      -> 'kind Kind.manager contents
-
-and _ manager_operation =
+type _ manager_operation =
   | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
   | Transaction : transaction -> Kind.transaction manager_operation
   | Origination : origination -> Kind.origination manager_operation
@@ -367,7 +299,75 @@ and _ manager_operation =
     }
       -> Kind.sc_rollup_publish manager_operation
 
-and counter = Z.t
+type counter = Z.t
+
+type 'kind operation = {
+  shell : Operation.shell_header;
+  protocol_data : 'kind protocol_data;
+}
+
+and 'kind protocol_data = {
+  contents : 'kind contents_list;
+  signature : Signature.t option;
+}
+
+and _ contents_list =
+  | Single : 'kind contents -> 'kind contents_list
+  | Cons :
+      'kind Kind.manager contents * 'rest Kind.manager contents_list
+      -> ('kind * 'rest) Kind.manager contents_list
+
+and _ contents =
+  | Preendorsement : consensus_content -> Kind.preendorsement contents
+  | Endorsement : consensus_content -> Kind.endorsement contents
+  | Seed_nonce_revelation : {
+      level : Raw_level_repr.t;
+      nonce : Seed_repr.nonce;
+    }
+      -> Kind.seed_nonce_revelation contents
+  | Double_preendorsement_evidence : {
+      op1 : Kind.preendorsement operation;
+      op2 : Kind.preendorsement operation;
+    }
+      -> Kind.double_preendorsement_evidence contents
+  | Double_endorsement_evidence : {
+      op1 : Kind.endorsement operation;
+      op2 : Kind.endorsement operation;
+    }
+      -> Kind.double_endorsement_evidence contents
+  | Double_baking_evidence : {
+      bh1 : Block_header_repr.t;
+      bh2 : Block_header_repr.t;
+    }
+      -> Kind.double_baking_evidence contents
+  | Activate_account : {
+      id : Ed25519.Public_key_hash.t;
+      activation_code : Blinded_public_key_hash.activation_code;
+    }
+      -> Kind.activate_account contents
+  | Proposals : {
+      source : Signature.Public_key_hash.t;
+      period : int32;
+      proposals : Protocol_hash.t list;
+    }
+      -> Kind.proposals contents
+  | Ballot : {
+      source : Signature.Public_key_hash.t;
+      period : int32;
+      proposal : Protocol_hash.t;
+      ballot : Vote_repr.ballot;
+    }
+      -> Kind.ballot contents
+  | Failing_noop : string -> Kind.failing_noop contents
+  | Manager_operation : {
+      source : Signature.public_key_hash;
+      fee : Tez_repr.tez;
+      counter : counter;
+      operation : 'kind manager_operation;
+      gas_limit : Gas_limit_repr.Arith.integral;
+      storage_limit : Z.t;
+    }
+      -> 'kind Kind.manager contents
 
 let manager_kind : type kind. kind manager_operation -> kind Kind.manager =
   function
@@ -631,7 +631,7 @@ module Encoding = struct
          encoding which is in hexadecimal for JSON. *)
       conv Bytes.of_string Bytes.to_string bytes
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case =
+    let tx_rollup_submit_batch_case =
       MCase
         {
           tag = tx_rollup_operation_submit_batch_tag;
@@ -645,7 +645,7 @@ module Encoding = struct
             (function
             | Manager (Tx_rollup_submit_batch _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} ->
                 (tx_rollup, content, burn_limit));
           inj =
@@ -653,7 +653,7 @@ module Encoding = struct
               Tx_rollup_submit_batch {tx_rollup; content; burn_limit});
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case =
+    let tx_rollup_commit_case =
       MCase
         {
           tag = tx_rollup_operation_commit_tag;
@@ -666,14 +666,14 @@ module Encoding = struct
             (function
             | Manager (Tx_rollup_commit _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment));
           inj =
             (fun (tx_rollup, commitment) ->
               Tx_rollup_commit {tx_rollup; commitment});
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case =
+    let tx_rollup_return_bond_case =
       MCase
         {
           tag = tx_rollup_operation_return_bond_tag;
@@ -686,7 +686,7 @@ module Encoding = struct
           inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup});
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case =
+    let tx_rollup_finalize_commitment_case =
       MCase
         {
           tag = tx_rollup_operation_finalize_commitment_tag;
@@ -701,7 +701,7 @@ module Encoding = struct
           inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup});
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case =
+    let tx_rollup_remove_commitment_case =
       MCase
         {
           tag = tx_rollup_operation_remove_commitment_tag;
@@ -716,7 +716,7 @@ module Encoding = struct
           inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup});
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case =
+    let tx_rollup_rejection_case =
       MCase
         {
           tag = tx_rollup_operation_rejection_tag;
@@ -862,7 +862,7 @@ module Encoding = struct
                 });
         }
 
-    let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case =
+    let sc_rollup_originate_case =
       MCase
         {
           tag = sc_rollup_operation_origination_tag;
@@ -875,13 +875,13 @@ module Encoding = struct
             (function
             | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Sc_rollup_originate {kind; boot_sector} -> (kind, boot_sector));
           inj =
             (fun (kind, boot_sector) -> Sc_rollup_originate {kind; boot_sector});
         }
 
-    let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case =
+    let sc_rollup_add_messages_case =
       MCase
         {
           tag = sc_rollup_operation_add_message_tag;
@@ -894,7 +894,7 @@ module Encoding = struct
             (function
             | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Sc_rollup_add_messages {rollup; messages} -> (rollup, messages));
           inj =
             (fun (rollup, messages) ->
@@ -967,7 +967,9 @@ module Encoding = struct
 
   let preendorsement_encoding =
     let make =
-     fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) ->
+     fun [@coq_grab_existentials] (Case
+                                    {tag; name; encoding; select = _; proj; inj})
+         ->
       case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
     in
     let to_list : Kind.preendorsement contents_list -> _ =
@@ -1019,7 +1021,9 @@ module Encoding = struct
 
   let endorsement_encoding =
     let make =
-     fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) ->
+     fun [@coq_grab_existentials] (Case
+                                    {tag; name; encoding; select = _; proj; inj})
+         ->
       case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
     in
     let to_list : Kind.endorsement contents_list -> _ =
@@ -1212,8 +1216,8 @@ module Encoding = struct
       {source; fee; counter; gas_limit; storage_limit; operation}
 
   let make_manager_case tag (type kind) =
-   fun [@coq_match_gadt] (Manager_operations.MCase mcase :
-                           kind Manager_operations.case) ->
+   fun [@coq_grab_existentials] (Manager_operations.MCase mcase :
+                                  kind Manager_operations.case) ->
     Case
       {
         tag;
diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli
index 7666ac1248c6..6bd4291136dc 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.mli
+++ b/src/proto_alpha/lib_protocol/operation_repr.mli
@@ -194,118 +194,9 @@ type origination = {
   credit : Tez_repr.tez;
 }
 
-(** An [operation] contains the operation header information in [shell]
-    and all data related to the operation itself in [protocol_data]. *)
-type 'kind operation = {
-  shell : Operation.shell_header;
-  protocol_data : 'kind protocol_data;
-}
-
-(** A [protocol_data] wraps together a signature for the operation and
-    the contents of the operation itself. *)
-and 'kind protocol_data = {
-  contents : 'kind contents_list;
-  signature : Signature.t option;
-}
-
-(** A [contents_list] is a list of contents, the GADT guarantees two
-    invariants:
-    - the list is not empty, and
-    - if the list has several elements then it only contains manager
-      operations. *)
-and _ contents_list =
-  | Single : 'kind contents -> 'kind contents_list
-  | Cons :
-      'kind Kind.manager contents * 'rest Kind.manager contents_list
-      -> ('kind * 'rest) Kind.manager contents_list
-
-(** A value of type [contents] an operation related to whether
-    consensus, governance or contract management. *)
-and _ contents =
-  (* Preendorsement: About consensus, preendorsement of a block held by a
-     validator (specific to Tenderbake). *)
-  | Preendorsement : consensus_content -> Kind.preendorsement contents
-  (* Endorsement: About consensus, endorsement of a block held by a
-     validator. *)
-  | Endorsement : consensus_content -> Kind.endorsement contents
-  (* Seed_nonce_revelation: Nonces are created by bakers and are
-     combined to create pseudo-random seeds. Bakers are urged to reveal their
-     nonces after a given number of cycles to keep their block rewards
-     from being forfeited. *)
-  | Seed_nonce_revelation : {
-      level : Raw_level_repr.t;
-      nonce : Seed_repr.nonce;
-    }
-      -> Kind.seed_nonce_revelation contents
-  (* Double_preendorsement_evidence: Double-preendorsement is a
-     kind of malicious attack where a byzantine attempts to fork
-     the chain by preendorsing blocks with different
-     contents (at the same level and same round)
-     twice. This behavior may be reported and the byzantine will have
-     its security deposit forfeited. *)
-  | Double_preendorsement_evidence : {
-      op1 : Kind.preendorsement operation;
-      op2 : Kind.preendorsement operation;
-    }
-      -> Kind.double_preendorsement_evidence contents
-  (* Double_endorsement_evidence: Similar to double-preendorsement but
-     for endorsements. *)
-  | Double_endorsement_evidence : {
-      op1 : Kind.endorsement operation;
-      op2 : Kind.endorsement operation;
-    }
-      -> Kind.double_endorsement_evidence contents
-  (* Double_baking_evidence: Similarly to double-endorsement but the
-     byzantine attempts to fork by signing two different blocks at the
-     same level. *)
-  | Double_baking_evidence : {
-      bh1 : Block_header_repr.t;
-      bh2 : Block_header_repr.t;
-    }
-      -> Kind.double_baking_evidence contents
-  (* Activate_account: Account activation allows to register a public
-     key hash on the blockchain. *)
-  | Activate_account : {
-      id : Ed25519.Public_key_hash.t;
-      activation_code : Blinded_public_key_hash.activation_code;
-    }
-      -> Kind.activate_account contents
-  (* Proposals: A candidate protocol can be proposed for voting. *)
-  | Proposals : {
-      source : Signature.Public_key_hash.t;
-      period : int32;
-      proposals : Protocol_hash.t list;
-    }
-      -> Kind.proposals contents
-  (* Ballot: The validators of the chain will then vote on proposals. *)
-  | Ballot : {
-      source : Signature.Public_key_hash.t;
-      period : int32;
-      proposal : Protocol_hash.t;
-      ballot : Vote_repr.ballot;
-    }
-      -> Kind.ballot contents
-  (* Failing_noop: An operation never considered by the state machine
-     and which will always fail at [apply]. This allows end-users to
-     sign arbitrary messages which have no computational semantics. *)
-  | Failing_noop : string -> Kind.failing_noop contents
-  (* Manager_operation: Operations, emitted and signed by
-     a (revealed) implicit account, that describe management and
-     interactions between contracts (whether implicit or
-     smart). *)
-  | Manager_operation : {
-      source : Signature.Public_key_hash.t;
-      fee : Tez_repr.tez;
-      counter : counter;
-      operation : 'kind manager_operation;
-      gas_limit : Gas_limit_repr.Arith.integral;
-      storage_limit : Z.t;
-    }
-      -> 'kind Kind.manager contents
-
 (** A [manager_operation] describes management and interactions
     between contracts (whether implicit or smart). *)
-and _ manager_operation =
+type _ manager_operation =
   (* [Reveal] for the revelation of a public key, a one-time
      prerequisite to any signed operation, in order to be able to
      check the sender’s signature. *)
@@ -443,7 +334,116 @@ and _ manager_operation =
     each manager operation declares a value for the counter. When
     a manager operation is applied, the value of the counter of
     its manager is checked and incremented. *)
-and counter = Z.t
+type counter = Z.t
+
+(** An [operation] contains the operation header information in [shell]
+    and all data related to the operation itself in [protocol_data]. *)
+type 'kind operation = {
+  shell : Operation.shell_header;
+  protocol_data : 'kind protocol_data;
+}
+
+(** A [protocol_data] wraps together a signature for the operation and
+    the contents of the operation itself. *)
+and 'kind protocol_data = {
+  contents : 'kind contents_list;
+  signature : Signature.t option;
+}
+
+(** A [contents_list] is a list of contents, the GADT guarantees two
+    invariants:
+    - the list is not empty, and
+    - if the list has several elements then it only contains manager
+      operations. *)
+and _ contents_list =
+  | Single : 'kind contents -> 'kind contents_list
+  | Cons :
+      'kind Kind.manager contents * 'rest Kind.manager contents_list
+      -> ('kind * 'rest) Kind.manager contents_list
+
+(** A value of type [contents] an operation related to whether
+    consensus, governance or contract management. *)
+and _ contents =
+  (* Preendorsement: About consensus, preendorsement of a block held by a
+     validator (specific to Tenderbake). *)
+  | Preendorsement : consensus_content -> Kind.preendorsement contents
+  (* Endorsement: About consensus, endorsement of a block held by a
+     validator. *)
+  | Endorsement : consensus_content -> Kind.endorsement contents
+  (* Seed_nonce_revelation: Nonces are created by bakers and are
+     combined to create pseudo-random seeds. Bakers are urged to reveal their
+     nonces after a given number of cycles to keep their block rewards
+     from being forfeited. *)
+  | Seed_nonce_revelation : {
+      level : Raw_level_repr.t;
+      nonce : Seed_repr.nonce;
+    }
+      -> Kind.seed_nonce_revelation contents
+  (* Double_preendorsement_evidence: Double-preendorsement is a
+     kind of malicious attack where a byzantine attempts to fork
+     the chain by preendorsing blocks with different
+     contents (at the same level and same round)
+     twice. This behavior may be reported and the byzantine will have
+     its security deposit forfeited. *)
+  | Double_preendorsement_evidence : {
+      op1 : Kind.preendorsement operation;
+      op2 : Kind.preendorsement operation;
+    }
+      -> Kind.double_preendorsement_evidence contents
+  (* Double_endorsement_evidence: Similar to double-preendorsement but
+     for endorsements. *)
+  | Double_endorsement_evidence : {
+      op1 : Kind.endorsement operation;
+      op2 : Kind.endorsement operation;
+    }
+      -> Kind.double_endorsement_evidence contents
+  (* Double_baking_evidence: Similarly to double-endorsement but the
+     byzantine attempts to fork by signing two different blocks at the
+     same level. *)
+  | Double_baking_evidence : {
+      bh1 : Block_header_repr.t;
+      bh2 : Block_header_repr.t;
+    }
+      -> Kind.double_baking_evidence contents
+  (* Activate_account: Account activation allows to register a public
+     key hash on the blockchain. *)
+  | Activate_account : {
+      id : Ed25519.Public_key_hash.t;
+      activation_code : Blinded_public_key_hash.activation_code;
+    }
+      -> Kind.activate_account contents
+  (* Proposals: A candidate protocol can be proposed for voting. *)
+  | Proposals : {
+      source : Signature.Public_key_hash.t;
+      period : int32;
+      proposals : Protocol_hash.t list;
+    }
+      -> Kind.proposals contents
+  (* Ballot: The validators of the chain will then vote on proposals. *)
+  | Ballot : {
+      source : Signature.Public_key_hash.t;
+      period : int32;
+      proposal : Protocol_hash.t;
+      ballot : Vote_repr.ballot;
+    }
+      -> Kind.ballot contents
+  (* Failing_noop: An operation never considered by the state machine
+     and which will always fail at [apply]. This allows end-users to
+     sign arbitrary messages which have no computational semantics. *)
+  | Failing_noop : string -> Kind.failing_noop contents
+  (* Manager_operation: Operations, emitted and signed by
+     a (revealed) implicit account, that describe management and
+     interactions between contracts (whether implicit or
+     smart). *)
+  | Manager_operation : {
+      source : Signature.Public_key_hash.t;
+      fee : Tez_repr.tez;
+      counter : counter;
+      operation : 'kind manager_operation;
+      gas_limit : Gas_limit_repr.Arith.integral;
+      storage_limit : Z.t;
+    }
+      -> 'kind Kind.manager contents
 
 type packed_manager_operation =
   | Manager : 'kind manager_operation -> packed_manager_operation
-- 
GitLab


From 472c3d4227370f6b30640ca1ff0ab81813d0a2ba Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 5 Jan 2022 14:40:11 +0100
Subject: [PATCH 30/69] Proto: WIP more annotations

---
 src/proto_alpha/lib_protocol/gas_monad.ml       | 16 ++++++++--------
 src/proto_alpha/lib_protocol/script_typed_ir.ml |  2 +-
 2 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml
index 7f5c435abbe6..f71b026b7f32 100644
--- a/src/proto_alpha/lib_protocol/gas_monad.ml
+++ b/src/proto_alpha/lib_protocol/gas_monad.ml
@@ -83,16 +83,16 @@ let run ctxt m =
       | None -> error Gas.Operation_quota_exceeded)
 
 let record_trace_eval :
-    type error_trace.
+    type a error_trace.
     error_details:error_trace Script_tc_errors.error_details ->
     (unit -> error) ->
-    ('a, error_trace) t ->
-    ('a, error_trace) t =
- fun ~error_details ->
-  match error_details with
-  | Fast -> fun _f m -> m
-  | Informative ->
-      fun f m gas ->
+    (a, error_trace) t ->
+    (a, error_trace) t =
+ fun ~error_details f m ->
+  match[@coq_match_gadt_with_result] (error_details, m) with
+  | (Fast, _) -> m
+  | (Informative, (m : (_, _ trace) t)) ->
+      fun gas ->
         m gas >>?? fun (x, gas) -> of_result (record_trace_eval f x) gas
 
 let fail e = of_result (Error e) [@@ocaml.inline always]
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index 7dc9ec48bb08..614b878f950d 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -296,7 +296,7 @@ module Type_size : TYPE_SIZE = struct
     if Compare.Int.(x = y) then Result.return_unit
     else
       Error
-        (match error_details with
+        (match[@coq_match_gadt_with_result] error_details with
         | Fast -> Inconsistent_types_fast
         | Informative ->
             trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y))
-- 
GitLab


From 2bd5f1dcb4bd00aebc5a3d6eeaaa0a7e1040b4ba Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 7 Jan 2022 11:43:18 +0100
Subject: [PATCH 31/69] Proto: CODE SWAP: move non-mutually recursive
 definition

---
 .../lib_protocol/script_interpreter.ml        | 24 +++++++++----------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index 1d78daf85fe7..88dce0786b0e 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -234,6 +234,18 @@ let () =
 
 *)
 
+let ifailwith : ifailwith_type =
+  {
+    ifailwith =
+      (fun logger (ctxt, _) gas kloc tv accu ->
+        let v = accu in
+        let ctxt = update_context gas ctxt in
+        trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
+        >>=? fun (v, _ctxt) ->
+        let v = Micheline.strip_locations v in
+        get_log logger >>=? fun log -> fail (Reject (kloc, v, log)));
+  }
+
 (*
 
     Evaluation of continuations
@@ -465,18 +477,6 @@ and[@coq_struct "gas"] ilsr_nat :
   | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log))
   | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack
 
-and[@coq_struct "function_parameter"] ifailwith : ifailwith_type =
-  {
-    ifailwith =
-      (fun logger (ctxt, _) gas kloc tv accu ->
-        let v = accu in
-        let ctxt = update_context gas ctxt in
-        trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
-        >>=? fun (v, _ctxt) ->
-        let v = Micheline.strip_locations v in
-        get_log logger >>=? fun log -> fail (Reject (kloc, v, log)));
-  }
-
 and[@coq_struct "gas"] iexec :
     type a b c d e f g. (a, b, c, d, e, f, g) iexec_type =
  fun logger g gas k ks accu stack ->
-- 
GitLab


From 053474f1d887987b9e5071c0713f2e7e06594d8b Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 11 Jan 2022 14:06:30 +0100
Subject: [PATCH 32/69] Proto: translate script_typed_ir_size.ml in Coq

---
 .../lib_protocol/script_typed_ir_size.ml      | 52 +++++++++++--------
 1 file changed, 29 insertions(+), 23 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index 67d992bf5b8b..a6b2ca67451f 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -240,7 +240,7 @@ let kinfo_size {iloc = _; kstack_ty = _} = h2w
    tail-recursive and the only recursive call that is not a tailcall
    cannot be nested. (See [big_map_size].) For this reason, these
    functions should not trigger stack overflows. *)
-let rec value_size :
+let[@coq_struct "ty"] rec value_size_aux :
     type a ac.
     count_lambda_nodes:bool ->
     nodes_and_size ->
@@ -250,7 +250,7 @@ let rec value_size :
  fun ~count_lambda_nodes accu ty x ->
   let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size =
    fun accu ty x ->
-    match ty with
+    match[@coq_match_gadt] [@coq_match_with_default] ty with
     | Unit_t -> ret_succ accu
     | Int_t -> ret_succ_adding accu (script_int_size x)
     | Nat_t -> ret_succ_adding accu (script_nat_size x)
@@ -268,7 +268,10 @@ let rec value_size :
     | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w
     | Union_t (_, _, _, _) -> ret_succ_adding accu h1w
     | Lambda_t (_, _, _) ->
-        (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x
+        (lambda_size_aux [@ocaml.tailcall])
+          ~count_lambda_nodes
+          (ret_succ accu)
+          x
     | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x)
     | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length))
     | Set_t (_, _) ->
@@ -280,7 +283,7 @@ let rec value_size :
         let boxing_space = !!308 in
         ret_succ_adding accu (boxing_space +! (h5w *? M.size))
     | Big_map_t (cty, ty', _) ->
-        (big_map_size [@ocaml.tailcall])
+        (big_map_size_aux [@ocaml.tailcall])
           ~count_lambda_nodes
           (ret_succ accu)
           cty
@@ -308,7 +311,7 @@ let rec value_size :
   let apply_comparable :
       type a. nodes_and_size -> a comparable_ty -> a -> nodes_and_size =
    fun accu ty x ->
-    match ty with
+    match[@coq_match_gadt] [@coq_match_with_default] ty with
     | Unit_t -> ret_succ accu
     | Int_t -> ret_succ_adding accu (script_int_size x)
     | Nat_t -> ret_succ_adding accu (script_nat_size x)
@@ -331,9 +334,8 @@ let rec value_size :
     | Never_t -> ( match x with _ -> .)
   in
   value_traverse ty x accu {apply; apply_comparable}
- [@@coq_axiom_with_reason "unreachable expressions '.' not handled for now"]
 
-and big_map_size :
+and[@coq_mutual_as_notation] big_map_size_aux :
     type a b bc.
     count_lambda_nodes:bool ->
     nodes_and_size ->
@@ -352,11 +354,11 @@ and big_map_size :
           (* The following recursive call cannot introduce a stack
              overflow because this would require a key of type
              big_map while big_map is not comparable. *)
-          let accu = value_size ~count_lambda_nodes accu (R cty) key in
+          let accu = value_size_aux ~count_lambda_nodes accu (R cty) key in
           match value with
           | None -> accu
           | Some value ->
-              (value_size [@ocaml.tailcall])
+              (value_size_aux [@ocaml.tailcall])
                 ~count_lambda_nodes
                 accu
                 (L ty')
@@ -373,7 +375,7 @@ and big_map_size :
     (comparable_ty_size key_type ++ ty_size value_type ++ diff_size)
     (h4w +! id_size)
 
-and lambda_size :
+and[@coq_struct "function_parameter"] lambda_size_aux :
     type i o.
     count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size
     =
@@ -383,9 +385,9 @@ and lambda_size :
   let accu =
     ret_adding (accu ++ if count_lambda_nodes then node_size node else zero) h2w
   in
-  (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr
+  (kdescr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr
 
-and kdescr_size :
+and[@coq_mutual_as_notation] kdescr_size_aux :
     type a s r f.
     count_lambda_nodes:bool ->
     nodes_and_size ->
@@ -395,9 +397,9 @@ and kdescr_size :
   let accu =
     ret_adding (accu ++ stack_ty_size kbef ++ stack_ty_size kaft) h4w
   in
-  (kinstr_size [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr
+  (kinstr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr
 
-and kinstr_size :
+and[@coq_struct "t_value"] kinstr_size_aux :
     type a s r f.
     count_lambda_nodes:bool ->
     nodes_and_size ->
@@ -415,7 +417,7 @@ and kinstr_size :
     | IConst (kinfo, x, k) ->
         let accu = ret_succ_adding accu (base kinfo +! word_size) in
         let (Ty_ex_c top_ty) = stack_top_ty (kinfo_of_kinstr k).kstack_ty in
-        (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu (L top_ty) x
+        (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu (L top_ty) x
     | ICons_pair (kinfo, _) -> ret_succ_adding accu (base kinfo)
     | ICar (kinfo, _) -> ret_succ_adding accu (base kinfo)
     | ICdr (kinfo, _) -> ret_succ_adding accu (base kinfo)
@@ -510,7 +512,7 @@ and kinstr_size :
         ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size)
     | ILambda (kinfo, lambda, _) ->
         let accu = ret_succ_adding accu (base kinfo +! word_size) in
-        (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda
+        (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu lambda
     | IFailwith (kinfo, _, ty) ->
         ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size)
     | ICompare (kinfo, cty, _) ->
@@ -663,20 +665,24 @@ let rec kinstr_extra_size : type a s r f. (a, s, r, f) kinstr -> nodes_and_size
          [ty_of_comparable_ty] to create a type that is embedded in the IR. *)
       | ITicket (_, k) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr k in
-          match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty)
+          match[@coq_match_with_default] kinfo.kstack_ty with
+          | Item_t (ty, _) -> ty_size ty)
       | IRead_ticket (_, k) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr k in
           match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty)
       | ICompare (_, ty, _) -> comparable_ty_size ty
       | ISet_iter (_, body, _) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr body in
-          match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty)
+          match[@coq_match_with_default] kinfo.kstack_ty with
+          | Item_t (ty, _) -> ty_size ty)
       | IMap_map (_, body, _) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr body in
-          match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty)
+          match[@coq_match_with_default] kinfo.kstack_ty with
+          | Item_t (ty, _) -> ty_size ty)
       | IMap_iter (_, body, _) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr body in
-          match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty)
+          match[@coq_match_with_default] kinfo.kstack_ty with
+          | Item_t (ty, _) -> ty_size ty)
       | ILambda (_, lambda, _) -> lambda_extra_size lambda
       | _ -> zero
     in
@@ -695,7 +701,7 @@ let lambda_size lam =
 
   *)
   let (lambda_nodes, lambda_size) =
-    lambda_size ~count_lambda_nodes:true zero lam
+    lambda_size_aux ~count_lambda_nodes:true zero lam
   in
   let (lambda_extra_size_nodes, lambda_extra_size) = lambda_extra_size lam in
   let size = (lambda_size *? 157 /? 100) +! (lambda_extra_size *? 18 /? 100) in
@@ -704,12 +710,12 @@ let lambda_size lam =
 let kinstr_size kinstr =
   let (kinstr_extra_size_nodes, kinstr_extra_size) = kinstr_extra_size kinstr in
   let (kinstr_nodes, kinstr_size) =
-    kinstr_size ~count_lambda_nodes:true zero kinstr
+    kinstr_size_aux ~count_lambda_nodes:true zero kinstr
   in
   let size = (kinstr_size *? 157 /? 100) +! (kinstr_extra_size *? 18 /? 100) in
   (Nodes.add kinstr_nodes kinstr_extra_size_nodes, size)
 
-let value_size ty x = value_size ~count_lambda_nodes:true zero (L ty) x
+let value_size ty x = value_size_aux ~count_lambda_nodes:true zero (L ty) x
 
 module Internal_for_tests = struct
   let ty_size = ty_size
-- 
GitLab


From 4db242b808214f8bd8bbc5c29012fa488f848a41 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 11 Jan 2022 19:08:51 +0100
Subject: [PATCH 33/69] Proto: compile the ticker_scanner

---
 .../lib_protocol/carbonated_map.ml            |  2 +-
 .../lib_protocol/ticket_lazy_storage_diff.ml  | 28 +++++++++++++------
 .../lib_protocol/ticket_scanner.ml            |  4 +--
 .../lib_protocol/ticket_scanner.mli           |  2 +-
 4 files changed, 23 insertions(+), 13 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml
index ceda9cd2c853..0a50804c93c3 100644
--- a/src/proto_alpha/lib_protocol/carbonated_map.ml
+++ b/src/proto_alpha/lib_protocol/carbonated_map.ml
@@ -80,7 +80,7 @@ module type COMPARABLE = sig
   val compare_cost : t -> Gas.cost
 end
 
-module Make (C : COMPARABLE) = struct
+module Make (C : COMPARABLE) : S with type key := C.t = struct
   module M = Map.Make (C)
 
   type 'a t = {map : 'a M.t; size : int}
diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml
index eb19db16ab7e..cd81d13147be 100644
--- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml
+++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml
@@ -76,7 +76,7 @@ let parse_value_type ctxt value_type =
     removing a value containing tickets. *)
 let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc
     =
-  Ticket_scanner.tickets_of_node
+  (Ticket_scanner.tickets_of_node [@coq_implicit "(a := a)"])
     ctxt
     (* It's currently not possible to have nested lazy structures, but this is
        for future proofing. *)
@@ -111,7 +111,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets
       =
     match expr_opt with
     | Some expr ->
-        collect_token_diffs_of_node
+        (collect_token_diffs_of_node [@coq_implicit "(a := a)"])
           ctxt
           has_tickets
           expr
@@ -165,12 +165,13 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates
      We should have the non-serialized version of the value type.
   *)
   parse_value_type ctxt value_type
-  >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) ->
+  >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) ->
   Ticket_scanner.type_has_tickets ctxt value_type
   >>?= fun (has_tickets, ctxt) ->
   List.fold_left_es
     (fun (acc, already_updated, ctxt) update ->
-      collect_token_diffs_of_big_map_update
+      (collect_token_diffs_of_big_map_update
+      [@coq_implicit "(a := __Ex_ty_'a)"])
         ctxt
         ~big_map_id
         has_tickets
@@ -195,7 +196,8 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc =
          type. It would be more efficient if the value preserved.
       *)
       parse_value_type ctxt value_ty
-      >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) ->
+      >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt)
+        ->
       Ticket_scanner.type_has_tickets ctxt value_type
       >>?= fun (has_tickets, ctxt) ->
       (* Iterate over big-map items. *)
@@ -207,7 +209,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc =
       Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) ->
       List.fold_left_es
         (fun (acc, ctxt) node ->
-          collect_token_diffs_of_node
+          (collect_token_diffs_of_node [@coq_implicit "(a := __Ex_ty_'a)"])
             ctxt
             has_tickets
             node
@@ -238,15 +240,23 @@ let collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc =
 let collect_token_diffs_of_big_map_diff ctxt diff_item acc =
   Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step
   >>?= fun ctxt ->
-  match diff_item with
-  | Lazy_storage.Item (Lazy_storage_kind.Big_map, big_map_id, Remove) ->
+  match[@coq_match_gadt] diff_item with
+  | Lazy_storage.Item
+      (Lazy_storage_kind.Big_map, (big_map_id : Big_map.Id.t), Remove) ->
       (* Collect all removed tokens from the big-map. *)
       collect_token_diffs_of_big_map
         ctxt
         ~get_token_and_amount:neg_token_and_amount
         big_map_id
         acc
-  | Item (Lazy_storage_kind.Big_map, big_map_id, Update {init; updates}) -> (
+  | Item
+      ( Lazy_storage_kind.Big_map,
+        (big_map_id : Big_map.Id.t),
+        (Update {init; updates} :
+          ( Big_map.Id.t,
+            Lazy_storage_kind.Big_map.alloc,
+            Lazy_storage_kind.Big_map.updates )
+          Lazy_storage.diff) ) -> (
       match init with
       | Lazy_storage.Existing ->
           (* Collect token diffs from the updates to the big-map. *)
diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml
index 77096a85b495..80880cc21112 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.ml
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml
@@ -532,8 +532,8 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr =
   let (Has_tickets (ht, ty)) = has_tickets in
   match ht with
   | Ticket_inspection.False_ht -> return ([], ctxt)
-  | _ ->
-      Script_ir_translator.parse_data
+  | (_ : _ Ticket_inspection.has_tickets) ->
+      (Script_ir_translator.parse_data [@coq_implicit "(a := a)"])
         ctxt
         ~legacy:true
         ~allow_forged:true
diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.mli b/src/proto_alpha/lib_protocol/ticket_scanner.mli
index 209c633ab74a..c732b79842a8 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.mli
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.mli
@@ -39,7 +39,7 @@ type ex_ticket =
 (** A type-witness that contains information about which branches of a type ['a]
     include tickets. This value is used for traversing only the relevant
     branches of values when scanning for tickets. *)
-type 'a has_tickets
+type 'a has_tickets [@@coq_phantom]
 
 (** [type_has_tickets ctxt ty] returns a [has_tickets] witness of the given
     shape [ty].
-- 
GitLab


From a293a2040b75981a61d03568009826e54bd52a11 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 12 Jan 2022 10:45:04 +0100
Subject: [PATCH 34/69] Proto: put list conversions at top-level

---
 src/proto_alpha/lib_protocol/apply_results.ml | 97 ++++++++++---------
 .../lib_protocol/apply_results.mli            |  3 +-
 .../operations/test_combined_operations.ml    |  9 +-
 3 files changed, 61 insertions(+), 48 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 98b1d054d534..76ae42690919 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -1862,27 +1862,34 @@ type packed_contents_result_list =
       'kind contents_result_list
       -> packed_contents_result_list
 
+let rec contents_result_list_to_list : type kind. kind contents_result_list -> _
+    = function
+  | Single_result o -> [Contents_result o]
+  | Cons_result (o, os) -> Contents_result o :: contents_result_list_to_list os
+
+let packed_contents_result_list_to_list = function
+  | Contents_result_list l -> contents_result_list_to_list l
+
+let rec packed_contents_result_list_of_list = function
+  | [] -> Error "cannot decode empty operation result"
+  | [Contents_result o] -> Ok (Contents_result_list (Single_result o))
+  | Contents_result o :: os -> (
+      packed_contents_result_list_of_list os
+      >>? fun (Contents_result_list os) ->
+      match (o, os) with
+      | (Manager_operation_result _, Single_result (Manager_operation_result _))
+        ->
+          Ok (Contents_result_list (Cons_result (o, os)))
+      | (Manager_operation_result _, Cons_result _) ->
+          Ok (Contents_result_list (Cons_result (o, os)))
+      | _ -> Error "cannot decode ill-formed operation result")
+
 let contents_result_list_encoding =
-  let rec to_list = function
-    | Contents_result_list (Single_result o) -> [Contents_result o]
-    | Contents_result_list (Cons_result (o, os)) ->
-        Contents_result o :: to_list (Contents_result_list os)
-  in
-  let rec of_list = function
-    | [] -> Error "cannot decode empty operation result"
-    | [Contents_result o] -> Ok (Contents_result_list (Single_result o))
-    | Contents_result o :: os -> (
-        of_list os >>? fun (Contents_result_list os) ->
-        match (o, os) with
-        | ( Manager_operation_result _,
-            Single_result (Manager_operation_result _) ) ->
-            Ok (Contents_result_list (Cons_result (o, os)))
-        | (Manager_operation_result _, Cons_result _) ->
-            Ok (Contents_result_list (Cons_result (o, os)))
-        | _ -> Error "cannot decode ill-formed operation result")
-  in
   def "operation.alpha.contents_list_result"
-  @@ conv_with_guard to_list of_list (list contents_result_encoding)
+  @@ conv_with_guard
+       packed_contents_result_list_to_list
+       packed_contents_result_list_of_list
+       (list contents_result_encoding)
 
 type 'kind contents_and_result_list =
   | Single_and_result :
@@ -1899,27 +1906,34 @@ type packed_contents_and_result_list =
       'kind contents_and_result_list
       -> packed_contents_and_result_list
 
+let rec contents_and_result_list_to_list :
+    type kind. kind contents_and_result_list -> _ = function
+  | Single_and_result (op, res) -> [Contents_and_result (op, res)]
+  | Cons_and_result (op, res, rest) ->
+      Contents_and_result (op, res) :: contents_and_result_list_to_list rest
+
+let packed_contents_and_result_list_to_list = function
+  | Contents_and_result_list l -> contents_and_result_list_to_list l
+
+let rec packed_contents_and_result_list_of_list = function
+  | [] -> Error "cannot decode empty combined operation result"
+  | [Contents_and_result (op, res)] ->
+      Ok (Contents_and_result_list (Single_and_result (op, res)))
+  | Contents_and_result (op, res) :: rest -> (
+      packed_contents_and_result_list_of_list rest
+      >>? fun (Contents_and_result_list rest) ->
+      match (op, rest) with
+      | (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
+          Ok (Contents_and_result_list (Cons_and_result (op, res, rest)))
+      | (Manager_operation _, Cons_and_result (_, _, _)) ->
+          Ok (Contents_and_result_list (Cons_and_result (op, res, rest)))
+      | _ -> Error "cannot decode ill-formed combined operation result")
+
 let contents_and_result_list_encoding =
-  let rec to_list = function
-    | Contents_and_result_list (Single_and_result (op, res)) ->
-        [Contents_and_result (op, res)]
-    | Contents_and_result_list (Cons_and_result (op, res, rest)) ->
-        Contents_and_result (op, res) :: to_list (Contents_and_result_list rest)
-  in
-  let rec of_list = function
-    | [] -> Error "cannot decode empty combined operation result"
-    | [Contents_and_result (op, res)] ->
-        Ok (Contents_and_result_list (Single_and_result (op, res)))
-    | Contents_and_result (op, res) :: rest -> (
-        of_list rest >>? fun (Contents_and_result_list rest) ->
-        match (op, rest) with
-        | (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
-            Ok (Contents_and_result_list (Cons_and_result (op, res, rest)))
-        | (Manager_operation _, Cons_and_result (_, _, _)) ->
-            Ok (Contents_and_result_list (Cons_and_result (op, res, rest)))
-        | _ -> Error "cannot decode ill-formed combined operation result")
-  in
-  conv_with_guard to_list of_list (Variable.list contents_and_result_encoding)
+  conv_with_guard
+    packed_contents_and_result_list_to_list
+    packed_contents_and_result_list_of_list
+    (Variable.list contents_and_result_encoding)
 
 type 'kind operation_metadata = {contents : 'kind contents_result_list}
 
@@ -2505,11 +2519,6 @@ let rec unpack_contents_list :
       let (ops, ress) = unpack_contents_list rest in
       (Cons (op, ops), Cons_result (res, ress))
 
-let rec to_list = function
-  | Contents_result_list (Single_result o) -> [Contents_result o]
-  | Contents_result_list (Cons_result (o, os)) ->
-      Contents_result o :: to_list (Contents_result_list os)
-
 let operation_data_and_metadata_encoding =
   def "operation.alpha.operation_with_metadata"
   @@ union
diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli
index a311800bff7c..6635350e8524 100644
--- a/src/proto_alpha/lib_protocol/apply_results.mli
+++ b/src/proto_alpha/lib_protocol/apply_results.mli
@@ -325,7 +325,8 @@ val unpack_contents_list :
   'kind contents_and_result_list ->
   'kind contents_list * 'kind contents_result_list
 
-val to_list : packed_contents_result_list -> packed_contents_result list
+val packed_contents_result_list_to_list :
+  packed_contents_result_list -> packed_contents_result list
 
 type ('a, 'b) eq = Eq : ('a, 'a) eq
 
diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml
index 43fc555cde62..224792bc63d7 100644
--- a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml
+++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml
@@ -124,7 +124,8 @@ let test_multiple_origination_and_delegation () =
       (fun acc -> function
         | No_operation_metadata -> assert false
         | Operation_metadata {contents} ->
-            to_list (Contents_result_list contents) @ acc)
+            packed_contents_result_list_to_list (Contents_result_list contents)
+            @ acc)
       []
       tickets
     |> List.rev
@@ -193,7 +194,8 @@ let test_failing_operation_in_the_middle () =
       (fun acc -> function
         | No_operation_metadata -> assert false
         | Operation_metadata {contents} ->
-            to_list (Contents_result_list contents) @ acc)
+            packed_contents_result_list_to_list (Contents_result_list contents)
+            @ acc)
       []
       tickets
   in
@@ -241,7 +243,8 @@ let test_failing_operation_in_the_middle_with_fees () =
       (fun acc -> function
         | No_operation_metadata -> assert false
         | Operation_metadata {contents} ->
-            to_list (Contents_result_list contents) @ acc)
+            packed_contents_result_list_to_list (Contents_result_list contents)
+            @ acc)
       []
       tickets
   in
-- 
GitLab


From a6de80997e5e5542bf30edf109004d89be9d7a47 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 12 Jan 2022 13:41:30 +0100
Subject: [PATCH 35/69] Proto: TEMP: simplify fitness_repr.ml code

---
 src/proto_alpha/lib_protocol/fitness_repr.ml | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/fitness_repr.ml b/src/proto_alpha/lib_protocol/fitness_repr.ml
index 0a1c3bd7fa8a..5f9b73b1f605 100644
--- a/src/proto_alpha/lib_protocol/fitness_repr.ml
+++ b/src/proto_alpha/lib_protocol/fitness_repr.ml
@@ -167,10 +167,10 @@ let locked_round_to_bytes = function
   | Some locked_round -> int32_to_bytes (Round_repr.to_int32 locked_round)
 
 let locked_round_of_bytes b =
-  match Bytes.length b with
-  | 0 -> ok None
-  | 4 -> Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r)
-  | _ -> error Invalid_fitness
+  if Compare.Int.(Bytes.length b = 0) then ok None
+  else if Compare.Int.(Bytes.length b = 4) then
+    Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r)
+  else error Invalid_fitness
 
 let predecessor_round_of_bytes neg_predecessor_round =
   int32_of_bytes neg_predecessor_round >>? fun neg_predecessor_round ->
-- 
GitLab


From e384eac4a189c1cd250f387633b13eac2f4e6f6a Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 00:15:20 +0100
Subject: [PATCH 36/69] Proto: changes to help convert the translator to Coq

---
 .../lib_protocol/alpha_context.mli            | 11 +++++++----
 .../lib_protocol/script_ir_translator.ml      | 19 ++++++++++++-------
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index e5d145e0d957..fb4c92aadceb 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -1268,7 +1268,7 @@ module Big_map : sig
     Id.t ->
     (context * Script.expr list) tzresult Lwt.t
 
-  type update = {
+  type update = Lazy_storage_kind.Big_map.update = {
     key : Script_repr.expr;
     key_hash : Script_expr_hash.t;
     value : Script_repr.expr option;
@@ -1276,7 +1276,10 @@ module Big_map : sig
 
   type updates = update list
 
-  type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr}
+  type alloc = Lazy_storage_kind.Big_map.alloc = {
+    key_type : Script_repr.expr;
+    value_type : Script_repr.expr;
+  }
 end
 
 module Sapling : sig
@@ -1303,7 +1306,7 @@ module Sapling : sig
   val diff_encoding : diff Data_encoding.t
 
   module Memo_size : sig
-    type t
+    type t = Sapling_repr.Memo_size.t
 
     val encoding : t Data_encoding.t
 
@@ -1356,7 +1359,7 @@ module Sapling : sig
     string ->
     (context * (Int64.t * state) option) tzresult Lwt.t
 
-  type alloc = {memo_size : Memo_size.t}
+  type alloc = Lazy_storage_kind.Sapling_state.alloc = {memo_size : Memo_size.t}
 
   type updates = diff
 
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index bf2dd91fab05..d27108702a62 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -850,7 +850,7 @@ let memo_size_eq :
   if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit
   else
     Error
-      (match error_details with
+      (match[@coq_match_gadt_with_result] error_details with
       | Fast -> Inconsistent_types_fast
       | Informative -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2))
 
@@ -1045,6 +1045,7 @@ type ('a, 's) judgement =
       descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr;
     }
       -> ('a, 's) judgement
+[@@coq_force_gadt]
 
 (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)
 
@@ -1817,6 +1818,7 @@ type 'storage ex_view =
   | Ex_view :
       ('input * 'storage, 'output) Script_typed_ir.lambda
       -> 'storage ex_view
+[@@coq_force_gadt]
 
 type (_, _) dig_proof_argument =
   | Dig_proof_argument :
@@ -1859,16 +1861,19 @@ type 'before comb_get_proof_argument =
   | Comb_get_proof_argument :
       ('before, 'after) comb_get_gadt_witness * ('after, _) ty
       -> 'before comb_get_proof_argument
+[@@coq_force_gadt]
 
 type ('rest, 'before) comb_set_proof_argument =
   | Comb_set_proof_argument :
       ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty
       -> ('rest, 'before) comb_set_proof_argument
+[@@coq_force_gadt]
 
 type 'before dup_n_proof_argument =
   | Dup_n_proof_argument :
       ('before, 'a) dup_n_gadt_witness * ('a, _) ty
       -> 'before dup_n_proof_argument
+[@@coq_force_gadt]
 
 let rec make_dug_proof_argument :
     type a s x xc.
@@ -1979,7 +1984,7 @@ let find_entrypoint (type full fullc error_trace)
       else
         Gas_monad.of_result
         @@ Error
-             (match error_details with
+             (match[@coq_match_gadt_with_result] error_details with
              | Fast -> (Inconsistent_types_fast : error_trace)
              | Informative -> trace_of_error @@ No_such_entrypoint entrypoint)
 
@@ -2950,7 +2955,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data :
   | (Chest_t, expr) ->
       traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
 
-and parse_view_returning :
+and[@coq_struct "ctxt"] parse_view_returning :
     type storage storagec.
     ?type_logger:type_logger ->
     context ->
@@ -3010,7 +3015,7 @@ and parse_view_returning :
           eq >|? fun Eq -> (Ex_view (Lam (close_descr descr, view_code)), ctxt)
       | _ -> error (ill_type_view loc aft ()))
 
-and typecheck_views :
+and[@coq_struct "ctxt"] typecheck_views :
     type storage storagec.
     ?type_logger:type_logger ->
     context ->
@@ -5185,8 +5190,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra
             @@ Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg)
       else fail (No_such_entrypoint entrypoint)
 
-and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult =
-  function
+and[@coq_struct "ctxt"] parse_view_name ctxt :
+    Script.node -> (Script_string.t * context) tzresult = function
   | String (loc, v) as expr ->
       (* The limitation of length of string is same as entrypoint *)
       if Compare.Int.(String.length v > 31) then error (View_name_too_long v)
@@ -5207,7 +5212,7 @@ and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult =
             Script_string.of_string v >|? fun s -> (s, ctxt) )
   | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr)
 
-and parse_toplevel :
+and[@coq_struct "ctxt"] parse_toplevel :
     context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult =
  fun ctxt ~legacy toplevel ->
   record_trace (Ill_typed_contract (toplevel, []))
-- 
GitLab


From 79c9de854d1b63c95646e7f3b7e39ec45b83f461 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 00:29:15 +0100
Subject: [PATCH 37/69] Proto: avoid top-level name collisions for Coq in the
 translator

---
 .../lib_protocol/script_ir_translator.ml      | 219 +++++++++---------
 1 file changed, 111 insertions(+), 108 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index d27108702a62..e88bfa0e9a3a 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -603,13 +603,13 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data :
     a ->
     (loc Script.michelson_node * context) tzresult Lwt.t =
  fun ~loc ctxt mode ty a ->
-  (* No need for stack_depth here. Unlike [unparse_data],
-     [unparse_comparable_data] doesn't call [unparse_code].
+  (* No need for stack_depth here. Unlike [unparse_data_aux],
+     [unparse_comparable_data] doesn't call [unparse_code_aux].
      The stack depth is bounded by the type depth, currently bounded
      by 1000 (michelson_maximum_type_size). *)
   Gas.consume ctxt Unparse_costs.unparse_data_cycle
   (* We could have a smaller cost but let's keep it consistent with
-     [unparse_data] for now. *)
+     [unparse_data_aux] for now. *)
   >>?=
   fun ctxt ->
   match (ty, a) with
@@ -1098,7 +1098,7 @@ let parse_memo_size (n : (location, _) Micheline.node) :
 type ex_comparable_ty =
   | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty
 
-let[@coq_struct "ty"] rec parse_comparable_ty :
+let[@coq_struct "ty"] rec parse_comparable_ty_aux :
     stack_depth:int ->
     context ->
     Script.node ->
@@ -1170,25 +1170,25 @@ let[@coq_struct "ty"] rec parse_comparable_ty :
             (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *)
             ok (Prim (loc, T_pair, right, [])))
         >>? fun right ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right
         >>? fun (Ex_comparable_ty right, ctxt) ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left
         >>? fun (Ex_comparable_ty left, ctxt) ->
         pair_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt)
     | Prim (loc, T_or, [left; right], annot) ->
         check_type_annot loc annot >>? fun () ->
         remove_field_annot left >>? fun left ->
         remove_field_annot right >>? fun right ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right
         >>? fun (Ex_comparable_ty right, ctxt) ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left
         >>? fun (Ex_comparable_ty left, ctxt) ->
         union_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt)
     | Prim (loc, ((T_pair | T_or) as prim), l, _) ->
         error (Invalid_arity (loc, prim, 2, List.length l))
     | Prim (loc, T_option, [t], annot) ->
         check_type_annot loc annot >>? fun () ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t
         >>? fun (Ex_comparable_ty t, ctxt) ->
         option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt)
     | Prim (loc, T_option, l, _) ->
@@ -1234,21 +1234,21 @@ type ex_parameter_ty_and_entrypoints_node =
     }
       -> ex_parameter_ty_and_entrypoints_node
 
-(** [parse_ty] can be used to parse regular types as well as parameter types
+(** [parse_ty_aux] can be used to parse regular types as well as parameter types
     together with their entrypoints.
 
-    In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will
+    In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty_aux] will
     return an [ex_ty].
 
-    In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return
-    an [ex_parameter_ty_and_entrypoints_node].
+    In the second case, use [~ret:Parse_entrypoints], [parse_ty_aux] will return
+    an [ex_parameter_ty_and_entrypoints].
 *)
 type ('ret, 'name) parse_ty_ret =
   | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret
   | Parse_entrypoints
       : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret
 
-let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty :
+let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty_aux :
     type ret name.
     context ->
     stack_depth:int ->
@@ -1341,7 +1341,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
         check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t
     | Prim (loc, T_contract, [utl], annot) ->
         if allow_contract then
-          parse_passable_ty
+          parse_passable_ty_aux_with_ret
             ctxt
             ~stack_depth:(stack_depth + 1)
             ~legacy
@@ -1353,7 +1353,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
         else error (Unexpected_contract loc)
     | Prim (loc, T_pair, utl :: utr, annot) ->
         remove_field_annot utl >>? fun utl ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1370,7 +1370,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
             (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *)
             ok (Prim (loc, T_pair, utr, [])))
         >>? fun utr ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1390,7 +1390,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
             remove_field_annot utr >|? fun utr -> (utl, utr)
         | Parse_entrypoints -> ok (utl, utr))
         >>? fun (utl, utr) ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1401,7 +1401,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
           ~ret
           utl
         >>? fun (parsed_l, ctxt) ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1437,9 +1437,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
             (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt)
         )
     | Prim (loc, T_lambda, [uta; utr], annot) ->
-        parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta
+        parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta
         >>? fun (Ex_ty ta, ctxt) ->
-        parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr
+        parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr
         >>? fun (Ex_ty tr, ctxt) ->
         check_type_annot loc annot >>? fun () ->
         lambda_t loc ta tr >|? fun ty -> return ctxt ty
@@ -1450,7 +1450,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
          check_composed_type_annot loc annot >>? fun () -> ok ut
         else check_type_annot loc annot >>? fun () -> ok ut)
         >>? fun ut ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1463,7 +1463,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
         >>? fun (Ex_ty t, ctxt) ->
         option_t loc t >|? fun ty -> return ctxt ty
     | Prim (loc, T_list, [ut], annot) ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1478,20 +1478,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
         list_t loc t >|? fun ty -> return ctxt ty
     | Prim (loc, T_ticket, [ut], annot) ->
         if allow_ticket then
-          parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut
+          parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut
           >>? fun (Ex_comparable_ty t, ctxt) ->
           check_type_annot loc annot >>? fun () ->
           ticket_t loc t >|? fun ty -> return ctxt ty
         else error (Unexpected_ticket loc)
     | Prim (loc, T_set, [ut], annot) ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut
         >>? fun (Ex_comparable_ty t, ctxt) ->
         check_type_annot loc annot >>? fun () ->
         set_t loc t >|? fun ty -> return ctxt ty
     | Prim (loc, T_map, [uta; utr], annot) ->
-        parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta
+        parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta
         >>? fun (Ex_comparable_ty ta, ctxt) ->
-        parse_ty
+        parse_ty_aux
           ctxt
           ~stack_depth:(stack_depth + 1)
           ~legacy
@@ -1588,7 +1588,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
                T_tx_rollup_l2_address;
              ]
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty :
+and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux_with_ret :
     type ret name.
     context ->
     stack_depth:int ->
@@ -1597,7 +1597,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab
     Script.node ->
     (ret * context) tzresult =
  fun ctxt ~stack_depth ~legacy ->
-  (parse_ty [@tailcall])
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -1606,7 +1606,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab
     ~allow_contract:true
     ~allow_ticket:true
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty
+and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty_aux
     :
     context ->
     stack_depth:int ->
@@ -1614,7 +1614,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty
     Script.node ->
     (ex_ty * context) tzresult =
  fun ctxt ~stack_depth ~legacy ->
-  (parse_ty [@tailcall])
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -1629,9 +1629,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma
   Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt ->
   match args with
   | [key_ty; value_ty] ->
-      parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty
+      parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty
       >>? fun (Ex_comparable_ty key_ty, ctxt) ->
-      parse_big_map_value_ty
+      parse_big_map_value_ty_aux
         ctxt
         ~stack_depth:(stack_depth + 1)
         ~legacy
@@ -1642,9 +1642,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma
       (Ex_ty big_map_ty, ctxt)
   | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty
+and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty_aux
     ctxt ~stack_depth ~legacy value_ty =
-  (parse_ty [@tailcall])
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -1655,8 +1655,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma
     ~ret:Don't_parse_entrypoints
     value_ty
 
-let parse_packable_ty ctxt ~stack_depth ~legacy node =
-  (parse_ty [@tailcall])
+let parse_packable_ty_aux ctxt ~stack_depth ~legacy node =
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -1671,7 +1671,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node =
     node
 
 let parse_view_input_ty ctxt ~stack_depth ~legacy node =
-  (parse_ty [@tailcall])
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -1683,7 +1683,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node =
     node
 
 let parse_view_output_ty ctxt ~stack_depth ~legacy node =
-  (parse_ty [@tailcall])
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -1695,7 +1695,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node =
     node
 
 let parse_normal_storage_ty ctxt ~stack_depth ~legacy node =
-  (parse_ty [@tailcall])
+  (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
     ~legacy
@@ -2078,7 +2078,7 @@ let parse_parameter_ty_and_entrypoints :
     Script.node ->
     (ex_parameter_ty_and_entrypoints * context) tzresult =
  fun ctxt ~stack_depth ~legacy node ->
-  parse_passable_ty
+  parse_passable_ty_aux_with_ret
     ctxt
     ~stack_depth:(stack_depth + 1)
     ~legacy
@@ -2092,7 +2092,8 @@ let parse_parameter_ty_and_entrypoints :
   let entrypoints = {root = entrypoints; original_type_expr = node} in
   (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt)
 
-let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints
+let parse_passable_ty_aux =
+  parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints
 
 let parse_uint ~nb_bits =
   assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ;
@@ -2439,7 +2440,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data :
     Script.node ->
     (a * context) tzresult Lwt.t =
  fun ?type_logger ctxt ty script_data ->
-  (* No need for stack_depth here. Unlike [parse_data],
+  (* No need for stack_depth here. Unlike [parse_data_aux],
      [parse_comparable_data] doesn't call [parse_returning].
      The stack depth is bounded by the type depth, bounded by 1024. *)
   let parse_data_error () =
@@ -2450,7 +2451,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data :
   let traced body = trace_eval parse_data_error body in
   Gas.consume ctxt Typecheck_costs.parse_data_cycle
   (* We could have a smaller cost but let's keep it consistent with
-     [parse_data] for now. *)
+     [parse_data_aux] for now. *)
   >>?=
   fun ctxt ->
   let legacy = false in
@@ -2501,7 +2502,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness =
 (*
   Some values, such as operations, tickets, or big map ids, are used only
   internally and are not allowed to be forged by users.
-  In [parse_data], [allow_forged] should be [false] for:
+  In [parse_data_aux], [allow_forged] should be [false] for:
   - PUSH
   - UNPACK
   - user-provided script parameters
@@ -2511,7 +2512,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness =
   - storage after origination
 *)
 
-let[@coq_axiom_with_reason "gadt"] rec parse_data :
+let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
     type a ac.
     ?type_logger:type_logger ->
     stack_depth:int ->
@@ -2527,7 +2528,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data :
     if Compare.Int.(stack_depth > 10_000) then
       fail Typechecking_too_many_recursive_calls
     else
-      parse_data
+      parse_data_aux
         ?type_logger
         ~stack_depth:(stack_depth + 1)
         ctxt
@@ -2686,7 +2687,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data :
       traced
         ( parse_address ctxt expr >>?= fun (address, ctxt) ->
           let loc = location expr in
-          parse_contract
+          parse_contract_aux
             ~stack_depth:(stack_depth + 1)
             ctxt
             loc
@@ -2823,12 +2824,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data :
             | (_, None) -> traced_fail (Invalid_big_map (loc, id))
             | (ctxt, Some (btk, btv)) ->
                 Lwt.return
-                  ( parse_comparable_ty
+                  ( parse_comparable_ty_aux
                       ~stack_depth:(stack_depth + 1)
                       ctxt
                       (Micheline.root btk)
                   >>? fun (Ex_comparable_ty btk, ctxt) ->
-                    parse_big_map_value_ty
+                    parse_big_map_value_ty_aux
                       ctxt
                       ~stack_depth:(stack_depth + 1)
                       ~legacy
@@ -2979,7 +2980,7 @@ and[@coq_struct "ctxt"] parse_view_returning :
     (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty)
   >>?= fun (Ex_ty output_ty', ctxt) ->
   pair_t input_ty_loc input_ty' storage_type >>?= fun (Ty_ex_c pair_ty) ->
-  parse_instr
+  parse_instr_aux
     ?type_logger
     ~stack_depth:0
     Tc_context.view
@@ -3042,7 +3043,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning :
     Script.node ->
     ((arg, ret) lambda * context) tzresult Lwt.t =
  fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr ->
-  parse_instr
+  parse_instr_aux
     ?type_logger
     tc_context
     ctxt
@@ -3072,7 +3073,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning :
             : (arg, ret) lambda),
           ctxt )
 
-and[@coq_axiom_with_reason "gadt"] parse_instr :
+and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
     type a s.
     ?type_logger:type_logger ->
     stack_depth:int ->
@@ -3118,7 +3119,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
     if Compare.Int.(stack_depth > 10000) then
       fail Typechecking_too_many_recursive_calls
     else
-      parse_instr
+      parse_instr_aux
         ?type_logger
         tc_context
         ctxt
@@ -3250,9 +3251,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       typed ctxt loc swap stack_ty
   | (Prim (loc, I_PUSH, [t; d], annot), stack) ->
       check_var_annot loc annot >>?= fun () ->
-      parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t
+      parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t
       >>?= fun (Ex_ty t, ctxt) ->
-      parse_data
+      parse_data_aux
         ?type_logger
         ~stack_depth:(stack_depth + 1)
         ctxt
@@ -3273,7 +3274,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in
       option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest))
   | (Prim (loc, I_NONE, [t], annot), stack) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t
       >>?= fun (Ex_ty t, ctxt) ->
       check_var_type_annot loc annot >>?= fun () ->
       let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in
@@ -3438,7 +3439,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       typed ctxt loc cdr (Item_t (b, rest))
   (* unions *)
   | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr
       >>?= fun (Ex_ty tr, ctxt) ->
       check_constr_annot loc annot >>?= fun () ->
       let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in
@@ -3446,7 +3447,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       let stack_ty = Item_t (ty, rest) in
       typed ctxt loc cons_left stack_ty
   | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl
       >>?= fun (Ex_ty tl, ctxt) ->
       check_constr_annot loc annot >>?= fun () ->
       let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in
@@ -3491,7 +3492,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       Lwt.return @@ merge_branches ctxt loc btr bfr {branch}
   (* lists *)
   | (Prim (loc, I_NIL, [t], annot), stack) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t
       >>?= fun (Ex_ty t, ctxt) ->
       check_var_type_annot loc annot >>?= fun () ->
       let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in
@@ -3612,7 +3613,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       )
   (* sets *)
   | (Prim (loc, I_EMPTY_SET, [t], annot), rest) ->
-      parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t
+      parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t
       >>?= fun (Ex_comparable_ty t, ctxt) ->
       check_var_type_annot loc annot >>?= fun () ->
       let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in
@@ -3675,9 +3676,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       typed ctxt loc instr (Item_t (nat_t, rest))
   (* maps *)
   | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) ->
-      parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk
+      parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk
       >>?= fun (Ex_comparable_ty tk, ctxt) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv
       >>?= fun (Ex_ty tv, ctxt) ->
       check_var_type_annot loc annot >>?= fun () ->
       let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in
@@ -3808,9 +3809,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       typed ctxt loc instr (Item_t (nat_t, rest))
   (* big_map *)
   | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) ->
-      parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk
+      parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk
       >>?= fun (Ex_comparable_ty tk, ctxt) ->
-      parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv
+      parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv
       >>?= fun (Ex_ty tv, ctxt) ->
       check_var_type_annot loc annot >>?= fun () ->
       let instr =
@@ -4051,9 +4052,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
           let stack = Item_t (tr, rest) in
           typed_no_lwt ctxt loc instr stack)
   | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg
       >>?= fun (Ex_ty arg, ctxt) ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret
       >>?= fun (Ex_ty ret, ctxt) ->
       check_kind [Seq_kind] code >>?= fun () ->
       check_var_annot loc annot >>?= fun () ->
@@ -4500,7 +4501,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
   (* annotations *)
   | (Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack)) ->
       check_var_annot loc annot >>?= fun () ->
-      parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t
+      parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t
       >>?= fun (Ex_ty cast_t, ctxt) ->
       Gas_monad.run ctxt @@ ty_eq ~error_details:Informative loc cast_t t
       >>?= fun (eq, ctxt) ->
@@ -4525,7 +4526,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       let stack = Item_t (bytes_t, rest) in
       typed ctxt loc instr stack
   | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest)) ->
-      parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
+      parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
       >>?= fun (Ex_ty t, ctxt) ->
       check_var_type_annot loc annot >>?= fun () ->
       option_t loc t >>?= fun res_ty ->
@@ -4539,7 +4540,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
       let stack = Item_t (address_t, rest) in
       typed ctxt loc instr stack
   | (Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest)) ->
-      parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
+      parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
       >>?= fun (Ex_ty t, ctxt) ->
       contract_t loc t >>?= fun contract_ty ->
       option_t loc contract_ty >>?= fun res_ty ->
@@ -4598,7 +4599,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
          contracts but then we throw away the typed version, except for the
          storage type which is kept for efficiency in the ticket scanner. *)
       let canonical_code = Micheline.strip_locations code in
-      parse_toplevel ctxt ~legacy canonical_code
+      parse_toplevel_aux ctxt ~legacy canonical_code
       >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) ->
       record_trace
         (Ill_formed_type (Some "parameter", canonical_code, location arg_type))
@@ -5113,7 +5114,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr :
              I_OPEN_CHEST;
            ]
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract :
+and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_aux :
     type arg argc.
     stack_depth:int ->
     context ->
@@ -5153,7 +5154,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra
                     code
                 >>? fun (code, ctxt) ->
                   (* can only fail because of gas *)
-                  parse_toplevel ctxt ~legacy:true code
+                  parse_toplevel_aux ctxt ~legacy:true code
                   >>? fun ({arg_type; _}, ctxt) ->
                   parse_parameter_ty_and_entrypoints
                     ctxt
@@ -5212,7 +5213,7 @@ and[@coq_struct "ctxt"] parse_view_name ctxt :
             Script_string.of_string v >|? fun s -> (s, ctxt) )
   | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr)
 
-and[@coq_struct "ctxt"] parse_toplevel :
+and[@coq_struct "ctxt"] parse_toplevel_aux :
     context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult =
  fun ctxt ~legacy toplevel ->
   record_trace (Ill_typed_contract (toplevel, []))
@@ -5304,7 +5305,7 @@ and[@coq_struct "ctxt"] parse_toplevel :
           Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () ->
           ({code_field = c; arg_type; views; storage_type = s}, ctxt))
 
-(* Same as [parse_contract], but does not fail when the contact is missing or
+(* Same as [parse_contract_aux], but does not fail when the contact is missing or
    if the expected type doesn't match the actual one. In that case None is
    returned and some overapproximation of the typechecking gas is consumed.
    This can still fail on gas exhaustion. *)
@@ -5354,7 +5355,7 @@ let parse_contract_for_script :
                     code
                 >>? fun (code, ctxt) ->
                   (* can only fail because of gas *)
-                  match parse_toplevel ctxt ~legacy:true code with
+                  match parse_toplevel_aux ctxt ~legacy:true code with
                   | Error _ -> error (Invalid_contract (loc, contract))
                   | Ok ({arg_type; _}, ctxt) -> (
                       match
@@ -5433,7 +5434,7 @@ let parse_code :
     code
   >>?= fun (code, ctxt) ->
   Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) ->
-  parse_toplevel ctxt ~legacy code
+  parse_toplevel_aux ctxt ~legacy code
   >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) ->
   let arg_type_loc = location arg_type in
   record_trace
@@ -5486,7 +5487,7 @@ let parse_storage :
     (fun () ->
       let storage_type = serialize_ty_for_error storage_type in
       Ill_typed_data (None, storage, storage_type))
-    (parse_data
+    (parse_data_aux
        ?type_logger
        ~stack_depth:0
        ctxt
@@ -5528,9 +5529,9 @@ let typecheck_code :
     Script.expr ->
     (type_map * context) tzresult Lwt.t =
  fun ~legacy ~show_types ctxt code ->
-  (* Constants need to be expanded or [parse_toplevel] may fail. *)
+  (* Constants need to be expanded or [parse_toplevel_aux] may fail. *)
   Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) ->
-  parse_toplevel ctxt ~legacy code
+  parse_toplevel_aux ctxt ~legacy code
   >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) ->
   let type_map = ref [] in
   let arg_type_loc = location arg_type in
@@ -5635,7 +5636,7 @@ let comb_witness2 :
   | Pair_t _ -> Comb_Pair Comb_Any
   | _ -> Comb_Any
 
-let[@coq_axiom_with_reason "gadt"] rec unparse_data :
+let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
     type a ac.
     context ->
     stack_depth:int ->
@@ -5648,7 +5649,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data :
   let non_terminal_recursion ctxt mode ty a =
     if Compare.Int.(stack_depth > 10_000) then
       fail Unparsing_too_many_recursive_calls
-    else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a
+    else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a
   in
   let loc = Micheline.dummy_location in
   match (ty, a) with
@@ -5701,7 +5702,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data :
       let t = ty_of_comparable_ty opened_ticket_ty in
       let destination : Destination.t = Contract ticketer in
       let addr = {destination; entrypoint = Entrypoint.default} in
-      (unparse_data [@tailcall])
+      (unparse_data_aux [@tailcall])
         ctxt
         ~stack_depth
         mode
@@ -5764,7 +5765,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data :
       unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
       >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
   | (Lambda_t _, Lam (_, original_code)) ->
-      unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code
+      unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code
   | (Never_t, _) -> .
   | (Sapling_transaction_t _, s) ->
       Lwt.return
@@ -5835,22 +5836,23 @@ and unparse_items :
     (fun (l, ctxt) (k, v) ->
       let loc = Micheline.dummy_location in
       unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) ->
-      unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v
+      unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v
       >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt))
     ([], ctxt)
     items
 
-and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code =
+and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code
+    =
   let legacy = true in
   Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt ->
   let non_terminal_recursion ctxt mode code =
     if Compare.Int.(stack_depth > 10_000) then
       fail Unparsing_too_many_recursive_calls
-    else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code
+    else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code
   in
   match code with
   | Prim (loc, I_PUSH, [ty; data], annot) ->
-      parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
+      parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
       >>?= fun (Ex_ty t, ctxt) ->
       let allow_forged =
         false
@@ -5859,7 +5861,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code =
            from APPLYing a non-forgeable but this cannot happen either as long
            as all packable values are also forgeable. *)
       in
-      parse_data
+      parse_data_aux
         ctxt
         ~stack_depth:(stack_depth + 1)
         ~legacy
@@ -5867,7 +5869,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code =
         t
         data
       >>=? fun (data, ctxt) ->
-      unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data
+      unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode t data
       >>=? fun (data, ctxt) ->
       return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
   | Seq (loc, items) ->
@@ -5897,8 +5899,9 @@ let unparse_script ctxt mode
       (Script {code; arg_type; storage; storage_type; entrypoints; views; _})) =
   let (Lam (_, original_code)) = code in
   Gas.consume ctxt Unparse_costs.unparse_script >>?= fun ctxt ->
-  unparse_code ctxt ~stack_depth:0 mode original_code >>=? fun (code, ctxt) ->
-  unparse_data ctxt ~stack_depth:0 mode storage_type storage
+  unparse_code_aux ctxt ~stack_depth:0 mode original_code
+  >>=? fun (code, ctxt) ->
+  unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage
   >>=? fun (storage, ctxt) ->
   Lwt.return
     (let loc = Micheline.dummy_location in
@@ -5946,7 +5949,7 @@ let unparse_script ctxt mode
        ctxt ))
 
 let pack_data_with_mode ctxt ty data ~mode =
-  unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) ->
+  unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) ->
   Lwt.return @@ pack_node unparsed ctxt
 
 let hash_data ctxt ty data =
@@ -5984,7 +5987,7 @@ let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) =
       Alpha_context.Big_map.get_opt ctxt id key >>=? function
       | (ctxt, None) -> return (None, ctxt)
       | (ctxt, Some value) ->
-          parse_data
+          parse_data_aux
             ~stack_depth:0
             ctxt
             ~legacy:true
@@ -6071,7 +6074,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy
       (match value with
       | None -> return (None, ctxt)
       | Some x ->
-          unparse_data ~stack_depth:0 ctxt mode value_type x
+          unparse_data_aux ~stack_depth:0 ctxt mode value_type x
           >>=? fun (node, ctxt) ->
           Lwt.return
             ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt ->
@@ -6395,7 +6398,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode
 let list_of_big_map_ids ids =
   Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids []
 
-let parse_data = parse_data ~stack_depth:0
+let parse_data = parse_data_aux ~stack_depth:0
 
 let parse_instr :
     type a s.
@@ -6407,7 +6410,7 @@ let parse_instr :
     (a, s) stack_ty ->
     ((a, s) judgement * context) tzresult Lwt.t =
  fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty ->
-  parse_instr
+  parse_instr_aux
     ~stack_depth:0
     ?type_logger
     tc_context
@@ -6416,31 +6419,31 @@ let parse_instr :
     script_instr
     stack_ty
 
-let unparse_data = unparse_data ~stack_depth:0
+let unparse_data = unparse_data_aux ~stack_depth:0
 
 let unparse_code ctxt mode code =
-  (* Constants need to be expanded or [unparse_code] may fail. *)
+  (* Constants need to be expanded or [unparse_code_aux] may fail. *)
   Global_constants_storage.expand ctxt (strip_locations code)
-  >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code)
+  >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code)
 
 let parse_contract context loc arg_ty contract ~entrypoint =
-  parse_contract ~stack_depth:0 context loc arg_ty contract ~entrypoint
+  parse_contract_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint
 
 let parse_toplevel ctxt ~legacy toplevel =
   Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) ->
-  Lwt.return @@ parse_toplevel ctxt ~legacy toplevel
+  Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel
 
-let parse_comparable_ty = parse_comparable_ty ~stack_depth:0
+let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0
 
-let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0
+let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0
 
-let parse_packable_ty = parse_packable_ty ~stack_depth:0
+let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0
 
-let parse_passable_ty = parse_passable_ty ~stack_depth:0
+let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0
 
-let parse_any_ty = parse_any_ty ~stack_depth:0
+let parse_any_ty = parse_any_ty_aux ~stack_depth:0
 
-let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints
+let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints
 
 let parse_parameter_ty_and_entrypoints =
   parse_parameter_ty_and_entrypoints ~stack_depth:0
-- 
GitLab


From 9636318ee16ac977a239e399cc49a622150c58af Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 00:29:32 +0100
Subject: [PATCH 38/69] Proto: changes to help compile the translator to Coq

---
 src/proto_alpha/lib_protocol/script_ir_translator.mli | 1 +
 src/proto_alpha/lib_protocol/ticket_scanner.ml        | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli
index 2d88ed80ebaf..1a62441f7bd6 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.mli
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli
@@ -118,6 +118,7 @@ type 'storage ex_view =
   | Ex_view :
       ('input * 'storage, 'output) Script_typed_ir.lambda
       -> 'storage ex_view
+[@@coq_force_gadt]
 
 type ('a, 's, 'b, 'u) cinstr = {
   apply :
diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml
index 80880cc21112..88de29a45e3a 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.ml
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml
@@ -533,7 +533,7 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr =
   match ht with
   | Ticket_inspection.False_ht -> return ([], ctxt)
   | (_ : _ Ticket_inspection.has_tickets) ->
-      (Script_ir_translator.parse_data [@coq_implicit "(a := a)"])
+      (Script_ir_translator.parse_data [@coq_implicit "(A := a)"])
         ctxt
         ~legacy:true
         ~allow_forged:true
-- 
GitLab


From 2bec1ea8d9465d86a9f9e243f14b0bb3f2cf1537 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 12:03:39 +0100
Subject: [PATCH 39/69] Proto: convert more of the translator

---
 .../lib_protocol/script_ir_translator.ml      | 93 ++++++++++++-------
 1 file changed, 60 insertions(+), 33 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index e88bfa0e9a3a..5a62f738a893 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -6303,7 +6303,7 @@ end
 (** Prematurely abort if [f] generates an error. Use this function without the
     [unit] type for [error] if you are in a case where errors are impossible.
 *)
-let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage :
+let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage :
     type a ac error.
     f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f ->
     init:'acc ->
@@ -6314,33 +6314,53 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage :
     (('acc, error) Fold_lazy_storage.result * context) tzresult =
  fun ~f ~init ctxt ty x ~has_lazy_storage ->
   Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->
-  match (has_lazy_storage, ty, x) with
-  | (Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _}) ->
-      Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->
-      ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt)
-  | (Sapling_state_f, Sapling_state_t _, {id = Some id; _}) ->
-      Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->
-      ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt)
+  match[@coq_match_gadt] (has_lazy_storage, ty, x) with
+  | (Big_map_f, Big_map_t (_, _, _), (x : _ big_map)) -> (
+      match x with
+      | Big_map {id = Some id; _} ->
+          Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->
+          ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt)
+      | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt))
+  | (Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state)) -> (
+      match x with
+      | {id = Some id; _} ->
+          Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->
+          ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt)
+      | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt))
   | (False_f, _, _) -> ok (Fold_lazy_storage.Ok init, ctxt)
-  | (Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _}) ->
-      ok (Fold_lazy_storage.Ok init, ctxt)
-  | (Sapling_state_f, Sapling_state_t _, {id = None; _}) ->
-      ok (Fold_lazy_storage.Ok init, ctxt)
-  | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> (
+  | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> (
+      let (xl, xr) = x in
       fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl
       >>? fun (init, ctxt) ->
       match init with
       | Fold_lazy_storage.Ok init ->
           fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr
       | Fold_lazy_storage.Error -> ok (init, ctxt))
-  | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) ->
-      fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage
-  | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) ->
-      fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage
-  | (_, Option_t (_, _, _), None) -> ok (Fold_lazy_storage.Ok init, ctxt)
-  | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) ->
-      fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage
-  | (List_f has_lazy_storage, List_t (ty, _), l) ->
+  | ( Union_f (has_lazy_storage_l, has_lazy_storage_r),
+      Union_t (tyl, tyr, _, _),
+      (x : _ union) ) -> (
+      match x with
+      | L x ->
+          fold_lazy_storage
+            ~f
+            ~init
+            ctxt
+            tyl
+            x
+            ~has_lazy_storage:has_lazy_storage_l
+      | R x ->
+          fold_lazy_storage
+            ~f
+            ~init
+            ctxt
+            tyr
+            x
+            ~has_lazy_storage:has_lazy_storage_r)
+  | (Option_f has_lazy_storage, Option_t (ty, _, _), (o : _ option)) -> (
+      match o with
+      | None -> ok (Fold_lazy_storage.Ok init, ctxt)
+      | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage)
+  | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) ->
       List.fold_left_e
         (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x ->
           match init with
@@ -6349,7 +6369,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage :
           | Fold_lazy_storage.Error -> ok (init, ctxt))
         (Fold_lazy_storage.Ok init, ctxt)
         l.elements
-  | (Map_f has_lazy_storage, Map_t (_, ty, _), m) ->
+  | (Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map)) ->
       Script_map.fold
         (fun _
              v
@@ -6362,18 +6382,21 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage :
         m
         (ok (Fold_lazy_storage.Ok init, ctxt))
 
-let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x =
+let collect_lazy_storage ctxt ty x =
   let has_lazy_storage = has_lazy_storage ty in
   let f kind id (acc : (_, never) Fold_lazy_storage.result) =
-    let acc = match acc with Fold_lazy_storage.Ok acc -> acc in
+    let acc =
+      match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc
+    in
     Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc)
   in
   fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage
   >>? fun (ids, ctxt) ->
-  match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt)
+  match[@coq_match_with_default] ids with
+  | Fold_lazy_storage.Ok ids -> ok (ids, ctxt)
 
-let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode
-    ~temporary ~to_duplicate ~to_update ty v =
+let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v
+    =
   (*
     Basically [to_duplicate] are ids from the argument and [to_update] are ids
     from the storage before execution (i.e. it is safe to reuse them since they
@@ -6386,10 +6409,14 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode
     if temporary then diffs
     else
       let dead = Lazy_storage.IdSet.diff to_update alive in
-      Lazy_storage.IdSet.fold_all
-        {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)}
-        dead
-        diffs
+      let f kind id acc =
+        (Lazy_storage.make [@coq_implicit "(a := unit) (u := unit)"])
+          kind
+          id
+          Remove
+        :: acc
+      in
+      Lazy_storage.IdSet.fold_all {f} dead diffs
   in
   match diffs with
   | [] -> (v, None, ctxt)
@@ -6452,8 +6479,8 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x =
   let has_lazy_storage = has_lazy_storage ty in
   let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i)
       single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result =
-    match kind with
-    | Lazy_storage.Kind.Sapling_state -> (
+    match[@coq_match_gadt] (kind, id) with
+    | (Lazy_storage.Kind.Sapling_state, (id : Alpha_context.Sapling.Id.t)) -> (
         match single_id_opt with
         | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id)
         | Fold_lazy_storage.Ok (Some _) ->
-- 
GitLab


From f559311161cbc3e6ad4c42d4f69114712dcf6ba4 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 13:35:15 +0100
Subject: [PATCH 40/69] Proto: convert more of the translator

---
 .../lib_protocol/script_ir_translator.ml      | 305 ++++++++++--------
 1 file changed, 178 insertions(+), 127 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 5a62f738a893..6696275c9e1e 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -334,7 +334,7 @@ let serialize_ty_for_error ty =
   *)
   unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations
 
-let[@coq_axiom_with_reason "gadt"] rec comparable_ty_of_ty :
+let rec comparable_ty_of_ty :
     type a ac.
     context ->
     Script.location ->
@@ -594,7 +594,7 @@ let comparable_comb_witness2 :
   | Pair_t _ -> Comb_Pair Comb_Any
   | _ -> Comb_Any
 
-let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data :
+let[@coq_struct "ty"] rec unparse_comparable_data :
     type a loc.
     loc:loc ->
     context ->
@@ -612,33 +612,38 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data :
      [unparse_data_aux] for now. *)
   >>?=
   fun ctxt ->
-  match (ty, a) with
-  | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v
-  | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v
-  | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v
-  | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s
-  | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s
-  | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b
-  | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t
-  | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address
-  | (Tx_rollup_l2_address_t, address) ->
+  match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with
+  | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v
+  | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v
+  | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v
+  | (String_t, (s : Script_string.t)) ->
+      Lwt.return @@ unparse_string ~loc ctxt s
+  | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s
+  | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b
+  | (Timestamp_t, (t : Script_timestamp.t)) ->
+      Lwt.return @@ unparse_timestamp ~loc ctxt mode t
+  | (Address_t, (address : address)) ->
+      Lwt.return @@ unparse_address ~loc ctxt mode address
+  | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) ->
       Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address
-  | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s
-  | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v
-  | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k
-  | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k
-  | (Chain_id_t, chain_id) ->
+  | (Signature_t, (s : signature)) ->
+      Lwt.return @@ unparse_signature ~loc ctxt mode s
+  | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v
+  | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k
+  | (Key_hash_t, (k : public_key_hash)) ->
+      Lwt.return @@ unparse_key_hash ~loc ctxt mode k
+  | (Chain_id_t, (chain_id : Script_chain_id.t)) ->
       Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id
-  | (Pair_t (tl, tr, _, YesYes), pair) ->
+  | (Pair_t (tl, tr, _, YesYes), (pair : _ * _)) ->
       let r_witness = comparable_comb_witness2 tr in
       let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in
       let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in
       unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair
-  | (Union_t (tl, tr, _, YesYes), v) ->
+  | (Union_t (tl, tr, _, YesYes), (v : _ union)) ->
       let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in
       let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in
       unparse_union ~loc unparse_l unparse_r ctxt v
-  | (Option_t (t, _, Yes), v) ->
+  | (Option_t (t, _, Yes), (v : _ option)) ->
       let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in
       unparse_option ~loc unparse_v ctxt v
   | (Never_t, _) -> .
@@ -1642,8 +1647,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma
       (Ex_ty big_map_ty, ctxt)
   | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty_aux
-    ctxt ~stack_depth ~legacy value_ty =
+and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth
+    ~legacy value_ty =
   (parse_ty_aux [@tailcall])
     ctxt
     ~stack_depth
@@ -2432,7 +2437,7 @@ let comparable_comb_witness1 :
   | Pair_t _ -> Comb_Pair Comb_Any
   | _ -> Comb_Any
 
-let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data :
+let[@coq_struct "ty"] rec parse_comparable_data :
     type a.
     ?type_logger:type_logger ->
     context ->
@@ -2455,7 +2460,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data :
   >>?=
   fun ctxt ->
   let legacy = false in
-  match (ty, script_data) with
+  match[@coq_match_gadt_with_result] (ty, script_data) with
   | (Unit_t, expr) ->
       Lwt.return @@ traced_no_lwt
       @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult)
@@ -5636,7 +5641,7 @@ let comb_witness2 :
   | Pair_t _ -> Comb_Pair Comb_Any
   | _ -> Comb_Any
 
-let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
+let[@coq_struct "ctxt"] rec unparse_data_aux :
     type a ac.
     context ->
     stack_depth:int ->
@@ -5652,43 +5657,51 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
     else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a
   in
   let loc = Micheline.dummy_location in
-  match (ty, a) with
-  | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v
-  | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v
-  | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v
-  | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s
-  | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s
-  | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b
-  | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t
-  | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address
-  | (Tx_rollup_l2_address_t, address) ->
+  match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with
+  | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v
+  | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v
+  | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v
+  | (String_t, (s : Script_string.t)) ->
+      Lwt.return @@ unparse_string ~loc ctxt s
+  | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s
+  | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b
+  | (Timestamp_t, (t : Script_timestamp.t)) ->
+      Lwt.return @@ unparse_timestamp ~loc ctxt mode t
+  | (Address_t, (address : address)) ->
+      Lwt.return @@ unparse_address ~loc ctxt mode address
+  | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) ->
       Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address
-  | (Contract_t _, contract) ->
+  | (Contract_t _, (contract : _ typed_contract)) ->
       Lwt.return @@ unparse_contract ~loc ctxt mode contract
-  | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s
-  | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v
-  | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k
-  | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k
-  | (Operation_t, operation) ->
+  | (Signature_t, (s : signature)) ->
+      Lwt.return @@ unparse_signature ~loc ctxt mode s
+  | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v
+  | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k
+  | (Key_hash_t, (k : public_key_hash)) ->
+      Lwt.return @@ unparse_key_hash ~loc ctxt mode k
+  | (Operation_t, (operation : operation)) ->
       Lwt.return @@ unparse_operation ~loc ctxt operation
-  | (Chain_id_t, chain_id) ->
+  | (Chain_id_t, (chain_id : Script_chain_id.t)) ->
       Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id
-  | (Bls12_381_g1_t, x) -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x
-  | (Bls12_381_g2_t, x) -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x
-  | (Bls12_381_fr_t, x) -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x
-  | (Pair_t (tl, tr, _, _), pair) ->
+  | (Bls12_381_g1_t, (x : Script_bls.G1.t)) ->
+      Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x
+  | (Bls12_381_g2_t, (x : Script_bls.G2.t)) ->
+      Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x
+  | (Bls12_381_fr_t, (x : Script_bls.Fr.t)) ->
+      Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x
+  | (Pair_t (tl, tr, _, _), (pair : _ * _)) ->
       let r_witness = comb_witness2 tr in
       let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in
       let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in
       unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair
-  | (Union_t (tl, tr, _, _), v) ->
+  | (Union_t (tl, tr, _, _), (v : _ union)) ->
       let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in
       let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in
       unparse_union ~loc unparse_l unparse_r ctxt v
-  | (Option_t (t, _, _), v) ->
+  | (Option_t (t, _, _), (v : _ option)) ->
       let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in
       unparse_option ~loc unparse_v ctxt v
-  | (List_t (t, _), items) ->
+  | (List_t (t, _), (items : _ boxed_list)) ->
       List.fold_left_es
         (fun (l, ctxt) element ->
           non_terminal_recursion ctxt mode t element
@@ -5696,7 +5709,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
         ([], ctxt)
         items.elements
       >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt)
-  | (Ticket_t (t, _), {ticketer; contents; amount}) ->
+  | (Ticket_t (t, _), (x : _ ticket)) ->
+      let {ticketer; contents; amount} = x in
       (* ideally we would like to allow a little overhead here because it is only used for unparsing *)
       opened_ticket_type loc t >>?= fun opened_ticket_ty ->
       let t = ty_of_comparable_ty opened_ticket_ty in
@@ -5708,7 +5722,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
         mode
         t
         (addr, (contents, amount))
-  | (Set_t (t, _), set) ->
+  | (Set_t (t, _), (set : _ set)) ->
       List.fold_left_es
         (fun (l, ctxt) item ->
           unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) ->
@@ -5716,58 +5730,63 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
         ([], ctxt)
         (Script_set.fold (fun e acc -> e :: acc) set [])
       >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
-  | (Map_t (kt, vt, _), map) ->
+  | (Map_t (kt, vt, _), (map : _ map)) ->
       let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in
       unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
       >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
-  | (Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _})
-    when Compare.Int.( = ) size 0 ->
-      return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt)
-  | (Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _}) ->
-      let items =
-        Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map []
-      in
-      let items =
-        (* Sort the items in Michelson comparison order and not in key
-           hash order. This code path is only exercised for tracing,
-           so we don't bother carbonating this sort operation
-           precisely. Also, the sort uses a reverse compare because
-           [unparse_items] will reverse the result. *)
-        List.sort
-          (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)
-          items
-      in
-      (* this can't fail if the original type is well-formed
-         because [option vt] is always strictly smaller than [big_map kt vt] *)
-      option_t loc vt >>?= fun vt ->
-      unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
-      >|=? fun (items, ctxt) ->
-      ( Micheline.Prim
-          ( loc,
-            D_Pair,
-            [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)],
-            [] ),
-        ctxt )
-  | (Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _}) ->
-      let items =
-        Big_map_overlay.fold
-          (fun _ (k, v) acc ->
-            match v with None -> acc | Some v -> (k, v) :: acc)
-          map
-          []
-      in
-      let items =
-        (* See note above. *)
-        List.sort
-          (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)
-          items
-      in
-      unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
-      >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
-  | (Lambda_t _, Lam (_, original_code)) ->
+  | (Big_map_t (kt, vt, _), (x : _ big_map)) -> (
+      let (Big_map {id; diff = {map; size; _}; _}) = x in
+      match id with
+      | Some id ->
+          if Compare.Int.( = ) size 0 then
+            return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt)
+          else
+            let items =
+              Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map []
+            in
+            let items =
+              (* Sort the items in Michelson comparison order and not in key
+                 hash order. This code path is only exercised for tracing,
+                 so we don't bother carbonating this sort operation
+                 precisely. Also, the sort uses a reverse compare because
+                 [unparse_items] will reverse the result. *)
+              List.sort
+                (fun (a, _) (b, _) ->
+                  Script_comparable.compare_comparable kt b a)
+                items
+            in
+            (* this can't fail if the original type is well-formed
+               because [option vt] is always strictly smaller than [big_map kt vt] *)
+            option_t loc vt >>?= fun vt ->
+            unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
+            >|=? fun (items, ctxt) ->
+            ( Micheline.Prim
+                ( loc,
+                  D_Pair,
+                  [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)],
+                  [] ),
+              ctxt )
+      | None ->
+          let items =
+            Big_map_overlay.fold
+              (fun _ (k, v) acc ->
+                match v with None -> acc | Some v -> (k, v) :: acc)
+              map
+              []
+          in
+          let items =
+            (* See note above. *)
+            List.sort
+              (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)
+              items
+          in
+          unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
+          >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt))
+  | (Lambda_t _, (x : _ lambda)) ->
+      let (Lam (_, original_code)) = x in
       unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code
   | (Never_t, _) -> .
-  | (Sapling_transaction_t _, s) ->
+  | (Sapling_transaction_t _, (s : Sapling.transaction)) ->
       Lwt.return
         ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt ->
           let bytes =
@@ -5784,7 +5803,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
               s
           in
           (Bytes (loc, bytes), ctxt) )
-  | (Sapling_state_t _, {id; diff; _}) ->
+  | (Sapling_state_t _, (x : Sapling.state)) ->
+      let {Sapling.id; diff; _} = x in
       Lwt.return
         ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt ->
           ( (match diff with
@@ -5806,14 +5826,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
                     Micheline.Prim
                       (loc, D_Pair, [Int (loc, id); unparsed_diff], []))),
             ctxt ) )
-  | (Chest_key_t, s) ->
+  | (Chest_key_t, (s : Script_timelock.chest_key)) ->
       unparse_with_data_encoding
         ~loc
         ctxt
         s
         Unparse_costs.chest_key
         Script_timelock.chest_key_encoding
-  | (Chest_t, s) ->
+  | (Chest_t, (s : Script_timelock.chest)) ->
       unparse_with_data_encoding
         ~loc
         ctxt
@@ -5822,7 +5842,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux :
            ~plaintext_size:(Script_timelock.get_plaintext_size s))
         Script_timelock.chest_encoding
 
-and unparse_items :
+and[@coq_mutual_as_notation] unparse_items :
     type k v vc.
     context ->
     stack_depth:int ->
@@ -5841,8 +5861,7 @@ and unparse_items :
     ([], ctxt)
     items
 
-and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code
-    =
+and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code =
   let legacy = true in
   Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt ->
   let non_terminal_recursion ctxt mode code =
@@ -5853,7 +5872,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code
   match code with
   | Prim (loc, I_PUSH, [ty; data], annot) ->
       parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty
-      >>?= fun (Ex_ty t, ctxt) ->
+      >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) ->
       let allow_forged =
         false
         (* Forgeable in PUSH data are already forbidden at parsing,
@@ -5869,7 +5888,12 @@ and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code
         t
         data
       >>=? fun (data, ctxt) ->
-      unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode t data
+      unparse_data_aux
+        ctxt
+        ~stack_depth:(stack_depth + 1)
+        mode
+        t
+        (data [@coq_type_annotation])
       >>=? fun (data, ctxt) ->
       return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
   | Seq (loc, items) ->
@@ -6191,9 +6215,9 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage =
   storage diff to show on the receipt and apply on the storage.
 
 *)
-let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
+let extract_lazy_storage_updates ctxt mode
     ~temporary ids_to_copy acc ty x =
-  let rec aux :
+  let[@coq_struct "ctxt"] rec aux :
       type a ac.
       context ->
       unparsing_mode ->
@@ -6206,9 +6230,10 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
       (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t =
    fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage ->
     Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->
-    match (has_lazy_storage, ty, x) with
-    | (False_f, _, _) -> return (ctxt, x, ids_to_copy, acc)
-    | (Big_map_f, Big_map_t (_, _, _), map) ->
+    match[@coq_match_gadt_with_result] (has_lazy_storage, ty, x) with
+    | (False_f, _, _) ->
+        return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation]
+    | (Big_map_f, Big_map_t (_, _, _), (map : _ big_map)) ->
         diff_of_big_map ctxt mode ~temporary ~ids_to_copy map
         >|=? fun (diff, id, ctxt) ->
         let map =
@@ -6223,7 +6248,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
         let diff = Lazy_storage.make Big_map id diff in
         let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in
         (ctxt, map, ids_to_copy, diff :: acc)
-    | (Sapling_state_f, Sapling_state_t _, sapling_state) ->
+    | (Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state)) ->
         diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state
         >|=? fun (diff, id, ctxt) ->
         let sapling_state =
@@ -6232,22 +6257,48 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
         let diff = Lazy_storage.make Sapling_state id diff in
         let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in
         (ctxt, sapling_state, ids_to_copy, diff :: acc)
-    | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) ->
+    | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) ->
+        let (xl, xr) = x in
         aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl
         >>=? fun (ctxt, xl, ids_to_copy, acc) ->
         aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr
         >|=? fun (ctxt, xr, ids_to_copy, acc) ->
         (ctxt, (xl, xr), ids_to_copy, acc)
-    | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) ->
-        aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage
-        >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc)
-    | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) ->
-        aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage
-        >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc)
-    | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) ->
-        aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage
-        >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc)
-    | (List_f has_lazy_storage, List_t (ty, _), l) ->
+    | ( Union_f (has_lazy_storage_l, has_lazy_storage_r),
+        Union_t (tyl, tyr, _, _),
+        (x : _ union) ) -> (
+        match x with
+        | L x ->
+            aux
+              ctxt
+              mode
+              ~temporary
+              ids_to_copy
+              acc
+              tyl
+              x
+              ~has_lazy_storage:has_lazy_storage_l
+            >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc)
+        | R x ->
+            aux
+              ctxt
+              mode
+              ~temporary
+              ids_to_copy
+              acc
+              tyr
+              x
+              ~has_lazy_storage:has_lazy_storage_r
+            >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc)
+        )
+    | (Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option)) -> (
+        match x with
+        | Some x ->
+            aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage
+            >|=? fun (ctxt, x, ids_to_copy, acc) ->
+            (ctxt, Some x, ids_to_copy, acc)
+        | None -> return (ctxt, None, ids_to_copy, acc))
+    | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) ->
         List.fold_left_es
           (fun (ctxt, l, ids_to_copy, acc) x ->
             aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage
@@ -6258,7 +6309,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
         >|=? fun (ctxt, l, ids_to_copy, acc) ->
         let reversed = {length = l.length; elements = List.rev l.elements} in
         (ctxt, reversed, ids_to_copy, acc)
-    | (Map_f has_lazy_storage, Map_t (_, ty, _), map) ->
+    | (Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map)) ->
         let (module M) = Script_map.get_module map in
         let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in
         List.fold_left_es
@@ -6269,7 +6320,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
           (ctxt, M.OPS.empty, ids_to_copy, acc)
           (bindings M.boxed)
         >|=? fun (ctxt, m, ids_to_copy, acc) ->
-        let module M = struct
+        let module M :
+          Boxed_map with type key = M.key and type value = M.value = struct
           module OPS = M.OPS
 
           type key = M.key
@@ -6287,7 +6339,6 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode
                and type value = M.value),
           ids_to_copy,
           acc )
-    | (_, Option_t (_, _, _), None) -> return (ctxt, None, ids_to_copy, acc)
   in
   let has_lazy_storage = has_lazy_storage ty in
   aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage
@@ -6480,7 +6531,7 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x =
   let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i)
       single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result =
     match[@coq_match_gadt] (kind, id) with
-    | (Lazy_storage.Kind.Sapling_state, (id : Alpha_context.Sapling.Id.t)) -> (
+    | (Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t)) -> (
         match single_id_opt with
         | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id)
         | Fold_lazy_storage.Ok (Some _) ->
-- 
GitLab


From 5bce486195fa34d2e6addf164a61915446fe7541 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 14:49:55 +0100
Subject: [PATCH 41/69] Proto: more conversion of the translator

---
 .../lib_protocol/script_ir_translator.ml      | 32 +++++++++++++------
 1 file changed, 23 insertions(+), 9 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 6696275c9e1e..24facf790be1 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -5119,7 +5119,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
              I_OPEN_CHEST;
            ]
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_aux :
+and[@coq_mutual_as_notation] parse_contract_aux :
     type arg argc.
     stack_depth:int ->
     context ->
@@ -5501,7 +5501,7 @@ let parse_storage :
        storage_type
        (root storage))
 
-let[@coq_axiom_with_reason "gadt"] parse_script :
+let parse_script :
     ?type_logger:type_logger ->
     context ->
     legacy:bool ->
@@ -5510,10 +5510,17 @@ let[@coq_axiom_with_reason "gadt"] parse_script :
     (ex_script * context) tzresult Lwt.t =
  fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} ->
   parse_code ~legacy ctxt ?type_logger ~code
-  >>=? fun ( Ex_code
-               (Code
-                 {code; arg_type; storage_type; views; entrypoints; code_size}),
-             ctxt ) ->
+  >>=? fun [@coq_match_gadt] ( Ex_code
+                                 (Code
+                                   {
+                                     code;
+                                     arg_type;
+                                     storage_type;
+                                     views;
+                                     entrypoints;
+                                     code_size;
+                                   }),
+                               ctxt ) ->
   parse_storage
     ?type_logger
     ctxt
@@ -5524,7 +5531,15 @@ let[@coq_axiom_with_reason "gadt"] parse_script :
   >|=? fun (storage, ctxt) ->
   ( Ex_script
       (Script
-         {code_size; code; arg_type; storage; storage_type; views; entrypoints}),
+         {
+           code_size;
+           code;
+           arg_type;
+           storage = storage [@coq_type_annotation];
+           storage_type;
+           views;
+           entrypoints;
+         }),
     ctxt )
 
 let typecheck_code :
@@ -6215,8 +6230,7 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage =
   storage diff to show on the receipt and apply on the storage.
 
 *)
-let extract_lazy_storage_updates ctxt mode
-    ~temporary ids_to_copy acc ty x =
+let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x =
   let[@coq_struct "ctxt"] rec aux :
       type a ac.
       context ->
-- 
GitLab


From f38acd68df63b28b41439feb9bc9ee94e53ff80c Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 15:46:13 +0100
Subject: [PATCH 42/69] Proto: FIX: add missing order type

---
 src/lib_protocol_environment/environment_context_intf.ml | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/lib_protocol_environment/environment_context_intf.ml b/src/lib_protocol_environment/environment_context_intf.ml
index 3746891bc17c..04498b15a483 100644
--- a/src/lib_protocol_environment/environment_context_intf.ml
+++ b/src/lib_protocol_environment/environment_context_intf.ml
@@ -208,6 +208,8 @@ module V3 = V2
 module V4 = struct
   type depth = V3.depth
 
+  type order = [`Sorted | `Undefined]
+
   module type VIEW = sig
     include V3.VIEW
 
-- 
GitLab


From 7a216d6d6f6ad04cde5c94c217bee4d929d2a24b Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 17:48:59 +0100
Subject: [PATCH 43/69] Proto: convert the parse_instr_aux function to Coq

---
 .../lib_protocol/script_ir_translator.ml      | 29 ++++++++++++-------
 1 file changed, 18 insertions(+), 11 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 24facf790be1..03b75a73ed3c 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -3036,7 +3036,7 @@ and[@coq_struct "ctxt"] typecheck_views :
   in
   Script_map.fold_es aux views ctxt
 
-and[@coq_axiom_with_reason "gadt"] parse_returning :
+and[@coq_mutual_as_notation] parse_returning :
     type arg argc ret retc.
     ?type_logger:type_logger ->
     stack_depth:int ->
@@ -3078,7 +3078,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning :
             : (arg, ret) lambda),
           ctxt )
 
-and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
+and[@coq_struct "ctxt"] parse_instr_aux :
     type a s.
     ?type_logger:type_logger ->
     stack_depth:int ->
@@ -3257,7 +3257,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
   | (Prim (loc, I_PUSH, [t; d], annot), stack) ->
       check_var_annot loc annot >>?= fun () ->
       parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t
-      >>?= fun (Ex_ty t, ctxt) ->
+      >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) ->
       parse_data_aux
         ?type_logger
         ~stack_depth:(stack_depth + 1)
@@ -3267,7 +3267,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
         t
         d
       >>=? fun (v, ctxt) ->
-      let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in
+      let const =
+        {apply = (fun kinfo k -> IConst (kinfo, (v [@coq_type_annotation]), k))}
+      in
       typed ctxt loc const (Item_t (t, stack))
   | (Prim (loc, I_UNIT, [], annot), stack) ->
       check_var_type_annot loc annot >>?= fun () ->
@@ -3363,8 +3365,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
             ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty)))
         | (n, Item_t (a_ty, tl_ty)) ->
             make_proof_argument (n - 1) tl_ty
-            >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty')))
-              ->
+            >>? fun [@coq_match_with_default] (Comb_proof_argument
+                                                ( comb_witness,
+                                                  Item_t (b_ty, tl_ty') )) ->
             pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) ->
             Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty'))
         | _ ->
@@ -3381,7 +3384,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
       typed ctxt loc comb after_ty
   | (Prim (loc, I_UNPAIR, [n], annot), stack_ty) ->
       error_unexpected_annot loc annot >>?= fun () ->
-      let rec make_proof_argument :
+      let[@coq_struct "n_value"] rec make_proof_argument :
           type a s.
           int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult =
        fun n stack_ty ->
@@ -4637,10 +4640,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux :
            arg_type_full
            ret_type_full
            code_field)
-      >>=? fun ( Lam
-                   ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _},
-                     _ ),
-                 ctxt ) ->
+      >>=? fun [@coq_match_with_default] ( Lam
+                                             ( {
+                                                 kbef = Item_t (arg, Bot_t);
+                                                 kaft = Item_t (ret, Bot_t);
+                                                 _;
+                                               },
+                                               _ ),
+                                           ctxt ) ->
       let views_result =
         typecheck_views ctxt ?type_logger ~legacy storage_type views
       in
-- 
GitLab


From 8c7553a4e55446ae8068907dfc0b026d6d334b94 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 13 Jan 2022 19:08:44 +0100
Subject: [PATCH 44/69] Proto: end of the conversion of the translator to Coq

---
 .../lib_protocol/script_ir_translator.ml      | 53 +++++++++++++------
 1 file changed, 37 insertions(+), 16 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 03b75a73ed3c..d0df147a14b3 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -2517,7 +2517,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness =
   - storage after origination
 *)
 
-let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
+let[@coq_struct "ctxt"] rec parse_data_aux :
     type a ac.
     ?type_logger:type_logger ->
     stack_depth:int ->
@@ -2661,7 +2661,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
     |> traced
     >|=? fun (_, map, ctxt) -> (map, ctxt)
   in
-  match (ty, script_data) with
+  match[@coq_match_gadt_with_result] (ty, script_data) with
   | (Unit_t, expr) ->
       Lwt.return @@ traced_no_lwt
       @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult)
@@ -2732,7 +2732,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
            tr
            script_instr
   | (Lambda_t _, expr) ->
-      traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Seq_kind], kind expr))
   (* Options *)
   | (Option_t (t, _, _), expr) ->
       let parse_v ctxt v =
@@ -2749,7 +2750,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
            items
            (Script_list.empty, ctxt)
   | (List_t _, expr) ->
-      traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Seq_kind], kind expr))
   (* Tickets *)
   | (Ticket_t (t, _ty_name), expr) ->
       if allow_forged then
@@ -2792,12 +2794,22 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
            vs
       >|=? fun (_, set, ctxt) -> (set, ctxt)
   | (Set_t _, expr) ->
-      traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Seq_kind], kind expr))
   (* Maps *)
   | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) ->
-      parse_items ?type_logger ctxt expr tk tv vs (fun x -> x)
+      ((parse_items [@coq_type_annotation])
+         ?type_logger
+         ctxt
+         expr
+         tk
+         tv
+         vs
+         (fun x -> x)
+        : (_ map * _) tzresult Lwt.t)
   | (Map_t _, expr) ->
-      traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Seq_kind], kind expr))
   | (Big_map_t (tk, tv, _ty_name), expr) ->
       (match expr with
       | Int (loc, id) ->
@@ -2860,14 +2872,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
       | Some pt -> return (pt, ctxt)
       | None -> fail_parse_data ())
   | (Bls12_381_g1_t, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Bls12_381_g2_t, Bytes (_, bs)) -> (
       Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt ->
       match Script_bls.G2.of_bytes_opt bs with
       | Some pt -> return (pt, ctxt)
       | None -> fail_parse_data ())
   | (Bls12_381_g2_t, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Bls12_381_fr_t, Bytes (_, bs)) -> (
       Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt ->
       match Script_bls.Fr.of_bytes_opt bs with
@@ -2877,7 +2891,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
       Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt ->
       return (Script_bls.Fr.of_z v, ctxt)
   | (Bls12_381_fr_t, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
   (*
     /!\ When adding new lazy storage kinds, you may want to guard the parsing
     of identifiers with [allow_forged].
@@ -2899,7 +2914,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
                 >|? fun () -> (transaction, ctxt) ))
       | None -> fail_parse_data ())
   | (Sapling_transaction_t _, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> (
       match
         Data_encoding.Binary.of_bytes_opt
@@ -2918,7 +2934,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
                 >|? fun () -> (transaction, ctxt) ))
       | None -> fail_parse_data ())
   | (Sapling_transaction_deprecated_t _, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Sapling_state_t memo_size, Int (loc, id)) ->
       if allow_forged then
         let id = Sapling.Id.parse_z id in
@@ -2932,11 +2949,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
           >|? fun () -> (state, ctxt) )
       else traced_fail (Unexpected_forged_value loc)
   | (Sapling_state_t memo_size, Seq (_, [])) ->
-      return (Sapling.empty_state ~memo_size (), ctxt)
+      ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt)
+        : (Sapling.state * _) tzresult Lwt.t)
   | (Sapling_state_t _, expr) ->
       (* Do not allow to input diffs as they are untrusted and may not be the
          result of a verify_update. *)
-      traced_fail
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
         (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr))
   (* Time lock*)
   | (Chest_key_t, Bytes (_, bytes)) -> (
@@ -2949,7 +2967,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
       | Some chest_key -> return (chest_key, ctxt)
       | None -> fail_parse_data ())
   | (Chest_key_t, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Chest_t, Bytes (_, bytes)) -> (
       Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes))
       >>?= fun ctxt ->
@@ -2959,7 +2978,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux :
       | Some chest -> return (chest, ctxt)
       | None -> fail_parse_data ())
   | (Chest_t, expr) ->
-      traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))
+      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+        (Invalid_kind (location expr, [Bytes_kind], kind expr))
 
 and[@coq_struct "ctxt"] parse_view_returning :
     type storage storagec.
@@ -5650,6 +5670,7 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty)
     | Some {name; original_type_expr} ->
         (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true)
   in
+
   fold_tree full entrypoints.root [] reachable ([], init)
   [@@coq_axiom_with_reason "unsupported syntax"]
 
-- 
GitLab


From d5e115ccdc4fa50e8d101fd2bcd95cdb44038289 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 14 Jan 2022 15:58:57 +0100
Subject: [PATCH 45/69] Proto: changes to compile rollup_inbox changes to Coq

---
 src/proto_alpha/lib_protocol/apply_results.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 76ae42690919..28886a8c01f0 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -879,7 +879,7 @@ module Manager_result = struct
         | Successful_manager_result (Sc_rollup_add_messages_result _ as op) ->
             Some op
         | _ -> None)
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Sc_rollup_add_messages_result {consumed_gas; inbox_after} ->
             (Gas.Arith.ceil consumed_gas, consumed_gas, inbox_after))
       ~kind:Kind.Sc_rollup_add_messages_manager_kind
-- 
GitLab


From 8d18950b74e931e387adbf6351ec05eba9b3301a Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 21 Jan 2022 17:45:35 +0100
Subject: [PATCH 46/69] Proto: various changes for the latest protocol updates

---
 src/proto_alpha/lib_protocol/script_int_repr.ml         | 2 +-
 src/proto_alpha/lib_protocol/script_int_repr.mli        | 2 +-
 src/proto_alpha/lib_protocol/script_interpreter.ml      | 9 ++++++++-
 src/proto_alpha/lib_protocol/script_interpreter_defs.ml | 2 +-
 src/proto_alpha/lib_protocol/script_ir_translator.ml    | 8 ++++++--
 src/proto_alpha/lib_protocol/script_typed_ir_size.ml    | 3 ++-
 src/proto_alpha/lib_protocol/storage.ml                 | 9 +++++++--
 src/proto_alpha/lib_protocol/ticket_hash_repr.ml        | 4 +++-
 8 files changed, 29 insertions(+), 10 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_int_repr.ml b/src/proto_alpha/lib_protocol/script_int_repr.ml
index fba40417adb4..9b74fcf18e1d 100644
--- a/src/proto_alpha/lib_protocol/script_int_repr.ml
+++ b/src/proto_alpha/lib_protocol/script_int_repr.ml
@@ -35,7 +35,7 @@ type z = Integer_tag
    having to deconstruct to and reconstruct from `Z.t`. *)
 type 't repr = Z.t
 
-type 't num = Num_tag of 't repr [@@ocaml.unboxed]
+type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt]
 
 let compare (Num_tag x) (Num_tag y) = Z.compare x y
 
diff --git a/src/proto_alpha/lib_protocol/script_int_repr.mli b/src/proto_alpha/lib_protocol/script_int_repr.mli
index 1dbb5425330d..7abe7e93c569 100644
--- a/src/proto_alpha/lib_protocol/script_int_repr.mli
+++ b/src/proto_alpha/lib_protocol/script_int_repr.mli
@@ -34,7 +34,7 @@ type 't repr [@@coq_phantom]
 
 (** [num] is made algebraic in order to distinguish it from the other type
     parameters of [Script_typed_ir.ty]. *)
-type 't num = Num_tag of 't repr [@@ocaml.unboxed]
+type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt]
 
 (** Flag for natural numbers. *)
 type n = Natural_tag
diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index 88dce0786b0e..25c3ba98c054 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -1473,7 +1473,14 @@ and[@coq_struct "function_parameter"] step :
           | Some (balance, state) ->
               let state = Some (Script_int.of_int64 balance, state) in
               (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack
-          | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)
+          | None ->
+              (step [@ocaml.tailcall])
+                (ctxt, sc)
+                gas
+                k
+                ks
+                (None [@coq_type_annotation])
+                stack)
       | (IChainId (_, k), _, _) ->
           let stack = (accu, stack) in
           let accu = Script_chain_id.make sc.chain_id in
diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
index aedb940d85b1..ecbf1aa6707f 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
@@ -448,7 +448,7 @@ let apply ctxt gas capture_ty capture lam =
       >>=? fun (const_expr, ctxt) ->
       let loc = Micheline.dummy_location in
       unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) ->
-      match full_arg_ty with
+      match[@coq_match_with_default] full_arg_ty with
       | Pair_t (capture_ty, arg_ty, _, _) ->
           let arg_stack_ty = Item_t (arg_ty, Bot_t) in
           let full_descr =
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index d0df147a14b3..0ea14424928d 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -6272,7 +6272,9 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x =
       (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t =
    fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage ->
     Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->
-    match[@coq_match_gadt_with_result] (has_lazy_storage, ty, x) with
+    match[@coq_match_gadt_with_result] [@coq_match_with_default]
+      (has_lazy_storage, ty, x)
+    with
     | (False_f, _, _) ->
         return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation]
     | (Big_map_f, Big_map_t (_, _, _), (map : _ big_map)) ->
@@ -6407,7 +6409,9 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage :
     (('acc, error) Fold_lazy_storage.result * context) tzresult =
  fun ~f ~init ctxt ty x ~has_lazy_storage ->
   Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->
-  match[@coq_match_gadt] (has_lazy_storage, ty, x) with
+  match[@coq_match_gadt] [@coq_match_with_default]
+    (has_lazy_storage, ty, x)
+  with
   | (Big_map_f, Big_map_t (_, _, _), (x : _ big_map)) -> (
       match x with
       | Big_map {id = Some id; _} ->
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index a6b2ca67451f..240f1f5c9120 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -275,7 +275,8 @@ let[@coq_struct "ty"] rec value_size_aux :
     | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x)
     | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length))
     | Set_t (_, _) ->
-        let module M = (val Script_set.get x) in
+        let set = Script_set.get x in
+        let module M = (val set) in
         let boxing_space = !!300 in
         ret_succ_adding accu (boxing_space +! (h4w *? M.size))
     | Map_t (_, _, _) ->
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 624e50ecdb28..3e4b62cac9d7 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1388,9 +1388,14 @@ module Ticket_balance = struct
     let name = ["ticket_balance"]
   end
 
-  module Sub_context = Make_subcontext (Registered) (Raw_context) (Name)
+  module Sub_context = Make_subcontext (Registered) (Raw_context.M) (Name)
   module Index = Make_index (Ticket_hash_repr.Index)
-  module Table =
+
+  module Table :
+    Non_iterable_indexed_carbonated_data_storage
+      with type t := Raw_context.t
+       and type key = Ticket_hash_repr.t
+       and type value = Z.t =
     Make_indexed_carbonated_data_storage (Sub_context) (Index) (Encoding.Z)
 end
 
diff --git a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml
index 21c186911404..36465bcf1245 100644
--- a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml
+++ b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml
@@ -35,4 +35,6 @@ include Compare.Make (struct
   let compare = compare
 end)
 
-module Index = Script_expr_hash
+module Index : Storage_description.INDEX with type t = t = struct
+  include Script_expr_hash
+end
-- 
GitLab


From b6d1a35f1f8ae6a36990ea662d0202887e6d6626 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 25 Jan 2022 12:01:26 +0100
Subject: [PATCH 47/69] Proto: translate pack/unpack to Coq

---
 .../lib_protocol/storage_description.ml        | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/storage_description.ml b/src/proto_alpha/lib_protocol/storage_description.ml
index 7bac72c5a969..aee0ea463cd9 100644
--- a/src/proto_alpha/lib_protocol/storage_description.ml
+++ b/src/proto_alpha/lib_protocol/storage_description.ml
@@ -124,26 +124,28 @@ type (_, _, _) args =
       ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
       -> ('key, 'a * 'b, 'sub_key) args
 
-let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function
+let[@coq_struct "function_parameter"] rec unpack :
+    type a b c. (a, b, c) args -> c -> a * b =
+  function[@coq_match_gadt_with_result]
   | One _ -> fun x -> x
   | Pair (l, r) ->
-      let unpack_l = unpack l in
-      let unpack_r = unpack r in
+      let unpack_l = (unpack [@coq_type_annotation]) l in
+      let unpack_r = (unpack [@coq_type_annotation]) r in
       fun x ->
         let (c, d) = unpack_r x in
         let (b, a) = unpack_l c in
         (b, (a, d))
-  [@@coq_axiom_with_reason "gadt"]
 
-let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function
+let[@coq_struct "function_parameter"] rec pack :
+    type a b c. (a, b, c) args -> a -> b -> c =
+  function[@coq_match_gadt_with_result]
   | One _ -> fun b a -> (b, a)
   | Pair (l, r) ->
-      let pack_l = pack l in
-      let pack_r = pack r in
+      let pack_l = (pack [@coq_type_annotation]) l in
+      let pack_r = (pack [@coq_type_annotation]) r in
       fun b (a, d) ->
         let c = pack_l b a in
         pack_r c d
-  [@@coq_axiom_with_reason "gadt"]
 
 let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function
   | One {compare; _} -> compare
-- 
GitLab


From d89358e52d784ac5a89cc2fe3a4df73aa8da57dc Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Mon, 31 Jan 2022 17:49:25 +0100
Subject: [PATCH 48/69] Proto: compile tx_rollup_l2_address.ml to Coq

---
 .../tx_rollup_commitments_storage.ml          | 94 +++++++++++++++++++
 1 file changed, 94 insertions(+)
 create mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml

diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml
new file mode 100644
index 000000000000..e414e422f789
--- /dev/null
+++ b/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml
@@ -0,0 +1,94 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2021 Marigold <contact@marigold.dev>                        *)
+(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com>                *)
+(* Copyright (c) 2021 Oxhead Alpha <info@oxheadalpha.com>                    *)
+(*                                                                           *)
+(* 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.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+let just_ctxt (ctxt, _, _) = ctxt
+
+open Tx_rollup_commitments_repr
+
+(** Return commitments in the order that they were submitted *)
+let get_or_empty_commitments :
+    Raw_context.t ->
+    Raw_level_repr.t * Tx_rollup_repr.t ->
+    (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t =
+ fun ctxt key ->
+  Storage.Tx_rollup.Commitment_list.find ctxt key >|=? fun (ctxt, commitment) ->
+  Option.fold
+    commitment
+    ~none:(ctxt, Tx_rollup_commitments_repr.empty)
+    ~some:(fun l -> (ctxt, List.rev l))
+
+let get_prev_level ctxt tx_rollup level =
+  Tx_rollup_inbox_storage.get_adjacent_levels ctxt level tx_rollup
+  >|=? fun (ctxt, predecessor_level, _) -> (ctxt, predecessor_level)
+
+let check_commitment_predecessor_hash ctxt tx_rollup (commitment : Commitment.t)
+    =
+  let level = commitment.level in
+  (* Check that level has the correct predecessor *)
+  get_prev_level ctxt tx_rollup level >>=? fun (ctxt, predecessor_level) ->
+  match (predecessor_level, commitment.predecessor) with
+  | (None, None) -> return ctxt
+  | (Some _, None) | (None, Some _) -> fail Wrong_commitment_predecessor_level
+  | (Some predecessor_level, Some hash) ->
+      (* The predecessor level must include this commitment*)
+      get_or_empty_commitments ctxt (predecessor_level, tx_rollup)
+      >>=? fun (ctxt, predecesor_commitments) ->
+      fail_unless
+        (Tx_rollup_commitments_repr.commitment_exists
+           predecesor_commitments
+           hash)
+        Missing_commitment_predecessor
+      >>=? fun () -> return ctxt
+
+let add_commitment ctxt tx_rollup contract (commitment : Commitment.t) =
+  let key = (commitment.level, tx_rollup) in
+  get_or_empty_commitments ctxt key >>=? fun (ctxt, pending) ->
+  Tx_rollup_inbox_storage.get ctxt ~level:(Level commitment.level) tx_rollup
+  >>=? fun (ctxt, inbox) ->
+  let expected_len = List.length inbox.contents in
+  let actual_len = List.length commitment.batches in
+  fail_unless Compare.Int.(expected_len = actual_len) Wrong_batch_count
+  >>=? fun () ->
+  check_commitment_predecessor_hash ctxt tx_rollup commitment >>=? fun ctxt ->
+  Tx_rollup_commitments_repr.append
+    pending
+    contract
+    commitment
+    (Raw_context.current_level ctxt).level
+  >>?= fun new_pending ->
+  Storage.Tx_rollup.Commitment_list.add ctxt key new_pending >|=? just_ctxt
+
+let get_commitments :
+    Raw_context.t ->
+    Tx_rollup_repr.t ->
+    Raw_level_repr.t ->
+    (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t =
+ fun ctxt tx_rollup level ->
+  Storage.Tx_rollup.State.find ctxt tx_rollup >>=? fun (ctxt, state) ->
+  match state with
+  | None -> fail @@ Tx_rollup_state_storage.Tx_rollup_does_not_exist tx_rollup
+  | Some _ -> get_or_empty_commitments ctxt (level, tx_rollup)
-- 
GitLab


From d632367473ea826202caa3a6115dd1b46f4ed8ee Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 1 Feb 2022 17:26:57 +0100
Subject: [PATCH 49/69] Proto: fix compilation of ticket_operations_diff.ml to
 Coq

---
 src/proto_alpha/lib_protocol/ticket_operations_diff.ml | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
index 60837e56e172..a508530f3078 100644
--- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
+++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
@@ -187,9 +187,9 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location
           match script_opt with
           | None -> fail (Failed_to_get_script destination)
           | Some script -> return (script, ctxt))
-      >>=? fun ( Script_ir_translator.Ex_script
-                   (Script {arg_type; entrypoints; _}),
-                 ctxt ) ->
+      >>=? fun [@coq_match_gadt] ( Script_ir_translator.Ex_script
+                                     (Script {arg_type; entrypoints; _}),
+                                   ctxt ) ->
       (* Find the entrypoint type for the given entrypoint. *)
       Gas_monad.run
         ctxt
-- 
GitLab


From 6e4548ab012271129f6baf26c1f8fd76d9cb6df3 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Thu, 3 Feb 2022 13:01:27 +0100
Subject: [PATCH 50/69] Proto: compile changes of 2022-02-03 to Coq

---
 src/lib_protocol_environment/sigs/v5/bounded.mli | 2 +-
 src/lib_protocol_environment/sigs/v5/context.mli | 1 +
 src/proto_alpha/lib_protocol/sc_rollup_repr.ml   | 3 ++-
 src/proto_alpha/lib_protocol/sc_rollup_repr.mli  | 2 +-
 src/proto_alpha/lib_protocol/tx_rollup_repr.ml   | 4 +++-
 5 files changed, 8 insertions(+), 4 deletions(-)

diff --git a/src/lib_protocol_environment/sigs/v5/bounded.mli b/src/lib_protocol_environment/sigs/v5/bounded.mli
index 46539808d088..f2a037d48a7b 100644
--- a/src/lib_protocol_environment/sigs/v5/bounded.mli
+++ b/src/lib_protocol_environment/sigs/v5/bounded.mli
@@ -66,5 +66,5 @@ module Int32 : sig
       allow future compatiblity with larger bounds, at the price of addding 1-3
       redundant bytes to each message.
    *)
-  module Make (_ : BOUNDS) : S
+  module Make (B : BOUNDS) : S
 end
diff --git a/src/lib_protocol_environment/sigs/v5/context.mli b/src/lib_protocol_environment/sigs/v5/context.mli
index 4d7ccd466b73..068eedd5add5 100644
--- a/src/lib_protocol_environment/sigs/v5/context.mli
+++ b/src/lib_protocol_environment/sigs/v5/context.mli
@@ -139,6 +139,7 @@ end
 module Kind : sig
   type t = [`Value | `Tree]
 end
+[@@coq_plain_module]
 
 module type TREE = sig
   (** [Tree] provides immutable, in-memory partial mirror of the
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml
index 411a3f4bfb6c..f26031dbc110 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml
@@ -219,7 +219,8 @@ module Index = struct
   let compare = Address.compare
 end
 
-module Commitment_hash_index = struct
+module Commitment_hash_index :
+  Storage_description.INDEX with type t = Commitment_hash.t = struct
   include Commitment_hash
 end
 
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
index ccfff22d9534..decea0652e93 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
+++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
@@ -56,7 +56,7 @@ module Internal_for_tests : sig
   val originated_sc_rollup : Origination_nonce.t -> Address.t
 end
 
-module Commitment_hash : S.HASH
+module Commitment_hash : S.HASH [@@coq_plain_module]
 
 module State_hash : S.HASH
 
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_repr.ml
index 2623a090fe3e..8782ee21d606 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_repr.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_repr.ml
@@ -83,7 +83,9 @@ let in_memory_size _ =
 let to_b58check rollup = Hash.to_b58check rollup
 
 let of_b58check_opt s =
-  match Base58.decode s with Some (Hash.Data hash) -> Some hash | _ -> None
+  match Base58.decode s with
+  | Some data -> ( match data with Hash.Data hash -> Some hash | _ -> None)
+  | _ -> None
 
 let of_b58check s =
   match of_b58check_opt s with
-- 
GitLab


From c961bb04ea4ed35fd6714b8fcd82005edfcdad94 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 4 Feb 2022 16:00:02 +0100
Subject: [PATCH 51/69] Proto: fix compilation of ticket_hash_builder.ml in Coq

---
 src/proto_alpha/lib_protocol/ticket_hash_builder.ml | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml
index fc7f79181e18..1fdc9e9245dc 100644
--- a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml
+++ b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml
@@ -41,11 +41,11 @@ let () =
     (fun () -> Failed_to_hash_node)
 
 let hash_bytes_cost bytes =
-  let module S = Saturation_repr in
-  let ( + ) = S.add in
-  let v0 = S.safe_int @@ Bytes.length bytes in
-  let ( lsr ) = S.shift_right in
-  S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost
+  let ( + ) = Saturation_repr.add in
+  let v0 = Saturation_repr.safe_int @@ Bytes.length bytes in
+  let ( lsr ) = Saturation_repr.shift_right in
+  Saturation_repr.safe_int 200 + (v0 + (v0 lsr 2))
+  |> Gas_limit_repr.atomic_step_cost
 
 let hash_of_node ctxt node =
   Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node)
-- 
GitLab


From 73a0c6942044bdbeda6bfb18b67917d832acf358 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 9 Feb 2022 18:47:11 +0100
Subject: [PATCH 52/69] Proto: fix compilation of the translator for
 coq-of-ocaml

---
 .../lib_protocol/script_ir_translator.ml      | 111 ++++++++++--------
 1 file changed, 64 insertions(+), 47 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 0ea14424928d..8e3b97622094 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -1253,7 +1253,7 @@ type ('ret, 'name) parse_ty_ret =
   | Parse_entrypoints
       : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret
 
-let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty_aux :
+let[@coq_struct "node_value"] rec parse_ty_aux :
     type ret name.
     context ->
     stack_depth:int ->
@@ -1279,11 +1279,11 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
     error Typechecking_too_many_recursive_calls
   else
     (match ret with
-    | Don't_parse_entrypoints -> ok (node, (() : name))
+    | Don't_parse_entrypoints -> ok (node, None)
     | Parse_entrypoints -> extract_entrypoint_annot node)
     >>? fun (node, name) ->
     let return ctxt ty : ret * context =
-      match ret with
+      match[@coq_match_gadt_with_result] ret with
       | Don't_parse_entrypoints -> (Ex_ty ty, ctxt)
       | Parse_entrypoints ->
           let at_node =
@@ -1418,12 +1418,22 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
           utr
         >>? fun (parsed_r, ctxt) ->
         check_type_annot loc annot >>? fun () ->
-        match ret with
-        | Don't_parse_entrypoints ->
+        match[@coq_match_gadt_with_result]
+          ( ret,
+            (parsed_l [@coq_type_annotation]),
+            (parsed_r [@coq_type_annotation]) )
+        with
+        | (Don't_parse_entrypoints, (parsed_l : ex_ty), (parsed_r : ex_ty)) ->
             let (Ex_ty tl) = parsed_l in
             let (Ex_ty tr) = parsed_r in
             union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt)
-        | Parse_entrypoints ->
+
+        (* | Parse_entrypoints ->
+         *     let (Ex_parameter_ty_and_entrypoints_node *)
+
+        | ( Parse_entrypoints,
+            (parsed_l : ex_parameter_ty_and_entrypoints_node),
+            (parsed_r : ex_parameter_ty_and_entrypoints_node) ) ->
             let (Ex_parameter_ty_and_entrypoints_node
                   {arg_type = tl; entrypoints = left}) =
               parsed_l
@@ -1593,7 +1603,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty
                T_tx_rollup_l2_address;
              ]
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux_with_ret :
+and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret :
     type ret name.
     context ->
     stack_depth:int ->
@@ -1602,35 +1612,34 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab
     Script.node ->
     (ret * context) tzresult =
  fun ctxt ~stack_depth ~legacy ->
-  (parse_ty_aux [@tailcall])
-    ctxt
-    ~stack_depth
-    ~legacy
-    ~allow_lazy_storage:true
-    ~allow_operation:false
-    ~allow_contract:true
-    ~allow_ticket:true
+  ((parse_ty_aux [@tailcall])
+     ctxt
+     ~stack_depth
+     ~legacy
+     ~allow_lazy_storage:true
+     ~allow_operation:false
+     ~allow_contract:true
+     ~allow_ticket:true [@coq_type_annotation])
 
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty_aux
-    :
+and[@coq_mutual_as_notation] parse_any_ty_aux :
     context ->
     stack_depth:int ->
     legacy:bool ->
     Script.node ->
     (ex_ty * context) tzresult =
  fun ctxt ~stack_depth ~legacy ->
-  (parse_ty_aux [@tailcall])
-    ctxt
-    ~stack_depth
-    ~legacy
-    ~allow_lazy_storage:true
-    ~allow_operation:true
-    ~allow_contract:true
-    ~allow_ticket:true
-    ~ret:Don't_parse_entrypoints
-
-and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty
-    ctxt ~stack_depth ~legacy big_map_loc args map_annot =
+  ((parse_ty_aux [@tailcall])
+     ctxt
+     ~stack_depth
+     ~legacy
+     ~allow_lazy_storage:true
+     ~allow_operation:true
+     ~allow_contract:true
+     ~allow_ticket:true
+     ~ret:Don't_parse_entrypoints [@coq_type_annotation])
+
+and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc
+    args map_annot =
   Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt ->
   match args with
   | [key_ty; value_ty] ->
@@ -1649,16 +1658,16 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma
 
 and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth
     ~legacy value_ty =
-  (parse_ty_aux [@tailcall])
-    ctxt
-    ~stack_depth
-    ~legacy
-    ~allow_lazy_storage:false
-    ~allow_operation:false
-    ~allow_contract:legacy
-    ~allow_ticket:true
-    ~ret:Don't_parse_entrypoints
-    value_ty
+  ((parse_ty_aux [@tailcall])
+     ctxt
+     ~stack_depth
+     ~legacy
+     ~allow_lazy_storage:false
+     ~allow_operation:false
+     ~allow_contract:legacy
+     ~allow_ticket:true
+     ~ret:Don't_parse_entrypoints
+     value_ty [@coq_type_annotation])
 
 let parse_packable_ty_aux ctxt ~stack_depth ~legacy node =
   (parse_ty_aux [@tailcall])
@@ -1956,7 +1965,7 @@ let find_entrypoint (type full fullc error_trace)
       (t ex_ty_cstr, unit) Gas_monad.t =
    fun ty entrypoints entrypoint ->
     let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in
-    match (ty, entrypoints) with
+    match[@coq_match_with_default] (ty, entrypoints) with
     | (_, {at_node = Some {name; original_type_expr}; _})
       when Entrypoint.(name = entrypoint) ->
         return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr})
@@ -2076,7 +2085,7 @@ type ex_parameter_ty_and_entrypoints =
     }
       -> ex_parameter_ty_and_entrypoints
 
-let parse_parameter_ty_and_entrypoints :
+let parse_parameter_ty_and_entrypoints_aux :
     context ->
     stack_depth:int ->
     legacy:bool ->
@@ -4631,7 +4640,7 @@ and[@coq_struct "ctxt"] parse_instr_aux :
       >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) ->
       record_trace
         (Ill_formed_type (Some "parameter", canonical_code, location arg_type))
-        (parse_parameter_ty_and_entrypoints
+        (parse_parameter_ty_and_entrypoints_aux
            ctxt
            ~stack_depth:(stack_depth + 1)
            ~legacy
@@ -5188,7 +5197,7 @@ and[@coq_mutual_as_notation] parse_contract_aux :
                   (* can only fail because of gas *)
                   parse_toplevel_aux ctxt ~legacy:true code
                   >>? fun ({arg_type; _}, ctxt) ->
-                  parse_parameter_ty_and_entrypoints
+                  parse_parameter_ty_and_entrypoints_aux
                     ctxt
                     ~stack_depth:(stack_depth + 1)
                     ~legacy:true
@@ -5391,7 +5400,7 @@ let parse_contract_for_script :
                   | Error _ -> error (Invalid_contract (loc, contract))
                   | Ok ({arg_type; _}, ctxt) -> (
                       match
-                        parse_parameter_ty_and_entrypoints
+                        parse_parameter_ty_and_entrypoints_aux
                           ctxt
                           ~stack_depth:0
                           ~legacy:true
@@ -5471,7 +5480,11 @@ let parse_code :
   let arg_type_loc = location arg_type in
   record_trace
     (Ill_formed_type (Some "parameter", code, arg_type_loc))
-    (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type)
+    (parse_parameter_ty_and_entrypoints_aux
+       ctxt
+       ~stack_depth:0
+       ~legacy
+       arg_type)
   >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) ->
   let storage_type_loc = location storage_type in
   record_trace
@@ -5584,7 +5597,11 @@ let typecheck_code :
   let arg_type_loc = location arg_type in
   record_trace
     (Ill_formed_type (Some "parameter", code, arg_type_loc))
-    (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type)
+    (parse_parameter_ty_and_entrypoints_aux
+       ctxt
+       ~stack_depth:0
+       ~legacy
+       arg_type)
   >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) ->
   let storage_type_loc = location storage_type in
   record_trace
@@ -6570,7 +6587,7 @@ let parse_any_ty = parse_any_ty_aux ~stack_depth:0
 let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints
 
 let parse_parameter_ty_and_entrypoints =
-  parse_parameter_ty_and_entrypoints ~stack_depth:0
+  parse_parameter_ty_and_entrypoints_aux ~stack_depth:0
 
 let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x =
   let has_lazy_storage = has_lazy_storage ty in
-- 
GitLab


From 19beb71efa6ec52f52a458d82a1950cd258b6d47 Mon Sep 17 00:00:00 2001
From: Klaus Andrey <deepmindster@gmail.com>
Date: Fri, 11 Feb 2022 13:15:19 +0300
Subject: [PATCH 53/69] fixed wrong function definitions for value_size_aux and
 apply_comparable

---
 .../lib_protocol/script_typed_ir_size.ml      | 128 ++++++++++--------
 1 file changed, 73 insertions(+), 55 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index 240f1f5c9120..f35cdcd99097 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -250,89 +250,107 @@ let[@coq_struct "ty"] rec value_size_aux :
  fun ~count_lambda_nodes accu ty x ->
   let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size =
    fun accu ty x ->
-    match[@coq_match_gadt] [@coq_match_with_default] ty with
-    | Unit_t -> ret_succ accu
-    | Int_t -> ret_succ_adding accu (script_int_size x)
-    | Nat_t -> ret_succ_adding accu (script_nat_size x)
-    | Signature_t -> ret_succ_adding accu signature_size
-    | String_t -> ret_succ_adding accu (script_string_size x)
-    | Bytes_t -> ret_succ_adding accu (bytes_size x)
-    | Mutez_t -> ret_succ_adding accu mutez_size
-    | Key_hash_t -> ret_succ_adding accu (key_hash_size x)
-    | Key_t -> ret_succ_adding accu (public_key_size x)
-    | Timestamp_t -> ret_succ_adding accu (timestamp_size x)
-    | Address_t -> ret_succ_adding accu (address_size x)
-    | Tx_rollup_l2_address_t ->
+    match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with
+    | (Unit_t, _) -> ret_succ accu
+    | (Int_t, (x : _ Script_int.num)) ->
+        ret_succ_adding accu (script_int_size x)
+    | (Nat_t, (x : _ Script_int.num)) ->
+        ret_succ_adding accu (script_nat_size x)
+    | (Signature_t, _) -> ret_succ_adding accu signature_size
+    | (String_t, (x : Script_string.t)) ->
+        ret_succ_adding accu (script_string_size x)
+    | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x)
+    | (Mutez_t, _) -> ret_succ_adding accu mutez_size
+    | (Key_hash_t, (x : public_key_hash)) ->
+        ret_succ_adding accu (key_hash_size x)
+    | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x)
+    | (Timestamp_t, (x : Script_timestamp.t)) ->
+        ret_succ_adding accu (timestamp_size x)
+    | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x)
+    | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) ->
         ret_succ_adding accu (tx_rollup_l2_address_size x)
-    | Bool_t -> ret_succ accu
-    | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w
-    | Union_t (_, _, _, _) -> ret_succ_adding accu h1w
-    | Lambda_t (_, _, _) ->
+    | (Bool_t, _) -> ret_succ accu
+    | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w
+    | (Union_t (_, _, _, _), _) -> ret_succ_adding accu h1w
+    | (Lambda_t (_, _, _), (x : _ lambda)) ->
         (lambda_size_aux [@ocaml.tailcall])
           ~count_lambda_nodes
           (ret_succ accu)
           x
-    | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x)
-    | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length))
-    | Set_t (_, _) ->
+    | (Option_t (_, _, _), (x : _ option)) ->
+        ret_succ_adding accu (option_size (fun _ -> !!0) x)
+    | (List_t (_, _), (x : _ boxed_list)) ->
+        ret_succ_adding accu (h2w +! (h2w *? x.length))
+    | (Set_t (_, _), (x : _ set)) ->
         let set = Script_set.get x in
         let module M = (val set) in
         let boxing_space = !!300 in
         ret_succ_adding accu (boxing_space +! (h4w *? M.size))
-    | Map_t (_, _, _) ->
-        let module M = (val Script_map.get_module x) in
+    | (Map_t (_, _, _), (x : _ map)) ->
+        let map = Script_map.get_module x in
+        let module M = (val map) in
         let boxing_space = !!308 in
         ret_succ_adding accu (boxing_space +! (h5w *? M.size))
-    | Big_map_t (cty, ty', _) ->
+    | (Big_map_t (cty, ty', _), (x : _ big_map)) ->
         (big_map_size_aux [@ocaml.tailcall])
           ~count_lambda_nodes
           (ret_succ accu)
           cty
           ty'
           x
-    | Contract_t (_, _) -> ret_succ (accu ++ contract_size x)
-    | Sapling_transaction_t _ ->
+    | (Contract_t (_, _), (x : _ typed_contract)) ->
+        ret_succ (accu ++ contract_size x)
+    | (Sapling_transaction_t _, (x : Sapling.transaction)) ->
         ret_succ_adding accu (Sapling.transaction_in_memory_size x)
-    | Sapling_transaction_deprecated_t _ ->
+    | (Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction))
+      ->
         ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x)
-    | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x)
+    | (Sapling_state_t _, (x : Sapling.state)) ->
+        ret_succ_adding accu (sapling_state_size x)
     (* Operations are neither storable nor pushable, so they can appear neither
        in the storage nor in the script. Hence they cannot appear in the cache
        and we never need to measure their size. *)
-    | Operation_t -> assert false
-    | Chain_id_t -> ret_succ_adding accu chain_id_size
-    | Never_t -> ( match x with _ -> .)
-    | Bls12_381_g1_t -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory
-    | Bls12_381_g2_t -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory
-    | Bls12_381_fr_t -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory
-    | Ticket_t (_, _) -> ret_succ_adding accu (ticket_size x)
-    | Chest_key_t -> ret_succ_adding accu (chest_key_size x)
-    | Chest_t -> ret_succ_adding accu (chest_size x)
+    | (Operation_t, _) -> assert false
+    | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size
+    | (Never_t, _) -> .
+    | (Bls12_381_g1_t, _) -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory
+    | (Bls12_381_g2_t, _) -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory
+    | (Bls12_381_fr_t, _) -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory
+    | (Ticket_t (_, _), (x : _ ticket)) -> ret_succ_adding accu (ticket_size x)
+    | (Chest_key_t, (x : Script_timelock.chest_key)) ->
+        ret_succ_adding accu (chest_key_size x)
+    | (Chest_t, (x : Script_timelock.chest)) ->
+        ret_succ_adding accu (chest_size x)
   in
   let apply_comparable :
       type a. nodes_and_size -> a comparable_ty -> a -> nodes_and_size =
    fun accu ty x ->
-    match[@coq_match_gadt] [@coq_match_with_default] ty with
-    | Unit_t -> ret_succ accu
-    | Int_t -> ret_succ_adding accu (script_int_size x)
-    | Nat_t -> ret_succ_adding accu (script_nat_size x)
-    | Signature_t -> ret_succ_adding accu signature_size
-    | String_t -> ret_succ_adding accu (script_string_size x)
-    | Bytes_t -> ret_succ_adding accu (bytes_size x)
-    | Mutez_t -> ret_succ_adding accu mutez_size
-    | Key_hash_t -> ret_succ_adding accu (key_hash_size x)
-    | Key_t -> ret_succ_adding accu (public_key_size x)
-    | Timestamp_t -> ret_succ_adding accu (timestamp_size x)
-    | Address_t -> ret_succ_adding accu (address_size x)
-    | Tx_rollup_l2_address_t ->
+    match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with
+    | (Unit_t, _) -> ret_succ accu
+    | (Int_t, (x : _ Script_int.num)) ->
+        ret_succ_adding accu (script_int_size x)
+    | (Nat_t, (x : _ Script_int.num)) ->
+        ret_succ_adding accu (script_nat_size x)
+    | (Signature_t, _) -> ret_succ_adding accu signature_size
+    | (String_t, (x : Script_string.t)) ->
+        ret_succ_adding accu (script_string_size x)
+    | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x)
+    | (Mutez_t, _) -> ret_succ_adding accu mutez_size
+    | (Key_hash_t, (x : public_key_hash)) ->
+        ret_succ_adding accu (key_hash_size x)
+    | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x)
+    | (Timestamp_t, (x : Script_timestamp.t)) ->
+        ret_succ_adding accu (timestamp_size x)
+    | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x)
+    | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) ->
         ret_succ_adding accu (tx_rollup_l2_address_size x)
-    | Bool_t -> ret_succ accu
-    | Pair_t (_, _, _, YesYes) -> ret_succ_adding accu h2w
-    | Union_t (_, _, _, YesYes) -> ret_succ_adding accu h1w
-    | Option_t (_, _, Yes) ->
+    | (Bool_t, _) -> ret_succ accu
+    | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w
+    | (Union_t (_, _, _, YesYes), _) -> ret_succ_adding accu h1w
+    | (Option_t (_, _, Yes), (x : _ option)) ->
         ret_succ_adding accu (option_size (fun _ -> !!0) x)
-    | Chain_id_t -> ret_succ_adding accu chain_id_size
-    | Never_t -> ( match x with _ -> .)
+    | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size
+    | (Never_t, _) -> .
   in
   value_traverse ty x accu {apply; apply_comparable}
 
-- 
GitLab


From b03ca52186db9f59d06545676dd51019c0a43218 Mon Sep 17 00:00:00 2001
From: Klaus Andrey <deepmindster@gmail.com>
Date: Fri, 11 Feb 2022 19:16:46 +0300
Subject: [PATCH 54/69] WIP

---
 src/proto_alpha/lib_protocol/script_ir_translator.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 8e3b97622094..930c5f89ef38 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -6589,7 +6589,7 @@ let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints
 let parse_parameter_ty_and_entrypoints =
   parse_parameter_ty_and_entrypoints_aux ~stack_depth:0
 
-let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x =
+let get_single_sapling_state ctxt ty x =
   let has_lazy_storage = has_lazy_storage ty in
   let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i)
       single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result =
-- 
GitLab


From 54768f6089e2536199d86f00853c9027e27f7d13 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 11 Feb 2022 18:30:57 +0100
Subject: [PATCH 55/69] UNSAFE: removing the 'assert false' from the storage
 functors

---
 src/proto_alpha/lib_protocol/storage_functors.ml | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml
index 658e8702ecee..23838ada99c5 100644
--- a/src/proto_alpha/lib_protocol/storage_functors.ml
+++ b/src/proto_alpha/lib_protocol/storage_functors.ml
@@ -247,7 +247,9 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
     C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc ->
         match C.Tree.kind tree with
         | `Value -> (
-            match I.of_path file with None -> assert false | Some p -> f p acc)
+            match I.of_path file with
+            | None -> Lwt.return acc
+            | Some p -> f p acc)
         | `Tree -> Lwt.return acc)
 
   let elements s =
@@ -319,7 +321,7 @@ struct
         C.Tree.to_value tree >>= function
         | Some v -> (
             match I.of_path file with
-            | None -> assert false
+            | None -> Lwt.return acc
             | Some path -> (
                 let key () = C.absolute_key s file in
                 match of_bytes ~key v with
@@ -499,7 +501,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL
             else
               (* Nominal case *)
               match I.of_path file with
-              | None -> assert false
+              | None -> Lwt.return acc
               | Some key ->
                   get_unprojected s key >|=? fun (s, value) ->
                   (s, value :: rev_values, 0, pred length))
@@ -522,9 +524,9 @@ module Make_indexed_carbonated_data_storage_INTERNAL
             | last :: rest when Compare.String.(last = data_name) -> (
                 let file = List.rev rest in
                 match I.of_path file with
-                | None -> assert false
+                | None -> Lwt.return acc
                 | Some path -> f path acc)
-            | _ -> assert false)
+            | _ -> Lwt.return acc)
         | `Tree -> Lwt.return acc)
 
   let keys_unaccounted s =
@@ -644,7 +646,7 @@ module Make_indexed_data_snapshotable_storage
             C.Tree.to_value tree >>= function
             | Some v -> (
                 match I.of_path file with
-                | None -> assert false
+                | None -> return acc
                 | Some path -> (
                     let key () = C.absolute_key s file in
                     match V_encoder.of_bytes ~key v with
@@ -676,7 +678,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
         match C.Tree.kind tree with
         | `Tree -> (
             match I.of_path path with
-            | None -> assert false
+            | None -> Lwt.return acc
             | Some path -> f path acc)
         | `Value -> Lwt.return acc)
 
-- 
GitLab


From 499aa5b83613f319525161b4b3fc310d02050c86 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 11 Feb 2022 19:51:26 +0100
Subject: [PATCH 56/69] Proto: fix inlining of comparison for Coq

---
 src/lib_protocol_environment/sigs/v5/compare.mli | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/lib_protocol_environment/sigs/v5/compare.mli b/src/lib_protocol_environment/sigs/v5/compare.mli
index 0437dd1e23de..38f5f19e98bd 100644
--- a/src/lib_protocol_environment/sigs/v5/compare.mli
+++ b/src/lib_protocol_environment/sigs/v5/compare.mli
@@ -120,6 +120,7 @@ module Int : sig
 
   external equal : int -> int -> bool = "%equal"
 end
+[@@coq_plain_module]
 
 module Int32 : S with type t = int32
 
-- 
GitLab


From 2170e2d791d7e56c5cd2d6bae17ac77781b1c0ef Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 4 Mar 2022 15:20:19 +0100
Subject: [PATCH 57/69] Proto: changes to help coq-of-ocaml

---
 src/proto_alpha/lib_protocol/indexable.ml     |  51 ++-
 src/proto_alpha/lib_protocol/indexable.mli    |  16 +-
 src/proto_alpha/lib_protocol/level_repr.ml    |   3 +-
 .../lib_protocol/script_string_repr.ml        |   2 +-
 src/proto_alpha/lib_protocol/seed_repr.ml     |   4 +-
 .../tx_rollup_commitments_repr.ml             | 320 ++++++++++++++++++
 6 files changed, 379 insertions(+), 17 deletions(-)
 create mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml

diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml
index 918e33f7d216..efd4595208f2 100644
--- a/src/proto_alpha/lib_protocol/indexable.ml
+++ b/src/proto_alpha/lib_protocol/indexable.ml
@@ -148,10 +148,13 @@ let compare :
   | ((Hidden_value _ | Value _), (Hidden_index _ | Index _)) -> 1
 
 let compare_values c : 'a value -> 'a value -> int =
- fun (Value x) (Value y) -> c x y
+ fun x y ->
+  match[@coq_match_with_default] (x, y) with (Value x, Value y) -> c x y
 
 let compare_indexes : 'a index -> 'a index -> int =
- fun (Index x) (Index y) -> Compare.Int32.compare x y
+ fun x y ->
+  match[@coq_match_with_default] (x, y) with
+  | (Index x, Index y) -> Compare.Int32.compare x y
 
 module type VALUE = sig
   type t
@@ -163,7 +166,41 @@ module type VALUE = sig
   val pp : Format.formatter -> t -> unit
 end
 
-module Make (V : VALUE) = struct
+module type INDEXABLE = sig
+  type v_t
+
+  type nonrec 'state t = ('state, v_t) t
+
+  type nonrec index = v_t index
+
+  type nonrec value = v_t value
+
+  type nonrec either = v_t either
+
+  val value : v_t -> value
+
+  val index : int32 -> index tzresult
+
+  val index_exn : int32 -> index
+
+  val compact : either Data_encoding.Compact.t
+
+  val encoding : either Data_encoding.t
+
+  val index_encoding : index Data_encoding.t
+
+  val value_encoding : value Data_encoding.t
+
+  val compare : 'state t -> 'state' t -> int
+
+  val compare_values : value -> value -> int
+
+  val compare_indexes : index -> index -> int
+
+  val pp : Format.formatter -> 'state t -> unit
+end
+
+module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct
   type nonrec 'state t = ('state, V.t) t
 
   type nonrec index = V.t index
@@ -172,15 +209,15 @@ module Make (V : VALUE) = struct
 
   type nonrec either = V.t either
 
-  let value = value
+  let value : V.t -> value = value
 
-  let index = index
+  let index : int32 -> index tzresult = index
 
-  let index_exn = index_exn
+  let index_exn : int32 -> index = index_exn
 
   let compact = compact V.encoding
 
-  let encoding = encoding V.encoding
+  let encoding : either Data_encoding.t = encoding V.encoding
 
   let index_encoding : index Data_encoding.t =
     Data_encoding.(
diff --git a/src/proto_alpha/lib_protocol/indexable.mli b/src/proto_alpha/lib_protocol/indexable.mli
index cc921e802f1f..e71d8926bc4a 100644
--- a/src/proto_alpha/lib_protocol/indexable.mli
+++ b/src/proto_alpha/lib_protocol/indexable.mli
@@ -162,16 +162,18 @@ module type VALUE = sig
   val pp : Format.formatter -> t -> unit
 end
 
-module Make (V : VALUE) : sig
-  type nonrec 'state t = ('state, V.t) t
+module type INDEXABLE = sig
+  type v_t
 
-  type nonrec index = V.t index
+  type nonrec 'state t = ('state, v_t) t
 
-  type nonrec value = V.t value
+  type nonrec index = v_t index
 
-  type nonrec either = V.t either
+  type nonrec value = v_t value
 
-  val value : V.t -> value
+  type nonrec either = v_t either
+
+  val value : v_t -> value
 
   val index : int32 -> index tzresult
 
@@ -194,4 +196,6 @@ module Make (V : VALUE) : sig
   val pp : Format.formatter -> 'state t -> unit
 end
 
+module Make (V : VALUE) : INDEXABLE with type v_t := V.t
+
 type error += Index_cannot_be_negative of int32
diff --git a/src/proto_alpha/lib_protocol/level_repr.ml b/src/proto_alpha/lib_protocol/level_repr.ml
index 0b5926f387f5..cc16715354fc 100644
--- a/src/proto_alpha/lib_protocol/level_repr.ml
+++ b/src/proto_alpha/lib_protocol/level_repr.ml
@@ -130,7 +130,8 @@ let create_cycle_eras cycle_eras =
   match cycle_eras with
   | [] -> error Invalid_cycle_eras
   | newest_era :: older_eras ->
-      let rec aux {first_level; first_cycle; _} older_eras =
+      let rec aux era older_eras =
+        let {first_level; first_cycle; _} = era in
         match older_eras with
         | ({
              first_level = first_level_of_previous_era;
diff --git a/src/proto_alpha/lib_protocol/script_string_repr.ml b/src/proto_alpha/lib_protocol/script_string_repr.ml
index b3108eb31ef2..ea0c6bca872c 100644
--- a/src/proto_alpha/lib_protocol/script_string_repr.ml
+++ b/src/proto_alpha/lib_protocol/script_string_repr.ml
@@ -57,7 +57,7 @@ let () =
 let empty = String_tag ""
 
 let of_string v =
-  let rec check_printable_ascii i =
+  let[@coq_struct "i_value"] rec check_printable_ascii i =
     if Compare.Int.(i < 0) then ok (String_tag v)
     else
       match v.[i] with
diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml
index 68e4e4452f0d..bc8c2dec03c0 100644
--- a/src/proto_alpha/lib_protocol/seed_repr.ml
+++ b/src/proto_alpha/lib_protocol/seed_repr.ml
@@ -78,7 +78,7 @@ let take_int32 s bound =
     let drop_if_over =
       Int32.sub Int32.max_int (Int32.rem Int32.max_int bound)
     in
-    let rec loop s =
+    let[@coq_struct "s_value"] rec loop s =
       let (bytes, s) = take s in
       let r = TzEndian.get_int32 bytes 0 in
       (* The absolute value of min_int is min_int.  Also, every
@@ -101,7 +101,7 @@ let take_int64 s bound =
       Int64.sub Int64.max_int (Int64.rem Int64.max_int bound)
     in
 
-    let rec loop s =
+    let[@coq_struct "s_value"] rec loop s =
       let (bytes, s) = take s in
       let r = TzEndian.get_int64 bytes 0 in
       (* The absolute value of min_int is min_int.  Also, every
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml
new file mode 100644
index 000000000000..1c356cfd7890
--- /dev/null
+++ b/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml
@@ -0,0 +1,320 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2022 Marigold <contact@marigold.dev>                        *)
+(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
+(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com>                    *)
+(*                                                                           *)
+(* 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.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+type error += (* `Branch *) Commitment_hash_already_submitted
+
+type error += (* `Branch *) Two_commitments_from_one_committer
+
+type error += (* `Branch *) Wrong_commitment_predecessor_level
+
+type error += (* `Temporary *) Missing_commitment_predecessor
+
+type error += (* `Branch *) Wrong_batch_count
+
+type error += (* `Temporary *) Commitment_too_early
+
+let () =
+  let open Data_encoding in
+  (* Commitment_hash_already_submitted *)
+  register_error_kind
+    `Temporary
+    ~id:"tx_rollup_commit_hash_already_submitted"
+    ~title:"Someone already made this commitment"
+    ~description:"The requested commitment is a duplicate"
+    unit
+    (function Commitment_hash_already_submitted -> Some () | _ -> None)
+    (fun () -> Commitment_hash_already_submitted) ;
+  (* Two_commitments_from_one_committer *)
+  register_error_kind
+    `Temporary
+    ~id:"tx_rollup_two_commitments_from_one_committer"
+    ~title:"This contract already made a different commitment at this level"
+    ~description:
+      "This contract already made a different commitment at this level"
+    unit
+    (function Two_commitments_from_one_committer -> Some () | _ -> None)
+    (fun () -> Two_commitments_from_one_committer) ;
+  (* Wrong_commitment_predecessor_level *)
+  register_error_kind
+    `Temporary
+    ~id:"tx_rollup_wrong_commitment_predecessor_level"
+    ~title:"This commitment's predecessor is invalid"
+    ~description:
+      "This commitment has predecessor but shouldn't, or doesn't but should"
+    unit
+    (function Wrong_commitment_predecessor_level -> Some () | _ -> None)
+    (fun () -> Wrong_commitment_predecessor_level) ;
+  (* Missing_commitment_predecessor *)
+  register_error_kind
+    `Temporary
+    ~id:"tx_rollup_missing_commitment_predecessor"
+    ~title:"This commitment refers to a predecessor that doesn't exist"
+    ~description:"This commitment refers to a predecessor that doesn't exist"
+    unit
+    (function Missing_commitment_predecessor -> Some () | _ -> None)
+    (fun () -> Missing_commitment_predecessor) ;
+  (* Wrong_batch_count *)
+  register_error_kind
+    `Temporary
+    ~id:"tx_rollup_wrong_batch_count"
+    ~title:"This commitment has the wrong number of batches"
+    ~description:
+      "This commitment has a different number of batches than its inbox"
+    unit
+    (function Wrong_batch_count -> Some () | _ -> None)
+    (fun () -> Wrong_batch_count) ;
+  (* Commitment_too_early *)
+  register_error_kind
+    `Temporary
+    ~id:"tx_rollup_commitment_too_early"
+    ~title:"This commitment is for a level that hasn't finished yet"
+    ~description:"This commitment is for a level that hasn't finished yet"
+    unit
+    (function Commitment_too_early -> Some () | _ -> None)
+    (fun () -> Commitment_too_early)
+
+let compare_or cmp c1 c2 f = match cmp c1 c2 with 0 -> f () | diff -> diff
+
+module Commitment_hash = struct
+  let commitment_hash = "\017\249\195\013" (* toc1(54) *)
+
+  module H =
+    Blake2B.Make
+      (Base58)
+      (struct
+        let name = "Commitment_hash"
+
+        let title = "A commitment ID"
+
+        let b58check_prefix = commitment_hash
+
+        let size = Some 32
+      end)
+
+  include H
+
+  let () = Base58.check_encoded_prefix b58check_encoding "toc1" 54
+
+  include Path_encoding.Make_hex (H)
+
+  let rpc_arg =
+    let construct = Data_encoding.Binary.to_string_exn encoding in
+    let destruct str =
+      Option.value_e ~error:"Failed to decode commitment"
+      @@ Data_encoding.Binary.of_string_opt encoding str
+    in
+    RPC_arg.make
+      ~descr:"A tx_rollup commitment."
+      ~name:"tx_rollup_commitment"
+      ~construct
+      ~destruct
+      ()
+end
+
+module Commitment = struct
+  type batch_commitment = {
+    (* TODO: add effects and replace bytes with Irmin:
+       https://gitlab.com/tezos/tezos/-/issues/2444
+    *)
+    root : bytes;
+  }
+
+  module Batch = struct
+    type t = batch_commitment
+
+    let encoding =
+      Data_encoding.(
+        conv (fun {root} -> root) (fun root -> {root}) (obj1 (req "root" bytes)))
+
+    let pp : Format.formatter -> t -> unit =
+     fun fmt {root} -> Hex.pp fmt (Hex.of_bytes root)
+
+    include Compare.Make (struct
+      type nonrec t = t
+
+      let compare {root = root1} {root = root2} = Bytes.compare root1 root2
+    end)
+  end
+  [@@coq_plain_module]
+
+  let batch_commitment_equal : batch_commitment -> batch_commitment -> bool =
+    Batch.equal
+
+  type t = {
+    level : Raw_level_repr.t;
+    batches : batch_commitment list;
+    predecessor : Commitment_hash.t option;
+  }
+
+  include Compare.Make (struct
+    type nonrec t = t
+
+    module Compare_root_list = Compare.List (Batch)
+
+    let compare r1 r2 =
+      compare_or Raw_level_repr.compare r1.level r2.level (fun () ->
+          compare_or Compare_root_list.compare r1.batches r2.batches (fun () ->
+              Option.compare
+                Commitment_hash.compare
+                r1.predecessor
+                r2.predecessor))
+  end)
+
+  let pp : Format.formatter -> t -> unit =
+   fun fmt t ->
+    Format.fprintf
+      fmt
+      "commitment %a : batches = %a predecessor %a"
+      Raw_level_repr.pp
+      t.level
+      (Format.pp_print_list Batch.pp)
+      t.batches
+      (Format.pp_print_option Commitment_hash.pp)
+      t.predecessor
+
+  (* FIXME/TORU: https://gitlab.com/tezos/tezos/-/issues/2470
+
+     This encoding is not bounded, and maybe it is an issue. *)
+  let encoding =
+    let open Data_encoding in
+    conv
+      (fun {level; batches; predecessor} -> (level, batches, predecessor))
+      (fun (level, batches, predecessor) -> {level; batches; predecessor})
+      (obj3
+         (req "level" Raw_level_repr.encoding)
+         (req "batches" (list Batch.encoding))
+         (req "predecessor" (option Commitment_hash.encoding)))
+
+  let hash t =
+    let to_bytes_exn = Data_encoding.Binary.to_bytes_exn in
+    let level_bytes = to_bytes_exn Raw_level_repr.encoding t.level in
+    let predecessor_bytes =
+      Option.fold
+        ~none:Bytes.empty
+        ~some:(fun pred -> Commitment_hash.to_bytes pred)
+        t.predecessor
+    in
+    let batches_bytes =
+      to_bytes_exn (Data_encoding.list Batch.encoding) t.batches
+    in
+    Commitment_hash.hash_bytes [level_bytes; predecessor_bytes; batches_bytes]
+
+  module Index = struct
+    type t = Commitment_hash.t
+
+    let path_length = 1
+
+    let to_path c l =
+      let raw_key =
+        Data_encoding.Binary.to_bytes_exn Commitment_hash.encoding c
+      in
+      let (`Hex key) = Hex.of_bytes raw_key in
+      key :: l
+
+    let of_path = function
+      | [key] ->
+          Option.bind
+            (Hex.to_bytes (`Hex key))
+            (Data_encoding.Binary.of_bytes_opt Commitment_hash.encoding)
+      | _ -> None
+
+    let rpc_arg = Commitment_hash.rpc_arg
+
+    let encoding = Commitment_hash.encoding
+
+    let compare = Commitment_hash.compare
+  end
+end
+
+type pending_commitment = {
+  commitment : Commitment.t;
+  hash : Commitment_hash.t;
+  committer : Signature.Public_key_hash.t;
+  submitted_at : Raw_level_repr.t;
+}
+
+let pp_pending_commitment : Format.formatter -> pending_commitment -> unit =
+ fun fmt {commitment; hash; committer; submitted_at} ->
+  Format.fprintf
+    fmt
+    "pending_commitment %a; hash = %a; committer = %a; submitted_at = %a"
+    Commitment.pp
+    commitment
+    Commitment_hash.pp
+    hash
+    Signature.Public_key_hash.pp_short
+    committer
+    Raw_level_repr.pp
+    submitted_at
+
+let pending_commitment_encoding =
+  Data_encoding.(
+    conv
+      (fun {commitment; committer; submitted_at; _} ->
+        (commitment, committer, submitted_at))
+      (fun (commitment, committer, submitted_at) ->
+        let hash = Commitment.hash commitment in
+        {hash; commitment; committer; submitted_at})
+      (obj3
+         (req "commitment" Commitment.encoding)
+         (req "commiter" Signature.Public_key_hash.encoding)
+         (req "submitted_at" Raw_level_repr.encoding)))
+
+type t = pending_commitment list
+
+let encoding = Data_encoding.(list pending_commitment_encoding)
+
+let empty = []
+
+let commitment_exists : t -> Commitment_hash.t -> bool =
+ fun t hash -> List.exists (fun {hash = h; _} -> Commitment_hash.(h = hash)) t
+
+let commitment_with_committer_exists : t -> Signature.Public_key_hash.t -> bool
+    =
+ fun t contract ->
+  List.exists
+    (fun {committer; _} -> Signature.Public_key_hash.(committer = contract))
+    t
+
+let append :
+    t ->
+    Signature.Public_key_hash.t ->
+    Commitment.t ->
+    Raw_level_repr.t ->
+    t tzresult =
+ fun t contract commitment level ->
+  let hash = Commitment.hash commitment in
+  (* We fail if this contract already has a commitment at this level,
+     or if anyone has already made this commitment at this level; a
+     bond entitles you to at most one commitment per level. *)
+  error_when (commitment_exists t hash) Commitment_hash_already_submitted
+  >>? fun () ->
+  error_when
+    (commitment_with_committer_exists t contract)
+    Two_commitments_from_one_committer
+  >>? fun () ->
+  Ok ({hash; commitment; committer = contract; submitted_at = level} :: t)
-- 
GitLab


From a443660534b394af28a571994e5940fd9ef86aa7 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 4 Mar 2022 17:45:31 +0100
Subject: [PATCH 58/69] Proto: update coq-of-ocaml annotations for implicit
 types

---
 .../lib_protocol/script_interpreter.ml        | 10 ++++----
 .../lib_protocol/script_ir_translator.ml      | 25 ++++++++++---------
 .../lib_protocol/ticket_lazy_storage_diff.ml  |  9 +++----
 .../lib_protocol/ticket_scanner.ml            |  2 +-
 4 files changed, 23 insertions(+), 23 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index 25c3ba98c054..a915120fea14 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -621,7 +621,7 @@ and[@coq_struct "function_parameter"] step :
             gas
             k
             ks
-            (accu [@coq_implicit "(E := __INil_'b)"])
+            (accu [@coq_implicit "E" "__INil_'b"])
             stack
       | ( IIf_cons {branch_if_cons; branch_if_nil; k; _},
           (accu : _ boxed_list),
@@ -646,7 +646,7 @@ and[@coq_struct "function_parameter"] step :
                 hd
                 (tl, stack))
       | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) ->
-          (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b)"])
+          (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"])
             id
             g
             gas
@@ -684,7 +684,7 @@ and[@coq_struct "function_parameter"] step :
           let res = (Script_map.empty [@coq_type_annotation]) ty in
           (step [@ocaml.tailcall]) g gas k ks res stack
       | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) ->
-          (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c)"])
+          (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"])
             id
             g
             gas
@@ -1777,7 +1777,7 @@ and[@coq_struct "function_parameter"] log :
   let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in
   match[@coq_match_gadt] (k, accu, stack) with
   | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) ->
-      (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b2)"])
+      (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"])
         with_log
         g
         gas
@@ -1790,7 +1790,7 @@ and[@coq_struct "function_parameter"] log :
   | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) ->
       (iset_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack
   | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) ->
-      (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c2)"])
+      (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"])
         with_log
         g
         gas
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 930c5f89ef38..506b9cda219d 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -2741,7 +2741,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
            tr
            script_instr
   | (Lambda_t _, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Seq_kind], kind expr))
   (* Options *)
   | (Option_t (t, _, _), expr) ->
@@ -2759,7 +2759,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
            items
            (Script_list.empty, ctxt)
   | (List_t _, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Seq_kind], kind expr))
   (* Tickets *)
   | (Ticket_t (t, _ty_name), expr) ->
@@ -2803,7 +2803,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
            vs
       >|=? fun (_, set, ctxt) -> (set, ctxt)
   | (Set_t _, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Seq_kind], kind expr))
   (* Maps *)
   | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) ->
@@ -2817,7 +2817,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
          (fun x -> x)
         : (_ map * _) tzresult Lwt.t)
   | (Map_t _, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Seq_kind], kind expr))
   | (Big_map_t (tk, tv, _ty_name), expr) ->
       (match expr with
@@ -2881,7 +2881,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
       | Some pt -> return (pt, ctxt)
       | None -> fail_parse_data ())
   | (Bls12_381_g1_t, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Bls12_381_g2_t, Bytes (_, bs)) -> (
       Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt ->
@@ -2889,7 +2889,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
       | Some pt -> return (pt, ctxt)
       | None -> fail_parse_data ())
   | (Bls12_381_g2_t, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Bls12_381_fr_t, Bytes (_, bs)) -> (
       Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt ->
@@ -2900,7 +2900,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
       Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt ->
       return (Script_bls.Fr.of_z v, ctxt)
   | (Bls12_381_fr_t, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
   (*
     /!\ When adding new lazy storage kinds, you may want to guard the parsing
@@ -2923,7 +2923,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
                 >|? fun () -> (transaction, ctxt) ))
       | None -> fail_parse_data ())
   | (Sapling_transaction_t _, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> (
       match
@@ -2963,7 +2963,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
   | (Sapling_state_t _, expr) ->
       (* Do not allow to input diffs as they are untrusted and may not be the
          result of a verify_update. *)
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr))
   (* Time lock*)
   | (Chest_key_t, Bytes (_, bytes)) -> (
@@ -2976,7 +2976,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
       | Some chest_key -> return (chest_key, ctxt)
       | None -> fail_parse_data ())
   | (Chest_key_t, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Chest_t, Bytes (_, bytes)) -> (
       Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes))
@@ -2987,7 +2987,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
       | Some chest -> return (chest, ctxt)
       | None -> fail_parse_data ())
   | (Chest_t, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
 
 and[@coq_struct "ctxt"] parse_view_returning :
@@ -6524,7 +6524,8 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v
     else
       let dead = Lazy_storage.IdSet.diff to_update alive in
       let f kind id acc =
-        (Lazy_storage.make [@coq_implicit "(a := unit) (u := unit)"])
+        (Lazy_storage.make
+        [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"])
           kind
           id
           Remove
diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml
index cd81d13147be..3b90e7d5163e 100644
--- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml
+++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml
@@ -76,7 +76,7 @@ let parse_value_type ctxt value_type =
     removing a value containing tickets. *)
 let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc
     =
-  (Ticket_scanner.tickets_of_node [@coq_implicit "(a := a)"])
+  (Ticket_scanner.tickets_of_node [@coq_implicit "a" "a"])
     ctxt
     (* It's currently not possible to have nested lazy structures, but this is
        for future proofing. *)
@@ -111,7 +111,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets
       =
     match expr_opt with
     | Some expr ->
-        (collect_token_diffs_of_node [@coq_implicit "(a := a)"])
+        (collect_token_diffs_of_node [@coq_implicit "a" "a"])
           ctxt
           has_tickets
           expr
@@ -170,8 +170,7 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates
   >>?= fun (has_tickets, ctxt) ->
   List.fold_left_es
     (fun (acc, already_updated, ctxt) update ->
-      (collect_token_diffs_of_big_map_update
-      [@coq_implicit "(a := __Ex_ty_'a)"])
+      (collect_token_diffs_of_big_map_update [@coq_implicit "a" "__Ex_ty_'a"])
         ctxt
         ~big_map_id
         has_tickets
@@ -209,7 +208,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc =
       Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) ->
       List.fold_left_es
         (fun (acc, ctxt) node ->
-          (collect_token_diffs_of_node [@coq_implicit "(a := __Ex_ty_'a)"])
+          (collect_token_diffs_of_node [@coq_implicit "a" "__Ex_ty_'a"])
             ctxt
             has_tickets
             node
diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml
index 88de29a45e3a..e9584d1b286f 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.ml
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml
@@ -533,7 +533,7 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr =
   match ht with
   | Ticket_inspection.False_ht -> return ([], ctxt)
   | (_ : _ Ticket_inspection.has_tickets) ->
-      (Script_ir_translator.parse_data [@coq_implicit "(A := a)"])
+      (Script_ir_translator.parse_data [@coq_implicit "A" "a"])
         ctxt
         ~legacy:true
         ~allow_forged:true
-- 
GitLab


From 9943d417dcf2297aeac02177ad1d5d5255b8b863 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Mon, 7 Mar 2022 23:56:31 +0100
Subject: [PATCH 59/69] Proto: more changes to help coq-of-ocaml

---
 src/lib_protocol_environment/sigs/v5/map.mli  |   4 +-
 .../lib_protocol/delegate_storage.ml          |   2 +-
 src/proto_alpha/lib_protocol/indexable.ml     |  22 +-
 .../lib_protocol/operation_repr.ml            |  12 +-
 src/proto_alpha/lib_protocol/raw_context.ml   |   3 -
 .../lib_protocol/raw_context_intf.ml          | 211 +-----------
 .../lib_protocol/sapling_storage.ml           |   4 +-
 .../lib_protocol/sc_rollup_storage.ml         |   2 +-
 src/proto_alpha/lib_protocol/slot_repr.ml     |   6 +-
 .../lib_protocol/storage_functors.ml          |   3 -
 .../test/unit/test_tx_rollup_l2.ml            |  10 +-
 .../lib_protocol/ticket_hash_repr.ml          |  27 +-
 .../tx_rollup_commitments_repr.ml             | 320 ------------------
 .../tx_rollup_commitments_storage.ml          |  94 -----
 .../lib_protocol/tx_rollup_l2_apply.ml        |   8 +-
 .../lib_protocol/tx_rollup_l2_context.ml      |   8 +-
 .../lib_protocol/tx_rollup_l2_context_sig.ml  |  10 +-
 .../lib_protocol/tx_rollup_message_repr.ml    |   2 +-
 18 files changed, 75 insertions(+), 673 deletions(-)
 delete mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml
 delete mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml

diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli
index 559bf1cf7854..81f19be657ef 100644
--- a/src/lib_protocol_environment/sigs/v5/map.mli
+++ b/src/lib_protocol_environment/sigs/v5/map.mli
@@ -154,9 +154,9 @@ module type S = sig
   val of_seq : (key * 'a) Seq.t -> 'a t
 
   val iter_ep :
-    (key -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) ->
+    (key -> 'a -> (unit, 'error) result Lwt.t) ->
     'a t ->
-    (unit, 'error Error_monad.trace) result Lwt.t
+    (unit, 'error list) result Lwt.t
 
 end
 
diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml
index 366a6d3fd0d3..80d2c8cee6e9 100644
--- a/src/proto_alpha/lib_protocol/delegate_storage.ml
+++ b/src/proto_alpha/lib_protocol/delegate_storage.ml
@@ -750,7 +750,7 @@ module Random = struct
          the sequence and try again). *)
       Int64.sub Int64.max_int (Int64.rem Int64.max_int bound)
     in
-    let rec loop (bytes, n) =
+    let[@coq_struct "function_parameter"] rec loop (bytes, n) =
       let consumed_bytes = 8 in
       let state_size = Bytes.length bytes in
       if Compare.Int.(n > state_size - consumed_bytes) then
diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml
index efd4595208f2..4365483c7f73 100644
--- a/src/proto_alpha/lib_protocol/indexable.ml
+++ b/src/proto_alpha/lib_protocol/indexable.ml
@@ -93,9 +93,9 @@ let forget : type state a. (state, a) t -> (unknown, a) t = function
   | Hidden_value x | Value x -> Hidden_value x
   | Hidden_index x | Index x -> Hidden_index x
 
-let to_int32 = function Index x -> x
+let to_int32 = function[@coq_match_with_default] Index x -> x
 
-let to_value = function Value x -> x
+let to_value = function[@coq_match_with_default] Value x -> x
 
 let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result =
  fun ~error v ->
@@ -104,7 +104,8 @@ let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result =
 let compact val_encoding =
   Data_encoding.Compact.(
     conv
-      (function Hidden_index x -> Either.Left x | Hidden_value x -> Right x)
+      (function[@coq_match_with_default]
+        | Hidden_index x -> Either.Left x | Hidden_value x -> Right x)
       (function Left x -> Hidden_index x | Right x -> Hidden_value x)
     @@ or_int32 ~int32_title:"index" ~alt_title:"value" val_encoding)
 
@@ -215,20 +216,27 @@ module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct
 
   let index_exn : int32 -> index = index_exn
 
-  let compact = compact V.encoding
+  let compact : either Data_encoding.Compact.t = compact V.encoding
 
   let encoding : either Data_encoding.t = encoding V.encoding
 
   let index_encoding : index Data_encoding.t =
     Data_encoding.(
-      conv (fun (Index x) -> x) (fun x -> Index x) Data_encoding.int32)
+      conv
+        (fun [@coq_match_with_default] (Index x) -> x)
+        (fun x -> Index x)
+        Data_encoding.int32)
 
   let value_encoding : value Data_encoding.t =
-    Data_encoding.(conv (fun (Value x) -> x) (fun x -> Value x) V.encoding)
+    Data_encoding.(
+      conv
+        (fun [@coq_match_with_default] (Value x) -> x)
+        (fun x -> Value x)
+        V.encoding)
 
   let pp : Format.formatter -> 'state t -> unit = fun fmt x -> pp V.pp fmt x
 
-  let compare_values = compare_values V.compare
+  let compare_values : value -> value -> int = compare_values V.compare
 
   let compare_indexes = compare_indexes
 
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index 37afcd847230..4f5c3982831b 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -682,7 +682,9 @@ module Encoding = struct
           select =
             (function
             | Manager (Tx_rollup_return_bond _ as op) -> Some op | _ -> None);
-          proj = (function Tx_rollup_return_bond {tx_rollup} -> tx_rollup);
+          proj =
+            (function[@coq_match_with_default]
+            | Tx_rollup_return_bond {tx_rollup} -> tx_rollup);
           inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup});
         }
 
@@ -697,7 +699,8 @@ module Encoding = struct
             | Manager (Tx_rollup_finalize_commitment _ as op) -> Some op
             | _ -> None);
           proj =
-            (function Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup);
+            (function[@coq_match_with_default]
+            | Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup);
           inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup});
         }
 
@@ -712,7 +715,8 @@ module Encoding = struct
             | Manager (Tx_rollup_remove_commitment _ as op) -> Some op
             | _ -> None);
           proj =
-            (function Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup);
+            (function[@coq_match_with_default]
+            | Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup);
           inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup});
         }
 
@@ -736,7 +740,7 @@ module Encoding = struct
             (function
             | Manager (Tx_rollup_rejection _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Tx_rollup_rejection
                 {
                   tx_rollup;
diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml
index 055867558c29..5f279387c3ac 100644
--- a/src/proto_alpha/lib_protocol/raw_context.ml
+++ b/src/proto_alpha/lib_protocol/raw_context.ml
@@ -1043,8 +1043,6 @@ let fold ?depth ctxt k ~order ~init ~f =
 
 let config ctxt = Context.config (context ctxt)
 
-module Proof = Context.Proof
-
 module Tree :
   Raw_context_intf.TREE
     with type t := t
@@ -1432,7 +1430,6 @@ module M : T with type t = root = struct
   let config = config
 
   module Tree = Tree
-  module Proof = Proof
 
   let verify_tree_proof = verify_tree_proof
 
diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml
index d6ef0becd0e5..b3f1ad418e55 100644
--- a/src/proto_alpha/lib_protocol/raw_context_intf.ml
+++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml
@@ -173,7 +173,7 @@ module type VIEW = sig
       lexicographic order of their keys. For large nodes, it is memory-consuming,
       use [`Undefined] for a more memory efficient [fold]. *)
   val fold :
-    ?depth:depth ->
+    ?depth:Context.depth ->
     t ->
     key ->
     order:[`Sorted | `Undefined] ->
@@ -187,10 +187,6 @@ module type VIEW = sig
   val config : t -> config
 end
 
-module Kind = struct
-  type t = [`Value | `Tree]
-end
-
 module type TREE = sig
   (** [Tree] provides immutable, in-memory partial mirror of the
       context, with lazy reads and delayed writes. The trees are Merkle
@@ -219,7 +215,7 @@ module type TREE = sig
 
   (** [kind t] is [t]'s kind. It's either a tree node or a leaf
       value. *)
-  val kind : tree -> Kind.t
+  val kind : tree -> Context.Kind.t
 
   (** [to_value t] is an Lwt promise that resolves to [Some v] if [t]
       is a leaf tree and [None] otherwise. It is equivalent to [find t
@@ -240,203 +236,6 @@ module type TREE = sig
   val clear : ?depth:int -> tree -> unit
 end
 
-module type PROOF = sig
-  (** Proofs are compact representations of trees which can be shared
-      between peers.
-
-      This is expected to be used as follows:
-
-      - A first peer runs a function [f] over a tree [t]. While performing
-        this computation, it records: the hash of [t] (called [before]
-        below), the hash of [f t] (called [after] below) and a subset of [t]
-        which is needed to replay [f] without any access to the first peer's
-        storage. Once done, all these informations are packed into a proof of
-        type [t] that is sent to the second peer.
-
-      - The second peer generates an initial tree [t'] from [p] and computes
-        [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before]
-        and [after]. If they match, they know that the result state [f t'] is a
-        valid context state, without having to have access to the full storage
-        of the first peer. *)
-
-  (** The type for file and directory names. *)
-  type step = string
-
-  (** The type for values. *)
-  type value = bytes
-
-  (** The type of indices for inodes' children. *)
-  type index = int
-
-  (** The type for hashes. *)
-  type hash = Context_hash.t
-
-  (** The type for (internal) inode proofs.
-
-      These proofs encode large directories into a tree-like structure. This
-      reflects irmin-pack's way of representing nodes and computing
-      hashes (tree-like representations for nodes scales better than flat
-      representations).
-
-      [length] is the total number of entries in the children of the inode.
-      It's the size of the "flattened" version of that inode. [length] can be
-      used to prove the correctness of operations such [Tree.length] and
-      [Tree.list ~offset ~length] in an efficient way.
-
-      In proofs with [version.is_binary = false], an inode at depth 0 has a
-      [length] of at least [257]. Below that threshold a [Node] tag is used in
-      [tree]. That threshold is [3] when [version.is_binary = true].
-
-      [proofs] contains the children proofs. It is a sparse list of ['a] values.
-      These values are associated to their index in the list, and the list is
-      kept sorted in increasing order of indices. ['a] can be a concrete proof
-      or a hash of that proof.
-
-      In proofs with [version.is_binary = true], inodes have at most 2 proofs
-      (indexed 0 or 1).
-
-      In proofs with [version.is_binary = false], inodes have at most 32 proofs
-      (indexed from 0 to 31). *)
-  type 'a inode = {length : int; proofs : (index * 'a) list}
-
-  (** The type for inode extenders.
-
-      An extender is a compact representation of a sequence of [inode] which
-      contain only one child. As for inodes, The ['a] parameter can be a
-      concrete proof or a hash of that proof.
-
-      If an inode proof contains singleton children [i_0, ..., i_n] such as:
-      [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}],
-      then it is compressed into the inode extender
-      [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same lenght [l]
-      and final proof [p]. *)
-  type 'a inode_extender = {length : int; segment : index list; proof : 'a}
-
-  (** The type for compressed and partial Merkle tree proofs.
-
-      Tree proofs do not provide any guarantee with the ordering of
-      computations. For instance, if two effects commute, they won't be
-      distinguishable by this kind of proofs.
-
-      [Value v] proves that a value [v] exists in the store.
-
-      [Blinded_value h] proves a value with hash [h] exists in the store.
-
-      [Node ls] proves that a a "flat" node containing the list of files [ls]
-      exists in the store.
-
-      In proofs with [version.is_binary = true], the length of [ls] is at most
-      2.
-
-      In proofs with [version.is_binary = false], the length of [ls] is at most
-      256.
-
-      [Blinded_node h] proves that a node with hash [h] exists in the store.
-
-      [Inode i] proves that an inode [i] exists in the store.
-
-      [Extender e] proves that an inode extender [e] exist in the store. *)
-  type tree =
-    | Value of value
-    | Blinded_value of hash
-    | Node of (step * tree) list
-    | Blinded_node of hash
-    | Inode of inode_tree inode
-    | Extender of inode_tree inode_extender
-
-  (** The type for inode trees. It is a subset of [tree], limited to nodes.
-
-      [Blinded_inode h] proves that an inode with hash [h] exists in the store.
-
-      [Inode_values ls] is simliar to trees' [Node].
-
-      [Inode_tree i] is similar to tree's [Inode].
-
-      [Inode_extender e] is similar to trees' [Extender].  *)
-  and inode_tree =
-    | Blinded_inode of hash
-    | Inode_values of (step * tree) list
-    | Inode_tree of inode_tree inode
-    | Inode_extender of inode_tree inode_extender
-
-  (** The type for kinded hashes. *)
-  type kinded_hash = [`Value of hash | `Node of hash]
-
-  module Stream : sig
-    (** Stream proofs represent an explicit traversal of a Merle tree proof.
-        Every element (a node, a value, or a shallow pointer) met is first
-        "compressed" by shallowing its children and then recorded in the proof.
-
-        As stream proofs directly encode the recursive construction of the
-        Merkle root hash is slightly simpler to implement: verifier simply
-        need to hash the compressed elements lazily, without any memory or
-        choice.
-
-        Moreover, the minimality of stream proofs is trivial to check.
-        Once the computation has consumed the compressed elements required,
-        it is sufficient to check that no more compressed elements remain
-        in the proof.
-
-        However, as the compressed elements contain all the hashes of their
-        shallow children, the size of stream proofs is larger
-        (at least double in size in practice) than tree proofs, which only
-        contains the hash for intermediate shallow pointers. *)
-
-    (** The type for elements of stream proofs.
-
-        [Value v] is a proof that the next element read in the store is the
-        value [v].
-
-        [Node n] is a proof that the next element read in the store is the
-        node [n].
-
-        [Inode i] is a proof that the next element read in the store is the
-        inode [i].
-
-        [Inode_extender e] is a proof that the next element read in the store
-        is the node extender [e]. *)
-    type elt =
-      | Value of value
-      | Node of (step * kinded_hash) list
-      | Inode of hash inode
-      | Inode_extender of hash inode_extender
-
-    (** The type for stream proofs.
-
-        The sequance [e_1 ... e_n] proves that the [e_1], ..., [e_n] are
-        read in the store in sequence. *)
-    type t = elt Seq.t
-  end
-
-  type stream = Stream.t
-
-  (** The type for proofs of kind ['a].
-
-      A proof [p] proves that the state advanced from [before p] to
-      [after p]. [state p]'s hash is [before p], and [state p] contains
-      the minimal information for the computation to reach [after p].
-
-      [version p] is the proof version, it packs several informations.
-
-      [is_stream] discriminates between the stream proofs and the tree proofs.
-
-      [is_binary] discriminates between proofs emitted from
-      [Tezos_context(_memory).Context_binary] and
-      [Tezos_context(_memory).Context].
-
-      It will also help discriminate between the data encoding techniques used.
-
-      The version is meant to be decoded and encoded using the
-      {!Tezos_context_helpers.Context.decode_proof_version} and
-      {!Tezos_context_helpers.Context.encode_proof_version}. *)
-  type 'a t = {
-    version : int;
-    before : kinded_hash;
-    after : kinded_hash;
-    state : 'a;
-  }
-end
-
 module type T = sig
   (** The type for root contexts. *)
   type root
@@ -450,8 +249,6 @@ module type T = sig
        and type value := value
        and type tree := tree
 
-  module Proof : PROOF
-
   (** [verify p f] runs [f] in checking mode. [f] is a function that takes a
       tree as input and returns a new version of the tree and a result. [p] is a
       proof, that is a minimal representation of the tree that contains what [f]
@@ -503,7 +300,7 @@ module type T = sig
 
       Guarantee that the given computation performs exactly the same state
       operations as the generating computation, *in some order*. *)
-  type tree_proof := Proof.tree Proof.t
+  type tree_proof := Context.Proof.tree Context.Proof.t
 
   (** [verify_tree_proof] is the verifier of tree proofs. *)
   val verify_tree_proof : (tree_proof, 'a) verifier
@@ -512,7 +309,7 @@ module type T = sig
 
       Guarantee that the given computation performs exactly the same state
       operations as the generating computation, in the exact same order. *)
-  type stream_proof := Proof.stream Proof.t
+  type stream_proof := Context.Proof.stream Context.Proof.t
 
   (** [verify_stream] is the verifier of stream proofs. *)
   val verify_stream_proof : (stream_proof, 'a) verifier
diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml
index 167f75f1f913..600c870ef43c 100644
--- a/src/proto_alpha/lib_protocol/sapling_storage.ml
+++ b/src/proto_alpha/lib_protocol/sapling_storage.ml
@@ -240,7 +240,7 @@ module Ciphertexts = struct
   let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c
 
   let get_from ctx id offset =
-    let rec aux (ctx, acc) pos =
+    let[@coq_struct "function_parameter"] rec aux (ctx, acc) pos =
       Storage.Sapling.Ciphertexts.find (ctx, id) pos >>=? fun (ctx, c) ->
       match c with
       | None -> return (ctx, List.rev acc)
@@ -319,7 +319,7 @@ module Roots = struct
 
   let mem ctx id root =
     Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun start_pos ->
-    let rec aux pos =
+    let[@coq_struct "pos"] rec aux pos =
       Storage.Sapling.Roots.get (ctx, id) pos >>=? fun hash ->
       if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true
       else
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
index 6772013fe281..7d61f36d1d06 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
@@ -218,7 +218,7 @@ end
 
 module Store = Storage.Sc_rollup
 module Commitment = Sc_rollup_repr.Commitment
-module Commitment_hash = Sc_rollup_repr.Commitment_hash
+module Commitment_hash = Sc_rollup_repr.Commitment_hash [@@coq_plain_module]
 
 let originate ctxt ~kind ~boot_sector =
   Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) ->
diff --git a/src/proto_alpha/lib_protocol/slot_repr.ml b/src/proto_alpha/lib_protocol/slot_repr.ml
index 4cb7219bfedc..338df1a6d3e2 100644
--- a/src/proto_alpha/lib_protocol/slot_repr.ml
+++ b/src/proto_alpha/lib_protocol/slot_repr.ml
@@ -84,21 +84,21 @@ module Range = struct
     ok (Interval {lo = min; hi = max})
 
   let fold f init (Interval {lo; hi}) =
-    let rec loop ~acc ~next =
+    let[@coq_struct "next"] rec loop ~acc ~next =
       if Compare.Int.(next > hi) then acc
       else loop ~acc:(f acc next) ~next:(next + 1)
     in
     loop ~acc:(f init lo) ~next:(lo + 1)
 
   let fold_es f init (Interval {lo; hi}) =
-    let rec loop ~acc ~next =
+    let[@coq_struct "next"] rec loop ~acc ~next =
       if Compare.Int.(next > hi) then return acc
       else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1)
     in
     f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1)
 
   let rev_fold_es f init (Interval {lo; hi}) =
-    let rec loop ~acc ~next =
+    let[@coq_struct "next"] rec loop ~acc ~next =
       if Compare.Int.(next < lo) then return acc
       else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1)
     in
diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml
index 23838ada99c5..fc68ca75c975 100644
--- a/src/proto_alpha/lib_protocol/storage_functors.ml
+++ b/src/proto_alpha/lib_protocol/storage_functors.ml
@@ -115,7 +115,6 @@ module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
   let config t = C.config t
 
   module Tree = C.Tree
-  module Proof = C.Proof
 
   let verify_tree_proof = C.verify_tree_proof
 
@@ -799,8 +798,6 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
         C.Tree.empty t
     end
 
-    module Proof = C.Proof
-
     let verify_tree_proof = C.verify_tree_proof
 
     let verify_stream_proof = C.verify_stream_proof
diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml
index b5d9787447e1..8a54b1eb680d 100644
--- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml
+++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml
@@ -203,7 +203,7 @@ module type S = sig
   val set_count : t -> int32 -> t m
 
   val get_or_associate_index :
-    t -> value -> (t * [`Created | `Existed] * index) m
+    t -> value -> (t * Tx_rollup_l2_context_sig.created_existed * index) m
 
   val get : t -> value -> index option m
 
@@ -224,7 +224,7 @@ module Test_index (Index : S) = struct
     let* (ctxt, value) = init_context_1 () in
 
     let* (ctxt, created, idx1) = Index.get_or_associate_index ctxt value in
-    assert (created = `Created) ;
+    assert (created = Created) ;
     let* idx2 = Index.get ctxt value in
 
     assert (Some idx1 = idx2) ;
@@ -244,7 +244,7 @@ module Test_index (Index : S) = struct
     assert (idx = None) ;
 
     let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in
-    assert (created = `Created) ;
+    assert (created = Created) ;
     let* count = Index.count ctxt in
 
     assert (count = 1l) ;
@@ -260,14 +260,14 @@ module Test_index (Index : S) = struct
     let expected = Indexable.index_exn 0l in
 
     let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in
-    assert (created = `Created) ;
+    assert (created = Created) ;
     assert (idx = expected) ;
 
     let* idx = Index.get ctxt value in
     assert (idx = Some (Indexable.index_exn 0l)) ;
 
     let* (ctxt, existed, idx) = Index.get_or_associate_index ctxt value in
-    assert (existed = `Existed) ;
+    assert (existed = Existed) ;
     assert (idx = expected) ;
 
     let* count = Index.count ctxt in
diff --git a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml
index 36465bcf1245..274f6366f321 100644
--- a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml
+++ b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml
@@ -23,18 +23,33 @@
 (*                                                                           *)
 (*****************************************************************************)
 
-include Script_expr_hash
+type t = Script_expr_hash.t
 
-let of_script_expr_hash t = t
+let encoding = Script_expr_hash.encoding
+
+let pp = Script_expr_hash.pp
+
+let to_b58check = Script_expr_hash.to_b58check
+
+let of_b58check_opt = Script_expr_hash.of_b58check_opt
+
+let of_b58check_exn = Script_expr_hash.of_b58check_exn
 
-let zero = zero
+let of_bytes_exn = Script_expr_hash.of_bytes_exn
+
+let of_bytes_opt = Script_expr_hash.of_bytes_opt
 
 include Compare.Make (struct
-  type nonrec t = t
+  type nonrec t = Script_expr_hash.t
 
-  let compare = compare
+  let compare = Script_expr_hash.compare
 end)
 
-module Index : Storage_description.INDEX with type t = t = struct
+let zero = Script_expr_hash.zero
+
+let of_script_expr_hash t = t
+
+module Index : Storage_description.INDEX with type t = Script_expr_hash.t =
+struct
   include Script_expr_hash
 end
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml
deleted file mode 100644
index 1c356cfd7890..000000000000
--- a/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml
+++ /dev/null
@@ -1,320 +0,0 @@
-(*****************************************************************************)
-(*                                                                           *)
-(* Open Source License                                                       *)
-(* Copyright (c) 2022 Marigold <contact@marigold.dev>                        *)
-(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
-(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com>                    *)
-(*                                                                           *)
-(* 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.                                                 *)
-(*                                                                           *)
-(*****************************************************************************)
-
-type error += (* `Branch *) Commitment_hash_already_submitted
-
-type error += (* `Branch *) Two_commitments_from_one_committer
-
-type error += (* `Branch *) Wrong_commitment_predecessor_level
-
-type error += (* `Temporary *) Missing_commitment_predecessor
-
-type error += (* `Branch *) Wrong_batch_count
-
-type error += (* `Temporary *) Commitment_too_early
-
-let () =
-  let open Data_encoding in
-  (* Commitment_hash_already_submitted *)
-  register_error_kind
-    `Temporary
-    ~id:"tx_rollup_commit_hash_already_submitted"
-    ~title:"Someone already made this commitment"
-    ~description:"The requested commitment is a duplicate"
-    unit
-    (function Commitment_hash_already_submitted -> Some () | _ -> None)
-    (fun () -> Commitment_hash_already_submitted) ;
-  (* Two_commitments_from_one_committer *)
-  register_error_kind
-    `Temporary
-    ~id:"tx_rollup_two_commitments_from_one_committer"
-    ~title:"This contract already made a different commitment at this level"
-    ~description:
-      "This contract already made a different commitment at this level"
-    unit
-    (function Two_commitments_from_one_committer -> Some () | _ -> None)
-    (fun () -> Two_commitments_from_one_committer) ;
-  (* Wrong_commitment_predecessor_level *)
-  register_error_kind
-    `Temporary
-    ~id:"tx_rollup_wrong_commitment_predecessor_level"
-    ~title:"This commitment's predecessor is invalid"
-    ~description:
-      "This commitment has predecessor but shouldn't, or doesn't but should"
-    unit
-    (function Wrong_commitment_predecessor_level -> Some () | _ -> None)
-    (fun () -> Wrong_commitment_predecessor_level) ;
-  (* Missing_commitment_predecessor *)
-  register_error_kind
-    `Temporary
-    ~id:"tx_rollup_missing_commitment_predecessor"
-    ~title:"This commitment refers to a predecessor that doesn't exist"
-    ~description:"This commitment refers to a predecessor that doesn't exist"
-    unit
-    (function Missing_commitment_predecessor -> Some () | _ -> None)
-    (fun () -> Missing_commitment_predecessor) ;
-  (* Wrong_batch_count *)
-  register_error_kind
-    `Temporary
-    ~id:"tx_rollup_wrong_batch_count"
-    ~title:"This commitment has the wrong number of batches"
-    ~description:
-      "This commitment has a different number of batches than its inbox"
-    unit
-    (function Wrong_batch_count -> Some () | _ -> None)
-    (fun () -> Wrong_batch_count) ;
-  (* Commitment_too_early *)
-  register_error_kind
-    `Temporary
-    ~id:"tx_rollup_commitment_too_early"
-    ~title:"This commitment is for a level that hasn't finished yet"
-    ~description:"This commitment is for a level that hasn't finished yet"
-    unit
-    (function Commitment_too_early -> Some () | _ -> None)
-    (fun () -> Commitment_too_early)
-
-let compare_or cmp c1 c2 f = match cmp c1 c2 with 0 -> f () | diff -> diff
-
-module Commitment_hash = struct
-  let commitment_hash = "\017\249\195\013" (* toc1(54) *)
-
-  module H =
-    Blake2B.Make
-      (Base58)
-      (struct
-        let name = "Commitment_hash"
-
-        let title = "A commitment ID"
-
-        let b58check_prefix = commitment_hash
-
-        let size = Some 32
-      end)
-
-  include H
-
-  let () = Base58.check_encoded_prefix b58check_encoding "toc1" 54
-
-  include Path_encoding.Make_hex (H)
-
-  let rpc_arg =
-    let construct = Data_encoding.Binary.to_string_exn encoding in
-    let destruct str =
-      Option.value_e ~error:"Failed to decode commitment"
-      @@ Data_encoding.Binary.of_string_opt encoding str
-    in
-    RPC_arg.make
-      ~descr:"A tx_rollup commitment."
-      ~name:"tx_rollup_commitment"
-      ~construct
-      ~destruct
-      ()
-end
-
-module Commitment = struct
-  type batch_commitment = {
-    (* TODO: add effects and replace bytes with Irmin:
-       https://gitlab.com/tezos/tezos/-/issues/2444
-    *)
-    root : bytes;
-  }
-
-  module Batch = struct
-    type t = batch_commitment
-
-    let encoding =
-      Data_encoding.(
-        conv (fun {root} -> root) (fun root -> {root}) (obj1 (req "root" bytes)))
-
-    let pp : Format.formatter -> t -> unit =
-     fun fmt {root} -> Hex.pp fmt (Hex.of_bytes root)
-
-    include Compare.Make (struct
-      type nonrec t = t
-
-      let compare {root = root1} {root = root2} = Bytes.compare root1 root2
-    end)
-  end
-  [@@coq_plain_module]
-
-  let batch_commitment_equal : batch_commitment -> batch_commitment -> bool =
-    Batch.equal
-
-  type t = {
-    level : Raw_level_repr.t;
-    batches : batch_commitment list;
-    predecessor : Commitment_hash.t option;
-  }
-
-  include Compare.Make (struct
-    type nonrec t = t
-
-    module Compare_root_list = Compare.List (Batch)
-
-    let compare r1 r2 =
-      compare_or Raw_level_repr.compare r1.level r2.level (fun () ->
-          compare_or Compare_root_list.compare r1.batches r2.batches (fun () ->
-              Option.compare
-                Commitment_hash.compare
-                r1.predecessor
-                r2.predecessor))
-  end)
-
-  let pp : Format.formatter -> t -> unit =
-   fun fmt t ->
-    Format.fprintf
-      fmt
-      "commitment %a : batches = %a predecessor %a"
-      Raw_level_repr.pp
-      t.level
-      (Format.pp_print_list Batch.pp)
-      t.batches
-      (Format.pp_print_option Commitment_hash.pp)
-      t.predecessor
-
-  (* FIXME/TORU: https://gitlab.com/tezos/tezos/-/issues/2470
-
-     This encoding is not bounded, and maybe it is an issue. *)
-  let encoding =
-    let open Data_encoding in
-    conv
-      (fun {level; batches; predecessor} -> (level, batches, predecessor))
-      (fun (level, batches, predecessor) -> {level; batches; predecessor})
-      (obj3
-         (req "level" Raw_level_repr.encoding)
-         (req "batches" (list Batch.encoding))
-         (req "predecessor" (option Commitment_hash.encoding)))
-
-  let hash t =
-    let to_bytes_exn = Data_encoding.Binary.to_bytes_exn in
-    let level_bytes = to_bytes_exn Raw_level_repr.encoding t.level in
-    let predecessor_bytes =
-      Option.fold
-        ~none:Bytes.empty
-        ~some:(fun pred -> Commitment_hash.to_bytes pred)
-        t.predecessor
-    in
-    let batches_bytes =
-      to_bytes_exn (Data_encoding.list Batch.encoding) t.batches
-    in
-    Commitment_hash.hash_bytes [level_bytes; predecessor_bytes; batches_bytes]
-
-  module Index = struct
-    type t = Commitment_hash.t
-
-    let path_length = 1
-
-    let to_path c l =
-      let raw_key =
-        Data_encoding.Binary.to_bytes_exn Commitment_hash.encoding c
-      in
-      let (`Hex key) = Hex.of_bytes raw_key in
-      key :: l
-
-    let of_path = function
-      | [key] ->
-          Option.bind
-            (Hex.to_bytes (`Hex key))
-            (Data_encoding.Binary.of_bytes_opt Commitment_hash.encoding)
-      | _ -> None
-
-    let rpc_arg = Commitment_hash.rpc_arg
-
-    let encoding = Commitment_hash.encoding
-
-    let compare = Commitment_hash.compare
-  end
-end
-
-type pending_commitment = {
-  commitment : Commitment.t;
-  hash : Commitment_hash.t;
-  committer : Signature.Public_key_hash.t;
-  submitted_at : Raw_level_repr.t;
-}
-
-let pp_pending_commitment : Format.formatter -> pending_commitment -> unit =
- fun fmt {commitment; hash; committer; submitted_at} ->
-  Format.fprintf
-    fmt
-    "pending_commitment %a; hash = %a; committer = %a; submitted_at = %a"
-    Commitment.pp
-    commitment
-    Commitment_hash.pp
-    hash
-    Signature.Public_key_hash.pp_short
-    committer
-    Raw_level_repr.pp
-    submitted_at
-
-let pending_commitment_encoding =
-  Data_encoding.(
-    conv
-      (fun {commitment; committer; submitted_at; _} ->
-        (commitment, committer, submitted_at))
-      (fun (commitment, committer, submitted_at) ->
-        let hash = Commitment.hash commitment in
-        {hash; commitment; committer; submitted_at})
-      (obj3
-         (req "commitment" Commitment.encoding)
-         (req "commiter" Signature.Public_key_hash.encoding)
-         (req "submitted_at" Raw_level_repr.encoding)))
-
-type t = pending_commitment list
-
-let encoding = Data_encoding.(list pending_commitment_encoding)
-
-let empty = []
-
-let commitment_exists : t -> Commitment_hash.t -> bool =
- fun t hash -> List.exists (fun {hash = h; _} -> Commitment_hash.(h = hash)) t
-
-let commitment_with_committer_exists : t -> Signature.Public_key_hash.t -> bool
-    =
- fun t contract ->
-  List.exists
-    (fun {committer; _} -> Signature.Public_key_hash.(committer = contract))
-    t
-
-let append :
-    t ->
-    Signature.Public_key_hash.t ->
-    Commitment.t ->
-    Raw_level_repr.t ->
-    t tzresult =
- fun t contract commitment level ->
-  let hash = Commitment.hash commitment in
-  (* We fail if this contract already has a commitment at this level,
-     or if anyone has already made this commitment at this level; a
-     bond entitles you to at most one commitment per level. *)
-  error_when (commitment_exists t hash) Commitment_hash_already_submitted
-  >>? fun () ->
-  error_when
-    (commitment_with_committer_exists t contract)
-    Two_commitments_from_one_committer
-  >>? fun () ->
-  Ok ({hash; commitment; committer = contract; submitted_at = level} :: t)
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml
deleted file mode 100644
index e414e422f789..000000000000
--- a/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml
+++ /dev/null
@@ -1,94 +0,0 @@
-(*****************************************************************************)
-(*                                                                           *)
-(* Open Source License                                                       *)
-(* Copyright (c) 2021 Marigold <contact@marigold.dev>                        *)
-(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com>                *)
-(* Copyright (c) 2021 Oxhead Alpha <info@oxheadalpha.com>                    *)
-(*                                                                           *)
-(* 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.                                                 *)
-(*                                                                           *)
-(*****************************************************************************)
-
-let just_ctxt (ctxt, _, _) = ctxt
-
-open Tx_rollup_commitments_repr
-
-(** Return commitments in the order that they were submitted *)
-let get_or_empty_commitments :
-    Raw_context.t ->
-    Raw_level_repr.t * Tx_rollup_repr.t ->
-    (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t =
- fun ctxt key ->
-  Storage.Tx_rollup.Commitment_list.find ctxt key >|=? fun (ctxt, commitment) ->
-  Option.fold
-    commitment
-    ~none:(ctxt, Tx_rollup_commitments_repr.empty)
-    ~some:(fun l -> (ctxt, List.rev l))
-
-let get_prev_level ctxt tx_rollup level =
-  Tx_rollup_inbox_storage.get_adjacent_levels ctxt level tx_rollup
-  >|=? fun (ctxt, predecessor_level, _) -> (ctxt, predecessor_level)
-
-let check_commitment_predecessor_hash ctxt tx_rollup (commitment : Commitment.t)
-    =
-  let level = commitment.level in
-  (* Check that level has the correct predecessor *)
-  get_prev_level ctxt tx_rollup level >>=? fun (ctxt, predecessor_level) ->
-  match (predecessor_level, commitment.predecessor) with
-  | (None, None) -> return ctxt
-  | (Some _, None) | (None, Some _) -> fail Wrong_commitment_predecessor_level
-  | (Some predecessor_level, Some hash) ->
-      (* The predecessor level must include this commitment*)
-      get_or_empty_commitments ctxt (predecessor_level, tx_rollup)
-      >>=? fun (ctxt, predecesor_commitments) ->
-      fail_unless
-        (Tx_rollup_commitments_repr.commitment_exists
-           predecesor_commitments
-           hash)
-        Missing_commitment_predecessor
-      >>=? fun () -> return ctxt
-
-let add_commitment ctxt tx_rollup contract (commitment : Commitment.t) =
-  let key = (commitment.level, tx_rollup) in
-  get_or_empty_commitments ctxt key >>=? fun (ctxt, pending) ->
-  Tx_rollup_inbox_storage.get ctxt ~level:(Level commitment.level) tx_rollup
-  >>=? fun (ctxt, inbox) ->
-  let expected_len = List.length inbox.contents in
-  let actual_len = List.length commitment.batches in
-  fail_unless Compare.Int.(expected_len = actual_len) Wrong_batch_count
-  >>=? fun () ->
-  check_commitment_predecessor_hash ctxt tx_rollup commitment >>=? fun ctxt ->
-  Tx_rollup_commitments_repr.append
-    pending
-    contract
-    commitment
-    (Raw_context.current_level ctxt).level
-  >>?= fun new_pending ->
-  Storage.Tx_rollup.Commitment_list.add ctxt key new_pending >|=? just_ctxt
-
-let get_commitments :
-    Raw_context.t ->
-    Tx_rollup_repr.t ->
-    Raw_level_repr.t ->
-    (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t =
- fun ctxt tx_rollup level ->
-  Storage.Tx_rollup.State.find ctxt tx_rollup >>=? fun (ctxt, state) ->
-  match state with
-  | None -> fail @@ Tx_rollup_state_storage.Tx_rollup_does_not_exist tx_rollup
-  | Some _ -> get_or_empty_commitments ctxt (level, tx_rollup)
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
index 9d31271838fe..38f8d5ca4852 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
@@ -336,8 +336,8 @@ module Make (Context : CONTEXT) = struct
     | Right v -> (
         let+ (ctxt, created, idx) = get_or_associate_index ctxt v in
         match created with
-        | `Existed -> (ctxt, indexes, idx)
-        | `Created -> (ctxt, add_index indexes (v, idx), idx))
+        | Existed -> (ctxt, indexes, idx)
+        | Created -> (ctxt, add_index indexes (v, idx), idx))
     | Left i -> return (ctxt, indexes, i)
 
   let address_index ctxt indexes indexable =
@@ -445,7 +445,7 @@ module Make (Context : CONTEXT) = struct
 
             (* If the address is created, we add it to [indexes]. *)
             match created with
-            | `Existed ->
+            | Existed ->
                 (* If the public key existed in the context, it should not
                    be added in [indexes]. However, the metadata might not
                    have been initialized for the public key. Especially during
@@ -463,7 +463,7 @@ module Make (Context : CONTEXT) = struct
                       Address_metadata.init_with_public_key ctxt idx signer_pk
                 in
                 return (ctxt, indexes, signer_pk, idx)
-            | `Created ->
+            | Created ->
                 (* If the index is created, we need to add to indexes and
                    initialize the metadata. *)
                 let indexes =
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
index ae06d5b2330a..9aac11edd78d 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
@@ -301,10 +301,10 @@ struct
       let open Syntax in
       let* index_opt = get ctxt addr in
       match index_opt with
-      | Some idx -> return (ctxt, `Existed, idx)
+      | Some idx -> return (ctxt, Existed, idx)
       | None ->
           let+ (ctxt, idx) = associate_index ctxt addr in
-          (ctxt, `Created, idx)
+          (ctxt, Created, idx)
 
     module Internal_for_tests = struct
       let set_count ctxt count = set ctxt Address_count count
@@ -338,10 +338,10 @@ struct
       let open Syntax in
       let* index_opt = get ctxt ticket in
       match index_opt with
-      | Some idx -> return (ctxt, `Existed, idx)
+      | Some idx -> return (ctxt, Existed, idx)
       | None ->
           let+ (ctxt, idx) = associate_index ctxt ticket in
-          (ctxt, `Created, idx)
+          (ctxt, Created, idx)
 
     module Internal_for_tests = struct
       let set_count ctxt count = set ctxt Ticket_count count
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
index ba8d16138f32..635e27a2a7ef 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
@@ -157,6 +157,8 @@ let () =
     (function Counter_overflow -> Some () | _ -> None)
     (fun () -> Counter_overflow)
 
+type created_existed = Created | Existed
+
 (** This module type describes the API of the [Tx_rollup] context,
     which is used to implement the semantics of the L2 operations. *)
 module type CONTEXT = sig
@@ -276,9 +278,7 @@ module type CONTEXT = sig
         This function can fail with [Too_many_l2_addresses] iff there
         is no fresh index available. *)
     val get_or_associate_index :
-      t ->
-      Tx_rollup_l2_address.t ->
-      (t * [`Created | `Existed] * address_index) m
+      t -> Tx_rollup_l2_address.t -> (t * created_existed * address_index) m
 
     (** [count ctxt] returns the number of addresses that have been
         involved in the transaction rollup. *)
@@ -319,9 +319,7 @@ module type CONTEXT = sig
         This function can fail with [Too_many_l2_tickets] iff there
         is no fresh index available. *)
     val get_or_associate_index :
-      t ->
-      Alpha_context.Ticket_hash.t ->
-      (t * [`Created | `Existed] * ticket_index) m
+      t -> Alpha_context.Ticket_hash.t -> (t * created_existed * ticket_index) m
 
     (** [count ctxt] returns the number of tickets that have been
         involved in the transaction rollup. *)
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml
index bb0a7d57f0ec..146f294b3830 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml
@@ -71,7 +71,7 @@ let encoding =
         (fun deposit -> Deposit deposit);
     ]
 
-let pp fmt =
+let[@coq_axiom_with_reason "unresolved implicit arguments"] pp fmt =
   let open Format in
   function
   | Batch str ->
-- 
GitLab


From 14b7cdc232dd3719e571188666ffdf697994a513 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 8 Mar 2022 18:14:21 +0100
Subject: [PATCH 60/69] Proto: more changes for coq-of-ocaml

---
 .../lib_protocol/gas_comparable_input_size.ml |  2 +-
 .../lib_protocol/sc_rollup_storage.ml         | 60 +++++++++++--------
 src/proto_alpha/lib_protocol/storage.ml       | 24 ++++++--
 .../tx_rollup_commitment_storage.ml           | 10 ++--
 4 files changed, 61 insertions(+), 35 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml
index 6e90810eba69..9d65919e4bf8 100644
--- a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml
+++ b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml
@@ -106,7 +106,7 @@ let tx_rollup_l2_address x =
 let timestamp (tstamp : Alpha_context.Script_timestamp.t) : t =
   Z.numbits (Alpha_context.Script_timestamp.to_zint tstamp) / 8
 
-let rec size_of_comparable_value :
+let[@coq_axiom_with_reason "gadts"] rec size_of_comparable_value :
     type a. a Script_typed_ir.comparable_ty -> a -> t =
   fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) ->
    match wit with
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
index 7d61f36d1d06..1a6cd89848bb 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
@@ -217,8 +217,6 @@ module Lwt_tzresult_syntax = struct
 end
 
 module Store = Storage.Sc_rollup
-module Commitment = Sc_rollup_repr.Commitment
-module Commitment_hash = Sc_rollup_repr.Commitment_hash [@@coq_plain_module]
 
 let originate ctxt ~kind ~boot_sector =
   Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) ->
@@ -233,7 +231,10 @@ let originate ctxt ~kind ~boot_sector =
   Storage.Sc_rollup.Boot_sector.add ctxt address boot_sector >>= fun ctxt ->
   let inbox = Sc_rollup_inbox_repr.empty address level.level in
   Storage.Sc_rollup.Inbox.init ctxt address inbox >>=? fun (ctxt, size_diff) ->
-  Store.Last_cemented_commitment.init ctxt address Commitment_hash.zero
+  Store.Last_cemented_commitment.init
+    ctxt
+    address
+    Sc_rollup_repr.Commitment_hash.zero
   >>=? fun (ctxt, lcc_size_diff) ->
   Store.Staker_count.init ctxt address 0l >>=? fun (ctxt, stakers_size_diff) ->
   let addresses_size = 2 * Sc_rollup_repr.Address.size in
@@ -372,7 +373,7 @@ let set_commitment_added ctxt rollup node new_value =
 
 let deallocate ctxt rollup node =
   let open Lwt_tzresult_syntax in
-  if Commitment_hash.(node = zero) then return ctxt
+  if Sc_rollup_repr.Commitment_hash.(node = zero) then return ctxt
   else
     let* (ctxt, _size_freed) =
       Store.Commitments.remove_existing (ctxt, rollup) node
@@ -430,7 +431,7 @@ let withdraw_stake ctxt rollup staker =
   match res with
   | None -> fail Sc_rollup_not_staked
   | Some staked_on_commitment ->
-      if Commitment_hash.(staked_on_commitment = lcc) then
+      if Sc_rollup_repr.Commitment_hash.(staked_on_commitment = lcc) then
         (* TODO: https://gitlab.com/tezos/tezos/-/issues/2449
            We should refund stake here.
         *)
@@ -456,14 +457,14 @@ let sc_rollup_commitment_storage_size_in_bytes = 84
 let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment =
   let open Lwt_tzresult_syntax in
   let* (ctxt, min_level) =
-    if Commitment_hash.(lcc = zero) then
+    if Sc_rollup_repr.Commitment_hash.(lcc = zero) then
       let* level = Store.Initial_level.get ctxt rollup in
       return (ctxt, level)
     else
       let* (lcc, ctxt) = get_commitment_internal ctxt rollup lcc in
-      return (ctxt, Commitment.(lcc.inbox_level))
+      return (ctxt, Sc_rollup_repr.Commitment.(lcc.inbox_level))
   in
-  let max_level = Commitment.(commitment.inbox_level) in
+  let max_level = Sc_rollup_repr.Commitment.(commitment.inbox_level) in
   if
     Compare.Int32.(
       sc_rollup_max_lookahead < Raw_level_repr.diff max_level min_level)
@@ -475,16 +476,16 @@ let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment =
 *)
 let assert_commitment_frequency ctxt rollup commitment =
   let open Lwt_tzresult_syntax in
-  let pred = Commitment.(commitment.predecessor) in
+  let pred = Sc_rollup_repr.Commitment.(commitment.predecessor) in
   let* (ctxt, pred_level) =
-    if Commitment_hash.(pred = zero) then
+    if Sc_rollup_repr.Commitment_hash.(pred = zero) then
       let* level = Store.Initial_level.get ctxt rollup in
       return (ctxt, level)
     else
       let* (pred, ctxt) =
         get_commitment_internal ctxt rollup commitment.predecessor
       in
-      return (ctxt, Commitment.(pred.inbox_level))
+      return (ctxt, Sc_rollup_repr.Commitment.(pred.inbox_level))
   in
   (* We want to check the following inequalities on [commitment.inbox_level],
      [commitment.predecessor.inbox_level] and the constant [sc_rollup_commitment_frequency].
@@ -526,14 +527,14 @@ let refine_stake ctxt rollup staker commitment =
   let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in
   let* (staked_on, ctxt) = find_staker ctxt rollup staker in
   let* ctxt = assert_refine_conditions_met ctxt rollup lcc commitment in
-  let new_hash = Commitment.hash commitment in
+  let new_hash = Sc_rollup_repr.Commitment.hash commitment in
   (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559
      Add a test checking that L2 nodes can catch up after going offline. *)
-  let rec go node ctxt =
+  let[@coq_struct "node_value"] rec go node ctxt =
     (* WARNING: Do NOT reorder this sequence of ifs.
        we must check for staked_on before LCC, since refining
        from the LCC to another commit is a valid operation. *)
-    if Commitment_hash.(node = staked_on) then (
+    if Sc_rollup_repr.Commitment_hash.(node = staked_on) then (
       (* Previously staked commit found:
          Insert new commitment if not existing *)
       let* (ctxt, commitment_size_diff, _was_bound) =
@@ -560,7 +561,7 @@ let refine_stake ctxt rollup staker commitment =
           size_diff = 0
           || size_diff = sc_rollup_commitment_storage_size_in_bytes)) ;
       return (new_hash, ctxt) (* See WARNING above. *))
-    else if Commitment_hash.(node = lcc) then
+    else if Sc_rollup_repr.Commitment_hash.(node = lcc) then
       (* We reached the LCC, but [staker] is not staked directly on it.
          Thus, we backtracked. Note that everyone is staked indirectly on
          the LCC. *)
@@ -570,7 +571,7 @@ let refine_stake ctxt rollup staker commitment =
       let* (_size, ctxt) = increase_commitment_stake_count ctxt rollup node in
       (go [@ocaml.tailcall]) pred ctxt
   in
-  go Commitment.(commitment.predecessor) ctxt
+  go Sc_rollup_repr.Commitment.(commitment.predecessor) ctxt
 
 let publish_commitment ctxt rollup staker commitment =
   let open Lwt_tzresult_syntax in
@@ -599,8 +600,9 @@ let cement_commitment ctxt rollup new_lcc =
     let* (ctxt, new_lcc_added) =
       Store.Commitment_added.get (ctxt, rollup) new_lcc
     in
-    if Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc) then
-      fail Sc_rollup_parent_not_lcc
+    if
+      Sc_rollup_repr.Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc)
+    then fail Sc_rollup_parent_not_lcc
     else
       let* (new_lcc_stake_count, ctxt) =
         get_commitment_stake_count ctxt rollup new_lcc
@@ -629,7 +631,8 @@ let cement_commitment ctxt rollup new_lcc =
           @@ Sc_rollup_repr.Number_of_messages.to_int32
                new_lcc_commitment.number_of_messages)
 
-type conflict_point = Commitment_hash.t * Commitment_hash.t
+type conflict_point =
+  Sc_rollup_repr.Commitment_hash.t * Sc_rollup_repr.Commitment_hash.t
 
 (** [goto_inbox_level ctxt rollup inbox_level commit] Follows the predecessors of [commit] until it
     arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *)
@@ -637,7 +640,9 @@ let goto_inbox_level ctxt rollup inbox_level commit =
   let open Lwt_tzresult_syntax in
   let rec go ctxt commit =
     let* (info, ctxt) = get_commitment_internal ctxt rollup commit in
-    if Raw_level_repr.(info.Commitment.inbox_level <= inbox_level) then (
+    if
+      Raw_level_repr.(info.Sc_rollup_repr.Commitment.inbox_level <= inbox_level)
+    then (
       (* Assert that we're exactly at that level. If this isn't the case, we're most likely in a
          situation where inbox levels are inconsistent. *)
       assert (Raw_level_repr.(info.inbox_level = inbox_level)) ;
@@ -655,7 +660,7 @@ let get_conflict_point ctxt rollup staker1 staker2 =
   let* (commit2, ctxt) = find_staker ctxt rollup staker2 in
   let* () =
     fail_when
-      Commitment_hash.(
+      Sc_rollup_repr.Commitment_hash.(
         (* If PVM is in pre-boot state, there might be stakes on the zero commitment. *)
         commit1 = zero || commit2 = zero
         (* If either commit is the LCC, that also means there can't be a conflict. *)
@@ -685,7 +690,7 @@ let get_conflict_point ctxt rollup staker1 staker2 =
      We use this fact in the following to efficiently traverse both commitment histories towards
      the conflict points. *)
   let rec traverse_in_parallel ctxt commit1 commit2 =
-    if Commitment_hash.(commit1 = commit2) then
+    if Sc_rollup_repr.Commitment_hash.(commit1 = commit2) then
       (* This case will most dominantly happen when either commit is part of the other's history.
          It occurs when the commit that is farther ahead gets dereferenced to its predecessor often
          enough to land at the other commit. *)
@@ -695,7 +700,9 @@ let get_conflict_point ctxt rollup staker1 staker2 =
       let* (commit2_info, ctxt) = get_commitment_internal ctxt rollup commit2 in
       assert (
         Raw_level_repr.(commit1_info.inbox_level = commit2_info.inbox_level)) ;
-      if Commitment_hash.(commit1_info.predecessor = commit2_info.predecessor)
+      if
+        Sc_rollup_repr.Commitment_hash.(
+          commit1_info.predecessor = commit2_info.predecessor)
       then
         (* Same predecessor means we've found the conflict points. *)
         return ((commit1, commit2), ctxt)
@@ -715,14 +722,15 @@ let remove_staker ctxt rollup staker =
   match res with
   | None -> fail Sc_rollup_not_staked
   | Some staked_on ->
-      if Commitment_hash.(staked_on = lcc) then fail Sc_rollup_remove_lcc
+      if Sc_rollup_repr.Commitment_hash.(staked_on = lcc) then
+        fail Sc_rollup_remove_lcc
       else
         let* (ctxt, _size_diff) =
           Store.Stakers.remove_existing (ctxt, rollup) staker
         in
         let* ctxt = modify_staker_count ctxt rollup Int32.pred in
-        let rec go node ctxt =
-          if Commitment_hash.(node = lcc) then return ctxt
+        let[@coq_struct "node_value"] rec go node ctxt =
+          if Sc_rollup_repr.Commitment_hash.(node = lcc) then return ctxt
           else
             let* (pred, ctxt) = get_predecessor ctxt rollup node in
             let* ctxt = decrease_commitment_stake_count ctxt rollup node in
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 3e4b62cac9d7..3068cb6a6fc1 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1583,7 +1583,11 @@ module Sc_rollup = struct
         let encoding = Sc_rollup_repr.Commitment_hash.encoding
       end)
 
-  module Stakers =
+  module Stakers :
+    Non_iterable_indexed_carbonated_data_storage
+      with type key = Signature.Public_key_hash.t
+       and type value = Sc_rollup_repr.Commitment_hash.t
+       and type t = Raw_context.t * Sc_rollup_repr.t =
     Make_indexed_carbonated_data_storage
       (Make_subcontext (Registered) (Indexed_context.Raw_context)
          (struct
@@ -1607,7 +1611,11 @@ module Sc_rollup = struct
         let encoding = Data_encoding.int32
       end)
 
-  module Commitments =
+  module Commitments :
+    Non_iterable_indexed_carbonated_data_storage
+      with type key = Sc_rollup_repr.Commitment_hash.t
+       and type value = Sc_rollup_repr.Commitment.t
+       and type t = Raw_context.t * Sc_rollup_repr.t =
     Make_indexed_carbonated_data_storage
       (Make_subcontext (Registered) (Indexed_context.Raw_context)
          (struct
@@ -1620,7 +1628,11 @@ module Sc_rollup = struct
            let encoding = Sc_rollup_repr.Commitment.encoding
          end)
 
-  module Commitment_stake_count =
+  module Commitment_stake_count :
+    Non_iterable_indexed_carbonated_data_storage
+      with type key = Sc_rollup_repr.Commitment_hash.t
+       and type value = int32
+       and type t = Raw_context.t * Sc_rollup_repr.t =
     Make_indexed_carbonated_data_storage
       (Make_subcontext (Registered) (Indexed_context.Raw_context)
          (struct
@@ -1633,7 +1645,11 @@ module Sc_rollup = struct
            let encoding = Data_encoding.int32
          end)
 
-  module Commitment_added =
+  module Commitment_added :
+    Non_iterable_indexed_carbonated_data_storage
+      with type key = Sc_rollup_repr.Commitment_hash.t
+       and type value = Raw_level_repr.t
+       and type t = Raw_context.t * Sc_rollup_repr.t =
     Make_indexed_carbonated_data_storage
       (Make_subcontext (Registered) (Indexed_context.Raw_context)
          (struct
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml
index 880d97d95461..c2b53c18936f 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml
@@ -28,9 +28,11 @@
 open Tx_rollup_commitment_repr
 open Tx_rollup_errors_repr
 
+type direction = Incr | Decr
+
 let adjust_unfinalized_commitments_count ctxt state tx_rollup pkh
-    ~(dir : [`Incr | `Decr]) =
-  let delta = match dir with `Incr -> 1 | `Decr -> -1 in
+    ~(dir : direction) =
+  let delta = match dir with Incr -> 1 | Decr -> -1 in
   let bond_key = (tx_rollup, pkh) in
   Storage.Tx_rollup.Commitment_bond.find ctxt bond_key
   >>=? fun (ctxt, commitment) ->
@@ -207,7 +209,7 @@ let add_commitment ctxt tx_rollup state pkh commitment =
     commitment.level
     commitment_hash
   >>?= fun state ->
-  adjust_unfinalized_commitments_count ctxt state tx_rollup pkh ~dir:`Incr
+  adjust_unfinalized_commitments_count ctxt state tx_rollup pkh ~dir:Incr
   >>=? fun (ctxt, state) ->
   return (ctxt, state, paid_storage_size_diff_for_commitment)
 
@@ -249,7 +251,7 @@ let finalize_commitment ctxt rollup state =
         state
         rollup
         commitment.committer
-        ~dir:`Decr
+        ~dir:Decr
       >>=? fun (ctxt, state) ->
       (* We remove the inbox *)
       Tx_rollup_inbox_storage.remove ctxt oldest_inbox_level rollup state
-- 
GitLab


From f20aff28adedd1630dd14d7f787313793a3c97aa Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Wed, 9 Mar 2022 18:44:56 +0100
Subject: [PATCH 61/69] Proto: more changes for coq-of-ocaml

---
 src/lib_protocol_environment/sigs/v5/map.mli  |  2 +-
 src/proto_alpha/lib_protocol/apply_results.ml |  8 +-
 .../lib_protocol/gas_input_size.ml            |  2 +-
 .../lib_protocol/script_interpreter.ml        | 10 ++-
 .../lib_protocol/script_interpreter_defs.ml   |  2 +-
 .../lib_protocol/script_ir_annot.ml           |  2 +-
 .../lib_protocol/script_ir_translator.ml      |  9 +-
 src/proto_alpha/lib_protocol/script_map.ml    | 24 +++++-
 src/proto_alpha/lib_protocol/script_set.ml    | 16 +++-
 .../lib_protocol/script_typed_ir.ml           |  2 +
 .../lib_protocol/script_typed_ir.mli          |  2 +
 .../lib_protocol/script_typed_ir_size.ml      |  3 +-
 .../lib_protocol/ticket_accounting.ml         | 16 ++--
 .../lib_protocol/tx_rollup_l2_batch.ml        | 24 +++---
 .../lib_protocol/tx_rollup_l2_context.ml      |  6 +-
 .../lib_protocol/tx_rollup_l2_context_sig.ml  | 85 ++++++++++---------
 .../lib_protocol/tx_rollup_l2_storage_sig.ml  | 62 ++++++++------
 17 files changed, 174 insertions(+), 101 deletions(-)

diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli
index 81f19be657ef..8e1d02424fa2 100644
--- a/src/lib_protocol_environment/sigs/v5/map.mli
+++ b/src/lib_protocol_environment/sigs/v5/map.mli
@@ -154,7 +154,7 @@ module type S = sig
   val of_seq : (key * 'a) Seq.t -> 'a t
 
   val iter_ep :
-    (key -> 'a -> (unit, 'error) result Lwt.t) ->
+    (key -> 'a -> (unit, 'error list) result Lwt.t) ->
     'a t ->
     (unit, 'error list) result Lwt.t
 
diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 28886a8c01f0..9af74be7c31e 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -706,7 +706,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_return_bond_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_return_bond_result {balance_updates; consumed_gas} ->
             (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas))
       ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) ->
@@ -732,7 +732,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_finalize_commitment_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_finalize_commitment_result
             {balance_updates; consumed_gas; level; paid_storage_size_diff} ->
             ( balance_updates,
@@ -772,7 +772,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_remove_commitment_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_remove_commitment_result
             {balance_updates; consumed_gas; level} ->
             (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas, level))
@@ -795,7 +795,7 @@ module Manager_result = struct
             Some op
         | _ -> None)
       ~kind:Kind.Tx_rollup_rejection_manager_kind
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Tx_rollup_rejection_result {balance_updates; consumed_gas} ->
             (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas))
       ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) ->
diff --git a/src/proto_alpha/lib_protocol/gas_input_size.ml b/src/proto_alpha/lib_protocol/gas_input_size.ml
index bccdf39979e8..3026abf4e27e 100644
--- a/src/proto_alpha/lib_protocol/gas_input_size.ml
+++ b/src/proto_alpha/lib_protocol/gas_input_size.ml
@@ -52,7 +52,7 @@ let node leaves =
   let r = List.fold_left ( ++ ) micheline_zero leaves in
   {r with traversal = r.traversal + 1}
 
-let rec of_micheline (x : ('a, 'b) Micheline.node) =
+let[@coq_struct "x_value"] rec of_micheline (x : ('a, 'b) Micheline.node) =
   match x with
   | Micheline.Int (_loc, z) ->
       let int_bytes = integer (Alpha_context.Script_int.of_zint z) in
diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index a915120fea14..d7c67800ffee 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -423,7 +423,7 @@ and[@coq_struct "gas"] imap_map :
  fun log_if_needed g gas (body, k) ks accu stack ->
   let map = accu in
   let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in
-  let ys = Script_map.empty_from map in
+  let ys = (Script_map.empty_from [@coq_type_annotation]) map in
   let ks = log_if_needed (KMap_enter_body (body, xs, ys, KCons (k, ks))) in
   let (accu, stack) = stack in
   (next [@ocaml.tailcall]) g gas ks accu stack
@@ -1185,7 +1185,13 @@ and[@coq_struct "function_parameter"] step :
           let ctxt = update_context gas ctxt in
           let return_none ctxt =
             let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in
-            (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack
+            (step [@ocaml.tailcall])
+              (ctxt, sc)
+              gas
+              k
+              ks
+              (None [@coq_type_annotation])
+              stack
           in
           match c with
           | Contract c -> (
diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
index ecbf1aa6707f..fa66e622fa50 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
@@ -295,7 +295,7 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost =
   | (INeg_bls12_381_g1 _, _, _) -> Interp_costs.neg_bls12_381_g1
   | (INeg_bls12_381_g2 _, _, _) -> Interp_costs.neg_bls12_381_g2
   | (INeg_bls12_381_fr _, _, _) -> Interp_costs.neg_bls12_381_fr
-  | (IMul_bls12_381_fr_z _, _, _) ->
+  | (IMul_bls12_381_fr_z _, (accu : _ Script_int.num), _) ->
       let z = accu in
       Interp_costs.mul_bls12_381_fr_z z
   | (IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _)) ->
diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml
index a0cb334ce141..219aa6956933 100644
--- a/src/proto_alpha/lib_protocol/script_ir_annot.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml
@@ -42,7 +42,7 @@ let error_unexpected_annot loc annot =
 (* Check that the predicate p holds on all s.[k] for k >= i *)
 let string_iter p s i =
   let len = String.length s in
-  let rec aux i =
+  let[@coq_struct "i_value"] rec aux i =
     if Compare.Int.(i >= len) then Result.return_unit
     else p s.[i] >>? fun () -> aux (i + 1)
   in
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 506b9cda219d..2f3fc1b0aac6 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -786,7 +786,7 @@ let rec comparable_ty_eq :
     let not_equal () =
       of_result
       @@ Error
-           (match error_details with
+           (match[@coq_match_gadt_with_result] error_details with
            | Fast -> (Inconsistent_types_fast : error_trace)
            | Informative ->
                trace_of_error
@@ -2768,7 +2768,10 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
         parse_comparable_data ?type_logger ctxt ty expr
         >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) ->
         match destination with
-        | Contract ticketer -> return ({ticketer; contents; amount}, ctxt)
+        | Contract ticketer ->
+            return
+              ( {ticketer; contents = contents [@coq_type_annotation]; amount},
+                ctxt )
         | Tx_rollup _ -> fail (Unexpected_ticket_owner destination)
       else traced_fail (Unexpected_forged_value (location expr))
   (* Sets *)
@@ -6392,6 +6395,8 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x =
           let boxed = m
 
           let size = M.size
+
+          let boxed_map_tag = ()
         end in
         ( ctxt,
           Script_map.make
diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml
index e3fa0e966c7b..8cf9f123e74c 100644
--- a/src/proto_alpha/lib_protocol/script_map.ml
+++ b/src/proto_alpha/lib_protocol/script_map.ml
@@ -45,6 +45,8 @@ let empty_from : type a b c. (a, b) map -> (a, c) map =
       let boxed = OPS.empty
 
       let size = 0
+
+      let boxed_map_tag = ()
     end)
 
 let empty : type a b. a comparable_ty -> (a, b) map =
@@ -52,11 +54,27 @@ let empty : type a b. a comparable_ty -> (a, b) map =
   let module OPS : Boxed_map_OPS with type key = a = struct
     let key_size = Gas_comparable_input_size.size_of_comparable_value ty
 
-    include Map.Make (struct
+    module Map = Map.Make (struct
       type t = a
 
       let compare = Script_comparable.compare_comparable ty
     end)
+
+    type 'a t = 'a Map.t
+
+    type key = Map.key
+
+    let empty = Map.empty
+
+    let add = Map.add
+
+    let remove = Map.remove
+
+    let find = Map.find
+
+    let fold = Map.fold
+
+    let fold_es = Map.fold_es
   end in
   Map_tag
     (module struct
@@ -69,6 +87,8 @@ let empty : type a b. a comparable_ty -> (a, b) map =
       let boxed = OPS.empty
 
       let size = 0
+
+      let boxed_map_tag = ()
     end)
 
 let get : type key value. key -> (key, value) map -> value option =
@@ -95,6 +115,8 @@ let update : type a b. a -> b option -> (a, b) map -> (a, b) map =
       let boxed = boxed
 
       let size = size
+
+      let boxed_map_tag = ()
     end)
 
 let mem : type key value. key -> (key, value) map -> bool =
diff --git a/src/proto_alpha/lib_protocol/script_set.ml b/src/proto_alpha/lib_protocol/script_set.ml
index 22a37d1cc10d..15a650c3d62e 100644
--- a/src/proto_alpha/lib_protocol/script_set.ml
+++ b/src/proto_alpha/lib_protocol/script_set.ml
@@ -37,11 +37,25 @@ let empty : type a. a comparable_ty -> a set =
   let module OPS : Boxed_set_OPS with type elt = a = struct
     let elt_size = Gas_comparable_input_size.size_of_comparable_value ty
 
-    include Set.Make (struct
+    module Set = Set.Make (struct
       type t = a
 
       let compare = Script_comparable.compare_comparable ty
     end)
+
+    type t = Set.t
+
+    type elt = Set.elt
+
+    let empty = Set.empty
+
+    let add = Set.add
+
+    let mem = Set.mem
+
+    let remove = Set.remove
+
+    let fold = Set.fold
   end in
   Set_tag
     (module struct
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index 614b878f950d..dbe99010c087 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -399,6 +399,8 @@ module type Boxed_map = sig
   val boxed : value OPS.t
 
   val size : int
+
+  val boxed_map_tag : unit
 end
 
 type ('key, 'value) map =
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli
index 1651e995e13d..df5507e49d69 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.mli
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli
@@ -254,6 +254,8 @@ module type Boxed_map = sig
   val boxed : value OPS.t
 
   val size : int
+
+  val boxed_map_tag : unit
 end
 
 (** [map] is made algebraic in order to distinguish it from the other type
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index f35cdcd99097..abf95fb1ac3c 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -688,7 +688,8 @@ let rec kinstr_extra_size : type a s r f. (a, s, r, f) kinstr -> nodes_and_size
           | Item_t (ty, _) -> ty_size ty)
       | IRead_ticket (_, k) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr k in
-          match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty)
+          match[@coq_match_with_default] kinfo.kstack_ty with
+          | Item_t (ty, _) -> ty_size ty)
       | ICompare (_, ty, _) -> comparable_ty_size ty
       | ISet_iter (_, body, _) -> (
           let kinfo = Script_typed_ir.kinfo_of_kinstr body in
diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml
index e04e6c5c19fb..19edb40736a5 100644
--- a/src/proto_alpha/lib_protocol/ticket_accounting.ml
+++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml
@@ -58,7 +58,7 @@ module Ticket_token_map = struct
     Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) >|? fun ctxt ->
     (Z.add b1 b2, ctxt)
 
-  let of_list ctxt token_amounts =
+  let of_list_with_merge ctxt token_amounts =
     Ticket_token_map.of_list ctxt ~merge_overlap token_amounts
 
   let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap
@@ -83,9 +83,9 @@ let ticket_balances_of_value ctxt ~include_lazy ty value =
       >|? fun ctxt -> ((token, Script_int.to_zint amount) :: acc, ctxt))
     ([], ctxt)
     tickets
-  >>?= fun (list, ctxt) -> Ticket_token_map.of_list ctxt list
+  >>?= fun (list, ctxt) -> Ticket_token_map.of_list_with_merge ctxt list
 
-let update_ticket_balances ctxt ~total_storage_diff token destinations =
+let update_ticket_balances_raw ctxt ~total_storage_diff token destinations =
   List.fold_left_es
     (fun (tot_storage_diff, ctxt) (owner, delta) ->
       Ticket_balance_key.of_ex_token ctxt ~owner token
@@ -117,7 +117,7 @@ let update_ticket_balances_for_self_contract ctxt ~self ticket_diffs =
         is_valid_balance_update
         (invalid_ticket_transfer_error ~ticket_token ~amount)
       >>?= fun () ->
-      update_ticket_balances
+      update_ticket_balances_raw
         ctxt
         ~total_storage_diff
         ticket_token
@@ -132,7 +132,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets
     Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff
       ctxt
       lazy_storage_diff
-    >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list ctxt diffs
+    >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list_with_merge ctxt diffs
   else return (Ticket_token_map.empty, ctxt)
 
 (* TODO #2465
@@ -242,6 +242,10 @@ let update_ticket_balances ctxt ~self ~ticket_diffs operations =
         ([], ctxt)
         destinations
       >>?= fun (destinations, ctxt) ->
-      update_ticket_balances ctxt ~total_storage_diff ticket_token destinations)
+      update_ticket_balances_raw
+        ctxt
+        ~total_storage_diff
+        ticket_token
+        destinations)
     (total_storage_diff, ctxt)
     ticket_op_diffs
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml
index 210668f9a984..c879022d0e0a 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml
@@ -144,7 +144,7 @@ module V1 = struct
   let operation_content_encoding =
     Data_encoding.Compact.make ~tag_size compact_operation_content
 
-  let compact_operation encoding_signer =
+  let compact_operation_raw encoding_signer =
     Data_encoding.Compact.(
       conv
         (fun {signer; counter; contents} -> (signer, counter, contents))
@@ -154,30 +154,32 @@ module V1 = struct
            (req "counter" int64)
            (req "contents" @@ list ~bits:4 operation_content_encoding))
 
-  let operation_encoding encoding_signer =
-    Data_encoding.Compact.(make ~tag_size (compact_operation encoding_signer))
+  let operation_encoding_raw encoding_signer =
+    Data_encoding.Compact.(
+      make ~tag_size (compact_operation_raw encoding_signer))
 
-  let compact_transaction encoding_signer =
-    Data_encoding.Compact.list ~bits:8 (operation_encoding encoding_signer)
+  let compact_transaction_raw encoding_signer =
+    Data_encoding.Compact.list ~bits:8 (operation_encoding_raw encoding_signer)
 
-  let transaction_encoding :
+  let transaction_encoding_raw :
       'a -> ('b, Indexable.unknown) transaction Data_encoding.t =
    fun encoding_signer ->
-    Data_encoding.Compact.(make ~tag_size (compact_transaction encoding_signer))
+    Data_encoding.Compact.(
+      make ~tag_size (compact_transaction_raw encoding_signer))
 
   let compact_signer_index =
     Data_encoding.Compact.(conv Indexable.to_int32 Indexable.index_exn int32)
 
   let compact_signer_either = Signer_indexable.compact
 
-  let compact_operation = compact_operation compact_signer_either
+  let compact_operation = compact_operation_raw compact_signer_either
 
   let compact_transaction_signer_index =
-    compact_transaction compact_signer_index
+    compact_transaction_raw compact_signer_index
 
-  let compact_transaction = compact_transaction compact_signer_either
+  let compact_transaction = compact_transaction_raw compact_signer_either
 
-  let transaction_encoding = transaction_encoding compact_signer_either
+  let transaction_encoding = transaction_encoding_raw compact_signer_either
 
   let compact ~bits :
       (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t =
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
index 9aac11edd78d..509799948802 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
@@ -119,7 +119,7 @@ let packed_key_encoding : packed_key Data_encoding.t =
     underlying storage. *)
 let value_encoding : type a. a key -> a Data_encoding.t =
   let open Data_encoding in
-  function
+  function[@coq_match_gadt_with_result]
   | Address_metadata _ -> metadata_encoding
   | Address_count -> int32
   | Address_index _ -> Tx_rollup_l2_address.Indexable.index_encoding
@@ -175,7 +175,9 @@ struct
 
   type 'a m = 'a S.m
 
-  module Syntax = struct
+  module Syntax :
+    Tx_rollup_l2_context_sig.SYNTAX with type t := t and type 'a m := 'a m =
+  struct
     include S.Syntax
 
     let ( let*? ) res f =
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
index 635e27a2a7ef..7eb3f4b7aa99 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
@@ -159,6 +159,49 @@ let () =
 
 type created_existed = Created | Existed
 
+(** The necessary monadic operators the storage monad is required to
+    provide. *)
+module type SYNTAX = sig
+  type t
+
+  type 'a m
+
+  val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m
+
+  val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m
+
+  (** [let*?] is for binding the value from Result-only
+      expressions into the storage monad. *)
+  val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m
+
+  (** [fail err] shortcuts the current computation by raising an
+      error.
+
+      Said error can be handled with the [catch] combinator. *)
+  val fail : error -> 'a m
+
+  (** [catch p k h] tries to executes the monadic computation [p].
+      If [p] terminates without an error, then its result is passed
+      to the continuation [k]. On the contrary, if an error [err] is
+      raised, it is passed to the error handler [h]. *)
+  val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m
+
+  (** [return x] is the simplest computation inside the monad [m] which simply
+      computes [x] and nothing else. *)
+  val return : 'a -> 'a m
+
+  (** [list_fold_left_m f] is a monadic version of [List.fold_left
+      f], wherein [f] is not a pure computation, but a computation
+      in the monad [m]. *)
+  val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m
+
+  (** [fail_unless cond err] raises [err] iff [cond] is [false]. *)
+  val fail_unless : bool -> error -> unit m
+
+  (** [fail_when cond err] raises [err] iff [cond] is [true]. *)
+  val fail_when : bool -> error -> unit m
+end
+
 (** This module type describes the API of the [Tx_rollup] context,
     which is used to implement the semantics of the L2 operations. *)
 module type CONTEXT = sig
@@ -179,48 +222,12 @@ module type CONTEXT = sig
       needs to be inside the monad [m]. *)
   type 'a m
 
-  (** The necessary monadic operators the storage monad is required to
-      provide. *)
-  module Syntax : sig
-    val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m
-
-    val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m
-
-    (** [let*?] is for binding the value from Result-only
-        expressions into the storage monad. *)
-    val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m
-
-    (** [fail err] shortcuts the current computation by raising an
-        error.
-
-        Said error can be handled with the [catch] combinator. *)
-    val fail : error -> 'a m
-
-    (** [catch p k h] tries to executes the monadic computation [p].
-        If [p] terminates without an error, then its result is passed
-        to the continuation [k]. On the contrary, if an error [err] is
-        raised, it is passed to the error handler [h]. *)
-    val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m
-
-    (** [return x] is the simplest computation inside the monad [m] which simply
-        computes [x] and nothing else. *)
-    val return : 'a -> 'a m
-
-    (** [list_fold_left_m f] is a monadic version of [List.fold_left
-        f], wherein [f] is not a pure computation, but a computation
-        in the monad [m]. *)
-    val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m
-
-    (** [fail_unless cond err] raises [err] iff [cond] is [false]. *)
-    val fail_unless : bool -> error -> unit m
-
-    (** [fail_when cond err] raises [err] iff [cond] is [true]. *)
-    val fail_when : bool -> error -> unit m
-  end
+  module Syntax : SYNTAX with type t := t and type 'a m := 'a m
 
   (** [bls_aggregate_verify] allows to verify the aggregated signature
       of a batch. *)
-  val bls_verify : (Bls_signature.pk * bytes) list -> signature -> bool m
+  val bls_verify :
+    (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m
 
   (** The metadata associated to an address. *)
   module Address_metadata : sig
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml
index 4a81f9cd4180..2b62542033ce 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml
@@ -25,6 +25,39 @@
 (*                                                                           *)
 (*****************************************************************************)
 
+(** The necessary monadic operators the monad of the storage backend
+      is required to provide. *)
+module type SYNTAX = sig
+  type t
+
+  type 'a m
+
+  val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m
+
+  val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m
+
+  (** [fail err] shortcuts the current computation by raising an
+      error.
+
+      Said error can be handled with the [catch] combinator. *)
+  val fail : error -> 'a m
+
+  (** [catch p k h] tries to executes the monadic computation [p].
+      If [p] terminates without an error, then its result is passed
+      to the continuation [k]. On the contrary, if an error [err] is
+      raised, it is passed to the error handler [h]. *)
+  val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m
+
+  (** [return x] is the simplest computation inside the monad [m] which simply
+      computes [x] and nothing else. *)
+  val return : 'a -> 'a m
+
+  (** [list_fold_left_m f] is a monadic version of [List.fold_left
+      f], wherein [f] is not a pure computation, but a computation
+      in the monad [m]. *)
+  val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m
+end
+
 (** This module type is the minimal API a storage backend has to
     implement to be compatible with the [Tx_rollup] layer-2
     implementation.
@@ -44,34 +77,7 @@ module type STORAGE = sig
   (** The monad of the storage backend. *)
   type 'a m
 
-  (** The necessary monadic operators the monad of the storage backend
-      is required to provide. *)
-  module Syntax : sig
-    val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m
-
-    val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m
-
-    (** [fail err] shortcuts the current computation by raising an
-        error.
-
-        Said error can be handled with the [catch] combinator. *)
-    val fail : error -> 'a m
-
-    (** [catch p k h] tries to executes the monadic computation [p].
-        If [p] terminates without an error, then its result is passed
-        to the continuation [k]. On the contrary, if an error [err] is
-        raised, it is passed to the error handler [h]. *)
-    val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m
-
-    (** [return x] is the simplest computation inside the monad [m] which simply
-        computes [x] and nothing else. *)
-    val return : 'a -> 'a m
-
-    (** [list_fold_left_m f] is a monadic version of [List.fold_left
-        f], wherein [f] is not a pure computation, but a computation
-        in the monad [m]. *)
-    val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m
-  end
+  module Syntax : SYNTAX with type t := t and type 'a m := 'a m
 
   (** [get storage key] returns the value stored in [storage] for
       [key], if it exists. Returns [None] if it does not. *)
-- 
GitLab


From 66bfff7f231fb932afda17abecd8b42ba6871ea7 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Sun, 13 Mar 2022 16:47:13 +0100
Subject: [PATCH 62/69] Proto: compile ty_eq in Coq

---
 .../lib_protocol/script_ir_translator.ml      | 28 ++++++++++---------
 1 file changed, 15 insertions(+), 13 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 2f3fc1b0aac6..a4105a1c31c6 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -878,27 +878,28 @@ let ty_eq :
   let memo_size_eq ms1 ms2 =
     Gas_monad.of_result (memo_size_eq ~error_details ms1 ms2)
   in
-  let rec help :
-      type ta tac tb tbc.
-      (ta, tac) ty ->
-      (tb, tbc) ty ->
-      (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t =
-   fun ty1 ty2 ->
-    help0 ty1 ty2
-    |> Gas_monad.record_trace_eval ~error_details (fun () ->
-           default_ty_eq_error ty1 ty2)
-  and help0 :
+  let rec help0 :
       type ta tac tb tbc.
       (ta, tac) ty ->
       (tb, tbc) ty ->
       (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t =
    fun ty1 ty2 ->
+    let help :
+        type ta tac tb tbc.
+        (ta, tac) ty ->
+        (tb, tbc) ty ->
+        (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t =
+     fun ty1 ty2 ->
+      help0 ty1 ty2
+      |> Gas_monad.record_trace_eval ~error_details (fun () ->
+             default_ty_eq_error ty1 ty2)
+    in
     let open Gas_monad.Syntax in
     let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in
     let not_equal () =
       Gas_monad.of_result
       @@ Error
-           (match error_details with
+           (match[@coq_match_gadt_with_result] error_details with
            | Fast -> (Inconsistent_types_fast : error_trace)
            | Informative -> trace_of_error @@ default_ty_eq_error ty1 ty2)
     in
@@ -1016,8 +1017,9 @@ let ty_eq :
     | (Chest_key_t, Chest_key_t) -> return Eq
     | (Chest_key_t, _) -> not_equal ()
   in
-  help ty1 ty2
- [@@coq_axiom_with_reason "non-top-level mutual recursion"]
+  help0 ty1 ty2
+  |> Gas_monad.record_trace_eval ~error_details (fun () ->
+         default_ty_eq_error ty1 ty2)
 
 (* Same as ty_eq but for stacks.
    A single error monad is used here because there is no need to
-- 
GitLab


From 0c4b2953d2eadb6566173b7b2b262e9f03c6868f Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Sun, 13 Mar 2022 17:03:06 +0100
Subject: [PATCH 63/69] Proto: remove a warning from coq-of-ocaml

---
 src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
index 38f8d5ca4852..22ff30901063 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
@@ -692,7 +692,7 @@ module Make (Context : CONTEXT) = struct
         failed because of a [Counter_mismatch] the counters are left
         untouched.
     *)
-    let update_counters ctxt status transaction =
+    let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters ctxt status transaction =
       match status with
       | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt
       | Transaction_failure _ | Transaction_success ->
-- 
GitLab


From 736a80c53d3a3c1d94e36135a0b601ed3dbbac7b Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 15 Mar 2022 22:22:18 +0100
Subject: [PATCH 64/69] Proto: more changes for coq-of-ocaml

---
 src/lib_crypto/blake2B.ml                     |  15 +-
 src/lib_crypto/blake2B.mli                    |  16 +-
 .../sigs/v5/data_encoding.mli                 |   4 +-
 src/proto_alpha/lib_plugin/plugin.ml          |  11 +-
 .../lib_protocol/alpha_context.mli            |  12 +-
 src/proto_alpha/lib_protocol/apply_results.ml |  42 ++-
 .../lib_protocol/raw_context_intf.ml          |   3 -
 .../lib_protocol/script_interpreter_defs.ml   |   3 +-
 .../lib_protocol/script_ir_translator.ml      | 334 ++++++++++--------
 .../lib_protocol/script_ir_translator.mli     |   1 +
 .../lib_protocol/script_typed_ir.ml           |   3 +
 .../lib_protocol/script_typed_ir.mli          |   3 +
 .../lib_protocol/services_registration.ml     |  20 +-
 .../lib_protocol/services_registration.mli    |   6 +-
 src/proto_alpha/lib_protocol/storage.ml       |   6 +-
 .../lib_protocol/ticket_operations_diff.ml    |  16 +-
 .../lib_protocol/ticket_scanner.ml            |   1 +
 .../tx_rollup_commitment_repr.mli             |   1 +
 .../lib_protocol/tx_rollup_l2_apply.ml        |   3 +-
 .../lib_protocol/tx_rollup_withdraw_repr.ml   |   2 +-
 .../tx_rollup_withdraw_storage.ml             |   3 +-
 21 files changed, 275 insertions(+), 230 deletions(-)

diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml
index 4022f5993b59..011fbd085a18 100644
--- a/src/lib_crypto/blake2B.ml
+++ b/src/lib_crypto/blake2B.ml
@@ -318,20 +318,13 @@ end
 
 let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2)
 
-module Make_merkle_tree (R : sig
-  val register_encoding :
-    prefix:string ->
-    length:int ->
-    to_raw:('a -> string) ->
-    of_raw:(string -> 'a option) ->
-    wrap:('a -> Base58.data) ->
-    'a Base58.encoding
-end)
-(K : PrefixedName) (Contents : sig
+module type To_bytes = sig
   type t
 
   val to_bytes : t -> Bytes.t
-end) =
+end
+
+module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) =
 struct
   include Make (R) (K)
 
diff --git a/src/lib_crypto/blake2B.mli b/src/lib_crypto/blake2B.mli
index 044734007acd..021a5201e74d 100644
--- a/src/lib_crypto/blake2B.mli
+++ b/src/lib_crypto/blake2B.mli
@@ -68,20 +68,14 @@ module Make (Register : Register) (Name : PrefixedName) : S.HASH
 
 (**/**)
 
-module Make_merkle_tree (R : sig
-  val register_encoding :
-    prefix:string ->
-    length:int ->
-    to_raw:('a -> string) ->
-    of_raw:(string -> 'a option) ->
-    wrap:('a -> Base58.data) ->
-    'a Base58.encoding
-end)
-(K : PrefixedName) (Contents : sig
+module type To_bytes = sig
   type t
 
   val to_bytes : t -> Bytes.t
-end) : S.MERKLE_TREE with type elt = Contents.t
+end
+
+module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) :
+  S.MERKLE_TREE with type elt = Contents.t
 
 module Generic_Merkle_tree (H : sig
   type t
diff --git a/src/lib_protocol_environment/sigs/v5/data_encoding.mli b/src/lib_protocol_environment/sigs/v5/data_encoding.mli
index e7cd699b0623..b3c52a30caf2 100644
--- a/src/lib_protocol_environment/sigs/v5/data_encoding.mli
+++ b/src/lib_protocol_environment/sigs/v5/data_encoding.mli
@@ -466,6 +466,8 @@ type 't case
 
 type case_tag = Tag of int | Json_only
 
+type match_result
+
 (** A sum descriptor can be optimized by providing a specific
    [matching_function] which efficiently determines in which case
    some value of type ['a] falls.
@@ -481,8 +483,6 @@ type case_tag = Tag of int | Json_only
      inhabited. *)
 type 'a matching_function = 'a -> match_result
 
-and match_result
-
 (** [matched t e u] represents the fact that a value is tagged with [t] and
     carries the payload [u] which can be encoded with [e].
 
diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml
index 4f16ae4bd8c9..80b62b191f0e 100644
--- a/src/proto_alpha/lib_plugin/plugin.ml
+++ b/src/proto_alpha/lib_plugin/plugin.ml
@@ -1510,7 +1510,7 @@ module RPC = struct
     let register0_fullctxt ~chunked s f =
       patched_services :=
         RPC_directory.register ~chunked !patched_services s (fun ctxt q i ->
-            Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt ->
+            Services_registration.rpc_init ctxt Head_level >>=? fun ctxt ->
             f ctxt q i)
 
     let register0 ~chunked s f =
@@ -1520,7 +1520,8 @@ module RPC = struct
       patched_services :=
         RPC_directory.register ~chunked !patched_services s (fun ctxt q i ->
             let mode =
-              if q#successor_level then `Successor_level else `Head_level
+              if q#successor_level then Services_registration.Successor_level
+              else Head_level
             in
             Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i)
 
@@ -1535,7 +1536,7 @@ module RPC = struct
     let opt_register0_fullctxt ~chunked s f =
       patched_services :=
         RPC_directory.opt_register ~chunked !patched_services s (fun ctxt q i ->
-            Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt ->
+            Services_registration.rpc_init ctxt Head_level >>=? fun ctxt ->
             f ctxt q i)
 
     let opt_register0 ~chunked s f =
@@ -1548,7 +1549,7 @@ module RPC = struct
           !patched_services
           s
           (fun (ctxt, arg) q i ->
-            Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt ->
+            Services_registration.rpc_init ctxt Head_level >>=? fun ctxt ->
             f ctxt arg q i)
 
     let register1 ~chunked s f =
@@ -1561,7 +1562,7 @@ module RPC = struct
           !patched_services
           s
           (fun ((ctxt, arg1), arg2) q i ->
-            Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt ->
+            Services_registration.rpc_init ctxt Head_level >>=? fun ctxt ->
             f ctxt arg1 arg2 q i)
 
     let register2 ~chunked s f =
diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index fb4c92aadceb..4a1b537fa061 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -1456,7 +1456,7 @@ end
 (** This module re-exports functions from {!Ticket_hash_repr}. See
     documentation of the functions there. *)
 module Ticket_hash : sig
-  type t
+  type t = Ticket_hash_repr.t
 
   val encoding : t Data_encoding.t
 
@@ -1676,7 +1676,7 @@ end
 
 (** This module re-exports definitions from {!Tx_rollup_message_repr}. *)
 module Tx_rollup_message : sig
-  type deposit = {
+  type deposit = Tx_rollup_message_repr.deposit = {
     sender : public_key_hash;
     destination : Tx_rollup_l2_address.Indexable.value;
     ticket_hash : Ticket_hash.t;
@@ -2249,7 +2249,10 @@ module Delegate : sig
     endorsing_power:int ->
     context tzresult Lwt.t
 
-  type deposits = {initial_amount : Tez.t; current_amount : Tez.t}
+  type deposits = Storage.deposits = {
+    initial_amount : Tez.t;
+    current_amount : Tez.t;
+  }
 
   val frozen_deposits : context -> public_key_hash -> deposits tzresult Lwt.t
 
@@ -2409,7 +2412,7 @@ module Sc_rollup : sig
     module Map : Map.S with type key = t
   end
 
-  module Address : S.HASH
+  module Address : S.HASH [@@coq_plain_module]
 
   type t = Address.t
 
@@ -2418,6 +2421,7 @@ module Sc_rollup : sig
 
     val encoding : t Data_encoding.t
   end
+  [@@coq_plain_module]
 
   module Staker :
     S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t
diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 9af74be7c31e..e34c7644d130 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -898,7 +898,7 @@ module Manager_result = struct
       ~select:(function
         | Successful_manager_result (Sc_rollup_cement_result _ as op) -> Some op
         | _ -> None)
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Sc_rollup_cement_result {consumed_gas} ->
             (Gas.Arith.ceil consumed_gas, consumed_gas))
       ~kind:Kind.Sc_rollup_cement_manager_kind
@@ -949,7 +949,7 @@ module Internal_result = struct
         -> 'kind case
   [@@coq_force_gadt]
 
-  let[@coq_axiom_with_reason "gadt"] transaction_case =
+  let transaction_case =
     MCase
       {
         tag = Operation.Encoding.Manager_operations.transaction_tag;
@@ -972,7 +972,7 @@ module Internal_result = struct
         select =
           (function Manager (Transaction _ as op) -> Some op | _ -> None);
         proj =
-          (function
+          (function[@coq_match_with_default]
           | Transaction {amount; destination; parameters; entrypoint} ->
               let parameters =
                 if
@@ -992,7 +992,7 @@ module Internal_result = struct
             Transaction {amount; destination; parameters; entrypoint});
       }
 
-  let[@coq_axiom_with_reason "gadt"] origination_case =
+  let origination_case =
     MCase
       {
         tag = Operation.Encoding.Manager_operations.origination_tag;
@@ -1011,14 +1011,14 @@ module Internal_result = struct
         select =
           (function Manager (Origination _ as op) -> Some op | _ -> None);
         proj =
-          (function
+          (function[@coq_match_with_default]
           | Origination {credit; delegate; script} -> (credit, delegate, script));
         inj =
           (fun (credit, delegate, script) ->
             Origination {credit; delegate; script});
       }
 
-  let[@coq_axiom_with_reason "gadt"] delegation_case =
+  let delegation_case =
     MCase
       {
         tag = Operation.Encoding.Manager_operations.delegation_tag;
@@ -1032,7 +1032,7 @@ module Internal_result = struct
           | _ -> None);
         select =
           (function Manager (Delegation _ as op) -> Some op | _ -> None);
-        proj = (function Delegation key -> key);
+        proj = (function[@coq_match_with_default] Delegation key -> key);
         inj = (fun key -> Delegation key);
       }
 
@@ -1045,13 +1045,16 @@ module Internal_result = struct
       (fun ((), x) -> inj x)
 
   let encoding =
-    let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) =
-      case
-        (Tag tag)
-        name
-        encoding
-        (fun o -> match select o with None -> None | Some o -> Some (proj o))
-        (fun x -> Manager (inj x))
+    let make m_case =
+      match[@coq_grab_existentials] m_case with
+      | MCase {tag; name; encoding; iselect = _; select; proj; inj} ->
+          case
+            (Tag tag)
+            name
+            encoding
+            (fun o ->
+              match select o with None -> None | Some o -> Some (proj o))
+            (fun x -> Manager (inj x))
     in
     union
       ~tag_size:`Uint8
@@ -1073,9 +1076,12 @@ let internal_manager_operation_result_encoding :
     packed_internal_manager_operation_result Data_encoding.t =
   let make (type kind)
       (Manager_result.MCase res_case : kind Manager_result.case)
-      (Internal_result.MCase ires_case : kind Internal_result.case) =
-    match[@coq_grab_existentials] res_case.op_case with
-    | Operation.Encoding.Manager_operations.MCase op_case ->
+      (ires_case : kind Internal_result.case) =
+    let (Operation.Encoding.Manager_operations.MCase op_case) =
+      res_case.op_case
+    in
+    match[@coq_grab_existentials] ires_case with
+    | Internal_result.MCase ires_case ->
         case
           (Tag op_case.tag)
           ~title:op_case.name
@@ -1721,7 +1727,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case =
+  let sc_rollup_cement_case =
     make_manager_case
       Operation.Encoding.sc_rollup_cement_case
       Manager_result.sc_rollup_cement_case
diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml
index b3f1ad418e55..8840c5d9c8b3 100644
--- a/src/proto_alpha/lib_protocol/raw_context_intf.ml
+++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml
@@ -28,9 +28,6 @@
     as-is for direct context accesses, and used in {!Storage_functors}
     to provide restricted views to the context. *)
 
-(** The tree depth of a fold. See the [fold] function for more information. *)
-type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int]
-
 (** The type for context configuration. If two trees or stores have the
     same configuration, they will generate the same context hash. *)
 type config = Context.config
diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
index fa66e622fa50..dbaad1fb7fe3 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml
@@ -200,7 +200,8 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost =
       let outputs = List.length tx.outputs in
       Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs
   | (ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _)) ->
-      let ticket = accu and ((amount_a, amount_b), _) = stack in
+      let ticket = accu in
+      let ((amount_a, amount_b), _) = stack in
       Interp_costs.split_ticket ticket.amount amount_a amount_b
   | (IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _) ->
       let (ticket_a, ticket_b) = ticket_a_b in
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index a4105a1c31c6..b0c13bc5cf0f 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -1825,6 +1825,7 @@ type ('arg, 'storage) code =
       code_size : Cache_memory_helpers.sint;
     }
       -> ('arg, 'storage) code
+[@@coq_force_gadt]
 
 type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script
 
@@ -1959,7 +1960,7 @@ let find_entrypoint (type full fullc error_trace)
     (entrypoints : full entrypoints) entrypoint :
     (full ex_ty_cstr, error_trace) Gas_monad.t =
   let open Gas_monad.Syntax in
-  let rec find_entrypoint :
+  let[@coq_struct "ty"] rec find_entrypoint :
       type t tc.
       (t, tc) ty ->
       t entrypoints_node ->
@@ -1967,7 +1968,7 @@ let find_entrypoint (type full fullc error_trace)
       (t ex_ty_cstr, unit) Gas_monad.t =
    fun ty entrypoints entrypoint ->
     let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in
-    match[@coq_match_with_default] (ty, entrypoints) with
+    match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with
     | (_, {at_node = Some {name; original_type_expr}; _})
       when Entrypoint.(name = entrypoint) ->
         return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr})
@@ -2009,7 +2010,13 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace)
     entrypoints entrypoint loc :
     (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t =
   let open Gas_monad.Syntax in
-  let* res = find_entrypoint ~error_details full entrypoints entrypoint in
+  let* res =
+    (find_entrypoint
+       ~error_details
+       full
+       entrypoints
+       entrypoint [@coq_type_annotation])
+  in
   match res with
   | Ex_ty_cstr {ty; _} -> (
       match entrypoints.root.at_node with
@@ -2827,7 +2834,9 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
   | (Big_map_t (tk, tv, _ty_name), expr) ->
       (match expr with
       | Int (loc, id) ->
-          return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt)
+          return
+            (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt)
+          [@coq_type_annotation]
       | Seq (_, vs) ->
           parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x)
           >|=? fun (diff, ctxt) -> (None, diff, ctxt)
@@ -2948,7 +2957,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux :
                 >|? fun () -> (transaction, ctxt) ))
       | None -> fail_parse_data ())
   | (Sapling_transaction_deprecated_t _, expr) ->
-      (traced_fail [@coq_implicit "(B := a * Raw_context.t)"])
+      (traced_fail [@coq_implicit "B" "a * Raw_context.t"])
         (Invalid_kind (location expr, [Bytes_kind], kind expr))
   | (Sapling_state_t memo_size, Int (loc, id)) ->
       if allow_forged then
@@ -4761,7 +4770,7 @@ and[@coq_struct "ctxt"] parse_instr_aux :
       Lwt.return
         ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint ->
           let open Tc_context in
-          match tc_context.callsite with
+          match[@coq_match_gadt] tc_context.callsite with
           | _ when is_in_lambda tc_context ->
               error
                 (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim))
@@ -4774,11 +4783,11 @@ and[@coq_struct "ctxt"] parse_instr_aux :
                 (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim))
           | Toplevel {param_type; entrypoints; storage_type = _} ->
               Gas_monad.run ctxt
-              @@ find_entrypoint
-                   ~error_details:Informative
-                   param_type
-                   entrypoints
-                   entrypoint
+              @@ (find_entrypoint
+                    ~error_details:Informative
+                    param_type
+                    entrypoints
+                    entrypoint [@coq_type_annotation])
               >>? fun (r, ctxt) ->
               r >>? fun (Ex_ty_cstr {ty = param_type; _}) ->
               contract_t loc param_type >>? fun res_ty ->
@@ -5207,12 +5216,14 @@ and[@coq_mutual_as_notation] parse_contract_aux :
                     ~stack_depth:(stack_depth + 1)
                     ~legacy:true
                     arg_type
-                  >>? fun ( Ex_parameter_ty_and_entrypoints
-                              {arg_type = targ; entrypoints},
-                            ctxt ) ->
+                  >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints
+                                                {arg_type = targ; entrypoints},
+                                              ctxt ) ->
                   (* we don't check targ size here because it's a legacy contract code *)
                   Gas_monad.run ctxt
-                  @@ find_entrypoint_for_type
+                  @@ (find_entrypoint_for_type
+                     [@coq_implicit
+                       "full" "__Ex_parameter_ty_and_entrypoints_'a1"])
                        ~error_details:Informative
                        ~full:targ
                        ~expected:arg
@@ -5404,7 +5415,7 @@ let parse_contract_for_script :
                   match parse_toplevel_aux ctxt ~legacy:true code with
                   | Error _ -> error (Invalid_contract (loc, contract))
                   | Ok ({arg_type; _}, ctxt) -> (
-                      match
+                      match[@coq_match_gadt]
                         parse_parameter_ty_and_entrypoints_aux
                           ctxt
                           ~stack_depth:0
@@ -5418,7 +5429,9 @@ let parse_contract_for_script :
                             ctxt ) -> (
                           (* we don't check targ size here because it's a legacy contract code *)
                           Gas_monad.run ctxt
-                          @@ find_entrypoint_for_type
+                          @@ (find_entrypoint_for_type
+                             [@coq_implicit
+                               "full" "__Ex_parameter_ty_and_entrypoints_'a"])
                                ~error_details:Fast
                                ~full:targ
                                ~expected:arg
@@ -5800,53 +5813,64 @@ let[@coq_struct "ctxt"] rec unparse_data_aux :
       unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
       >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
   | (Big_map_t (kt, vt, _), (x : _ big_map)) -> (
-      let (Big_map {id; diff = {map; size; _}; _}) = x in
-      match id with
-      | Some id ->
-          if Compare.Int.( = ) size 0 then
-            return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt)
-          else
-            let items =
-              Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map []
-            in
-            let items =
-              (* Sort the items in Michelson comparison order and not in key
-                 hash order. This code path is only exercised for tracing,
-                 so we don't bother carbonating this sort operation
-                 precisely. Also, the sort uses a reverse compare because
-                 [unparse_items] will reverse the result. *)
-              List.sort
-                (fun (a, _) (b, _) ->
-                  Script_comparable.compare_comparable kt b a)
-                items
-            in
-            (* this can't fail if the original type is well-formed
-               because [option vt] is always strictly smaller than [big_map kt vt] *)
-            option_t loc vt >>?= fun vt ->
-            unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
-            >|=? fun (items, ctxt) ->
-            ( Micheline.Prim
-                ( loc,
-                  D_Pair,
-                  [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)],
-                  [] ),
-              ctxt )
-      | None ->
-          let items =
-            Big_map_overlay.fold
-              (fun _ (k, v) acc ->
-                match v with None -> acc | Some v -> (k, v) :: acc)
-              map
-              []
-          in
-          let items =
-            (* See note above. *)
-            List.sort
-              (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)
-              items
-          in
-          unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
-          >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt))
+      match[@coq_match_gadt] x with
+      | Big_map {id; diff = {map; size; _}; _} -> (
+          match id with
+          | Some id ->
+              if Compare.Int.( = ) size 0 then
+                return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt)
+              else
+                let items =
+                  Big_map_overlay.fold
+                    (fun _ (k, v) acc -> (k, v) :: acc)
+                    map
+                    []
+                in
+                let items =
+                  (* Sort the items in Michelson comparison order and not in key
+                     hash order. This code path is only exercised for tracing,
+                     so we don't bother carbonating this sort operation
+                     precisely. Also, the sort uses a reverse compare because
+                     [unparse_items] will reverse the result. *)
+                  List.sort
+                    (fun (a, _) (b, _) ->
+                      Script_comparable.compare_comparable kt b a)
+                    items
+                in
+                (* this can't fail if the original type is well-formed
+                   because [option vt] is always strictly smaller than [big_map kt vt] *)
+                option_t loc vt >>?= fun vt ->
+                unparse_items
+                  ctxt
+                  ~stack_depth:(stack_depth + 1)
+                  mode
+                  kt
+                  vt
+                  items
+                >|=? fun (items, ctxt) ->
+                ( Micheline.Prim
+                    ( loc,
+                      D_Pair,
+                      [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)],
+                      [] ),
+                  ctxt )
+          | None ->
+              let items =
+                Big_map_overlay.fold
+                  (fun _ (k, v) acc ->
+                    match v with None -> acc | Some v -> (k, v) :: acc)
+                  map
+                  []
+              in
+              let items =
+                (* See note above. *)
+                List.sort
+                  (fun (a, _) (b, _) ->
+                    Script_comparable.compare_comparable kt b a)
+                  items
+              in
+              unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
+              >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)))
   | (Lambda_t _, (x : _ lambda)) ->
       let (Lam (_, original_code)) = x in
       unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code
@@ -5858,7 +5882,8 @@ let[@coq_struct "ctxt"] rec unparse_data_aux :
             Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s
           in
           (Bytes (loc, bytes), ctxt) )
-  | (Sapling_transaction_deprecated_t _, s) ->
+  | (Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction))
+    ->
       Lwt.return
         ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s)
         >|? fun ctxt ->
@@ -6050,11 +6075,11 @@ let pack_data ctxt ty data =
 
 (* ---------------- Big map -------------------------------------------------*)
 
-let empty_big_map key_type value_type =
+let empty_big_map key_type value_type : ('a, 'b) big_map =
   Big_map
     {
       id = None;
-      diff = {map = Big_map_overlay.empty; size = 0};
+      diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation];
       key_type;
       value_type;
     }
@@ -6068,40 +6093,44 @@ let big_map_mem ctxt key (Big_map {id; diff; key_type; _}) =
   | (Some (_, None), _) -> return (false, ctxt)
   | (Some (_, Some _), _) -> return (true, ctxt)
 
-let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) =
-  match (Big_map_overlay.find key diff.map, id) with
-  | (Some (_, x), _) -> return (x, ctxt)
-  | (None, None) -> return (None, ctxt)
-  | (None, Some id) -> (
-      Alpha_context.Big_map.get_opt ctxt id key >>=? function
-      | (ctxt, None) -> return (None, ctxt)
-      | (ctxt, Some value) ->
-          parse_data_aux
-            ~stack_depth:0
-            ctxt
-            ~legacy:true
-            ~allow_forged:true
-            value_type
-            (Micheline.root value)
-          >|=? fun (x, ctxt) -> (Some x, ctxt))
+let big_map_get_by_hash ctxt key big_map =
+  match[@coq_match_gadt] big_map with
+  | Big_map {id; diff; value_type; _} -> (
+      match (Big_map_overlay.find key diff.map, id) with
+      | (Some (_, x), _) -> return (x, ctxt)
+      | (None, None) -> return (None, ctxt)
+      | (None, Some id) -> (
+          Alpha_context.Big_map.get_opt ctxt id key >>=? function
+          | (ctxt, None) -> return (None, ctxt)
+          | (ctxt, Some value) ->
+              parse_data_aux
+                ~stack_depth:0
+                ctxt
+                ~legacy:true
+                ~allow_forged:true
+                value_type
+                (Micheline.root value)
+              >|=? fun (x, ctxt) -> (Some x, ctxt)))
 
 let big_map_get ctxt key (Big_map {key_type; _} as map) =
   hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->
-  big_map_get_by_hash ctxt key_hash map
+  (big_map_get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map
 
-let big_map_update_by_hash ctxt key_hash key value (Big_map map) =
-  let contains = Big_map_overlay.mem key_hash map.diff.map in
-  return
-    ( Big_map
-        {
-          map with
-          diff =
+let big_map_update_by_hash ctxt key_hash key value map =
+  match[@coq_match_gadt] map with
+  | Big_map map ->
+      let contains = Big_map_overlay.mem key_hash map.diff.map in
+      return
+        ( Big_map
             {
-              map = Big_map_overlay.add key_hash (key, value) map.diff.map;
-              size = (if contains then map.diff.size else map.diff.size + 1);
-            };
-        },
-      ctxt )
+              map with
+              diff =
+                {
+                  map = Big_map_overlay.add key_hash (key, value) map.diff.map;
+                  size = (if contains then map.diff.size else map.diff.size + 1);
+                };
+            },
+          ctxt )
 
 let big_map_update ctxt key value (Big_map {key_type; _} as map) =
   hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->
@@ -6110,8 +6139,8 @@ let big_map_update ctxt key value (Big_map {key_type; _} as map) =
 let big_map_get_and_update ctxt key value (Big_map {key_type; _} as map) =
   hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->
   big_map_update_by_hash ctxt key_hash key value map >>=? fun (map', ctxt) ->
-  big_map_get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) ->
-  return ((old_value, map'), ctxt)
+  (big_map_get_by_hash [@coq_implicit "B" "B"]) ctxt key_hash map
+  >>=? fun (old_value, ctxt) -> return ((old_value, map'), ctxt)
 
 (* ---------------- Lazy storage---------------------------------------------*)
 
@@ -6120,60 +6149,63 @@ type lazy_storage_ids = Lazy_storage.IdSet.t
 let no_lazy_storage_id = Lazy_storage.IdSet.empty
 
 let diff_of_big_map ctxt mode ~temporary ~ids_to_copy
-    (Big_map {id; key_type; value_type; diff}) =
-  (match id with
-  | Some id ->
-      if Lazy_storage.IdSet.mem Big_map id ids_to_copy then
-        Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) ->
-        (ctxt, Lazy_storage.Copy {src = id}, duplicate)
-      else
-        (* The first occurrence encountered of a big_map reuses the
-             ID. This way, the payer is only charged for the diff.
-             For this to work, this diff has to be put at the end of
-             the global diff, otherwise the duplicates will use the
-             updated version as a base. This is true because we add
-             this diff first in the accumulator of
-             `extract_lazy_storage_updates`, and this accumulator is not
-             reversed. *)
-        return (ctxt, Lazy_storage.Existing, id)
-  | None ->
-      Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) ->
-      Lwt.return
-        (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in
-         Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt ->
-         unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) ->
-         Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt ->
-         let key_type = Micheline.strip_locations kt in
-         let value_type = Micheline.strip_locations kv in
-         (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id)))
-  >>=? fun (ctxt, init, id) ->
-  let pairs =
-    Big_map_overlay.fold
-      (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc)
-      diff.map
-      []
-  in
-  List.fold_left_es
-    (fun (acc, ctxt) (key_hash, key, value) ->
-      Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->
-      unparse_comparable_data ~loc:() ctxt mode key_type key
-      >>=? fun (key_node, ctxt) ->
-      Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt ->
-      let key = Micheline.strip_locations key_node in
-      (match value with
-      | None -> return (None, ctxt)
-      | Some x ->
-          unparse_data_aux ~stack_depth:0 ctxt mode value_type x
-          >>=? fun (node, ctxt) ->
+    (big_map : ('a, 'b) big_map) =
+  match[@coq_match_gadt] big_map with
+  | Big_map {id; key_type; value_type; diff} ->
+      (match id with
+      | Some id ->
+          if Lazy_storage.IdSet.mem Big_map id ids_to_copy then
+            Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) ->
+            (ctxt, Lazy_storage.Copy {src = id}, duplicate)
+          else
+            (* The first occurrence encountered of a big_map reuses the
+                 ID. This way, the payer is only charged for the diff.
+                 For this to work, this diff has to be put at the end of
+                 the global diff, otherwise the duplicates will use the
+                 updated version as a base. This is true because we add
+                 this diff first in the accumulator of
+                 `extract_lazy_storage_updates`, and this accumulator is not
+                 reversed. *)
+            return (ctxt, Lazy_storage.Existing, id)
+      | None ->
+          Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) ->
           Lwt.return
-            ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt ->
-              (Some (Micheline.strip_locations node), ctxt) ))
-      >|=? fun (value, ctxt) ->
-      let diff_item = Big_map.{key; key_hash; value} in
-      (diff_item :: acc, ctxt))
-    ([], ctxt)
-    (List.rev pairs)
-  >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt)
+            (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in
+             Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt ->
+             unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) ->
+             Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt ->
+             let key_type = Micheline.strip_locations kt in
+             let value_type = Micheline.strip_locations kv in
+             (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id)))
+      >>=? fun (ctxt, init, id) ->
+      let pairs : (Script_expr_hash.t * 'a * 'b option) list =
+        Big_map_overlay.fold
+          (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc)
+          diff.map
+          []
+      in
+      List.fold_left_es
+        (fun (acc, ctxt) (key_hash, key, value) ->
+          Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->
+          unparse_comparable_data ~loc:() ctxt mode key_type key
+          >>=? fun (key_node, ctxt) ->
+          Gas.consume ctxt (Script.strip_locations_cost key_node)
+          >>?= fun ctxt ->
+          let key = Micheline.strip_locations key_node in
+          (match value with
+          | None -> return (None, ctxt)
+          | Some x ->
+              unparse_data_aux ~stack_depth:0 ctxt mode value_type x
+              >>=? fun (node, ctxt) ->
+              Lwt.return
+                ( Gas.consume ctxt (Script.strip_locations_cost node)
+                >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) ))
+          >|=? fun (value, ctxt) ->
+          let diff_item = Big_map.{key; key_hash; value} in
+          (diff_item :: acc, ctxt))
+        ([], ctxt)
+        (List.rev pairs)
+      >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt)
 
 let diff_of_sapling_state ctxt ~temporary ~ids_to_copy
     ({id; diff; memo_size} : Sapling.state) =
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli
index 1a62441f7bd6..40477bd88fd1 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.mli
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli
@@ -111,6 +111,7 @@ type ('arg, 'storage) code =
          field as it has a dynamic size. *)
     }
       -> ('arg, 'storage) code
+[@@coq_force_gadt]
 
 type ex_code = Ex_code : ('a, 'c) code -> ex_code
 
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index dbe99010c087..21aa52c3245b 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -1151,6 +1151,7 @@ and 'arg typed_contract =
       address : address;
     }
       -> 'arg typed_contract
+[@@coq_force_gadt]
 
 and (_, _, _, _) continuation =
   | KNil : ('r, 'f, 'r, 'f) continuation
@@ -1302,6 +1303,7 @@ and ('key, 'value) big_map =
       value_type : ('value, _) ty;
     }
       -> ('key, 'value) big_map
+[@@coq_force_gadt]
 
 and ('a, 's, 'r, 'f) kdescr = {
   kloc : Script.location;
@@ -1367,6 +1369,7 @@ and ('input, 'output) view_signature =
       output_ty : ('output, _) ty;
     }
       -> ('input, 'output) view_signature
+[@@coq_force_gadt]
 
 and 'kind manager_operation =
   | Transaction : {
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli
index df5507e49d69..cef6f6b90a17 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.mli
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli
@@ -1149,6 +1149,7 @@ and 'arg typed_contract =
       address : address;
     }
       -> 'arg typed_contract
+[@@coq_force_gadt]
 
 (*
 
@@ -1396,6 +1397,7 @@ and ('key, 'value) big_map =
       value_type : ('value, _) ty;
     }
       -> ('key, 'value) big_map
+[@@coq_force_gadt]
 
 and ('a, 's, 'r, 'f) kdescr = {
   kloc : Script.location;
@@ -1495,6 +1497,7 @@ and ('input, 'output) view_signature =
       output_ty : ('output, _) ty;
     }
       -> ('input, 'output) view_signature
+[@@coq_force_gadt]
 
 and 'kind manager_operation =
   | Transaction : {
diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml
index de94c5dbdf69..4fa5d81a2d9c 100644
--- a/src/proto_alpha/lib_protocol/services_registration.ml
+++ b/src/proto_alpha/lib_protocol/services_registration.ml
@@ -31,12 +31,14 @@ type rpc_context = {
   context : Alpha_context.t;
 }
 
+type level = Head_level | Successor_level
+
 let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) mode =
   let timestamp = block_header.timestamp in
   let level =
     match mode with
-    | `Head_level -> block_header.level
-    | `Successor_level -> Int32.succ block_header.level
+    | Head_level -> block_header.level
+    | Successor_level -> Int32.succ block_header.level
   in
   Alpha_context.prepare
     ~level
@@ -51,7 +53,7 @@ let rpc_services =
 let register0_fullctxt ~chunked s f =
   rpc_services :=
     RPC_directory.register ~chunked !rpc_services s (fun ctxt q i ->
-        rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i)
+        rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i)
 
 let register0 ~chunked s f =
   register0_fullctxt ~chunked s (fun {context; _} -> f context)
@@ -63,7 +65,7 @@ let register0_noctxt ~chunked s f =
 let register1_fullctxt ~chunked s f =
   rpc_services :=
     RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i ->
-        rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i)
+        rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i)
 
 let register1 ~chunked s f =
   register1_fullctxt ~chunked s (fun {context; _} x -> f context x)
@@ -75,7 +77,7 @@ let register2_fullctxt ~chunked s f =
       !rpc_services
       s
       (fun ((ctxt, arg1), arg2) q i ->
-        rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i)
+        rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i)
 
 let register2 ~chunked s f =
   register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i ->
@@ -84,7 +86,7 @@ let register2 ~chunked s f =
 let opt_register0_fullctxt ~chunked s f =
   rpc_services :=
     RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i ->
-        rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i)
+        rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i)
 
 let opt_register0 ~chunked s f =
   opt_register0_fullctxt ~chunked s (fun {context; _} -> f context)
@@ -92,7 +94,7 @@ let opt_register0 ~chunked s f =
 let opt_register1_fullctxt ~chunked s f =
   rpc_services :=
     RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i ->
-        rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i)
+        rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i)
 
 let opt_register1 ~chunked s f =
   opt_register1_fullctxt ~chunked s (fun {context; _} x -> f context x)
@@ -104,7 +106,7 @@ let opt_register2_fullctxt ~chunked s f =
       !rpc_services
       s
       (fun ((ctxt, arg1), arg2) q i ->
-        rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i)
+        rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i)
 
 let opt_register2 ~chunked s f =
   opt_register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i ->
@@ -114,7 +116,7 @@ let get_rpc_services () =
   let p =
     RPC_directory.map
       (fun c ->
-        rpc_init c `Head_level >|= function
+        rpc_init c Head_level >|= function
         | Error t ->
             raise (Failure (Format.asprintf "%a" Error_monad.pp_trace t))
         | Ok c -> c.context)
diff --git a/src/proto_alpha/lib_protocol/services_registration.mli b/src/proto_alpha/lib_protocol/services_registration.mli
index c6bc2ed72c92..da7faca5500a 100644
--- a/src/proto_alpha/lib_protocol/services_registration.mli
+++ b/src/proto_alpha/lib_protocol/services_registration.mli
@@ -44,6 +44,8 @@ type rpc_context = {
   context : t;
 }
 
+type level = Head_level | Successor_level
+
 (** [rpc_init rpc_context mode] allows to instantiate an [rpc_context]
    using the [Alpha_context] representation from a raw context
    representation (the one the shell knows).
@@ -60,9 +62,7 @@ type rpc_context = {
    paths depend on the level. Using the successor level allows to
    ensure that the simulation is done on a fresh level. *)
 val rpc_init :
-  Updater.rpc_context ->
-  [`Head_level | `Successor_level] ->
-  rpc_context Error_monad.tzresult Lwt.t
+  Updater.rpc_context -> level -> rpc_context Error_monad.tzresult Lwt.t
 
 val register0 :
   chunked:bool ->
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 3068cb6a6fc1..4a1f6b77c6db 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1466,7 +1466,11 @@ module Tx_rollup = struct
       | [i] -> Int32.of_string_opt i
   end
 
-  module Consumed_withdraw =
+  module Consumed_withdraw :
+    Non_iterable_indexed_carbonated_data_storage
+      with type t := (Raw_context.t * Tx_rollup_level_repr.t) * Tx_rollup_repr.t
+       and type key = int32
+       and type value = Tx_rollup_withdraw_repr.Withdrawal_accounting.t =
     Make_indexed_carbonated_data_storage
       (Make_subcontext (Registered) (Level_tx_rollup_context.Raw_context)
          (struct
diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
index a508530f3078..df7d4e4fdb58 100644
--- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
+++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
@@ -191,15 +191,15 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location
                                      (Script {arg_type; entrypoints; _}),
                                    ctxt ) ->
       (* Find the entrypoint type for the given entrypoint. *)
-      Gas_monad.run
-        ctxt
-        (Script_ir_translator.find_entrypoint
-           ~error_details:Informative
-           arg_type
-           entrypoints
-           entrypoint)
+      (Gas_monad.run
+         ctxt
+         (Script_ir_translator.find_entrypoint
+            ~error_details:Informative
+            arg_type
+            entrypoints
+            entrypoint) [@coq_type_annotation])
       >>?= fun (res, ctxt) ->
-      res >>?= fun (Ex_ty_cstr {ty = entry_arg_ty; _}) ->
+      res >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entry_arg_ty; _}) ->
       Ticket_scanner.type_has_tickets ctxt entry_arg_ty
       >>?= fun (has_tickets, ctxt) ->
       (* Check that the parameter's type matches that of the entry-point, and
diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml
index e9584d1b286f..ccb047487c62 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.ml
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml
@@ -517,6 +517,7 @@ type 'a has_tickets =
   | Has_tickets :
       'a Ticket_inspection.has_tickets * ('a, _) Script_typed_ir.ty
       -> 'a has_tickets
+[@@coq_force_gadt]
 
 let type_has_tickets ctxt ty =
   Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) ->
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli
index 2d83b6b14342..ba5b5381136e 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli
+++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli
@@ -38,6 +38,7 @@ end
     tree root of the L2 context after any message (ie. deposit or batch),
     and [withdraw_hash] is a [Tx_rollup_withdraw_repr.withdrawals_merkle_root] *)
 module Message_result_hash : S.HASH
+[@@coq_plain_module]
 
 type message_result = {
   context_hash : Context_hash.t;
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
index 22ff30901063..71aa2cb02bb2 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
@@ -692,7 +692,8 @@ module Make (Context : CONTEXT) = struct
         failed because of a [Counter_mismatch] the counters are left
         untouched.
     *)
-    let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters ctxt status transaction =
+    let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters
+        ctxt status transaction =
       match status with
       | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt
       | Transaction_failure _ | Transaction_success ->
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_withdraw_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_withdraw_repr.ml
index 9b95cd4db412..65c2dc765d71 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_withdraw_repr.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_withdraw_repr.ml
@@ -189,7 +189,7 @@ module Withdrawal_accounting = struct
       elements ([0L]) until it reaches [ofs/64] elements.
 
       Fails if [ofs] is negative. *)
-  let rec set (bitv : t) (ofs : int) =
+  let[@coq_struct "ofs"] rec set (bitv : t) (ofs : int) =
     error_when_negative ofs >>? fun () ->
     if Compare.Int.(ofs < 64) then
       match bitv with
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_withdraw_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_withdraw_storage.ml
index 0301603e3e8e..405aef40354c 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_withdraw_storage.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_withdraw_storage.ml
@@ -87,7 +87,8 @@ let remove :
     inbox_length:int32 ->
     (Raw_context.t * Tx_rollup_state_repr.t) tzresult Lwt.t =
  fun ctxt state rollup level ~inbox_length ->
-  let rec remove_withdrawal_accounting ctxt state i len ~acc_freed_size =
+  let[@coq_struct "i_value"] rec remove_withdrawal_accounting ctxt state i len
+      ~acc_freed_size =
     if Compare.Int32.(i < len) then
       Storage.Tx_rollup.Consumed_withdraw.remove ((ctxt, level), rollup) i
       >>=? fun (ctxt, freed_size, _) ->
-- 
GitLab


From 8f2313c08f1426d70187a1fe4726257b9cc7c55d Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 22 Mar 2022 13:10:53 +0100
Subject: [PATCH 65/69] Proto: more changes for coq-of-ocaml

---
 .../lib_protocol/alpha_context.mli            |  2 +-
 src/proto_alpha/lib_protocol/apply.ml         |  2 +-
 .../lib_protocol/script_interpreter.ml        | 30 ++++++++++++++-----
 3 files changed, 25 insertions(+), 9 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 4a1b537fa061..1156508b7687 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -1556,7 +1556,7 @@ module Tx_rollup_commitment_hash : sig
   include S.HASH
 end
 
-module Tx_rollup_message_result_hash : S.HASH
+module Tx_rollup_message_result_hash : S.HASH [@@coq_plain_module]
 
 (** This module re-exports definitions from {!Tx_rollup_state_repr}
     and {!Tx_rollup_state_storage}. *)
diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 0146e8233da1..4b672d7e177f 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -1226,7 +1226,7 @@ let apply_internal_manager_operation_content :
   | Delegation delegate ->
       apply_delegation ~ctxt ~source ~delegate ~before_operation
 
-let apply_external_manager_operation_content :
+let[@coq_axiom_with_reason "unresolved implicit type"] apply_external_manager_operation_content :
     type kind.
     context ->
     Script_ir_translator.unparsing_mode ->
diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index d7c67800ffee..929385e5a2c3 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -238,9 +238,8 @@ let ifailwith : ifailwith_type =
   {
     ifailwith =
       (fun logger (ctxt, _) gas kloc tv accu ->
-        let v = accu in
         let ctxt = update_context gas ctxt in
-        trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
+        trace Cannot_serialize_failure (unparse_data ctxt Optimized tv accu)
         >>=? fun (v, _ctxt) ->
         let v = Micheline.strip_locations v in
         get_log logger >>=? fun log -> fail (Reject (kloc, v, log)));
@@ -719,7 +718,11 @@ and[@coq_struct "function_parameter"] step :
       (* Big map operations *)
       | (IEmpty_big_map (_, tk, tv, k), _, _) ->
           let ebm =
-            (Script_ir_translator.empty_big_map [@coq_type_annotation]) tk tv
+            (Script_ir_translator.empty_big_map
+            [@coq_implicit "a" "__IEmpty_big_map_'b"]
+            [@coq_implicit "b" "__IEmpty_big_map_'c"])
+              tk
+              tv
           in
           (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack)
       | (IBig_map_mem (_, k), _, (stack : _ * _)) ->
@@ -735,7 +738,13 @@ and[@coq_struct "function_parameter"] step :
           ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->
             Script_ir_translator.big_map_get ctxt key map )
           >>=? fun (res, ctxt, gas) ->
-          (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack
+          (step [@ocaml.tailcall])
+            (ctxt, sc)
+            gas
+            k
+            ks
+            (res [@coq_type_annotation])
+            stack
       | (IBig_map_update (_, k), _, (stack : _ * (_ * _))) ->
           let key = accu in
           let (maybe_value, (map, stack)) = stack in
@@ -1461,7 +1470,14 @@ and[@coq_struct "function_parameter"] step :
                     (Script_int.of_int64 balance, state) )
               in
               (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack
-          | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)
+          | None ->
+              (step [@ocaml.tailcall])
+                (ctxt, sc)
+                gas
+                k
+                ks
+                (None [@coq_type_annotation])
+                stack)
       | ( ISapling_verify_update_deprecated (_, k),
           (accu : Sapling_repr.legacy_transaction),
           (stack : _ * _) ) -> (
@@ -2010,8 +2026,8 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal
     ctxt
     (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint)
   >>?= fun (r, ctxt) ->
-  record_trace (Bad_contract_parameter step_constants.self) r
-  >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _})
+  record_trace (Bad_contract_parameter step_constants.self) (r [@coq_type_annotation])
+  >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _})
     ->
   trace
     (Bad_contract_parameter step_constants.self)
-- 
GitLab


From 6e215514f699cb4725592f973820629d0083ebfc Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 25 Mar 2022 00:51:11 +0100
Subject: [PATCH 66/69] Proto: add missing operation_repr definition for Coq

---
 src/proto_alpha/lib_protocol/operation_repr.ml | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index 4f5c3982831b..5a01d3fb3c8f 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -778,7 +778,7 @@ module Encoding = struct
                 });
         }
 
-    let[@coq_axiom_with_reason "gadt"] tx_rollup_withdraw_case =
+    let tx_rollup_withdraw_case =
       MCase
         {
           tag = tx_rollup_operation_withdraw_tag;
@@ -808,7 +808,7 @@ module Encoding = struct
             (function
             | Manager (Tx_rollup_withdraw _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Tx_rollup_withdraw
                 {
                   tx_rollup;
@@ -905,7 +905,7 @@ module Encoding = struct
               Sc_rollup_add_messages {rollup; messages});
         }
 
-    let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case =
+    let sc_rollup_cement_case =
       MCase
         {
           tag = sc_rollup_operation_cement_tag;
@@ -918,7 +918,7 @@ module Encoding = struct
             (function
             | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Sc_rollup_cement {rollup; commitment} -> (rollup, commitment));
           inj =
             (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment});
-- 
GitLab


From b8a85ed1dc9cf37eae6110482def8e82a1414c05 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Mon, 28 Mar 2022 01:50:13 +0200
Subject: [PATCH 67/69] Proto: more changes for coq-of-ocaml

---
 src/proto_alpha/bin_sc_rollup_node/store.ml   |   2 +
 .../lib_protocol/alpha_context.mli            |   6 +-
 src/proto_alpha/lib_protocol/apply_results.ml |   4 +-
 .../lib_protocol/dependent_bool.ml            |   4 +-
 .../lib_protocol/dependent_bool.mli           |   2 +-
 src/proto_alpha/lib_protocol/indexable.ml     |   2 +-
 src/proto_alpha/lib_protocol/merkle_list.ml   |  14 ++-
 src/proto_alpha/lib_protocol/merkle_list.mli  |   7 +-
 .../lib_protocol/operation_repr.ml            |   4 +-
 .../lib_protocol/sc_rollup_arith.ml           |  32 ++++--
 .../lib_protocol/sc_rollup_inbox_repr.ml      |  22 +++-
 .../lib_protocol/sc_rollup_inbox_repr.mli     |   2 +
 .../lib_protocol/sc_rollup_repr.mli           |   2 +-
 .../lib_protocol/sc_rollup_storage.ml         |   4 +-
 .../lib_protocol/sc_rollup_tick_repr.ml       |  26 +++--
 .../lib_protocol/script_interpreter.ml        |   2 +-
 .../lib_protocol/script_ir_translator.ml      |  26 +++--
 .../lib_protocol/script_typed_ir.ml           |   9 +-
 .../lib_protocol/script_typed_ir.mli          |   4 +-
 .../lib_protocol/script_typed_ir_size.ml      |   2 +-
 .../lib_protocol/skip_list_repr.ml            |  18 +--
 .../lib_protocol/skip_list_repr.mli           |   6 +-
 src/proto_alpha/lib_protocol/storage.ml       |   2 +-
 .../lib_protocol/ticket_operations_diff.ml    |   5 +-
 .../lib_protocol/ticket_scanner.ml            |   4 +-
 .../lib_protocol/tx_rollup_l2_apply.ml        | 106 ++++++++++++++++++
 .../lib_protocol/tx_rollup_l2_apply.mli       |   9 +-
 .../lib_protocol/tx_rollup_l2_context.ml      |   3 +-
 .../lib_protocol/tx_rollup_l2_context_sig.ml  |  67 ++++++-----
 .../lib_protocol/tx_rollup_parameters.ml      |   6 +-
 .../lib_protocol/tx_rollup_state_repr.ml      |   2 +-
 31 files changed, 289 insertions(+), 115 deletions(-)

diff --git a/src/proto_alpha/bin_sc_rollup_node/store.ml b/src/proto_alpha/bin_sc_rollup_node/store.ml
index a528546ee8c3..18874ade3adc 100644
--- a/src/proto_alpha/bin_sc_rollup_node/store.ml
+++ b/src/proto_alpha/bin_sc_rollup_node/store.ml
@@ -128,6 +128,8 @@ module IStoreTree = struct
   type key = path
 
   type value = bytes
+
+  let __infer_t _ = ()
 end
 
 module Inbox = Sc_rollup.Inbox.MakeHashingScheme (IStoreTree)
diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 1156508b7687..8a3b1b9ca230 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -2426,9 +2426,9 @@ module Sc_rollup : sig
   module Staker :
     S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t
 
-  module Commitment_hash : S.HASH
+  module Commitment_hash : S.HASH [@@coq_plain_module]
 
-  module State_hash : S.HASH
+  module State_hash : S.HASH [@@coq_plain_module]
 
   module Number_of_messages : Bounded.Int32.S
 
@@ -2536,6 +2536,8 @@ module Sc_rollup : sig
       val is_empty : tree -> bool
 
       val hash : tree -> Context_hash.t
+
+      val __infer_t : t -> unit
     end
 
     module MakeHashingScheme (Tree : TREE) :
diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index e34c7644d130..80115e5c9055 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -918,7 +918,7 @@ module Manager_result = struct
         | Successful_manager_result (Sc_rollup_publish_result _ as op) ->
             Some op
         | _ -> None)
-      ~proj:(function
+      ~proj:(function[@coq_match_with_default]
         | Sc_rollup_publish_result {consumed_gas; staked_hash} ->
             (Gas.Arith.ceil consumed_gas, consumed_gas, staked_hash))
       ~kind:Kind.Sc_rollup_publish_manager_kind
@@ -1738,7 +1738,7 @@ module Encoding = struct
             Some (op, res)
         | _ -> None)
 
-  let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case =
+  let sc_rollup_publish_case =
     make_manager_case
       Operation.Encoding.sc_rollup_publish_case
       Manager_result.sc_rollup_publish_case
diff --git a/src/proto_alpha/lib_protocol/dependent_bool.ml b/src/proto_alpha/lib_protocol/dependent_bool.ml
index 8fb3c49ec11a..5ae4a13404e1 100644
--- a/src/proto_alpha/lib_protocol/dependent_bool.ml
+++ b/src/proto_alpha/lib_protocol/dependent_bool.ml
@@ -36,7 +36,7 @@ type ('a, 'b, 'r) dand =
   | YesYes : (yes, yes, yes) dand
 
 type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand
-[@@unboxed]
+[@@unboxed] [@@coq_force_gadt]
 
 let dand : type a b. a dbool -> b dbool -> (a, b) ex_dand =
  fun a b ->
@@ -57,7 +57,7 @@ type (_, _) eq = Eq : ('a, 'a) eq
 let merge_dand :
     type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq =
  fun w1 w2 ->
-  match (w1, w2) with
+  match[@coq_match_with_default] (w1, w2) with
   | (NoNo, NoNo) -> Eq
   | (NoYes, NoYes) -> Eq
   | (YesNo, YesNo) -> Eq
diff --git a/src/proto_alpha/lib_protocol/dependent_bool.mli b/src/proto_alpha/lib_protocol/dependent_bool.mli
index 54416d9fd9c3..a5265a36a14f 100644
--- a/src/proto_alpha/lib_protocol/dependent_bool.mli
+++ b/src/proto_alpha/lib_protocol/dependent_bool.mli
@@ -46,7 +46,7 @@ type ('a, 'b, 'r) dand =
   | YesYes : (yes, yes, yes) dand
 
 type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand
-[@@unboxed]
+[@@unboxed] [@@coq_force_gadt]
 
 (** Logical conjunction of dependent booleans. *)
 val dand : 'a dbool -> 'b dbool -> ('a, 'b) ex_dand
diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml
index 4365483c7f73..9a103016a0f5 100644
--- a/src/proto_alpha/lib_protocol/indexable.ml
+++ b/src/proto_alpha/lib_protocol/indexable.ml
@@ -238,7 +238,7 @@ module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct
 
   let compare_values : value -> value -> int = compare_values V.compare
 
-  let compare_indexes = compare_indexes
+  let compare_indexes : index -> index -> int = compare_indexes
 
   let compare : 'state t -> 'state' t -> int = fun x y -> compare V.compare x y
 end
diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml
index c373f3e6c142..682b318ceef7 100644
--- a/src/proto_alpha/lib_protocol/merkle_list.ml
+++ b/src/proto_alpha/lib_protocol/merkle_list.ml
@@ -80,12 +80,14 @@ module type T = sig
   end
 end
 
-module Make (El : sig
+module type S_El = sig
   type t
 
   val to_bytes : t -> bytes
-end)
-(H : S.HASH) : T with type elt = El.t and type h = H.t = struct
+end
+
+module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t =
+struct
   type h = H.t
 
   type elt = El.t
@@ -154,7 +156,7 @@ end)
      Pre-condition: pos >= 0 /| pos <  2^depth
      Post-condition: len(to_bin pos depth) = depth *)
   let to_bin ~pos ~depth =
-    let rec aux acc pos depth =
+    let[@coq_struct "depth"] rec aux acc pos depth =
       let (pos', dir) = (pos / 2, pos mod 2) in
       match depth with
       | 0 -> acc
@@ -165,14 +167,14 @@ end)
   (* Constructs a tree of a given depth in which every right subtree is empty
    * and the only leaf contains the hash of el. *)
   let make_spine_with el =
-    let rec aux left = function
+    let[@coq_struct "function_parameter"] rec aux left = function
       | 0 -> left
       | d -> (aux [@tailcall]) (node_of left Empty) (d - 1)
     in
     aux (leaf_of el)
 
   let snoc t (el : elt) =
-    let rec traverse tree depth key =
+    let[@coq_struct "depth"] rec traverse tree depth key =
       match (tree, key) with
       | (Node (_, t_left, Empty), true :: _key) ->
           (* The base case where the left subtree is full and we start
diff --git a/src/proto_alpha/lib_protocol/merkle_list.mli b/src/proto_alpha/lib_protocol/merkle_list.mli
index b51933f4161c..273adf2c7a1c 100644
--- a/src/proto_alpha/lib_protocol/merkle_list.mli
+++ b/src/proto_alpha/lib_protocol/merkle_list.mli
@@ -99,9 +99,10 @@ module type T = sig
   end
 end
 
-module Make (El : sig
+module type S_El = sig
   type t
 
   val to_bytes : t -> bytes
-end)
-(H : S.HASH) : T with type elt = El.t and type h = H.t
+end
+
+module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index 5a01d3fb3c8f..c7a5d62ae575 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -924,7 +924,7 @@ module Encoding = struct
             (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment});
         }
 
-    let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case =
+    let sc_rollup_publish_case =
       MCase
         {
           tag = sc_rollup_operation_publish_tag;
@@ -937,7 +937,7 @@ module Encoding = struct
             (function
             | Manager (Sc_rollup_publish _ as op) -> Some op | _ -> None);
           proj =
-            (function
+            (function[@coq_match_with_default]
             | Sc_rollup_publish {rollup; commitment} -> (rollup, commitment));
           inj =
             (fun (rollup, commitment) -> Sc_rollup_publish {rollup; commitment});
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml
index 67d40d068be5..2f4105f5b2df 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml
@@ -233,7 +233,7 @@ module Make (Context : P) :
     open Monad
     open Monad.Syntax
 
-    module MakeVar (P : sig
+    module type P_MakeVar = sig
       type t
 
       val name : string
@@ -243,8 +243,21 @@ module Make (Context : P) :
       val pp : Format.formatter -> t -> unit
 
       val encoding : t Data_encoding.t
-    end) =
-    struct
+    end
+
+    module type S_MakeVar = sig
+      type t
+
+      val create : unit Monad.t
+
+      val get : t Monad.t
+
+      val set : t -> unit Monad.t
+
+      val pp : (Format.formatter -> unit -> unit) Monad.t
+    end
+
+    module MakeVar (P : P_MakeVar) : S_MakeVar with type t := P.t = struct
       let key = [P.name]
 
       let create = set_value key P.encoding P.initial
@@ -265,14 +278,15 @@ module Make (Context : P) :
         return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v
     end
 
-    module MakeDeque (P : sig
+    module type P_MakeDeque = sig
       type t
 
       val name : string
 
       val encoding : t Data_encoding.t
-    end) =
-    struct
+    end
+
+    module MakeDeque (P : P_MakeDeque) = struct
       (*
 
          A stateful deque.
@@ -343,11 +357,13 @@ module Make (Context : P) :
       let clear = remove [P.name]
     end
 
-    module CurrentTick = MakeVar (struct
+    module Tick_with_name = struct
       include Tick
 
       let name = "tick"
-    end)
+    end
+
+    module CurrentTick = MakeVar (Tick_with_name)
 
     module Stack = MakeDeque (struct
       type t = int
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml
index be457b5de8bb..abb6421913aa 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml
@@ -330,11 +330,13 @@ module type TREE = sig
   val is_empty : tree -> bool
 
   val hash : tree -> Context_hash.t
+
+  val __infer_t : t -> unit
 end
 
-module MakeHashingScheme (Tree : TREE) :
-  MerkelizedOperations with type tree = Tree.tree = struct
-  module Tree = Tree
+module MakeHashingScheme (P : TREE) :
+  MerkelizedOperations with type tree = P.tree = struct
+  module Tree = P
 
   type tree = Tree.tree
 
@@ -474,7 +476,7 @@ module MakeHashingScheme (Tree : TREE) :
       in
       (history, inbox)
     in
-    let rec aux (history, inbox) =
+    let[@coq_struct "function_parameter"] rec aux (history, inbox) =
       if Raw_level_repr.(inbox.level = target_level) then (history, inbox)
       else aux (archive_level history inbox)
     in
@@ -552,7 +554,15 @@ end
 
 include (
   MakeHashingScheme (struct
-    include Context.Tree
+    let find = Context.Tree.find
+
+    let find_tree = Context.Tree.find_tree
+
+    let add = Context.Tree.add
+
+    let is_empty = Context.Tree.is_empty
+
+    let hash = Context.Tree.hash
 
     type t = Context.t
 
@@ -561,5 +571,7 @@ include (
     type value = bytes
 
     type key = string list
+
+    let __infer_t (_ : t) = ()
   end) :
     MerkelizedOperations with type tree = Context.tree)
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli
index 705a988ea575..f22d62a822fd 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli
+++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli
@@ -271,6 +271,8 @@ module type TREE = sig
   val is_empty : tree -> bool
 
   val hash : tree -> Context_hash.t
+
+  val __infer_t : t -> unit
 end
 
 (**
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
index decea0652e93..4e7c87c53fe7 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
+++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli
@@ -58,7 +58,7 @@ end
 
 module Commitment_hash : S.HASH [@@coq_plain_module]
 
-module State_hash : S.HASH
+module State_hash : S.HASH [@@coq_plain_module]
 
 (** Number of messages consumed by a single commitment. This represents a claim
     about the shape of the Inbox, which can be disputed as part of a commitment
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
index 1a6cd89848bb..b79466da00fd 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml
@@ -638,7 +638,7 @@ type conflict_point =
     arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *)
 let goto_inbox_level ctxt rollup inbox_level commit =
   let open Lwt_tzresult_syntax in
-  let rec go ctxt commit =
+  let[@coq_struct "commit"] rec go ctxt commit =
     let* (info, ctxt) = get_commitment_internal ctxt rollup commit in
     if
       Raw_level_repr.(info.Sc_rollup_repr.Commitment.inbox_level <= inbox_level)
@@ -689,7 +689,7 @@ let get_conflict_point ctxt rollup staker1 staker2 =
   (* The inbox level of a commitment increases by a fixed amount over the preceding commitment.
      We use this fact in the following to efficiently traverse both commitment histories towards
      the conflict points. *)
-  let rec traverse_in_parallel ctxt commit1 commit2 =
+  let[@coq_struct "commit1"] rec traverse_in_parallel ctxt commit1 commit2 =
     if Sc_rollup_repr.Commitment_hash.(commit1 = commit2) then
       (* This case will most dominantly happen when either commit is part of the other's history.
          It occurs when the commit that is farther ahead gets dereferenced to its predecessor often
diff --git a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml
index e16ac07c9134..293bef4d2da8 100644
--- a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml
+++ b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml
@@ -24,13 +24,13 @@
 (*                                                                           *)
 (*****************************************************************************)
 
-include Z
+type t = Z.t
 
-let initial = zero
+let initial = Z.zero
 
-let next = succ
+let next = Z.succ
 
-let pp = pp_print
+let pp = Z.pp_print
 
 let encoding = Data_encoding.n
 
@@ -40,16 +40,24 @@ let of_int x = if Compare.Int.(x < 0) then None else Some (Z.of_int x)
 
 let to_int x = if Z.fits_int x then Some (Z.to_int x) else None
 
-let ( <= ) = leq
+let ( <= ) = Z.leq
 
-let ( < ) = lt
+let ( < ) = Z.lt
 
-let ( >= ) = geq
+let ( >= ) = Z.geq
 
-let ( > ) = gt
+let ( > ) = Z.gt
 
-let ( = ) = equal
+let ( = ) = Z.equal
 
 let ( <> ) x y = not (x = y)
 
+let compare = Z.compare
+
+let equal = Z.equal
+
+let min = Z.min
+
+let max = Z.max
+
 module Map = Map.Make (Z)
diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index 929385e5a2c3..e36d39c61d5d 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -1988,7 +1988,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty)
       >>?= fun (res, ctxt) ->
       res >>?= fun Eq ->
       let parsed_arg : a = parsed_arg in
-      return (parsed_arg, ctxt))
+      return ((parsed_arg [@coq_cast]), ctxt))
   >>=? fun (entrypoint_arg, ctxt) -> return (construct entrypoint_arg, ctxt)
 
 type execution_result = {
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index b0c13bc5cf0f..02996c37d004 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -162,7 +162,8 @@ let check_kind kinds expr =
    the end of the file. *)
 
 let rec ty_of_comparable_ty :
-    type a. a comparable_ty -> (a, Dependent_bool.yes) ty = function
+    type a. a comparable_ty -> (a, Dependent_bool.yes) ty =
+  function[@coq_match_with_default]
   | Unit_t -> Unit_t
   | Never_t -> Never_t
   | Int_t -> Int_t
@@ -186,7 +187,7 @@ let rec ty_of_comparable_ty :
 
 let rec unparse_comparable_ty_uncarbonated :
     type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node =
- fun ~loc -> function
+ fun ~loc -> function[@coq_match_with_default]
   | Unit_t -> Prim (loc, T_unit, [], [])
   | Never_t -> Prim (loc, T_never, [], [])
   | Int_t -> Prim (loc, T_int, [], [])
@@ -677,7 +678,8 @@ let hash_comparable_data ctxt ty data =
    All comparable types are dupable, this function exists only to not forget
    checking this property when adding new types.
 *)
-let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function
+let check_dupable_comparable_ty : type a. a comparable_ty -> unit =
+  function[@coq_match_with_default]
   | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t
   | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t
   | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ ->
@@ -794,7 +796,7 @@ let rec comparable_ty_eq :
                     (ty_of_comparable_ty ta)
                     (ty_of_comparable_ty tb))
     in
-    match (ta, tb) with
+    match[@coq_match_with_default] (ta, tb) with
     | (Unit_t, Unit_t) -> return (Eq : (ta comparable_ty, tb comparable_ty) eq)
     | (Unit_t, _) -> not_equal ()
     | (Never_t, Never_t) -> return Eq
@@ -1974,7 +1976,7 @@ let find_entrypoint (type full fullc error_trace)
         return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr})
     | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _})
       -> (
-        Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function
+        Gas_monad.bind_recover (find_entrypoint tl left entrypoint [@coq_type_annotation]) @@ (function [@coq_match_gadt]
         | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) ->
             return
               (Ex_ty_cstr
@@ -1984,11 +1986,11 @@ let find_entrypoint (type full fullc error_trace)
                    original_type_expr;
                  })
         | Error () ->
-            let+ (Ex_ty_cstr {ty; construct; original_type_expr}) =
-              find_entrypoint tr right entrypoint
-            in
-            Ex_ty_cstr
-              {ty; construct = (fun e -> R (construct e)); original_type_expr})
+          let+ x = (find_entrypoint tr right entrypoint [@coq_type_annotation]) in
+          match x with 
+          | Ex_ty_cstr {ty; construct; original_type_expr} ->
+            Ex_ty_cstr {ty; construct = (fun e -> R ((construct [@coq_type-annotation]) e)); original_type_expr})
+        [@coq_cast])
     | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ())
   in
   let {root; original_type_expr} = entrypoints in
@@ -2478,7 +2480,9 @@ let[@coq_struct "ty"] rec parse_comparable_data :
   >>?=
   fun ctxt ->
   let legacy = false in
-  match[@coq_match_gadt_with_result] (ty, script_data) with
+  match[@coq_match_gadt_with_result] [@coq_match_with_default]
+    (ty, script_data)
+  with
   | (Unit_t, expr) ->
       Lwt.return @@ traced_no_lwt
       @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult)
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml
index 21aa52c3245b..b6fad0aec4e9 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml
@@ -467,6 +467,7 @@ type ('arg, 'storage) script =
              field as it has a dynamic size. *)
     }
       -> ('arg, 'storage) script
+[@@coq_force_gadt]
 
 (* ---- Instructions --------------------------------------------------------*)
 and ('before_top, 'before, 'result_top, 'result) kinstr =
@@ -1805,7 +1806,8 @@ let ty_metadata : type a ac. (a, ac) ty -> a ty_metadata = function
   | Bls12_381_fr_t | Chest_t | Chest_key_t ->
       meta_basic
 
-let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata = function
+let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata =
+  function[@coq_match_with_default]
   | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t
   | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t
   | Tx_rollup_l2_address_t ->
@@ -1854,7 +1856,8 @@ let is_comparable : type v c. (v, c) ty -> c dbool = function
   | Chest_t -> No
   | Chest_key_t -> No
 
-type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed]
+type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c
+[@@ocaml.unboxed] [@@coq_force_gadt]
 
 let unit_t = Unit_t
 
@@ -2254,7 +2257,7 @@ module Ty_traverse = struct
       (continue [@ocaml.tailcall]) accu
     in
     let return () = (continue [@ocaml.tailcall]) accu in
-    match ty with
+    match[@coq_match_with_default] ty with
     | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t
     | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t
     | Bool_t | Chain_id_t | Never_t ->
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli
index cef6f6b90a17..429d6fe12d8d 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir.mli
+++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli
@@ -324,6 +324,7 @@ type ('arg, 'storage) script =
       code_size : Cache_memory_helpers.sint;
     }
       -> ('arg, 'storage) script
+[@@coq_force_gadt]
 
 (* ---- Instructions --------------------------------------------------------*)
 
@@ -1559,7 +1560,8 @@ val comparable_ty_size : 'a comparable_ty -> 'a Type_size.t
 
 val is_comparable : ('v, 'c) ty -> 'c dbool
 
-type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed]
+type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c
+[@@ocaml.unboxed] [@@coq_force_gadt]
 
 val unit_key : unit comparable_ty
 
diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
index abf95fb1ac3c..b93b94c0e634 100644
--- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
+++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml
@@ -45,7 +45,7 @@ module Ty_size = struct
   let apply_comparable :
       type a. nodes_and_size -> a comparable_ty -> nodes_and_size =
    fun accu cty ->
-    match cty with
+    match[@coq_match_with_default] cty with
     | Unit_t -> ret_succ_adding accu base_basic
     | Int_t -> ret_succ_adding accu base_basic
     | Nat_t -> ret_succ_adding accu base_basic
diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml
index 3a5a221d34fc..6e1a9efce38d 100644
--- a/src/proto_alpha/lib_protocol/skip_list_repr.ml
+++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml
@@ -38,7 +38,7 @@ module type S = sig
     'content Data_encoding.t ->
     ('content, 'ptr) cell Data_encoding.t
 
-  val index : (_, _) cell -> int
+  val index : ('content, 'ptr) cell -> int
 
   val content : ('content, 'ptr) cell -> 'content
 
@@ -69,9 +69,11 @@ module type S = sig
     bool
 end
 
-module Make (Parameters : sig
+module type S_Parameters = sig
   val basis : int
-end) : S = struct
+end
+
+module Make (Parameters : S_Parameters) : S = struct
   let () = assert (Compare.Int.(Parameters.basis >= 2))
 
   open Parameters
@@ -170,7 +172,7 @@ end) : S = struct
   let next ~prev_cell ~prev_cell_ptr content =
     let index = prev_cell.index + 1 in
     let back_pointers =
-      let rec aux power accu i =
+      let[@coq_struct "power"] rec aux power accu i =
         if Compare.Int.(index < power) then List.rev accu
         else
           let back_pointer_i =
@@ -194,7 +196,7 @@ end) : S = struct
 
   let best_skip cell target_index =
     let index = cell.index in
-    let rec aux idx pow best_idx best_skip =
+    let[@coq_struct "idx"] rec aux idx pow best_idx best_skip =
       if Compare.Int.(idx >= FallbackArray.length cell.back_pointers) then
         best_idx
       else
@@ -209,7 +211,7 @@ end) : S = struct
     aux 0 1 None None
 
   let back_path ~deref ~cell_ptr ~target_index =
-    let rec aux path ptr =
+    let[@coq_struct "ptr"] rec aux path ptr =
       let path = ptr :: path in
       Option.bind (deref ptr) @@ fun cell ->
       let index = cell.index in
@@ -224,7 +226,7 @@ end) : S = struct
   let mem equal x l =
     let open FallbackArray in
     let n = length l in
-    let rec aux idx =
+    let[@coq_struct "idx"] rec aux idx =
       if Compare.Int.(idx >= n) then false
       else
         match FallbackArray.get l idx with
@@ -239,7 +241,7 @@ end) : S = struct
     assume_some (deref target_ptr) @@ fun target ->
     assume_some (deref cell_ptr) @@ fun cell ->
     let target_index = index target and cell_index = index cell in
-    let rec valid_path index cell_ptr path =
+    let[@coq_struct "path"] rec valid_path index cell_ptr path =
       match (cell_ptr, path) with
       | (final_cell, []) ->
           equal_ptr target_ptr final_cell && Compare.Int.(index = target_index)
diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.mli b/src/proto_alpha/lib_protocol/skip_list_repr.mli
index 843003e18a15..88c52825bd5e 100644
--- a/src/proto_alpha/lib_protocol/skip_list_repr.mli
+++ b/src/proto_alpha/lib_protocol/skip_list_repr.mli
@@ -112,6 +112,8 @@ module type S = sig
     bool
 end
 
-module Make (_ : sig
+module type S_Parameters = sig
   val basis : int
-end) : S
+end
+
+module Make (_ : S_Parameters) : S
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 4a1f6b77c6db..3765ccf73826 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -108,7 +108,7 @@ module Tenderbake = struct
       (Raw_level_repr)
 
   module First_level_of_protocol =
-    Make_single_data_storage (Registered) (Raw_context)
+    Make_single_data_storage (Registered) (Raw_context.M)
       (struct
         let name = ["first_level_of_protocol"]
       end)
diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
index df7d4e4fdb58..f3c64c590079 100644
--- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
+++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml
@@ -166,7 +166,8 @@ let cast_transaction_parameter (type a ac b bc) ctxt location
        entry_arg_ty
        parameters_ty)
   >>?= fun (res, ctxt) ->
-  res >>?= fun Script_ir_translator.Eq -> return ((parameters : a), ctxt)
+  res >>?= fun Script_ir_translator.Eq ->
+  return (((parameters [@coq_cast]) : a), ctxt)
 
 let tickets_of_transaction ctxt ~destination ~entrypoint ~location
     ~parameters_ty ~parameters =
@@ -215,7 +216,7 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location
         ~include_lazy:true
         ctxt
         has_tickets
-        parameters
+        (parameters [@coq_type_annotation])
       >>=? fun (tickets, ctxt) ->
       return (Some {destination = Contract destination; tickets}, ctxt)
 
diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml
index ccb047487c62..5c0ed9931a64 100644
--- a/src/proto_alpha/lib_protocol/ticket_scanner.ml
+++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml
@@ -108,7 +108,7 @@ module Ticket_inspection = struct
       a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret =
    fun key_ty k ->
     let open Script_typed_ir in
-    match key_ty with
+    match[@coq_match_with_default] key_ty with
     | Unit_t -> (k [@ocaml.tailcall]) False_ht
     | Never_t -> (k [@ocaml.tailcall]) False_ht
     | Int_t -> (k [@ocaml.tailcall]) False_ht
@@ -273,7 +273,7 @@ module Ticket_collection = struct
       ret tzresult Lwt.t =
    fun ctxt comp_ty acc k ->
     let open Script_typed_ir in
-    match comp_ty with
+    match[@coq_match_with_default] comp_ty with
     | Unit_t -> (k [@ocaml.tailcall]) ctxt acc
     | Never_t -> (k [@ocaml.tailcall]) ctxt acc
     | Int_t -> (k [@ocaml.tailcall]) ctxt acc
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
index 71aa2cb02bb2..16bba0262702 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml
@@ -317,6 +317,112 @@ type parameters = {
   tx_rollup_max_withdrawals_per_batch : int;
 }
 
+module type S = sig
+  type ctxt
+
+  type 'a m
+
+  (** The operations are versioned (see {!Tx_rollup_l2_batch}),
+      so their interpretations are. *)
+
+  module Batch_V1 : sig
+    open Tx_rollup_l2_batch.V1
+
+    (** [apply_batch ctxt parameters batch] interprets the batch
+        {!Tx_rollup_l2_batch.V1.t}.
+
+        By construction, a failing transaction will not affect the [ctxt]
+        and other transactions will still be interpreted.
+        That is, this function can only fail because of internals errors.
+        Otherwise, the errors that caused the transactions to fail can be
+        observed in the result (see {!Message_result.Batch_V1.t}).
+
+        The counters are incremented when the operation is part of a transaction
+        that is correctly signed and whose every operations have the expected
+        counter. In particular, the result of the application is not important
+        (i.e. the counters are updated even if the transaction failed).
+
+        In addition, the list of withdrawals resulting from each
+        layer2-to-layer1 transfer message in the batch is returned.
+    *)
+    val apply_batch :
+      ctxt ->
+      parameters ->
+      (Indexable.unknown, Indexable.unknown) t ->
+      (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.withdrawal list) m
+
+    (** [check_signature ctxt batch] asserts that [batch] is correctly signed.
+
+        We recall that [batch] may contain indexes, that is integers which
+        replace larger values. The [signer] field of the
+        {!Tx_rollup_l2_batch.operation} type is concerned. This field is either
+        the public key to be used to check the signature, or an index.
+        In case of the public key, [check_signature] will check whether or not
+        the related {!Tx_rollup_l2_address.t} has already an index assigned,
+        and allocate one if not.
+
+        Overall, [check_signature] returns the revised context, the list of
+        newly allocated indexes, and an updated version of the batches where
+        all [signer] field have been replaced by valid indexes.
+
+        {b Note:} What a user is expected to sign is the version of the
+        operation it sends to the network. This is potentially unsafe,
+        because it means the user signs indexes, not addresses nor
+        ticket hashes. This poses two threats: Tezos reorganization,
+        and malicious provider of indexes. A Tezos reorganization may
+        imply that an index allocated to one address in a given branch
+        is allocated to another address in another branch. We deal with
+        this issue by making the rollup node aware of the Tezos level at
+        each time an index is allocated. This allows to implement a RPC that
+        can safely tell a client to use either the full value or the index,
+        thanks to Tenderbake finality. To prevent the rollup node to lie,
+        we will make the rollup node provide Merkle proofs that allows the
+        client to verify that the index is correct.
+    *)
+    val check_signature :
+      ctxt ->
+      (Indexable.unknown, Indexable.unknown) t ->
+      (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m
+  end
+
+  (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2
+      address in [ctxt].
+
+      This function can fail if the [deposit.amount] is not strictly-positive.
+
+      If the [deposit] causes an error, then a withdrawal returning
+      the funds to the deposit's sender is returned.
+  *)
+  val apply_deposit :
+    ctxt ->
+    Tx_rollup_message.deposit ->
+    (ctxt
+    * Message_result.deposit_result
+    * Tx_rollup_withdraw.withdrawal option)
+    m
+
+  (** [apply_message ctxt parameters message] interprets the [message] in the
+      [ctxt].
+
+      That is,
+
+      {ul {li Deposit tickets if the message is a deposit. }
+          {li Decodes the batch and interprets it for the
+              correct batch version. }}
+
+      The function can fail with {!Invalid_batch_encoding} if it's not able
+      to decode the batch.
+
+      The function can also return errors from subsequent functions,
+      see {!apply_deposit} and batch interpretations for various versions.
+
+      The list of withdrawals in the message result followed the ordering
+      of the contents in the message.
+  *)
+  val apply_message :
+    ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m
+end
+
 module Make (Context : CONTEXT) = struct
   open Context
   open Syntax
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli
index 008df0a5b766..71eafe45008b 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli
@@ -122,10 +122,10 @@ type parameters = {
   tx_rollup_max_withdrawals_per_batch : int;
 }
 
-module Make (Context : CONTEXT) : sig
-  open Context
+module type S = sig
+  type ctxt
 
-  type ctxt = t
+  type 'a m
 
   (** The operations are versioned (see {!Tx_rollup_l2_batch}),
       so their interpretations are. *)
@@ -227,3 +227,6 @@ module Make (Context : CONTEXT) : sig
   val apply_message :
     ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m
 end
+
+module Make (Context : CONTEXT) :
+  S with type ctxt = Context.t and type 'a m := 'a Context.m
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
index 509799948802..67cfdb0ebead 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml
@@ -175,8 +175,7 @@ struct
 
   type 'a m = 'a S.m
 
-  module Syntax :
-    Tx_rollup_l2_context_sig.SYNTAX with type t := t and type 'a m := 'a m =
+  module Syntax : Tx_rollup_l2_context_sig.SYNTAX with type 'a m := 'a m =
   struct
     include S.Syntax
 
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
index 7eb3f4b7aa99..270247f0feaa 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml
@@ -162,8 +162,6 @@ type created_existed = Created | Existed
 (** The necessary monadic operators the storage monad is required to
     provide. *)
 module type SYNTAX = sig
-  type t
-
   type 'a m
 
   val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m
@@ -202,6 +200,39 @@ module type SYNTAX = sig
   val fail_when : bool -> error -> unit m
 end
 
+module type ADDRESS_METADATA = sig
+  type t
+
+  type 'a m
+
+  (** [get ctxt idx] returns the current metadata associated to the
+      address indexed by [idx]. *)
+  val get : t -> address_index -> metadata option m
+
+  (** [incr_counter ctxt idx] increments the counter of the
+      address indexed by [idx].
+
+      This function can fail with [Counter_overflow] iff the counter
+      has reached the [Int64.max_int] limit.
+
+      This function can fail with [Unknown_address_index] if [idx]
+      has not been associated with a layer-2 address already. *)
+  val incr_counter : t -> address_index -> t m
+
+  (** [init_with_public_key ctxt idx pk] initializes the metadata
+      associated to the address indexed by [idx].
+
+      This can fails with [Metadata_already_initialized] if this
+      function has already been called with [idx]. *)
+  val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m
+
+  (**/**)
+
+  module Internal_for_tests : sig
+    val set : t -> address_index -> metadata -> t m
+  end
+end
+
 (** This module type describes the API of the [Tx_rollup] context,
     which is used to implement the semantics of the L2 operations. *)
 module type CONTEXT = sig
@@ -222,7 +253,7 @@ module type CONTEXT = sig
       needs to be inside the monad [m]. *)
   type 'a m
 
-  module Syntax : SYNTAX with type t := t and type 'a m := 'a m
+  module Syntax : SYNTAX with type 'a m := 'a m
 
   (** [bls_aggregate_verify] allows to verify the aggregated signature
       of a batch. *)
@@ -230,34 +261,8 @@ module type CONTEXT = sig
     (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m
 
   (** The metadata associated to an address. *)
-  module Address_metadata : sig
-    (** [get ctxt idx] returns the current metadata associated to the
-        address indexed by [idx]. *)
-    val get : t -> address_index -> metadata option m
-
-    (** [incr_counter ctxt idx] increments the counter of the
-        address indexed by [idx].
-
-        This function can fail with [Counter_overflow] iff the counter
-        has reached the [Int64.max_int] limit.
-
-        This function can fail with [Unknown_address_index] if [idx]
-        has not been associated with a layer-2 address already. *)
-    val incr_counter : t -> address_index -> t m
-
-    (** [init_with_public_key ctxt idx pk] initializes the metadata
-        associated to the address indexed by [idx].
-
-        This can fails with [Metadata_already_initialized] if this
-        function has already been called with [idx]. *)
-    val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m
-
-    (**/**)
-
-    module Internal_for_tests : sig
-      val set : t -> address_index -> metadata -> t m
-    end
-  end
+  module Address_metadata :
+    ADDRESS_METADATA with type t := t and type 'a m := 'a m
 
   (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}.
 
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml
index 7c93e0a7f75e..5832a20262b3 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml
@@ -35,8 +35,10 @@ let get_deposit_parameters :
     (a, comparable) Script_typed_ir.ty -> a -> deposit_parameters tzresult =
  fun ty contents ->
   let open Script_typed_ir in
-  match (ty, contents) with
+  match[@coq_match_gadt] (ty, contents) with
   | ( Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _),
-      (ticket, l2_destination) ) ->
+      (contents :
+        _ Script_typed_ir.ticket * Script_typed_ir.tx_rollup_l2_address) ) ->
+      let (ticket, l2_destination) = contents in
       ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination}
   | _ -> error Alpha_context.Tx_rollup_errors.Wrong_deposit_parameters
diff --git a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml
index 3a7f40313915..2cade26cc00e 100644
--- a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml
+++ b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml
@@ -410,7 +410,7 @@ let update_burn_per_byte_helper :
      be the maximum amount. *)
   | Error _ -> {state with burn_per_byte = Tez_repr.max_mutez; inbox_ema}
 
-let rec update_burn_per_byte :
+let[@coq_struct "elapsed"] rec update_burn_per_byte :
     t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t =
  fun state ~elapsed ~factor ~final_size ~hard_limit ->
   (* factor is expected to be a low number ~ 100 *)
-- 
GitLab


From 2cb70c5af3cd6d3be714126ac8d8d8e7103624c6 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Tue, 5 Apr 2022 19:35:11 +0200
Subject: [PATCH 68/69] Proto: formatting

---
 .../lib_protocol/script_interpreter.ml        | 12 ++++++---
 .../lib_protocol/script_ir_translator.ml      | 25 ++++++++++++-------
 2 files changed, 25 insertions(+), 12 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml
index e36d39c61d5d..e0758b8a8719 100644
--- a/src/proto_alpha/lib_protocol/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/script_interpreter.ml
@@ -2026,9 +2026,15 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal
     ctxt
     (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint)
   >>?= fun (r, ctxt) ->
-  record_trace (Bad_contract_parameter step_constants.self) (r [@coq_type_annotation])
-  >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _})
-    ->
+  record_trace
+    (Bad_contract_parameter step_constants.self)
+    (r [@coq_type_annotation])
+  >>?= fun [@coq_match_gadt] (Ex_ty_cstr
+                               {
+                                 ty = entrypoint_ty;
+                                 construct;
+                                 original_type_expr = _;
+                               }) ->
   trace
     (Bad_contract_parameter step_constants.self)
     (lift_execution_arg ctxt ~internal entrypoint_ty construct arg)
diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 02996c37d004..7710366fe346 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -1431,10 +1431,8 @@ let[@coq_struct "node_value"] rec parse_ty_aux :
             let (Ex_ty tl) = parsed_l in
             let (Ex_ty tr) = parsed_r in
             union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt)
-
         (* | Parse_entrypoints ->
          *     let (Ex_parameter_ty_and_entrypoints_node *)
-
         | ( Parse_entrypoints,
             (parsed_l : ex_parameter_ty_and_entrypoints_node),
             (parsed_r : ex_parameter_ty_and_entrypoints_node) ) ->
@@ -1976,7 +1974,9 @@ let find_entrypoint (type full fullc error_trace)
         return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr})
     | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _})
       -> (
-        Gas_monad.bind_recover (find_entrypoint tl left entrypoint [@coq_type_annotation]) @@ (function [@coq_match_gadt]
+        Gas_monad.bind_recover
+          (find_entrypoint tl left entrypoint [@coq_type_annotation])
+        @@ function[@coq_match_gadt] [@coq_cast]
         | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) ->
             return
               (Ex_ty_cstr
@@ -1985,12 +1985,19 @@ let find_entrypoint (type full fullc error_trace)
                    construct = (fun e -> L (construct e));
                    original_type_expr;
                  })
-        | Error () ->
-          let+ x = (find_entrypoint tr right entrypoint [@coq_type_annotation]) in
-          match x with 
-          | Ex_ty_cstr {ty; construct; original_type_expr} ->
-            Ex_ty_cstr {ty; construct = (fun e -> R ((construct [@coq_type-annotation]) e)); original_type_expr})
-        [@coq_cast])
+        | Error () -> (
+            let+ x =
+              (find_entrypoint tr right entrypoint [@coq_type_annotation])
+            in
+            match x with
+            | Ex_ty_cstr {ty; construct; original_type_expr} ->
+                Ex_ty_cstr
+                  {
+                    ty;
+                    construct =
+                      (fun e -> R ((construct [@coq_type -annotation]) e));
+                    original_type_expr;
+                  }))
     | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ())
   in
   let {root; original_type_expr} = entrypoints in
-- 
GitLab


From 9327a92d954c744cd6d88a297c434bf9baccfbb8 Mon Sep 17 00:00:00 2001
From: Guillaume Claret <dev@clarus.me>
Date: Fri, 8 Apr 2022 12:13:16 +0200
Subject: [PATCH 69/69] Proto: add missing changes for coq-of-ocaml

---
 .../lib_protocol/script_ir_translator.ml      | 48 +++++++++----------
 1 file changed, 24 insertions(+), 24 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml
index 7710366fe346..48f07c103e64 100644
--- a/src/proto_alpha/lib_protocol/script_ir_translator.ml
+++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml
@@ -1972,32 +1972,32 @@ let find_entrypoint (type full fullc error_trace)
     | (_, {at_node = Some {name; original_type_expr}; _})
       when Entrypoint.(name = entrypoint) ->
         return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr})
-    | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _})
-      -> (
+    | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) ->
         Gas_monad.bind_recover
           (find_entrypoint tl left entrypoint [@coq_type_annotation])
-        @@ function[@coq_match_gadt] [@coq_cast]
-        | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) ->
-            return
-              (Ex_ty_cstr
-                 {
-                   ty;
-                   construct = (fun e -> L (construct e));
-                   original_type_expr;
-                 })
-        | Error () -> (
-            let+ x =
-              (find_entrypoint tr right entrypoint [@coq_type_annotation])
-            in
-            match x with
-            | Ex_ty_cstr {ty; construct; original_type_expr} ->
-                Ex_ty_cstr
-                  {
-                    ty;
-                    construct =
-                      (fun e -> R ((construct [@coq_type -annotation]) e));
-                    original_type_expr;
-                  }))
+          (function [@coq_match_gadt]
+            | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) ->
+                return
+                  (Ex_ty_cstr
+                     {
+                       ty;
+                       construct = (fun e -> L (construct e));
+                       original_type_expr;
+                     })
+            | Error () -> (
+                let+ x =
+                  (find_entrypoint tr right entrypoint [@coq_type_annotation])
+                in
+                match[@coq_match_gadt] x with
+                | Ex_ty_cstr {ty; construct; original_type_expr} ->
+                    Ex_ty_cstr
+                      {
+                        ty;
+                        construct =
+                          (fun e -> R ((construct [@coq_type_annotation]) e));
+                        original_type_expr;
+                      }))
+            [@coq_cast]
     | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ())
   in
   let {root; original_type_expr} = entrypoints in
-- 
GitLab