From fd28da98a044071362dfe4d915007903ff5f6c0e Mon Sep 17 00:00:00 2001
From: Lesenechal Remi <lesenechal.remi@gmail.com>
Date: Fri, 14 Feb 2020 12:07:45 +0100
Subject: [PATCH] comparable pairs in the backend

---
 src/passes/8-compiler/compiler_type.ml | 23 +++++++++++++++++++++--
 1 file changed, 21 insertions(+), 2 deletions(-)

diff --git a/src/passes/8-compiler/compiler_type.ml b/src/passes/8-compiler/compiler_type.ml
index 9e7d874b0..c4874ef38 100644
--- a/src/passes/8-compiler/compiler_type.ml
+++ b/src/passes/8-compiler/compiler_type.ml
@@ -20,6 +20,7 @@ module Ty = struct
   let address_k = Address_key None
   let timestamp_k = Timestamp_key None
   let bytes_k = Bytes_key None
+  let pair_k a b = Pair_key ((a,None),(b,None),None)
   (* let timestamp_k = Timestamp_key None *)
 
   let unit = Unit_t None
@@ -77,12 +78,30 @@ module Ty = struct
     | TC_key_hash -> return key_hash_k
     | TC_chain_id -> fail (not_comparable "chain_id")
 
-  let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
+  let comparable_leaf : type a. (a, _) comparable_struct -> (a , leaf) comparable_struct result =
+      fun a ->
+    match a with
+    | Pair_key _ -> fail (not_comparable "pair (use (a,(b,c)) instead of (a,b,c))")
+    | Int_key annot -> ok (Int_key annot)
+    | Nat_key annot -> ok (Nat_key annot)
+    | String_key annot -> ok (String_key annot)
+    | Bytes_key annot -> ok (Bytes_key annot)
+    | Mutez_key annot -> ok (Mutez_key annot)
+    | Bool_key annot -> ok (Bool_key annot)
+    | Key_hash_key annot -> ok (Key_hash_key annot)
+    | Timestamp_key annot -> ok (Timestamp_key annot)
+    | Address_key annot -> ok (Address_key annot)
+
+  let rec comparable_type : type_value -> ex_comparable_ty result = fun tv ->
     match tv with
     | T_base b -> comparable_type_base b
     | T_function _ -> fail (not_comparable "function")
     | T_or _ -> fail (not_comparable "or")
-    | T_pair _ -> fail (not_comparable "pair")
+    | T_pair ((_,a),(_,b)) ->
+      let%bind (Ex_comparable_ty a') = comparable_type a in
+      let%bind (Ex_comparable_ty b') = comparable_type b in
+      let%bind a'' = comparable_leaf a' in
+      ok @@ Ex_comparable_ty (pair_k a'' b')
     | T_map _ -> fail (not_comparable "map")
     | T_big_map _ -> fail (not_comparable "big_map")
     | T_list _ -> fail (not_comparable "list")