fix error in records ; add more regular smart-contract primitives

src/lib_utils/logger.ml

@@ -0,0 +1,11 @@
+module Stateful () : sig
+  val log : string -> unit
+  val get : unit -> string
+end = struct
+
+  let logger = ref ""
+  let log : string -> unit =
+    fun s -> logger := !logger ^ s
+  let get () : string = !logger
+
+end

src/lib_utils/tezos_utils.ml

@@ -10,6 +10,7 @@ module Micheline = X_tezos_micheline
 module Function = Function
 module Error_monad = X_error_monad
 module Trace = Trace
+module Logger = Logger
 module PP_helpers = PP
 module Location = Location
 

src/ligo/contracts/coase.ligo

@@ -4,7 +4,6 @@ type card_pattern_id is nat
 type card_pattern is record [
   coefficient : tez ;
   quantity : nat ;
-  last_id : nat ;
 ]
 
 type card_patterns is map(card_pattern_id , card_pattern)
@@ -18,6 +17,7 @@ type cards is map(card_id , card)
 type storage_type is record [
   cards : cards ;
   card_patterns : card_patterns ;
+  next_id : nat ;
 ]
 
 type action_buy_single is record [
@@ -38,14 +38,24 @@ type action is
 
 function buy_single(const action : action_buy_single ; const s : storage_type) : (list(operation) * storage_type) is
   begin
+    // Check funds
     const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ;
     const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ;
     if (price > amount) then fail "Not enough money" else skip ;
+    // Administrative procedure
     const operations : list(operation) = nil ;
+    // Increase quantity
     card_pattern.quantity := card_pattern.quantity + 1n ;
     const card_patterns : card_patterns = s.card_patterns ;
     card_patterns[action.card_to_buy] := card_pattern ;
     s.card_patterns := card_patterns ;
+    // Add card
+    const cards : cards = s.cards ;
+    cards[s.next_id] := record
+      card_owner = source ;
+    end ;
+    s.cards := cards ;
+    s.next_id := s.next_id + 1n ;
   end with (operations , s)
 
 function main(const action : action ; const s : storage_type) : (list(operation) * storage_type) is

src/ligo/contracts/record.ligo

@@ -8,6 +8,22 @@ const fb : foobar = record
   bar = 0 ;
 end
 
+type abc is record
+  a : int ;
+  b : int ;
+  c : int ;
+end
+
+const abc : abc = record
+  a = 42 ;
+  b = 142 ;
+  c = 242 ;
+end
+
+const a : int = abc.a ;
+const b : int = abc.b ;
+const c : int = abc.c ;
+
 function projection (const r : foobar) : int is
   begin
     skip

src/ligo/operators/operators.ml

@@ -26,6 +26,7 @@ module Simplify = struct
     ("int" , 1) ;
     ("amount" , 0) ;
     ("unit" , 0) ;
+    ("source" , 0) ;
   ]
 
   module Camligo = struct
@@ -363,6 +364,8 @@ module Compiler = struct
     ("CONS" , simple_binary @@ prim I_CONS) ;
     ("UNIT" , simple_constant @@ prim I_UNIT) ;
     ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ;
+    ("SOURCE" , simple_constant @@ prim I_SOURCE) ;
+    ("SENDER" , simple_constant @@ prim I_SENDER) ;
     ( "MAP_UPDATE" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ;
   ]
 

src/ligo/test/coase_tests.ml

@@ -21,51 +21,51 @@ let card owner =
     ("card_owner" , owner) ;
   ]
 
+let card_ty = ez_t_record [
+    ("card_owner" , t_address ()) ;
+  ] ()
+
 let card_ez owner = card (e_a_empty_address owner)
 
 let make_cards lst =
   let card_id_ty = t_nat () in
-  let card_ty =
-    ez_t_record [
-      ("card_owner" , t_address ()) ;
-    ] () in
   let assoc_lst = List.mapi (fun i x -> (e_a_empty_nat i , x)) lst in
   e_a_empty_map assoc_lst card_id_ty card_ty
 
