balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'feature/michelson-or-type' into 'dev'

Browse Source 
michelson or type

See merge request ligolang/ligo!530
This commit is contained in:
Gabriel Alfour 2020-04-07 22:35:57 +00:00
commit 1f0519c8ee
28 changed files with 249 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
CHANGELOG.md
View File

@ -2,6 +2,10 @@
## [Unreleased] ## [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) ## [Support for self] (https://gitlab.com/ligolang/ligo/-/merge_requests/453)
### Added ### Added
- support for `Tezos.self(%Entrypoint)` - support for `Tezos.self(%Entrypoint)`

4
src/bin/expect_tests/contract_tests.ml
View File

@ -1117,7 +1117,7 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
[%expect {| [%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 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" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
[%expect {| [%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 If you're not sure how to fix this error, you can

41
src/bin/expect_tests/michelson_or_tests.ml Normal file
View File

@ -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' |}]

4
src/passes/10-transpiler/transpiler.ml
View File

@ -143,6 +143,10 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
ok (T_big_map kv') ok (T_big_map kv')
| T_operator (TC_map_or_big_map (_,_)) -> | T_operator (TC_map_or_big_map (_,_)) ->
fail @@ corner_case ~loc:"transpiler" "TC_map_or_big_map should have been resolved before transpilation" 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) -> | T_operator (TC_list t) ->
let%bind t' = transpile_type t in let%bind t' = transpile_type t in
ok (T_list t') ok (T_list t')

12
src/passes/10-transpiler/untranspiler.ml
View File

@ -186,6 +186,18 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
bind_fold_right_list aux init big_map' 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_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 -> ( | TC_list ty -> (
let%bind lst = let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@ trace_strong (wrong_mini_c_value "list" v) @@

9
src/passes/3-self_ast_imperative/michelson_or.ml Normal file
View File

@ -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

1
src/passes/3-self_ast_imperative/self_ast_imperative.ml
View File

@ -7,6 +7,7 @@ let all_expression_mapper = [
] ]
let all_type_expression_mapper = [ let all_type_expression_mapper = [
Entrypoints_length_limit.peephole_type_expression ; Entrypoints_length_limit.peephole_type_expression ;
Michelson_or.peephole_type_expression ;
] ]
let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper

6
src/passes/4-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -157,6 +157,9 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_big_map (k,v) 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) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in
ok @@ O.TC_arrow (i,o) 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) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v) 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) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o) ok @@ I.TC_arrow (i,o)

6
src/passes/6-sugar_to_core/sugar_to_core.ml
View File

@ -62,6 +62,9 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_big_map (k,v) 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) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in
ok @@ O.TC_arrow (i,o) 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 let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v) ok @@ I.TC_big_map (k,v)
| TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled" | 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) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o) ok @@ I.TC_arrow (i,o)

47
src/passes/8-typer-new/PP.ml
View File

@ -5,29 +5,30 @@ let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf ->
function function
|SC_Constructor { tv; c_tag; tv_list=_ } -> |SC_Constructor { tv; c_tag; tv_list=_ } ->
let ct = match c_tag with let ct = match c_tag with
| Solver.Core.C_arrow -> "arrow" | Solver.Core.C_arrow -> "arrow"
| Solver.Core.C_option -> "option" | Solver.Core.C_option -> "option"
| Solver.Core.C_record -> failwith "record" | Solver.Core.C_record -> failwith "record"
| Solver.Core.C_variant -> failwith "variant" | Solver.Core.C_variant -> failwith "variant"
| Solver.Core.C_map -> "map" | Solver.Core.C_map -> "map"
| Solver.Core.C_big_map -> "big_map" | Solver.Core.C_big_map -> "big_map"
| Solver.Core.C_list -> "list" | Solver.Core.C_michelson_or -> "michelson_or"
| Solver.Core.C_set -> "set" | Solver.Core.C_list -> "list"
| Solver.Core.C_unit -> "unit" | Solver.Core.C_set -> "set"
| Solver.Core.C_bool -> "bool" | Solver.Core.C_unit -> "unit"
| Solver.Core.C_string -> "string" | Solver.Core.C_bool -> "bool"
| Solver.Core.C_nat -> "nat" | Solver.Core.C_string -> "string"
| Solver.Core.C_mutez -> "mutez" | Solver.Core.C_nat -> "nat"
| Solver.Core.C_timestamp -> "timestamp" | Solver.Core.C_mutez -> "mutez"
| Solver.Core.C_int -> "int" | Solver.Core.C_timestamp -> "timestamp"
| Solver.Core.C_address -> "address" | Solver.Core.C_int -> "int"
| Solver.Core.C_bytes -> "bytes" | Solver.Core.C_address -> "address"
| Solver.Core.C_key_hash -> "key_hash" | Solver.Core.C_bytes -> "bytes"
| Solver.Core.C_key -> "key" | Solver.Core.C_key_hash -> "key_hash"
| Solver.Core.C_signature -> "signature" | Solver.Core.C_key -> "key"
| Solver.Core.C_operation -> "operation" | Solver.Core.C_signature -> "signature"
| Solver.Core.C_contract -> "contract" | Solver.Core.C_operation -> "operation"
| Solver.Core.C_chain_id -> "chain_id" | Solver.Core.C_contract -> "contract"
| Solver.Core.C_chain_id -> "chain_id"
in in
fprintf ppf "CTOR %a %s()" Var.pp tv ct fprintf ppf "CTOR %a %s()" Var.pp tv ct
|SC_Alias (a, b) -> fprintf ppf "Alias %a %a" Var.pp a Var.pp b |SC_Alias (a, b) -> fprintf ppf "Alias %a %a" Var.pp a Var.pp b

