diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 5f89f5a20..29640ada5 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -143,6 +143,10 @@ let rec transpile_type (t:AST.type_expression) : type_value result = ok (T_big_map kv') | T_operator (TC_map_or_big_map (_,_)) -> fail @@ corner_case ~loc:"transpiler" "TC_map_or_big_map should have been resolved before transpilation" + | T_operator (TC_michelson_or (l,r)) -> + let%bind l' = transpile_type l in + let%bind r' = transpile_type r in + ok (T_or ((None,l'),(None,r'))) | T_operator (TC_list t) -> let%bind t' = transpile_type t in ok (T_list t') diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 3665f8063..076f958da 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -186,6 +186,18 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul bind_fold_right_list aux init big_map' ) | TC_map_or_big_map (_, _) -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c" + | TC_michelson_or (l_ty, r_ty) -> ( + let%bind v' = bind_map_or (get_left , get_right) v in + ( match v' with + | D_left l -> + let%bind l' = untranspile l l_ty in + return @@ E_constructor { constructor = Constructor "M_left" ; element = l' } + | D_right r -> + let%bind r' = untranspile r r_ty in + return @@ E_constructor { constructor = Constructor "M_right" ; element = r' } + | _ -> fail (wrong_mini_c_value "michelson_or" v) + ) + ) | TC_list ty -> ( let%bind lst = trace_strong (wrong_mini_c_value "list" v) @@ diff --git a/src/passes/3-self_ast_imperative/michelson_or.ml b/src/passes/3-self_ast_imperative/michelson_or.ml new file mode 100644 index 000000000..28b773208 --- /dev/null +++ b/src/passes/3-self_ast_imperative/michelson_or.ml @@ -0,0 +1,9 @@ +open Ast_imperative +open Trace + +let peephole_type_expression : type_expression -> type_expression result = fun e -> + let return type_content = ok { type_content } in + match e.type_content with + | T_operator (TC_michelson_or (l_ty,r_ty)) -> + return @@ T_sum (CMap.of_list [ (Constructor "M_left", l_ty) ; (Constructor "M_right", r_ty) ]) + | e -> return e diff --git a/src/passes/3-self_ast_imperative/self_ast_imperative.ml b/src/passes/3-self_ast_imperative/self_ast_imperative.ml index b0270ebd0..5b02d6a49 100644 --- a/src/passes/3-self_ast_imperative/self_ast_imperative.ml +++ b/src/passes/3-self_ast_imperative/self_ast_imperative.ml @@ -7,6 +7,7 @@ let all_expression_mapper = [ ] let all_type_expression_mapper = [ Entrypoints_length_limit.peephole_type_expression ; + Michelson_or.peephole_type_expression ; ] let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 7d0a531b7..c7bc72dd9 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -157,6 +157,9 @@ and compile_type_operator : I.type_operator -> O.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in ok @@ O.TC_big_map (k,v) + | TC_michelson_or (l,r) -> + let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in + ok @@ O.TC_michelson_or (l,r) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in ok @@ O.TC_arrow (i,o) @@ -606,6 +609,9 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in ok @@ I.TC_big_map (k,v) + | TC_michelson_or (l,r) -> + let%bind (l,r) = bind_map_pair uncompile_type_expression (l,r) in + ok @@ I.TC_michelson_or (l,r) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in ok @@ I.TC_arrow (i,o) diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index ec9ca7dd1..e95b64ccf 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -62,6 +62,9 @@ and idle_type_operator : I.type_operator -> O.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in ok @@ O.TC_big_map (k,v) + | TC_michelson_or (l,r) -> + let%bind (l,r) = bind_map_pair idle_type_expression (l,r) in + ok @@ O.TC_michelson_or (l,r) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in ok @@ O.TC_arrow (i,o) @@ -287,6 +290,9 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result = let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in ok @@ I.TC_big_map (k,v) | TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled" + | TC_michelson_or (l,r) -> + let%bind (l,r) = bind_map_pair uncompile_type_expression (l,r) in + ok @@ I.TC_michelson_or (l,r) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in ok @@ I.TC_arrow (i,o) diff --git a/src/passes/8-typer-new/PP.ml b/src/passes/8-typer-new/PP.ml index c91f6905f..78520eb20 100644 --- a/src/passes/8-typer-new/PP.ml +++ b/src/passes/8-typer-new/PP.ml @@ -5,29 +5,30 @@ let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf -> function |SC_Constructor { tv; c_tag; tv_list=_ } -> let ct = match c_tag with - | Solver.Core.C_arrow -> "arrow" - | Solver.Core.C_option -> "option" - | Solver.Core.C_record -> failwith "record" - | Solver.Core.C_variant -> failwith "variant" - | Solver.Core.C_map -> "map" - | Solver.Core.C_big_map -> "big_map" - | Solver.Core.C_list -> "list" - | Solver.Core.C_set -> "set" - | Solver.Core.C_unit -> "unit" - | Solver.Core.C_bool -> "bool" - | Solver.Core.C_string -> "string" - | Solver.Core.C_nat -> "nat" - | Solver.Core.C_mutez -> "mutez" - | Solver.Core.C_timestamp -> "timestamp" - | Solver.Core.C_int -> "int" - | Solver.Core.C_address -> "address" - | Solver.Core.C_bytes -> "bytes" - | Solver.Core.C_key_hash -> "key_hash" - | Solver.Core.C_key -> "key" - | Solver.Core.C_signature -> "signature" - | Solver.Core.C_operation -> "operation" - | Solver.Core.C_contract -> "contract" - | Solver.Core.C_chain_id -> "chain_id" + | Solver.Core.C_arrow -> "arrow" + | Solver.Core.C_option -> "option" + | Solver.Core.C_record -> failwith "record" + | Solver.Core.C_variant -> failwith "variant" + | Solver.Core.C_map -> "map" + | Solver.Core.C_big_map -> "big_map" + | Solver.Core.C_michelson_or -> "michelson_or" + | Solver.Core.C_list -> "list" + | Solver.Core.C_set -> "set" + | Solver.Core.C_unit -> "unit" + | Solver.Core.C_bool -> "bool" + | Solver.Core.C_string -> "string" + | Solver.Core.C_nat -> "nat" + | Solver.Core.C_mutez -> "mutez" + | Solver.Core.C_timestamp -> "timestamp" + | Solver.Core.C_int -> "int" + | Solver.Core.C_address -> "address" + | Solver.Core.C_bytes -> "bytes" + | Solver.Core.C_key_hash -> "key_hash" + | Solver.Core.C_key -> "key" + | Solver.Core.C_signature -> "signature" + | Solver.Core.C_operation -> "operation" + | Solver.Core.C_contract -> "contract" + | Solver.Core.C_chain_id -> "chain_id" in fprintf ppf "CTOR %a %s()" Var.pp tv ct |SC_Alias (a, b) -> fprintf ppf "Alias %a %a" Var.pp a Var.pp b diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 25409822f..81c53ed9a 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -71,6 +71,7 @@ module Wrap = struct | TC_map ( k , v ) -> (C_map, [k;v]) | TC_big_map ( k , v) -> (C_big_map, [k;v]) | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) + | TC_michelson_or ( k , v) -> (C_michelson_or, [k;v]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) | TC_list l -> (C_list, [l]) | TC_contract c -> (C_contract, [c]) @@ -104,7 +105,8 @@ module Wrap = struct | TC_set s -> (C_set , [s]) | TC_map ( k , v ) -> (C_map , [k;v]) | TC_big_map ( k , v ) -> (C_big_map, [k;v]) - | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) + | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) + | TC_michelson_or ( k , v ) -> (C_michelson_or, [k;v]) | TC_contract c -> (C_contract, [c]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) ) @@ -749,93 +751,97 @@ let compare_simple_c_constant = function | C_arrow -> (function (* N/A -> 1 *) | C_arrow -> 0 - | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_option -> (function | C_arrow -> 1 | C_option -> 0 - | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_record -> (function | C_arrow | C_option -> 1 | C_record -> 0 - | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_variant -> (function | C_arrow | C_option | C_record -> 1 | C_variant -> 0 - | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_map -> (function | C_arrow | C_option | C_record | C_variant -> 1 | C_map -> 0 - | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_big_map -> (function | C_arrow | C_option | C_record | C_variant | C_map -> 1 | C_big_map -> 0 + | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_michelson_or -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1 + | C_michelson_or -> 0 | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_list -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or -> 1 | C_list -> 0 | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_set -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list -> 1 | C_set -> 0 | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_unit -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set -> 1 | C_unit -> 0 | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_bool -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit -> 1 | C_bool -> 0 | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_string -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool -> 1 | C_string -> 0 | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_nat -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string -> 1 | C_nat -> 0 | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_mutez -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1 | C_mutez -> 0 | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_timestamp -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1 | C_timestamp -> 0 | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_int -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1 | C_int -> 0 | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_address -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1 | C_address -> 0 | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_bytes -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1 | C_bytes -> 0 | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_key_hash -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1 | C_key_hash -> 0 | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_key -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 | C_key -> 0 | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_signature -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 | C_signature -> 0 | C_operation | C_contract | C_chain_id -> -1) | C_operation -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 | C_operation -> 0 | C_contract | C_chain_id -> -1) | C_contract -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 | C_contract -> 0 | C_chain_id -> -1) | C_chain_id -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1 + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_michelson_or | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1 | C_chain_id -> 0 (* N/A -> -1 *) ) @@ -851,6 +857,7 @@ let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag -> | Core.C_variant -> failwith "variant" | Core.C_map -> "map" | Core.C_big_map -> "big_map" + | Core.C_michelson_or -> "michelson_or" | Core.C_list -> "list" | Core.C_set -> "set" | Core.C_unit -> "unit" diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index ddbe3a139..e252d6617 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -349,6 +349,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_map_or_big_map (k,v) + | TC_michelson_or (l,r) -> + let%bind l = evaluate_type e l in + let%bind r = evaluate_type e r in + ok @@ O.TC_michelson_or (l,r) | TC_contract c -> let%bind c = evaluate_type e c in ok @@ O.TC_contract c @@ -845,6 +849,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in ok @@ I.TC_map_or_big_map (k,v) + | O.TC_michelson_or (l,r) -> + let%bind l = untype_type_expression l in + let%bind r = untype_type_expression r in + ok @@ I.TC_michelson_or (l,r) | O.TC_arrow ( arg , ret ) -> let%bind arg' = untype_type_expression arg in let%bind ret' = untype_type_expression ret in diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 1fd84ed0b..8348653cf 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -385,6 +385,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_map_or_big_map (k,v) + | TC_michelson_or (l,r) -> + let%bind l = evaluate_type e l in + let%bind r = evaluate_type e r in + ok @@ O.TC_michelson_or (l,r) | TC_arrow ( arg , ret ) -> let%bind arg' = evaluate_type e arg in let%bind ret' = evaluate_type e ret in diff --git a/src/passes/9-self_ast_typed/no_nested_big_map.ml b/src/passes/9-self_ast_typed/no_nested_big_map.ml index a0b2f869f..364859e2c 100644 --- a/src/passes/9-self_ast_typed/no_nested_big_map.ml +++ b/src/passes/9-self_ast_typed/no_nested_big_map.ml @@ -39,6 +39,10 @@ let rec check_no_nested_bigmap is_in_bigmap e = let%bind _ = check_no_nested_bigmap false a in let%bind _ = check_no_nested_bigmap false b in ok () + | T_operator (TC_michelson_or (a, b)) -> + let%bind _ = check_no_nested_bigmap false a in + let%bind _ = check_no_nested_bigmap false b in + ok () | T_sum s -> let es = CMap.to_list s in let%bind _ = bind_map_list (fun l -> check_no_nested_bigmap is_in_bigmap l) es in diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 74f7bfdc7..cc786c004 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -54,13 +54,14 @@ module Concrete_to_imperative = struct let type_operators s = match s with - "list" -> ok @@ TC_list unit_expr - | "option" -> ok @@ TC_option unit_expr - | "set" -> ok @@ TC_set unit_expr - | "map" -> ok @@ TC_map (unit_expr,unit_expr) - | "big_map" -> ok @@ TC_big_map (unit_expr,unit_expr) - | "contract" -> ok @@ TC_contract unit_expr - | _ -> simple_fail @@ "Not a built-in type (" ^ s ^ ")." + "list" -> ok @@ TC_list unit_expr + | "option" -> ok @@ TC_option unit_expr + | "set" -> ok @@ TC_set unit_expr + | "map" -> ok @@ TC_map (unit_expr,unit_expr) + | "big_map" -> ok @@ TC_big_map (unit_expr,unit_expr) + | "michelson_or" -> ok @@ TC_michelson_or (unit_expr,unit_expr) + | "contract" -> ok @@ TC_contract unit_expr + | _ -> simple_fail @@ "Not a built-in type (" ^ s ^ ")." let pseudo_modules = function | "Tezos.chain_id" -> ok C_CHAIN_ID diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index a9ca9fe03..4d735677b 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -39,6 +39,7 @@ and type_operator : | TC_set te -> Format.asprintf "set(%a)" f te | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_michelson_or (l, r) -> Format.asprintf "Michelson_or (%a,%a)" f l f r | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 595471fc5..8cdcb1db2 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -60,6 +60,7 @@ let t_sum m : type_expression = let t_function type1 type2 : type_expression = make_t @@ T_arrow {type1; type2} let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value)) let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value)) +let t_michelson_or l r : type_expression = make_t @@ T_operator (TC_michelson_or (l , r)) let t_set key : type_expression = make_t @@ T_operator (TC_set key) let t_contract contract : type_expression = make_t @@ T_operator (TC_contract contract) @@ -71,6 +72,7 @@ let t_operator op lst: type_expression result = | TC_option _ , [t] -> ok @@ t_option t | TC_map (_,_) , [kt;vt] -> ok @@ t_map kt vt | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map kt vt + | TC_michelson_or (_,_) , [l;r] -> ok @@ t_michelson_or l r | TC_contract _ , [t] -> ok @@ t_contract t | _ , _ -> fail @@ bad_type_operator op diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 6c396fb08..e9a48a87e 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -22,6 +22,7 @@ and type_operator = | TC_set of type_expression | TC_map of type_expression * type_expression | TC_big_map of type_expression * type_expression + | TC_michelson_or of type_expression * type_expression | TC_arrow of type_expression * type_expression and type_expression = {type_content: type_content} diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index b57e65bcb..419cbb724 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -35,6 +35,7 @@ and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_ | TC_set te -> Format.asprintf "set(%a)" f te | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_michelson_or (l, r) -> Format.asprintf "Michelson_or (%a,%a)" f l f r | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index cd648c754..767f5d744 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -21,6 +21,7 @@ and type_operator = | TC_list of type_expression | TC_set of type_expression | TC_map of type_expression * type_expression + | TC_michelson_or of type_expression * type_expression | TC_big_map of type_expression * type_expression | TC_arrow of type_expression * type_expression diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 8f6158109..6020f9539 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -341,8 +341,9 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : | (TC_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_map (kb,vb) | TC_map_or_big_map (kb,vb)) | (TC_big_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_big_map (kb,vb) | TC_map_or_big_map (kb,vb)) -> ok @@ ([ka;va] ,[kb;vb]) - | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _), - (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb + | TC_michelson_or (la,ra), TC_michelson_or (lb,rb) -> ok @@ ([la;ra] , [lb;rb]) + | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ | TC_michelson_or _ ), + (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ | TC_michelson_or _ ) -> fail @@ different_operators opa opb in if List.length lsta <> List.length lstb then fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 1877e2724..79fab238f 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -231,6 +231,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v | TC_map_or_big_map (k, v) -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v + | TC_michelson_or (k, v) -> Format.asprintf "michelson_or (%a,%a)" f k f v | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index a4c0c79e0..a0c19db52 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -54,6 +54,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_map of type_expression * type_expression | TC_big_map of type_expression * type_expression | TC_map_or_big_map of type_expression * type_expression + | TC_michelson_or of type_expression * type_expression | TC_arrow of type_expression * type_expression @@ -68,6 +69,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_map (x , y) -> TC_map (f x , f y) | TC_big_map (x , y)-> TC_big_map (f x , f y) | TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y) + | TC_michelson_or (x , y)-> TC_michelson_or (f x , f y) | TC_arrow (x, y) -> TC_arrow (f x, f y) let bind_map_type_operator f = function @@ -78,6 +80,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y) | TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y) | TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y) + | TC_michelson_or (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_michelson_or (x , y) | TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y) let type_operator_name = function @@ -88,6 +91,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_map _ -> "TC_map" | TC_big_map _ -> "TC_big_map" | TC_map_or_big_map _ -> "TC_map_or_big_map" + | TC_michelson_or _ -> "TC_michelson_or" | TC_arrow _ -> "TC_arrow" let type_expression'_of_string = function @@ -120,14 +124,15 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct failwith "internal error: unknown type operator" let string_of_type_operator = function - | TC_contract x -> "TC_contract" , [x] - | TC_option x -> "TC_option" , [x] - | TC_list x -> "TC_list" , [x] - | TC_set x -> "TC_set" , [x] - | TC_map (x , y) -> "TC_map" , [x ; y] - | TC_big_map (x , y) -> "TC_big_map" , [x ; y] - | TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] - | TC_arrow (x , y) -> "TC_arrow" , [x ; y] + | TC_contract x -> "TC_contract" , [x] + | TC_option x -> "TC_option" , [x] + | TC_list x -> "TC_list" , [x] + | TC_set x -> "TC_set" , [x] + | TC_map (x , y) -> "TC_map" , [x ; y] + | TC_big_map (x , y) -> "TC_big_map" , [x ; y] + | TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] + | TC_michelson_or (x , y) -> "TC_michelson_or" , [x ; y] + | TC_arrow (x , y) -> "TC_arrow" , [x ; y] let string_of_type_constant = function | TC_unit -> "TC_unit", [] diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index fc09e2637..fd62f2467 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -15,13 +15,14 @@ type constant_tag = | C_variant (* ( label , * ) … -> * *) | C_map (* * -> * -> * *) | C_big_map (* * -> * -> * *) + | C_michelson_or (* * -> * -> * *) | C_list (* * -> * *) | C_set (* * -> * *) | C_unit (* * *) | C_bool (* * *) | C_string (* * *) | C_nat (* * *) - | C_mutez (* * *) + | C_mutez (* * *) | C_timestamp (* * *) | C_int (* * *) | C_address (* * *) @@ -75,10 +76,11 @@ let type_expression'_of_simple_c_constant = function | C_set , [x] -> ok @@ Ast_typed.T_operator(TC_set x) | C_map , [x ; y] -> ok @@ Ast_typed.T_operator(TC_map (x , y)) | C_big_map , [x ; y] -> ok @@ Ast_typed.T_operator(TC_big_map (x, y)) + | C_michelson_or , [x ; y] -> ok @@ Ast_typed.T_operator(TC_michelson_or (x, y)) | C_arrow , [x ; y] -> ok @@ Ast_typed.T_operator(TC_arrow (x, y)) | C_record , _lst -> ok @@ failwith "records are not supported yet: T_record lst" | C_variant , _lst -> ok @@ failwith "sums are not supported yet: T_sum lst" - | (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow ), _ -> + | (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow | C_michelson_or ), _ -> failwith "internal error: wrong number of arguments for type operator" | C_unit , [] -> ok @@ Ast_typed.T_constant(TC_unit)