From 5e510436374b8c68606bacf1df656d62929c1839 Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 4 May 2019 03:44:45 +0000 Subject: [PATCH] fix error in records ; add more regular smart-contract primitives --- src/lib_utils/logger.ml | 11 +++++ src/lib_utils/tezos_utils.ml | 1 + src/ligo/contracts/coase.ligo | 12 ++++- src/ligo/contracts/record.ligo | 16 ++++++ src/ligo/operators/operators.ml | 3 ++ src/ligo/test/coase_tests.ml | 50 +++++++++---------- src/ligo/test/integration_tests.ml | 6 +++ src/ligo/transpiler/transpiler.ml | 78 ++++++++++-------------------- 8 files changed, 99 insertions(+), 78 deletions(-) create mode 100644 src/lib_utils/logger.ml diff --git a/src/lib_utils/logger.ml b/src/lib_utils/logger.ml new file mode 100644 index 000000000..76f536175 --- /dev/null +++ b/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 diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml index 3b7158df3..63dcd2c9d 100644 --- a/src/lib_utils/tezos_utils.ml +++ b/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 diff --git a/src/ligo/contracts/coase.ligo b/src/ligo/contracts/coase.ligo index 608a31dd1..0a381adaf 100644 --- a/src/ligo/contracts/coase.ligo +++ b/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 diff --git a/src/ligo/contracts/record.ligo b/src/ligo/contracts/record.ligo index 9e154025e..6a0171bd7 100644 --- a/src/ligo/contracts/record.ligo +++ b/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 diff --git a/src/ligo/operators/operators.ml b/src/ligo/operators/operators.ml index 8b084fa3a..61afb2e2e 100644 --- a/src/ligo/operators/operators.ml +++ b/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 ]) ; ] diff --git a/src/ligo/test/coase_tests.ml b/src/ligo/test/coase_tests.ml index 2342b140d..f1d180e2c 100644 --- a/src/ligo/test/coase_tests.ml +++ b/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") @@ diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 8476f9402..06b62be73 100644 --- a/src/ligo/test/integration_tests.ml +++ b/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 diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 4d7225d25..0b0868757 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/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 (