diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 986b675a9..26f6255bc 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -26,6 +26,11 @@ let get_predicate : string -> type_value -> expression list -> predicate result let%bind m_ty = Compiler_type.type_ ty' in ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL ) + | "SET_EMPTY" -> ( + let%bind ty' = Mini_c.get_t_set ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET + ) | "UNPACK" -> ( let%bind ty' = Mini_c.get_t_option ty in let%bind m_ty = Compiler_type.type_ ty' in @@ -86,14 +91,16 @@ let rec translate_value (v:value) : michelson result = match v with ok @@ prim ~children:[s'] D_Some | D_map lst -> let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in + let sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in let aux (a, b) = prim ~children:[a;b] D_Elt in - ok @@ seq @@ List.map aux lst' + ok @@ seq @@ List.map aux sorted | 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' + let sorted = List.sort compare lst' in + ok @@ seq sorted | D_operation _ -> simple_fail "can't compile an operation" diff --git a/src/contracts/set_arithmetic.ligo b/src/contracts/set_arithmetic.ligo new file mode 100644 index 000000000..e4c686310 --- /dev/null +++ b/src/contracts/set_arithmetic.ligo @@ -0,0 +1,15 @@ +const s_e : set(string) = (set_empty : set(string)) + +const s_fb : set(string) = set [ + "foo" ; + "bar" ; +] + +function add_op (const s : set(string)) : set(string) is + begin skip end with set_add("foobar" , s) + +function remove_op (const s : set(string)) : set(string) is + begin skip end with set_remove("foobar" , s) + +function mem_op (const s : set(string)) : bool is + begin skip end with set_mem("foobar" , s) diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index 17fc40ba2..24a38b489 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -32,8 +32,14 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v error title content in trace error @@ translate_entry entry in - if debug_michelson then Format.printf "Program: %a\n" Michelson.pp compiled.body ; let%bind input_michelson = translate_value input in + if debug_michelson then ( + Format.printf "Program: %a\n" Michelson.pp compiled.body ; + Format.printf "Expression: %a\n" PP.expression entry.result ; + Format.printf "Input: %a\n" PP.value input ; + Format.printf "Input Type: %a\n" PP.type_ entry.input ; + Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; + ) ; let%bind ex_ty_value = run_aux ?options compiled input_michelson in let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in ok result diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 7f69f392b..4fad1501d 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -74,6 +74,11 @@ module Simplify = struct ("bitwise_xor" , "XOR") ; ("string_concat" , "CONCAT") ; ("string_slice" , "SLICE") ; + ("set_empty" , "SET_EMPTY") ; + ("set_mem" , "SET_MEM") ; + ("set_add" , "SET_ADD") ; + ("set_remove" , "SET_REMOVE") ; + ("set_iter" , "SET_ITER") ; ] let type_constants = type_constants @@ -194,6 +199,11 @@ module Typer = struct | None -> simple_fail "untyped NONE" | Some t -> ok t + let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt -> + match tv_opt with + | None -> simple_fail "untyped SET_EMPTY" + | Some t -> ok t + let sub = typer_2 "SUB" @@ fun a b -> if (eq_2 (a , b) (t_int ())) then ok @@ t_int () else @@ -571,6 +581,7 @@ module Typer = struct map_map ; map_fold ; map_iter ; + set_empty ; set_mem ; set_add ; set_remove ; @@ -658,10 +669,11 @@ module Compiler = struct ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ; ("SOURCE" , simple_constant @@ prim I_SOURCE) ; ("SENDER" , simple_constant @@ prim I_SENDER) ; - ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ; + ("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]) ; + ("SET_REMOVE" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) ; ("SLICE" , simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")]) ; ("SHA256" , simple_unary @@ prim I_SHA256) ; ("SHA512" , simple_unary @@ prim I_SHA512) ; diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index 6542473d4..51aacac92 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -484,7 +484,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = fail @@ unsupported_string_catenation e | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l - | ESet _ -> fail @@ unsupported_set_expr t + | ESet s -> simpl_set_expression s | ECase c -> ( let (c , loc) = r_split c in let%bind e = simpl_expression c.expr in @@ -571,6 +571,21 @@ and simpl_list_expression (t:Raw.list_expr) : expression result = return @@ e_list ~loc [] ) +and simpl_set_expression (t:Raw.set_expr) : expression result = + match t with + | SetMem x -> ( + let (x' , loc) = r_split x in + let%bind set' = simpl_expression x'.set in + let%bind element' = simpl_expression x'.element in + ok @@ e_constant ~loc "SET_MEM" [ element' ; set' ] + ) + | SetInj x -> ( + let (x' , loc) = r_split x in + let elements = pseq_to_list x'.elements in + let%bind elements' = bind_map_list simpl_expression elements in + ok @@ e_set ~loc elements' + ) + and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = let return x = ok x in let (t , loc) = r_split t in diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 29235f2a7..bd49a31b9 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -159,6 +159,34 @@ let string_arithmetic () : unit result = let%bind () = expect_fail program "slice_op" (e_string "ba") in ok () +let set_arithmetic () : unit result = + let%bind program = type_file "./contracts/set_arithmetic.ligo" in + let%bind () = + expect_eq program "add_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in + let%bind () = + expect_eq program "add_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in + let%bind () = + expect_eq program "remove_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program "remove_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program "mem_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_bool true) in + let%bind () = + expect_eq program "mem_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_bool false) in + ok () + let unit_expression () : unit result = let%bind program = type_file "./contracts/unit.ligo" in expect_eq_evaluate program "u" (e_unit ()) @@ -368,8 +396,7 @@ let loop () : unit result = let make_expected = fun n -> e_nat (n * (n + 1) / 2) in expect_eq_n_pos_mid program "sum" make_input make_expected in - ok() - + ok () let matching () : unit result = let%bind program = type_file "./contracts/match.ligo" in @@ -590,6 +617,7 @@ let main = test_suite "Integration (End to End)" [ test "arithmetic" arithmetic ; test "bitiwse_arithmetic" bitwise_arithmetic ; test "string_arithmetic" string_arithmetic ; + test "set_arithmetic" set_arithmetic ; test "unit" unit_expression ; test "string" string_expression ; test "option" option ; diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index e2f8896ce..32f45d4a4 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -32,7 +32,13 @@ let rec error_pp out (e : error) = | `Null -> "" | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst | _ -> " " ^ (J.to_string infos) ^ "\n" in - Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos + let children = + let children = e |> member "children" in + match children with + | `Null -> "" + | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst + | _ -> " " ^ (J.to_string children) ^ "\n" in + Format.fprintf out "%s%s%s.\n%s%s%s" title error_code message data infos children let test name f = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 88e7b5ad9..fcaf67815 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -372,7 +372,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re Mini_c.Combinators.get_t_set tv in let%bind lst' = bind_map_list (translate_annotated_expression) lst in let aux : expression -> expression -> expression result = fun prev cur -> - return @@ E_constant ("CONS", [cur ; prev]) in + return @@ E_constant ("SET_ADD", [cur ; prev]) in let%bind (init : expression) = return @@ E_make_empty_set t in bind_fold_list aux init lst' ) @@ -674,7 +674,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression | T_constant ("nat", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "nat" v) @@ - get_nat v in + get_nat v in return (E_literal (Literal_nat n)) ) | T_constant ("timestamp", []) -> ( diff --git a/vendors/ligo-utils/proto-alpha-utils/trace.ml b/vendors/ligo-utils/proto-alpha-utils/trace.ml index 53cffe354..812ce0405 100644 --- a/vendors/ligo-utils/proto-alpha-utils/trace.ml +++ b/vendors/ligo-utils/proto-alpha-utils/trace.ml @@ -26,10 +26,12 @@ let trace_tzresult err = let trace_tzresult_r err_thunk_may_fail = function | Result.Ok x -> ok x - | Error _errs -> - (* let tz_errs = List.map of_tz_error errs in *) + | Error errs -> + let tz_errs = List.map of_tz_error errs in match err_thunk_may_fail () with - | Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Error (err) + | Simple_utils.Trace.Ok (err, annotations) -> + ignore annotations ; + Error (fun () -> patch_children tz_errs (err ())) | Error errors_while_generating_error -> (* TODO: the complexity could be O(n*n) in the worst case, this should use some catenable lists. *)