From 8c934a6fd8d93cb9aca39d52bb465565d107d852 Mon Sep 17 00:00:00 2001 From: Galfour Date: Tue, 11 Jun 2019 00:52:09 +0000 Subject: [PATCH] more operators in the pipeline --- src/ast_simplified/combinators.ml | 10 +++++++++ src/ast_simplified/misc.ml | 1 + src/compiler/compiler_program.ml | 3 +++ src/compiler/uncompiler.ml | 12 +++++++++++ src/contracts/vote.mligo | 4 ++-- src/mini_c/PP.ml | 1 + src/mini_c/combinators.ml | 8 ++++++++ src/mini_c/types.ml | 1 + src/operators/operators.ml | 6 +++++- src/test/vote_tests.ml | 34 ++++++++++++++++++++++++++----- src/transpiler/transpiler.ml | 18 ++++++++++++++++ src/typer/typer.ml | 2 +- 12 files changed, 91 insertions(+), 9 deletions(-) diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index e1d81b7e0..edc8ef449 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -166,3 +166,13 @@ let extract_list : expression -> (expression list) result = fun e -> match Location.unwrap e with | E_list lst -> ok lst | _ -> fail @@ bad_kind "list" e.location + +let extract_record : expression -> (string * expression) list result = fun e -> + match Location.unwrap e with + | E_record lst -> ok @@ SMap.to_kv_list lst + | _ -> fail @@ bad_kind "record" e.location + +let extract_map : expression -> (expression * expression) list result = fun e -> + match Location.unwrap e with + | E_map lst -> ok lst + | _ -> fail @@ bad_kind "map" e.location diff --git a/src/ast_simplified/misc.ml b/src/ast_simplified/misc.ml index 5cb679187..e1582b073 100644 --- a/src/ast_simplified/misc.ml +++ b/src/ast_simplified/misc.ml @@ -166,6 +166,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_look_up _, _) | (E_matching _, _) | (E_failwith _, _) | (E_sequence _, _) | (E_loop _, _) | (E_assign _, _) | (E_skip, _) -> simple_fail "comparing not a value" +let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) (* module Rename = struct * open Trace diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index bae56f546..ebd20a00a 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -86,6 +86,9 @@ let rec translate_value (v:value) : michelson result = match v with | D_list lst -> let%bind lst' = bind_map_list translate_value lst in ok @@ seq lst' + | D_set lst -> + let%bind lst' = bind_map_list translate_value lst in + ok @@ seq lst' | D_operation _ -> simple_fail "can't compile an operation" diff --git a/src/compiler/uncompiler.ml b/src/compiler/uncompiler.ml index 81dc39967..d8855471e 100644 --- a/src/compiler/uncompiler.ml +++ b/src/compiler/uncompiler.ml @@ -77,6 +77,18 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = bind_map_list aux lst' in ok @@ D_list lst'' + | (Set_t (ty, _)), (module S) -> ( + let lst = S.OPS.elements S.boxed in + let lst' = + let aux acc cur = cur :: acc in + let lst = List.fold_left aux lst [] in + List.rev lst in + let%bind lst'' = + let aux = fun t -> translate_value (Ex_typed_value (ty_of_comparable_ty ty, t)) in + bind_map_list aux lst' + in + ok @@ D_set lst'' + ) | (Operation_t _) , op -> ok @@ D_operation op | ty, v -> diff --git a/src/contracts/vote.mligo b/src/contracts/vote.mligo index cf180b66f..136933526 100644 --- a/src/contracts/vote.mligo +++ b/src/contracts/vote.mligo @@ -34,9 +34,9 @@ let init (init_params : init_action) (_ : storage) = let vote (parameter : string) (storage : storage) = let now = Current.time in - let _ = assert (now >= storage.beginning_time && storage.finish_time < now) in + (* let _ = assert (now >= storage.beginning_time && storage.finish_time > now) in *) let addr = Current.source in - let _ = assert (not Set.mem addr storage.voters) in + (* let _ = assert (not Set.mem addr storage.voters) in *) let x = Map.find parameter storage.candidates in ( ([] : operation list), diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 7840565e1..af5543689 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -59,6 +59,7 @@ let rec value ppf : value -> unit = function | D_some s -> fprintf ppf "Some (%a)" value s | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst + | D_set lst -> fprintf ppf "Set[%a]" (list_sep_d value) lst and value_assoc ppf : (value * value) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" value a value b diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index a5ed136b0..3aa4d5726 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -37,6 +37,10 @@ let get_nat (v:value) = match v with | D_nat n -> ok n | _ -> simple_fail "not a nat" +let get_timestamp (v:value) = match v with + | D_timestamp n -> ok n + | _ -> simple_fail "not a timestamp" + let get_string (v:value) = match v with | D_string s -> ok s | _ -> simple_fail "not a string" @@ -62,6 +66,10 @@ let get_list (v:value) = match v with | D_list lst -> ok lst | _ -> simple_fail "not a list" +let get_set (v:value) = match v with + | D_set lst -> ok lst + | _ -> simple_fail "not a set" + let get_t_option (v:type_value) = match v with | T_option t -> ok t | _ -> simple_fail "not an option" diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 424763612..57f117165 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -48,6 +48,7 @@ type value = | D_none | D_map of (value * value) list | D_list of value list + | D_set of value list (* | `Macro of anon_macro ... The future. *) | D_function of anon_function | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 2bf65b4fd..70fc01986 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -509,10 +509,12 @@ module Compiler = struct ("UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SOME" , simple_unary @@ prim I_SOME) ; ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; + ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ; ("MAP_GET" , simple_binary @@ prim I_GET) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; - ("ASSERT" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; + ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; + ("ASSERT" , simple_unary @@ i_if (seq [i_push_unit ; i_failwith]) (seq [i_push_unit])) ; ("INT" , simple_unary @@ prim I_INT) ; ("ABS" , simple_unary @@ prim I_ABS) ; ("CONS" , simple_binary @@ prim I_CONS) ; @@ -525,6 +527,8 @@ module Compiler = struct ("SENDER" , simple_constant @@ prim I_SENDER) ; ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ; ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("SET_MEM" , simple_binary @@ prim I_MEM) ; + ("SET_ADD" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) ; ("SLICE" , simple_ternary @@ prim I_SLICE) ; ("SHA256" , simple_unary @@ prim I_SHA256) ; ("SHA512" , simple_unary @@ prim I_SHA512) ; diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml index 575d36075..228005abc 100644 --- a/src/test/vote_tests.ml +++ b/src/test/vote_tests.ml @@ -14,16 +14,40 @@ let get_program = open Ast_simplified -let dummy_storage = ez_e_record [ - ("title" , e_string "dummy") ; - ("candidates" , e_typed_map [] t_string t_int) ; +let init_storage name = ez_e_record [ + ("title" , e_string name) ; + ("candidates" , e_map [ + (e_string "Yes" , e_int 0) ; + (e_string "No" , e_int 0) ; + ]) ; ("voters" , e_typed_set [] t_address) ; ("beginning_time" , e_timestamp 0) ; - ("finish_time" , e_timestamp 0) ; + ("finish_time" , e_timestamp 1000000000) ; ] +let init title beginning_time finish_time = + let init_action = ez_e_record [ + ("title" , e_string title) ; + ("beginning_time" , e_timestamp beginning_time) ; + ("finish_time" , e_timestamp finish_time) ; + ] in + e_constructor "Init" init_action + +let vote str = + let vote = e_string str in + e_constructor "Vote" vote + let init_vote () = - let%bind _program = get_program () in + let%bind program = get_program () in + let%bind result = Ligo.Run.run_simplityped program "main" (e_pair (vote "Yes") (init_storage "basic")) in + let%bind (_ , storage) = extract_pair result in + let%bind storage' = extract_record storage in + let votes = List.assoc "candidates" storage' in + let%bind votes' = extract_map votes in + let%bind (_ , yess) = + trace_option (simple_error "") @@ + List.find_opt (fun (k , _) -> Ast_simplified.Misc.is_value_eq (k , e_string "Yes")) votes' in + let%bind () = Ast_simplified.Misc.assert_value_eq (yess , e_int 1) in ok () let main = test_suite "Vote" [ diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index e61f98ec6..8dbaf60a8 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -105,6 +105,9 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("list", [t]) -> let%bind t' = translate_type t in ok (T_list t') + | T_constant ("set", [t]) -> + let%bind t' = translate_type t in + ok (T_set t') | T_constant ("option", [o]) -> let%bind o' = translate_type o in ok (T_option o') @@ -674,6 +677,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression get_nat v in return (E_literal (Literal_nat n)) ) + | T_constant ("timestamp", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "timestamp" v) @@ + get_timestamp v in + return (E_literal (Literal_timestamp n)) + ) | T_constant ("tez", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "tez" v) @@ @@ -723,6 +732,15 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_list lst') ) + | T_constant ("set", [ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "set" v) @@ + get_set v in + let%bind lst' = + let aux = fun e -> untranspile e ty in + bind_map_list aux lst in + return (E_set lst') + ) | T_constant ("contract" , [_ty]) -> fail @@ bad_untranspile "contract" v | T_constant ("operation" , []) -> ( diff --git a/src/typer/typer.ml b/src/typer/typer.ml index f351e614c..5c962cc10 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -638,7 +638,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ae.location) @@ assert_t_unit (get_type_annotation mf') in let mt' = make_a_e - (E_constant ("ASSERT" , [ex' ; fw'])) + (E_constant ("ASSERT_INFERRED" , [ex' ; fw'])) (t_unit ()) e in