53
src/passes/8-typer-new/solver.ml
View File

@ -71,6 +71,7 @@ module Wrap = struct
| TC_map ( k , v ) -> (C_map, [k;v]) | TC_map ( k , v ) -> (C_map, [k;v])
| TC_big_map ( k , v) -> (C_big_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_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_list l -> (C_list, [l]) | TC_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c]) | TC_contract c -> (C_contract, [c])
@ -104,7 +105,8 @@ module Wrap = struct
| TC_set s -> (C_set , [s]) | TC_set s -> (C_set , [s])
| TC_map ( k , v ) -> (C_map , [k;v]) | TC_map ( k , v ) -> (C_map , [k;v])
| TC_big_map ( k , v ) -> (C_big_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_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
) )
@ -749,93 +751,97 @@ let compare_simple_c_constant = function
| C_arrow -> (function | C_arrow -> (function
(* N/A -> 1 *) (* N/A -> 1 *)
| C_arrow -> 0 | 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_option -> (function
| C_arrow -> 1 | C_arrow -> 1
| C_option -> 0 | 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_record -> (function
| C_arrow | C_option -> 1 | C_arrow | C_option -> 1
| C_record -> 0 | 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_variant -> (function
| C_arrow | C_option | C_record -> 1 | C_arrow | C_option | C_record -> 1
| C_variant -> 0 | 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_map -> (function
| C_arrow | C_option | C_record | C_variant -> 1 | C_arrow | C_option | C_record | C_variant -> 1
| C_map -> 0 | 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_big_map -> (function
| C_arrow | C_option | C_record | C_variant | C_map -> 1 | C_arrow | C_option | C_record | C_variant | C_map -> 1
| C_big_map -> 0 | 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 | 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_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_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 | 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_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_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 | 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_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_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 | 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_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_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 | 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_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_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 | 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_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_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 | 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_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_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 | 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_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_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 | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_int -> (function | 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_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_address -> (function | 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_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bytes -> (function | 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_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key_hash -> (function | 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_hash -> 0
| C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key -> (function | 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_key -> 0
| C_signature | C_operation | C_contract | C_chain_id -> -1) | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_signature -> (function | 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_signature -> 0
| C_operation | C_contract | C_chain_id -> -1) | C_operation | C_contract | C_chain_id -> -1)
| C_operation -> (function | 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_operation -> 0
| C_contract | C_chain_id -> -1) | C_contract | C_chain_id -> -1)
| C_contract -> (function | 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_contract -> 0
| C_chain_id -> -1) | C_chain_id -> -1)
| C_chain_id -> (function | 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 | C_chain_id -> 0
(* N/A -> -1 *) (* 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_variant -> failwith "variant"
| Core.C_map -> "map" | Core.C_map -> "map"
| Core.C_big_map -> "big_map" | Core.C_big_map -> "big_map"
| Core.C_michelson_or -> "michelson_or"
| Core.C_list -> "list" | Core.C_list -> "list"
| Core.C_set -> "set" | Core.C_set -> "set"
| Core.C_unit -> "unit" | Core.C_unit -> "unit"

8
src/passes/8-typer-new/typer.ml
View File

@ -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 k = evaluate_type e k in
let%bind v = evaluate_type e v in let%bind v = evaluate_type e v in
ok @@ O.TC_map_or_big_map (k,v) 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 -> | TC_contract c ->
let%bind c = evaluate_type e c in let%bind c = evaluate_type e c in
ok @@ O.TC_contract c 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 k = untype_type_expression k in
let%bind v = untype_type_expression v in let%bind v = untype_type_expression v in
ok @@ I.TC_map_or_big_map (k,v) 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 ) -> | O.TC_arrow ( arg , ret ) ->
let%bind arg' = untype_type_expression arg in let%bind arg' = untype_type_expression arg in
let%bind ret' = untype_type_expression ret in let%bind ret' = untype_type_expression ret in

29
src/passes/8-typer-old/typer.ml
View File

@ -88,6 +88,15 @@ module Errors = struct
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
] in ] in
error ~data title message () 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 wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in 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 prev' = prev in
let%bind v' = evaluate_type e v in let%bind v' = evaluate_type e v in
let%bind () = match Environment.get_constructor k e with 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 | None -> ok () in
ok @@ I.CMap.add k v' prev' ok @@ I.CMap.add k v' prev'
in 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 k = evaluate_type e k in
let%bind v = evaluate_type e v in let%bind v = evaluate_type e v in
ok @@ O.TC_map_or_big_map (k,v) 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 ) -> | TC_arrow ( arg , ret ) ->
let%bind arg' = evaluate_type e arg in let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret 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 () | None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in | Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in
ok(ae) 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 *) (* Sum *)
| E_constructor {constructor; element} -> | E_constructor {constructor; element} ->
let%bind (c_tv, sum_tv) = let%bind (c_tv, sum_tv) =

4
src/passes/9-self_ast_typed/no_nested_big_map.ml
View File

@ -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 a in
let%bind _ = check_no_nested_bigmap false b in let%bind _ = check_no_nested_bigmap false b in
ok () 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 -> | T_sum s ->
let es = CMap.to_list s in let es = CMap.to_list s in
let%bind _ = bind_map_list (fun l -> check_no_nested_bigmap is_in_bigmap l) es in let%bind _ = bind_map_list (fun l -> check_no_nested_bigmap is_in_bigmap l) es in

15
src/passes/operators/operators.ml
View File

@ -54,13 +54,14 @@ module Concrete_to_imperative = struct
let type_operators s = let type_operators s =
match s with match s with
"list" -> ok @@ TC_list unit_expr "list" -> ok @@ TC_list unit_expr
| "option" -> ok @@ TC_option unit_expr | "option" -> ok @@ TC_option unit_expr
| "set" -> ok @@ TC_set unit_expr | "set" -> ok @@ TC_set unit_expr
| "map" -> ok @@ TC_map (unit_expr,unit_expr) | "map" -> ok @@ TC_map (unit_expr,unit_expr)
| "big_map" -> ok @@ TC_big_map (unit_expr,unit_expr) | "big_map" -> ok @@ TC_big_map (unit_expr,unit_expr)
| "contract" -> ok @@ TC_contract unit_expr | "michelson_or" -> ok @@ TC_michelson_or (unit_expr,unit_expr)
| _ -> simple_fail @@ "Not a built-in type (" ^ s ^ ")." | "contract" -> ok @@ TC_contract unit_expr
| _ -> simple_fail @@ "Not a built-in type (" ^ s ^ ")."
let pseudo_modules = function let pseudo_modules = function
| "Tezos.chain_id" -> ok C_CHAIN_ID | "Tezos.chain_id" -> ok C_CHAIN_ID

1
src/stages/1-ast_imperative/PP.ml
View File

@ -39,6 +39,7 @@ and type_operator :
| TC_set te -> Format.asprintf "set(%a)" f te | TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | 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_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_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te | TC_contract te -> Format.asprintf "Contract (%a)" f te
in in

2
src/stages/1-ast_imperative/combinators.ml
View File

@ -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_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_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_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_set key : type_expression = make_t @@ T_operator (TC_set key)
let t_contract contract : type_expression = make_t @@ T_operator (TC_contract contract) 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_option _ , [t] -> ok @@ t_option t
| TC_map (_,_) , [kt;vt] -> ok @@ t_map kt vt | TC_map (_,_) , [kt;vt] -> ok @@ t_map kt vt
| TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_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 | TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op | _ , _ -> fail @@ bad_type_operator op

1
src/stages/1-ast_imperative/types.ml
View File

@ -22,6 +22,7 @@ and type_operator =
| TC_set of type_expression | TC_set of type_expression
| TC_map of type_expression * type_expression | TC_map of type_expression * type_expression
| TC_big_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 | TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content} and type_expression = {type_content: type_content}

1
src/stages/2-ast_sugar/PP.ml
View File

@ -35,6 +35,7 @@ and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_
| TC_set te -> Format.asprintf "set(%a)" f te | TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | 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_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_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te | TC_contract te -> Format.asprintf "Contract (%a)" f te
in in

1
src/stages/2-ast_sugar/types.ml
View File

@ -21,6 +21,7 @@ and type_operator =
| TC_list of type_expression | TC_list of type_expression
| TC_set of type_expression | TC_set of type_expression
| TC_map of type_expression * 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_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression | TC_arrow of type_expression * type_expression

5
src/stages/4-ast_typed/misc.ml
View File

@ -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_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)) | (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]) -> 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_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 _ ) -> fail @@ different_operators opa opb | (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 in
if List.length lsta <> List.length lstb then if List.length lsta <> List.length lstb then
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)

