Deconstruct tuples in let and fun

Author: mebsout

Makefile

@@ -27,7 +27,7 @@ distclean: clean
 
 # All of these tests must be run with with_tezos=true
 
-NTESTS=19
+NTESTS=20
 SIMPLE_TESTS= `seq -f 'test%.0f' 0 $(NTESTS)`
 MORE_TESTS=test_ifcons test_if test_loop test_option test_transfer test_left \
   test_extfun test_left_constr test_closure test_closure2 test_closure3 \

tests/others/broker.liq

@@ -19,8 +19,8 @@ let%entry main
   else
     if Current.time () < storage.timeout then (* Before timeout *)
       (* We compute ((1 + P) + N) tez for keeping the contract alive *)
-      let pn = storage.pn in
-      let cost = 1.00tz + pn.(0) + pn.(1) in
+      let (pn0, pn1) = storage.pn in
+      let cost = 1.00tz + pn0 + pn1 in
       let b = Current.balance () in
       if cost < b then
         (* # Not enough cash, we just accept the transaction
@@ -30,15 +30,17 @@ let%entry main
         (* # Enough cash, successful ending
                    # We update the global*)
         let storage = storage.state <- "success" in
+        let (pn0, _) = storage.pn in
         let (_result, storage) =
-            Contract.call storage.x storage.pn.(0) storage () in
+          Contract.call storage.x pn0 storage () in
+        let (_, pn1) = storage.pn in
         let (_result, storage) =
-            Contract.call storage.a storage.pn.(1) storage () in
+            Contract.call storage.a pn1 storage () in
         ( (), storage )
     else
       (* # After timeout, we refund
            # We update the global *)
-      let p = storage.pn.(0) in
+      let (p, _) = storage.pn in
       let storage = storage.state <- "timeout" in
       (*  # We try to transfer the fee to the broker *)
       let bal = Current.balance () in

tests/test20.liq

@@ -0,0 +1,10 @@
+type storage = tez * int * ((nat * unit) * bool)
+
+let%entry main
+    (parameter : unit)
+    (storage : storage)
+  :  (nat * tez) * storage =
+
+  let x, y = 0p, 1p in
+  let amount, _, ((n, _), b) = storage in
+  ((n + x + y, amount), storage)

tests/test_extfun.liq

@@ -1,7 +1,7 @@
 
 [%%version 0.11]
 
-let f ( arg : unit * int ) = arg.(0)
+let f ((x : unit), (_ : int) ) = x
 
 let%entry main
       (parameter : int)

tools/liquidity/liquidFromOCaml.ml

@@ -390,6 +390,41 @@ and translate_pair exp =
 
 let mk desc = { desc; ty = (); bv = StringSet.empty; fail = false }
 
+let deconstruct_pat env pat =
+  let rec deconstruct_pat_aux acc indexes = function
+    | { ppat_desc = Ppat_constraint (pat, ty) } ->
+      let acc, _ = deconstruct_pat_aux acc indexes pat in
+      acc, translate_type env ty
+
+    | { ppat_desc = Ppat_var { txt = var; loc } } ->
+      (var, loc_of_loc loc, indexes) :: acc, Tunit (* Dummy type value *)
+
+    | { ppat_desc = Ppat_any; ppat_loc } ->
+      ("_", loc_of_loc ppat_loc, indexes) :: acc, Tunit (* Dummy type value *)
+
+    | { ppat_desc = Ppat_tuple pats } ->
+      let _, acc, tys =
+        List.fold_left (fun (i, acc, tys) pat ->
+            let acc, ty = deconstruct_pat_aux acc (i :: indexes) pat in
+            i + 1, acc, ty :: tys
+          ) (0, acc, []) pats
+      in
+      acc, Ttuple (List.rev tys)
+
+    | { ppat_loc } ->
+      error_loc ppat_loc "cannot deconstruct this pattern"
+  in
+  deconstruct_pat_aux [] [] pat
+
+let access_of_deconstruct var_name loc indexes =
+  let a = mk (Var (var_name, loc, [])) in
+  List.fold_right (fun i a ->
+      mk (Apply (Prim_tuple_get, loc, [
+          a;
+          mk (Const (Tnat, CNat (LiquidPrinter.integer_of_int i)))
+        ]))
+    ) indexes a
+
 let rec translate_code env exp =
   let desc =
     match exp with
@@ -463,16 +498,27 @@ let rec translate_code env exp =
                     translate_code env arg_exp,
                     translate_code env body)
 
-    | { pexp_desc = Pexp_let (Nonrecursive,
-                              [
-                                {
-                                  pvb_pat = { ppat_desc =
-                                                Ppat_var { txt = var; loc } };
-                                  pvb_expr = var_exp;
-                                }
-                              ], body) } ->
-       Let (var, loc_of_loc loc,
-            translate_code env var_exp, translate_code env body)
+    | { pexp_desc = Pexp_let (Nonrecursive, [ {
+        pvb_pat = pat;
+        pvb_expr = var_exp;
+      } ], body); pexp_loc } ->
+
+      let vars_infos, _ = deconstruct_pat env pat in
+      let exp, body = translate_code env var_exp, translate_code env body in
+      begin match vars_infos with
+        | [] -> assert false
+        | [v, loc, []] -> Let (v, loc, exp, body)
+        | _ ->
+          let var_name =
+            String.concat "_" (List.rev_map (fun (v,_,_) -> v) vars_infos) in
+          let lets_body =
+            List.fold_left (fun e (v, loc, indexes) ->
+                let access = access_of_deconstruct var_name loc indexes in
+                mk (Let (v, loc, access, e))
+              ) body vars_infos
+          in
+          Let (var_name, loc_of_loc pexp_loc, exp, lets_body)
+      end
 
     | { pexp_desc = Pexp_sequence (exp1, exp2) } ->
        Seq (translate_code env exp1, translate_code env exp2)
@@ -529,21 +575,28 @@ let rec translate_code env exp =
            MatchVariant(e, loc_of_loc pexp_loc, args)
        end
 
-    | { pexp_desc =
-          Pexp_fun (
-              Nolabel, None,
-              { ppat_desc =
-                  Ppat_constraint(
-                      { ppat_desc =
-                          Ppat_var { txt = arg_name } },
-                      arg_type)
-              },
-              body_exp) } ->
+    | { pexp_desc = Pexp_fun (Nolabel, None, pat, body_exp) } ->
        let body_exp = translate_code env body_exp in
-       let arg_type = translate_type env arg_type in
-       Lambda (arg_name, arg_type, loc_of_loc exp.pexp_loc,
-               body_exp,
-               Tunit) (* not yet inferred *)
+       let vars_infos, arg_type = deconstruct_pat env pat in
+       begin match vars_infos with
+         | [] -> assert false
+         | [arg_name, loc, []] ->
+           Lambda (arg_name, arg_type, loc_of_loc exp.pexp_loc,
+                   body_exp,
+                   Tunit) (* not yet inferred *)
+         | _ ->
+           let arg_name =
+             String.concat "_" (List.rev_map (fun (v,_,_) -> v) vars_infos) in
+           let lets_body =
+             List.fold_left (fun e (v, loc, indexes) ->
+                   let access = access_of_deconstruct arg_name loc indexes in
+                   mk (Let (v, loc, access, e))
+               ) body_exp vars_infos
+           in
+           Lambda (arg_name, arg_type, loc_of_loc exp.pexp_loc,
+                   lets_body,
+                   Tunit) (* not yet inferred *)
+       end
 
     | { pexp_desc = Pexp_record (lab_x_exp_list, None) } ->
        let lab_x_exp_list =