From 4af42cb1bd28a87e791dfa48651541e22c023bc5 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 27 Mar 2020 16:22:07 +0100 Subject: [PATCH 1/3] michelson_or types are transformed into variant types --- src/passes/10-transpiler/transpiler.ml | 4 ++ src/passes/10-transpiler/untranspiler.ml | 12 +++++ .../3-self_ast_imperative/michelson_or.ml | 9 ++++ .../self_ast_imperative.ml | 1 + .../imperative_to_sugar.ml | 6 +++ src/passes/6-sugar_to_core/sugar_to_core.ml | 6 +++ src/passes/8-typer-new/PP.ml | 47 ++++++++-------- src/passes/8-typer-new/solver.ml | 53 +++++++++++-------- src/passes/8-typer-new/typer.ml | 8 +++ src/passes/8-typer-old/typer.ml | 4 ++ .../9-self_ast_typed/no_nested_big_map.ml | 4 ++ src/passes/operators/operators.ml | 15 +++--- src/stages/1-ast_imperative/PP.ml | 1 + src/stages/1-ast_imperative/combinators.ml | 2 + src/stages/1-ast_imperative/types.ml | 1 + src/stages/2-ast_sugar/PP.ml | 1 + src/stages/2-ast_sugar/types.ml | 1 + src/stages/4-ast_typed/misc.ml | 5 +- src/stages/common/PP.ml | 1 + src/stages/common/types.ml | 21 +++++--- src/stages/typesystem/core.ml | 6 ++- 21 files changed, 143 insertions(+), 65 deletions(-) create mode 100644 src/passes/3-self_ast_imperative/michelson_or.ml 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) From be5ad35fb943e220f2d9962d082bf822026109d7 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 27 Mar 2020 17:20:56 +0100 Subject: [PATCH 2/3] Force annotation for michelson_or --- src/passes/8-typer-old/typer.ml | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 8348653cf..b94a51475 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -88,6 +88,15 @@ module Errors = struct ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; ] in error ~data title message () + + let michelson_or (c:I.constructor') loc () = + let title = (thunk "michelson_or types must be annotated") in + let message () = "" in + let data = [ + ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c); + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () = let title () = "wrong arity" in @@ -341,7 +350,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind prev' = prev in let%bind v' = evaluate_type e v in let%bind () = match Environment.get_constructor k e with - | Some _ -> fail (redundant_constructor e k) + | Some _ -> + if I.CMap.mem (Constructor "M_left") m || I.CMap.mem (Constructor "M_right") m then + ok () + else fail (redundant_constructor e k) | None -> ok () in ok @@ I.CMap.add k v' prev' in @@ -477,6 +489,17 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression | None -> ok () | Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in ok(ae) + | E_constructor {constructor = Constructor s ; element} when String.equal s "M_left" || String.equal s "M_right" -> ( + let%bind t = trace_option (Errors.michelson_or (Constructor s) ae.location) @@ tv_opt in + let%bind expr' = type_expression' e element in + ( match t.type_content with + | T_sum c -> + let ct = I.CMap.find (I.Constructor s) c in + let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, ct) in + return (E_constructor {constructor = Constructor s; element=expr'}) t + | _ -> simple_fail "ll" + ) + ) (* Sum *) | E_constructor {constructor; element} -> let%bind (c_tv, sum_tv) = From f9d1928d8e8ada0397ad9972f735ded6658d1e6f Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 30 Mar 2020 13:20:14 +0200 Subject: [PATCH 3/3] michelson_or tests and changelog --- CHANGELOG.md | 4 ++ src/bin/expect_tests/contract_tests.ml | 4 +- src/bin/expect_tests/michelson_or_tests.ml | 41 +++++++++++++++++++ src/test/contracts/double_michelson_or.ligo | 11 +++++ src/test/contracts/double_michelson_or.mligo | 9 ++++ src/test/contracts/michelson_or_tree.mligo | 8 ++++ .../contracts/negative/bad_michelson_or.mligo | 7 ++++ 7 files changed, 82 insertions(+), 2 deletions(-) create mode 100644 src/bin/expect_tests/michelson_or_tests.ml create mode 100644 src/test/contracts/double_michelson_or.ligo create mode 100644 src/test/contracts/double_michelson_or.mligo create mode 100644 src/test/contracts/michelson_or_tree.mligo create mode 100644 src/test/contracts/negative/bad_michelson_or.mligo diff --git a/CHANGELOG.md b/CHANGELOG.md index 3fc44d2cb..ccdd86d90 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ ## [Unreleased] +## [Michelson or type] (https://gitlab.com/ligolang/ligo/-/merge_requests/530) +### Added +- New type michelson_or, will give control over or types instead of relying on LIGO variants. + ## [Support for self] (https://gitlab.com/ligolang/ligo/-/merge_requests/453) ### Added - support for `Tezos.self(%Entrypoint)` diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 6be4ef583..f16a38e0b 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1117,7 +1117,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#705 = #P in\n let p = rhs#705.0 in\n let s = rhs#705.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} +ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#712 = #P in\n let p = rhs#712.0 in\n let s = rhs#712.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} If you're not sure how to fix this error, you can @@ -1130,7 +1130,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#708 = #P in\n let p = rhs#708.0 in\n let s = rhs#708.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} +ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#715 = #P in\n let p = rhs#715.0 in\n let s = rhs#715.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} If you're not sure how to fix this error, you can diff --git a/src/bin/expect_tests/michelson_or_tests.ml b/src/bin/expect_tests/michelson_or_tests.ml new file mode 100644 index 000000000..2656620c9 --- /dev/null +++ b/src/bin/expect_tests/michelson_or_tests.ml @@ -0,0 +1,41 @@ +open Cli_expect + +let contract basename = + "../../test/contracts/" ^ basename +let bad_contract basename = + "../../test/contracts/negative/" ^ basename + +let%expect_test _ = + run_ligo_good [ "dry-run" ; contract "double_michelson_or.mligo" ; "main" ; "unit" ; "(M_left (1) : storage)" ] ; + [%expect {| ( LIST_EMPTY() , M_right("one") ) |}]; + + run_ligo_good [ "dry-run" ; contract "double_michelson_or.ligo" ; "main" ; "unit" ; "(M_left (1) : storage)" ] ; + [%expect {| ( LIST_EMPTY() , M_right("one") ) |}] + + +let%expect_test _ = + run_ligo_good [ "compile-contract" ; contract "michelson_or_tree.mligo" ; "main" ] ; + [%expect {| + { parameter unit ; + storage (or (int %m_left) (or %m_right (int %m_left) (nat %m_right))) ; + code { PUSH int 1 ; + LEFT nat ; + RIGHT int ; + DUP ; + NIL operation ; + PAIR ; + DIP { DROP 2 } } } |}] + +let%expect_test _ = + run_ligo_bad [ "compile-contract" ; bad_contract "bad_michelson_or.mligo" ; "main" ] ; + [%expect {| + ligo: in file "bad_michelson_or.mligo", line 6, characters 12-27. michelson_or types must be annotated: {"constructor":"M_right","location":"in file \"bad_michelson_or.mligo\", line 6, characters 12-27"} + + + If you're not sure how to fix this error, you can + do one of the following: + + * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ + * Ask a question on our Discord: https://discord.gg/9rhYaEt + * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new + * Check the changelog by running 'ligo changelog' |}] \ No newline at end of file diff --git a/src/test/contracts/double_michelson_or.ligo b/src/test/contracts/double_michelson_or.ligo new file mode 100644 index 000000000..e1b1d6595 --- /dev/null +++ b/src/test/contracts/double_michelson_or.ligo @@ -0,0 +1,11 @@ +type storage is michelson_or (int, string) +type foobar is michelson_or (int, int) + +type return is list (operation) * storage + +function main (const action : unit; const store : storage) : return is +block { + const foo : storage = (M_right ("one") : storage); + const bar : foobar = (M_right (1) : foobar) +} with + ((nil : list (operation)), (foo : storage)) \ No newline at end of file diff --git a/src/test/contracts/double_michelson_or.mligo b/src/test/contracts/double_michelson_or.mligo new file mode 100644 index 000000000..f69f2b151 --- /dev/null +++ b/src/test/contracts/double_michelson_or.mligo @@ -0,0 +1,9 @@ +type storage = (int,string) michelson_or +type foobar = (int, int ) michelson_or + +type return = operation list * storage + +let main (action, store : unit * storage) : return = + let foo = (M_right ("one") : storage) in + let bar = (M_right 1 : foobar) in + (([] : operation list), (foo: storage)) diff --git a/src/test/contracts/michelson_or_tree.mligo b/src/test/contracts/michelson_or_tree.mligo new file mode 100644 index 000000000..6f08f67bc --- /dev/null +++ b/src/test/contracts/michelson_or_tree.mligo @@ -0,0 +1,8 @@ +type inner_storage = (int,nat) michelson_or +type storage = (int,inner_storage) michelson_or + +type return = operation list * storage + +let main (action, store : unit * storage) : return = + let foo = (M_right (M_left 1 : inner_storage) : storage) in + (([] : operation list), (foo: storage)) diff --git a/src/test/contracts/negative/bad_michelson_or.mligo b/src/test/contracts/negative/bad_michelson_or.mligo new file mode 100644 index 000000000..08c7fe035 --- /dev/null +++ b/src/test/contracts/negative/bad_michelson_or.mligo @@ -0,0 +1,7 @@ +type storage = (int,string) michelson_or + +type return = operation list * storage + +let main (action, store : unit * storage) : return = + let foo = M_right ("one") in + (([] : operation list), (foo: storage))