-let card_pattern (coeff , qtt , last) =
-    ez_e_a_empty_record [
+let card_pattern (coeff , qtt) =
+  ez_e_a_empty_record [
     ("coefficient" , coeff) ;
     ("quantity" , qtt) ;
-    ("last" , last) ;
   ]
 
-let card_pattern_ez (coeff , qtt , last) =
-  card_pattern (e_a_empty_tez coeff , e_a_empty_nat qtt , e_a_empty_nat last)
+let card_pattern_ty =
+  ez_t_record [
+    ("coefficient" , t_tez ()) ;
+    ("quantity" , t_nat ()) ;
+  ] ()
+
+let card_pattern_ez (coeff , qtt) =
+  card_pattern (e_a_empty_tez coeff , e_a_empty_nat qtt)
 
 let make_card_patterns lst =
   let card_pattern_id_ty = t_nat () in
-  let card_pattern_ty =
-    ez_t_record [
-      ("coefficient" , t_tez ()) ;
-      ("quantity" , t_nat ()) ;
-      ("last_id" , t_nat ()) ;
-    ] () in
   let assoc_lst = List.mapi (fun i x -> (e_a_empty_nat i , x)) lst in
   e_a_empty_map assoc_lst card_pattern_id_ty card_pattern_ty
 
-let storage cards_patterns cards =
+let storage cards_patterns cards next_id =
   ez_e_a_empty_record [
     ("cards" , cards) ;
     ("card_patterns" , cards_patterns) ;
+    ("next_id" , next_id) ;
   ]
 
-let storage_ez cps cs =
-  storage (make_card_patterns cps) (make_cards cs)
+let storage_ez cps cs next_id =
+  storage (make_card_patterns cps) (make_cards cs) (e_a_empty_nat next_id)
 
-let basic n =
+let basic a b n next_id =
   let card_patterns = List.map card_pattern_ez [
-    (100 , 100 , 150) ;
-    (20 , 1000 , 2000) ;
+    (100 , a) ;
+    (20 , b) ;
   ] in
   let owner =
     let open Tezos_utils.Memory_proto_alpha in
@@ -76,18 +76,18 @@ let basic n =
     List.map card_ez
     @@ List.map (Function.constant owner)
     @@ List.range n in
-  storage (make_card_patterns card_patterns) (make_cards cards)
+  storage_ez card_patterns cards next_id
 
 let buy () =
   let%bind program = get_program () in
   let aux n =
     let open AST_Typed.Combinators in
     let input =
-      let card_pattern_id = ez_e_a_empty_record [
+      let buy_action = ez_e_a_empty_record [
           ("card_to_buy" , e_a_empty_nat 0) ;
         ] in
-      let storage = basic n in
-      e_a_empty_pair card_pattern_id storage
+      let storage = basic 100 1000 n (2 * n) in
+      e_a_empty_pair buy_action storage
     in
     let%bind amount =
       trace_option (simple_error "getting amount for run") @@

src/ligo/test/integration_tests.ml

@@ -140,6 +140,12 @@ let record () : unit result  =
     let expected = record_ez_int ["foo" ; "bar"] 0 in
     expect_evaluate program "fb" expected
   in
+  let%bind () =
+    let%bind () = expect_evaluate program "a" (e_a_int 42) in
+    let%bind () = expect_evaluate program "b" (e_a_int 142) in
+    let%bind () = expect_evaluate program "c" (e_a_int 242) in
+    ok ()
+  in
   let%bind () =
     let make_input = record_ez_int ["foo" ; "bar"] in
     let make_expected = fun n -> e_a_int (2 * n) in

src/ligo/transpiler/transpiler.ml

@@ -79,29 +79,22 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [
     bind_fold_list aux (ty , []) lr_path in
   ok lst
 
-let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * (type_value * [`Left | `Right]) list) result = fun ty tym ind ->
+let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
   let tys = kv_list_of_map tym in
   let node_tv = Append_tree.of_list tys in
-  let leaf (i, _) : (type_value * (type_value * [`Left | `Right]) list) result =
-    if i = ind then (
-      ok (ty, [])
-    ) else (
-      simple_fail "bad leaf"
-    ) in
-  let node a b : (type_value * (type_value * [`Left | `Right]) list) result =
-    match%bind bind_lr (a, b) with
-    | `Left (t, acc) ->
-        let%bind (a, _) = Mini_c.get_t_pair t in
-        ok @@ (t, (a, `Left) :: acc)
-    | `Right (t, acc) -> (
-        let%bind (_, b) = Mini_c.get_t_pair t in
-        ok @@ (t, (b, `Right) :: acc)
-      ) in
-  let error_content () =
-    let aux ppf (name, ty) = Format.fprintf ppf "%s -> %a" name PP.type_ ty in
-    Format.asprintf "(%a).%s" (PP.list_sep_d aux) tys ind in
-  trace_strong (fun () -> error (thunk "bad index in record (shouldn't happen here)") error_content ()) @@
-  Append_tree.fold_ne leaf node node_tv
+  let%bind path =
+    let aux (i , _) = i = ind in
+    trace_option (simple_error "no leaf with given index") @@
+    Append_tree.exists_path aux node_tv in
+  let lr_path = List.map (fun b -> if b then `Right else `Left) path in
+  let%bind (_ , lst) =
+    let aux = fun (ty , acc) cur ->
+      let%bind (a , b) = Mini_c.get_t_pair ty in
+      match cur with
+      | `Left -> ok (a , (a , `Left) :: acc)
+      | `Right -> ok (b , (b , `Right) :: acc) in
+    bind_fold_list aux (ty , []) lr_path in
+  ok lst
 
 let rec translate_block env (b:AST.block) : block result =
   let aux = fun (precs, env) instruction ->
