diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index a6d34c72a..5dc82ee9d 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -15,6 +15,8 @@ let make_n_t type_name type_value = { type_name ; type_value } let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s let t_string ?s () : type_value = make_t (T_constant ("string", [])) s let t_bytes ?s () : type_value = make_t (T_constant ("bytes", [])) s +let t_key ?s () : type_value = make_t (T_constant ("key", [])) s +let t_key_hash ?s () : type_value = make_t (T_constant ("key_hash", [])) s let t_int ?s () : type_value = make_t (T_constant ("int", [])) s let t_address ?s () : type_value = make_t (T_constant ("address", [])) s let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s @@ -93,6 +95,18 @@ let get_t_list (t:type_value) : type_value result = match t.type_value' with | T_constant ("list", [o]) -> ok o | _ -> simple_fail "not a list" +let get_t_key (t:type_value) : unit result = match t.type_value' with + | T_constant ("key", []) -> ok () + | _ -> simple_fail "not a key" + +let get_t_signature (t:type_value) : unit result = match t.type_value' with + | T_constant ("signature", []) -> ok () + | _ -> simple_fail "not a signature" + +let get_t_key_hash (t:type_value) : unit result = match t.type_value' with + | T_constant ("key_hash", []) -> ok () + | _ -> simple_fail "not a key_hash" + let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with | T_tuple lst -> ok lst | _ -> simple_fail "not a tuple" @@ -136,7 +150,10 @@ let assert_t_map = fun t -> let is_t_map = Function.compose to_bool get_t_map -let assert_t_tez :type_value -> unit result = get_t_tez +let assert_t_tez : type_value -> unit result = get_t_tez +let assert_t_key = get_t_key +let assert_t_signature = get_t_signature +let assert_t_key_hash = get_t_key_hash let assert_t_list t = let%bind _ = get_t_list t in diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index db8e7936e..ee6a1bab9 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -16,6 +16,16 @@ let get_predicate : string -> type_value -> expression list -> predicate result | Some x -> ok x | None -> ( match s with + | "NONE" -> ( + let%bind ty' = Mini_c.get_t_option ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_unary @@ prim ~children:[m_ty] I_NONE + ) + | "UNPACK" -> ( + let%bind ty' = Mini_c.get_t_option ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK + ) | "MAP_REMOVE" -> let%bind v = match lst with | [ _ ; expr ] -> diff --git a/src/operators/operators.ml b/src/operators/operators.ml index d8c3d134f..c4ed39de0 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -42,6 +42,9 @@ module Simplify = struct ("bool" , "bool") ; ("operation" , "operation") ; ("address" , "address") ; + ("key" , "key") ; + ("key_hash" , "key_hash") ; + ("signature" , "signature") ; ("timestamp" , "timestamp") ; ("contract" , "contract") ; ("list" , "list") ; @@ -76,7 +79,7 @@ module Simplify = struct ("Bytes.pack" , "PACK") ; ("Crypto.hash" , "HASH") ; ("Operation.transaction" , "CALL") ; - ("Operation.get_contract" , "GET_CONTRACT") ; + ("Operation.get_contract" , "CONTRACT") ; ("sender" , "SENDER") ; ("unit" , "UNIT") ; ("source" , "SOURCE") ; @@ -126,7 +129,7 @@ module Simplify = struct ("List.iter", "ITER") ; ("Operation.transaction" , "CALL") ; - ("Operation.get_contract" , "GET_CONTRACT") ; + ("Operation.get_contract" , "CONTRACT") ; ("int" , "INT") ; ("abs" , "ABS") ; ("unit" , "UNIT") ; @@ -243,9 +246,15 @@ module Typer = struct let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ - (is_t_map t || is_t_list t) in + (is_t_map t || is_t_list t || is_t_string t) in ok @@ t_nat () + let slice = typer_3 "SLICE" @@ fun i j s -> + let%bind () = + Assert.assert_true @@ + (is_t_nat i && is_t_nat j && is_t_string s) in + ok @@ t_string () + let failwith_ = typer_1 "FAILWITH" @@ fun t -> let%bind () = Assert.assert_true @@ @@ -269,10 +278,28 @@ module Typer = struct trace_option (simple_error "untyped UNPACK") @@ output_opt - let crypto_hash = typer_1 "HASH" @@ fun t -> + let hash256 = typer_1 "SHA256" @@ fun t -> let%bind () = assert_t_bytes t in ok @@ t_bytes () + let hash512 = typer_1 "SHA512" @@ fun t -> + let%bind () = assert_t_bytes t in + ok @@ t_bytes () + + let blake2b = typer_1 "BLAKE2b" @@ fun t -> + let%bind () = assert_t_bytes t in + ok @@ t_bytes () + + let hash_key = typer_1 "HASH_KEY" @@ fun t -> + let%bind () = assert_t_key t in + ok @@ t_key_hash () + + let check_signature = typer_3 "CHECK_SIGNATURE" @@ fun k s b -> + let%bind () = assert_t_key k in + let%bind () = assert_t_signature s in + let%bind () = assert_t_bytes b in + ok @@ t_bool () + let sender = constant "SENDER" @@ t_address () let source = constant "SOURCE" @@ t_address () @@ -281,6 +308,8 @@ module Typer = struct let amount = constant "AMOUNT" @@ t_tez () + let address = constant "ADDRESS" @@ t_address () + let now = constant "NOW" @@ t_timestamp () let transaction = typer_3 "CALL" @@ fun param amount contract -> @@ -367,7 +396,11 @@ module Typer = struct get_force ; bytes_pack ; bytes_unpack ; - crypto_hash ; + hash256 ; + hash512 ; + blake2b ; + hash_key ; + check_signature ; sender ; source ; unit ; @@ -376,6 +409,8 @@ module Typer = struct get_contract ; abs ; now ; + slice ; + address ; ] end @@ -407,6 +442,8 @@ module Compiler = struct ("NEG" , simple_unary @@ prim I_NEG) ; ("OR" , simple_binary @@ prim I_OR) ; ("AND" , simple_binary @@ prim I_AND) ; + ("XOR" , simple_binary @@ prim I_XOR) ; + ("NOT" , simple_unary @@ prim I_NOT) ; ("PAIR" , simple_binary @@ prim I_PAIR) ; ("CAR" , simple_unary @@ prim I_CAR) ; ("CDR" , simple_unary @@ prim I_CDR) ; @@ -428,12 +465,22 @@ module Compiler = struct ("CONS" , simple_binary @@ prim I_CONS) ; ("UNIT" , simple_constant @@ prim I_UNIT) ; ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ; + ("ADDRESS" , simple_constant @@ prim I_ADDRESS) ; ("NOW" , simple_constant @@ prim I_NOW) ; ("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_UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ; + ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("SLICE" , simple_ternary @@ prim I_SLICE) ; + ("SHA256" , simple_unary @@ prim I_SHA256) ; + ("SHA512" , simple_unary @@ prim I_SHA512) ; + ("BLAKE2B" , simple_unary @@ prim I_BLAKE2B) ; + ("CHECK_SIGNATURE" , simple_ternary @@ prim I_CHECK_SIGNATURE) ; + ("HASH_KEY" , simple_unary @@ prim I_HASH_KEY) ; + ("PACK" , simple_unary @@ prim I_PACK) ; ] + (* Some complex predicates will need to be added in compiler/compiler_program *) + end diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 5817845aa..1b3063390 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -5,7 +5,7 @@ type test = | Test_suite of (string * test list) | Test of test_case -let error_pp out (e : error) = +let rec error_pp out (e : error) = let open JSON_string_utils in let message = let opt = e |> member "message" |> string in @@ -30,6 +30,7 @@ let error_pp out (e : error) = let infos = e |> member "infos" in match infos with | `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