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/gitlab-pages/docs/reference/toplevel.md b/gitlab-pages/docs/reference/toplevel.md
index 91a39aa3b..ce19cfa08 100644
--- a/gitlab-pages/docs/reference/toplevel.md
+++ b/gitlab-pages/docs/reference/toplevel.md
@@ -65,7 +65,7 @@ function failwith : string -> unit
val failwith : string -> unit
-let failwith : string => unit
+let failwith: string => unit
Cause the contract to fail with an error message.
@@ -80,7 +80,48 @@ function assert : bool -> unit
val assert : bool -> unit
-let assert : bool => unit
+let assert: bool => unit
Check if a certain condition has been met. If not the contract will fail.
+
+
+function ediv : int -> int -> option (int * nat)
+
+
+function ediv : mutez -> nat -> option (mutez * mutez)
+
+
+function ediv : mutez -> mutez -> option (nat * mutez)
+
+
+function ediv : nat -> nat -> option (nat * nat)
+
+
+
+val ediv : int -> int -> (int * nat) option
+
+
+val ediv : mutez -> nat -> (mutez * mutez) option
+
+
+val ediv : mutez -> mutez -> (nat * mutez) option
+
+
+val ediv : nat -> nat -> (nat * nat) option
+
+
+
+let ediv: (int, int) => option((int, nat))
+
+
+let ediv: (mutez, nat) => option((mutez, mutez))
+
+
+let ediv: (mutez, mutez) => option((nat, mutez))
+
+
+let ediv: (nat, nat) => option((nat, nat))
+
+
+Compiles to Michelson `EDIV`, one operation to get both the quotient and remainder of a division. `ediv x y` returns None if `y` is zero, otherwise returns `Some (quotient, remainder)` such that `x = (quotient * y) + remainder` and `0 <= remainder < abs(y)`.
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/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..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
@@ -385,6 +397,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
@@ -473,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) =
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)
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))