1
src/stages/common/PP.ml
View File

@ -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_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_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_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_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te | TC_contract te -> Format.asprintf "Contract (%a)" f te
in in

21
src/stages/common/types.ml
View File

@ -54,6 +54,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map of type_expression * type_expression | TC_map of type_expression * type_expression
| TC_big_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_map_or_big_map of type_expression * type_expression
| TC_michelson_or of type_expression * type_expression
| TC_arrow 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_map (x , y) -> TC_map (f x , f y)
| TC_big_map (x , y)-> TC_big_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_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) | TC_arrow (x, y) -> TC_arrow (f x, f y)
let bind_map_type_operator f = function 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_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_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_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) | 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 let type_operator_name = function
@ -88,6 +91,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_map _ -> "TC_map" | TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map" | TC_big_map _ -> "TC_big_map"
| TC_map_or_big_map _ -> "TC_map_or_big_map" | TC_map_or_big_map _ -> "TC_map_or_big_map"
| TC_michelson_or _ -> "TC_michelson_or"
| TC_arrow _ -> "TC_arrow" | TC_arrow _ -> "TC_arrow"
let type_expression'_of_string = function 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" failwith "internal error: unknown type operator"
let string_of_type_operator = function let string_of_type_operator = function
| TC_contract x -> "TC_contract" , [x] | TC_contract x -> "TC_contract" , [x]
| TC_option x -> "TC_option" , [x] | TC_option x -> "TC_option" , [x]
| TC_list x -> "TC_list" , [x] | TC_list x -> "TC_list" , [x]
| TC_set x -> "TC_set" , [x] | TC_set x -> "TC_set" , [x]
| TC_map (x , y) -> "TC_map" , [x ; y] | TC_map (x , y) -> "TC_map" , [x ; y]
| TC_big_map (x , y) -> "TC_big_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_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y]
| TC_arrow (x , y) -> "TC_arrow" , [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 let string_of_type_constant = function
| TC_unit -> "TC_unit", [] | TC_unit -> "TC_unit", []

6
src/stages/typesystem/core.ml
View File

@ -15,13 +15,14 @@ type constant_tag =
| C_variant (* ( label , * ) … -> * *) | C_variant (* ( label , * ) … -> * *)
| C_map (* * -> * -> * *) | C_map (* * -> * -> * *)
| C_big_map (* * -> * -> * *) | C_big_map (* * -> * -> * *)
| C_michelson_or (* * -> * -> * *)
| C_list (* * -> * *) | C_list (* * -> * *)
| C_set (* * -> * *) | C_set (* * -> * *)
| C_unit (* * *) | C_unit (* * *)
| C_bool (* * *) | C_bool (* * *)
| C_string (* * *) | C_string (* * *)
| C_nat (* * *) | C_nat (* * *)
| C_mutez (* * *) | C_mutez (* * *)
| C_timestamp (* * *) | C_timestamp (* * *)
| C_int (* * *) | C_int (* * *)
| C_address (* * *) | 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_set , [x] -> ok @@ Ast_typed.T_operator(TC_set x)
| C_map , [x ; y] -> ok @@ Ast_typed.T_operator(TC_map (x , y)) | 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_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_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_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_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" failwith "internal error: wrong number of arguments for type operator"
| C_unit , [] -> ok @@ Ast_typed.T_constant(TC_unit) | C_unit , [] -> ok @@ Ast_typed.T_constant(TC_unit)

11
src/test/contracts/double_michelson_or.ligo Normal file
View File

@ -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))

9
src/test/contracts/double_michelson_or.mligo Normal file
View File

@ -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))

8
src/test/contracts/michelson_or_tree.mligo Normal file
View File

@ -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))

7
src/test/contracts/negative/bad_michelson_or.mligo Normal file
View File

@ -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))