@@ -144,7 +137,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
                 trace error @@
                 AST.Combinators.get_t_record prev in
               let%bind ty'_map = bind_map_smap translate_type ty_map in
-              let%bind (_, path) = record_access_to_lr ty' ty'_map prop in
+              let%bind path = record_access_to_lr ty' ty'_map prop in
               let path' = List.map snd path in
               ok (Map.String.find prop ty_map, path' @ acc)
           | Access_map _k -> simple_fail "no patch for map yet"
@@ -300,36 +293,17 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
       in
       Append_tree.fold_ne (translate_annotated_expression env) aux node
   | E_record_accessor (record, property) ->
-      let%bind translation = translate_annotated_expression env record in
-      let%bind record_type_map =
-        let error =
-          let title () =
-            Format.asprintf "Accessing field of %a, that has type %a, which isn't a record"
-              AST.PP.annotated_expression record AST.PP.type_value record.type_annotation in
-          let content () = "" in
-          error title content in
-        trace error @@
-        get_t_record record.type_annotation in
-      let node_tv = Append_tree.of_list @@ kv_list_of_map record_type_map in
-      let leaf (key, _) : expression result =
-        if property = key then (
-          ok translation
-        ) else (
-          simple_fail "bad leaf"
-        ) in
-      let node (a:expression result) b : expression result =
-        match%bind bind_lr (a, b) with
-        | `Left expr -> (
-            let%bind (tv, _) = Mini_c.get_t_pair @@ Expression.get_type expr in
-            return ~tv @@ E_constant ("CAR", [expr])
-          )
-        | `Right expr -> (
-            let%bind (_, tv) = Mini_c.get_t_pair @@ Expression.get_type expr in
-            return ~tv @@ E_constant ("CDR", [expr])
-          ) in
-      let%bind expr =
-        trace_strong (simple_error "bad key in record (shouldn't happen here)") @@
-        Append_tree.fold_ne leaf node node_tv in
+      let%bind ty' = translate_type (get_type_annotation record) in
+      let%bind ty_smap = get_t_record (get_type_annotation record) in
+      let%bind ty'_smap = bind_map_smap translate_type ty_smap in
+      let%bind path = record_access_to_lr ty' ty'_smap property in
+      let aux = fun pred (ty, lr) ->
+        let c = match lr with
+          | `Left -> "CAR"
+          | `Right -> "CDR" in
+        Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty , env) in
+      let%bind record' = translate_annotated_expression env record in
+      let expr = List.fold_right' aux record' path in
       ok expr
   | E_constant (name, lst) ->
       let%bind lst' = bind_list @@ List.map (translate_annotated_expression env) lst in (