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

michelson_or custom layout and annotations

Browse Source
This commit is contained in:
Lesenechal Remi 2020-04-16 22:48:34 +02:00
parent 5d35aaec58
commit e94f445a51
52 changed files with 294 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/passes/1-parser/cameligo/AST.ml
View File

@ -166,6 +166,7 @@ and type_expr =
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
| TStringLiteral of Lexer.lexeme reg
and cartesian = (type_expr, times) nsepseq reg
@ -407,6 +408,7 @@ let type_expr_to_region = function
| TApp {region; _}
| TFun {region; _}
| TPar {region; _}
| TStringLiteral {region; _}
| TVar {region; _} -> region
let list_pattern_to_region = function

1
src/passes/1-parser/cameligo/Parser.mly
View File

@ -149,6 +149,7 @@ cartesian:
core_type:
type_name { TVar $1 }
| par(type_expr) { TPar $1 }
| "<string>" { TStringLiteral $1 }
| module_name "." type_name {
let module_name = $1.value in
let type_name = $3.value in

4
src/passes/1-parser/cameligo/ParserLog.ml
View File

@ -156,6 +156,7 @@ and print_type_expr state = function
| TPar par -> print_type_par state par
| TVar var -> print_var state var
| TFun t -> print_fun_type state t
| TStringLiteral s -> print_string state s
and print_fun_type state {value; _} =
let domain, arrow, range = value in
@ -1124,6 +1125,9 @@ and pp_type_expr state = function
| TVar v ->
pp_node state "TVar";
pp_ident (state#pad 1 0) v
| TStringLiteral s ->
pp_node state "String";
pp_string (state#pad 1 0) s
and pp_type_tuple state {value; _} =
let components = Utils.nsepseq_to_list value.inside in

2
src/passes/1-parser/pascaligo/AST.ml
View File

@ -185,6 +185,7 @@ and type_expr =
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
| TStringLiteral of Lexer.lexeme reg
and cartesian = (type_expr, times) nsepseq reg
@ -658,6 +659,7 @@ let type_expr_to_region = function
| TApp {region; _}
| TFun {region; _}
| TPar {region; _}
| TStringLiteral {region; _}
| TVar {region; _} -> region
let rec expr_to_region = function

1
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -161,6 +161,7 @@ cartesian:
core_type:
type_name { TVar $1 }
| "<string>" { TStringLiteral $1 }
| par(type_expr) { TPar $1 }
| type_name type_tuple {
let region = cover $1.region $2.region

4
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -153,6 +153,7 @@ and print_type_expr state = function
| TFun type_fun -> print_type_fun state type_fun
| TPar par_type -> print_par_type state par_type
| TVar type_var -> print_var state type_var
| TStringLiteral s -> print_string state s
and print_cartesian state {value; _} =
print_nsepseq state "*" print_type_expr value
@ -940,6 +941,9 @@ and pp_type_expr state = function
field_decl.value in
let fields = Utils.nsepseq_to_list value.ne_elements in
List.iteri (List.length fields |> apply) fields
| TStringLiteral s ->
pp_node state "String";
pp_string (state#pad 1 0) s
and pp_cartesian state {value; _} =
let apply len rank =

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

@ -258,10 +258,6 @@ 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')
@ -276,9 +272,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
let%bind result' = transpile_type result in
ok (T_function (param', result'))
)
(* TODO hmm *)
| T_sum m ->
let is_michelson_or = Ast_typed.Helpers.is_michelson_or m in
| T_sum m when Ast_typed.Helpers.is_michelson_or m ->
let node = Append_tree.of_list @@ kv_list_of_cmap m in
let aux a b : type_value annotated result =
let%bind a = a in
@ -286,14 +280,22 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
ok (None, T_or (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (Ast_typed.Types.Constructor ann, a) ->
let%bind a = transpile_type a in
ok ((
if is_michelson_or then
None
else
Some (String.uncapitalize_ascii ann)),
a))
(fun (_, ({ctor_type ; michelson_annotation}: AST.ctor_content)) ->
let%bind a = transpile_type ctor_type in
ok (michelson_annotation, a) )
aux node in
ok @@ snd m'
| T_sum m ->
let node = Append_tree.of_list @@ kv_list_of_cmap m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
ok (None, T_or (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (Ast_typed.Types.Constructor ann, ({ctor_type ; _}: AST.ctor_content)) ->
let%bind a = transpile_type ctor_type in
ok (Some (String.uncapitalize_ascii ann), a))
aux node in
ok @@ snd m'
| T_record m ->
@ -368,7 +370,8 @@ and transpile_environment_element_type : AST.environment_element -> type_value r
and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in
ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv
let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in
ok @@ Append_tree.of_list kt_list
and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind tv = transpile_type ae.type_expression in

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

@ -185,18 +185,6 @@ 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=l_ty; r=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) @@
@ -232,7 +220,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
fail @@ bad_untranspile "contract" v
)
| T_sum m ->
let lst = kv_list_of_cmap m in
let lst = List.map (fun (k,{ctor_type;_}) -> (k,ctor_type)) @@ kv_list_of_cmap m in
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
| Full t -> ok t

34
src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -160,6 +160,10 @@ open Operators.Concrete_to_imperative.Cameligo
let r_split = Location.r_split
let get_t_string_singleton_opt = function
| Raw.TStringLiteral s -> Some (String.(sub s.value 1 ((length s.value)-2)))
| _ -> None
let rec pattern_to_var : Raw.pattern -> _ = fun p ->
match p with
| Raw.PPar p -> pattern_to_var p.value.inside
@ -236,12 +240,29 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
| TApp x -> (
let (x,loc) = r_split x in
let (name, tuple) = x in
let lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_map_list compile_type_expression lst in
let%bind cst =
trace (unknown_predefined_type name) @@
type_operators name.value in
t_operator ~loc cst lst'
( match name.value with
| "michelson_or" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
let%bind b' =
trace_option (simple_error "second argument of michelson_or must be a string singleton") @@
get_t_string_singleton_opt b in
let%bind d' =
trace_option (simple_error "fourth argument of michelson_or must be a string singleton") @@
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d'
)
| _ -> simple_fail "michelson_or does not have the right number of argument")
| _ ->
let lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_map_list compile_type_expression lst in
let%bind cst =
trace (unknown_predefined_type name) @@
type_operators name.value in
t_operator ~loc cst lst' )
)
| TProd p -> (
let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in
@ -274,6 +295,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
@@ npseq_to_list s in
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TStringLiteral _s -> simple_fail "we don't support singleton string type"
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with

36
src/passes/2-concrete_to_imperative/pascaligo.ml
View File

@ -142,6 +142,10 @@ let return_statement expr = ok @@ fun expr'_opt ->
| None -> ok @@ expr
| Some expr' -> ok @@ e_sequence expr expr'
let get_t_string_singleton_opt = function
| Raw.TStringLiteral s -> Some (String.(sub s.value 1 ((length s.value)-2)))
| _ -> None
let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
match t with
@ -162,13 +166,30 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
| TApp x ->
let (x, loc) = r_split x in
let (name, tuple) = x in
let lst = npseq_to_list tuple.value.inside in
let%bind lst =
bind_list @@ List.map compile_type_expression lst in (** TODO: fix constant and operator*)
let%bind cst =
trace (unknown_predefined_type name) @@
type_operators name.value in
t_operator ~loc cst lst
(match name.value with
| "michelson_or" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
let%bind b' =
trace_option (simple_error "second argument of michelson_or must be a string singleton") @@
get_t_string_singleton_opt b in
let%bind d' =
trace_option (simple_error "fourth argument of michelson_or must be a string singleton") @@
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d'
)
| _ -> simple_fail "michelson_or does not have the right number of argument")
| _ ->
let lst = npseq_to_list tuple.value.inside in
let%bind lst =
bind_list @@ List.map compile_type_expression lst in (** TODO: fix constant and operator*)
let%bind cst =
trace (unknown_predefined_type name) @@
type_operators name.value in
t_operator ~loc cst lst)
| TProd p ->
let%bind tpl = compile_list_type_expression
@@ npseq_to_list p.value in
@ -203,6 +224,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
@@ npseq_to_list s in
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TStringLiteral _s -> simple_fail "we don't support singleton string type"
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with

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

@ -1,9 +0,0 @@
open Ast_imperative
open Trace
let peephole_type_expression : type_expression -> type_expression result = fun e ->
let return type_content = ok { type_content; location=e.location } 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,7 +7,6 @@ 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

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

@ -3,6 +3,15 @@ module O = Ast_sugar
open Trace
module Errors = struct
let corner_case loc =
let title () = "corner case" in
let message () = Format.asprintf "corner case, please report to developers\n" in
let data = [
("location",
fun () -> Format.asprintf "%s" loc)
] in
error ~data title message
let bad_collection expr =
let title () = "" in
let message () = Format.asprintf "\nCannot loop over this collection : %a\n" I.PP.expression expr in
@ -110,7 +119,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
let%bind sum =
bind_map_list (fun (k,v) ->
let%bind v = compile_type_expression v in
ok @@ (k,v)
let content : O.ctor_content = {ctor_type = v ; michelson_annotation = None} in
ok @@ (k,content)
) sum
in
return @@ O.T_sum (O.CMap.of_list sum)
@ -132,6 +142,13 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator (TC_michelson_or (l,l_ann,r,r_ann)) ->
let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
let sum : (O.constructor' * O.ctor_content) list = [
(O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann});
(O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann}); ]
in
return @@ O.T_sum (O.CMap.of_list sum)
| I.T_operator type_operator ->
let%bind type_operator = compile_type_operator type_operator in
return @@ T_operator type_operator
@ -157,12 +174,10 @@ 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)
| TC_michelson_or _ -> fail @@ Errors.corner_case __LOC__
let rec compile_expression : I.expression -> O.expression result =
fun e ->
@ -558,10 +573,12 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let return te = ok @@ I.make_t te in
match te.type_content with
| O.T_sum sum ->
(* This type sum could be a michelson_or as well, we could use is_michelson_or *)
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let%bind v = uncompile_type_expression v in
let {ctor_type;_} : O.ctor_content = v in
let%bind v = uncompile_type_expression ctor_type in
ok @@ (k,v)
) sum
in
@ -609,9 +626,6 @@ 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)

7
src/passes/5-self_ast_sugar/helpers.ml
View File

@ -2,6 +2,13 @@ open Ast_sugar
open Trace
open Stage_common.Helpers
let bind_map_cmap f map = bind_cmap (
CMap.map
(fun ({ctor_type;_} as ctor) ->
let%bind ctor' = f ctor_type in
ok {ctor with ctor_type = ctor'})
map)
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in

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

@ -10,8 +10,10 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let%bind v = idle_type_expression v in
ok @@ (k,v)
let {ctor_type ; michelson_annotation} : I.ctor_content = v in
let%bind ctor_type = idle_type_expression ctor_type in
let v' : O.ctor_content = {ctor_type ; michelson_annotation} in
ok @@ (k,v')
) sum
in
return @@ O.T_sum (O.CMap.of_list sum)
@ -62,9 +64,6 @@ 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)
@ -244,8 +243,10 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let sum = I.CMap.to_kv_list sum in
let%bind sum =
bind_map_list (fun (k,v) ->
let%bind v = uncompile_type_expression v in
ok @@ (k,v)
let {ctor_type;michelson_annotation} : O.ctor_content = v in
let%bind ctor_type = uncompile_type_expression ctor_type in
let v' : I.ctor_content = {ctor_type;michelson_annotation} in
ok @@ (k,v')
) sum
in
return @@ I.T_sum (O.CMap.of_list sum)
@ -290,9 +291,6 @@ 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)

10
src/passes/7-self_ast_core/helpers.ml
View File

@ -2,6 +2,16 @@ open Ast_core
open Trace
open Stage_common.Helpers
include Stage_common.PP
include Stage_common.Types.Ast_generic_type(Ast_core_parameter)
let bind_map_cmap f map = bind_cmap (
CMap.map
(fun ({ctor_type;_} as ctor) ->
let%bind ctor' = f ctor_type in
ok {ctor with ctor_type = ctor'})
map)
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in

24
src/passes/7-self_ast_core/self_ast_core.ml Normal file
View File

@ -0,0 +1,24 @@
open Trace
let all_expression_mapper = [
]
let all_type_expression_mapper = [
]
let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper
let all_ty = List.map (fun el -> Helpers.Type_expression el) all_type_expression_mapper
let all_program =
let all_p = List.map Helpers.map_program all_exp in
let all_p2 = List.map Helpers.map_program all_ty in
bind_chain (List.append all_p all_p2)
let all_expression =
let all_p = List.map Helpers.map_expression all_expression_mapper in
bind_chain all_p
let map_expression = Helpers.map_expression
let fold_expression = Helpers.fold_expression
let fold_map_expression = Helpers.fold_map_expression

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

@ -11,7 +11,6 @@ let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf ->
| 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"

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

@ -387,97 +387,93 @@ 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_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 | 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 -> (function
| C_arrow -> 1
| C_option -> 0
| 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 | 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 -> (function
| C_arrow | C_option -> 1
| C_record -> 0
| 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 | 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 -> (function
| C_arrow | C_option | C_record -> 1
| C_variant -> 0
| 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 | 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 -> (function
| C_arrow | C_option | C_record | C_variant -> 1
| C_map -> 0
| 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 | 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 | C_michelson_or -> 1
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 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_michelson_or | C_list -> 1
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | 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_michelson_or | C_list | C_set -> 1
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | 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_michelson_or | C_list | C_set | C_unit -> 1
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | 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_michelson_or | C_list | C_set | C_unit | C_bool -> 1
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | 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_michelson_or | 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_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_michelson_or | 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_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_michelson_or | 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_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_michelson_or | 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_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_michelson_or | 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_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_michelson_or | 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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_contract -> 0
| C_chain_id -> -1)
| C_chain_id -> (function
| 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_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_chain_id -> 0
(* N/A -> -1 *)
)
@ -493,7 +489,6 @@ 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"

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

@ -138,8 +138,9 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| T_sum m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ O.CMap.add (convert_constructor' k) v' prev'
let {ctor_type ; michelson_annotation} : I.ctor_content = v in
let%bind ctor_type = evaluate_type e ctor_type in
ok @@ O.CMap.add (convert_constructor' k) ({ctor_type ; michelson_annotation}:O.ctor_content) prev'
in
let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
return (T_sum m)
@ -181,10 +182,6 @@ 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

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

@ -149,9 +149,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
(* TODO: or should we use t.core if present? *)
let%bind t = match t.type_content with
| O.T_sum x ->
let aux k v acc =
let aux k ({ctor_type ; michelson_annotation} : O.ctor_content) acc =
let%bind acc = acc in
let%bind v' = untype_type_expression v in
let%bind ctor_type = untype_type_expression ctor_type in
let v' : I.ctor_content = {ctor_type ; michelson_annotation} in
ok @@ I.CMap.add (unconvert_constructor' k) v' acc in
let%bind x' = O.CMap.fold aux x (ok I.CMap.empty) in
ok @@ I.T_sum x'
@ -192,10 +193,6 @@ 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 { type1=arg ; type2=ret } ->
let%bind arg' = untype_type_expression arg in
let%bind ret' = untype_type_expression ret in

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

@ -34,7 +34,8 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun
match te.type_content with
| T_sum kvmap ->
let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_variant, T.CMap.to_list @@ T.CMap.map type_expression_to_type_value kvmap)
let tlist = List.map (fun ({ctor_type;_}:T.ctor_content) -> ctor_type) (T.CMap.to_list kvmap) in
P_constant (C_variant, List.map type_expression_to_type_value tlist)
| T_record kvmap ->
let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap)
@ -69,7 +70,6 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun
| 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 { l; r } -> (C_michelson_or, [l;r])
| TC_arrow { type1 ; type2 } -> (C_arrow, [ type1 ; type2 ])
| TC_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c])
@ -81,7 +81,8 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
match te.type_content with
| T_sum kvmap ->
let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_variant, I.CMap.to_list @@ I.CMap.map type_expression_to_type_value_copypasted kvmap)
let tlist = List.map (fun ({ctor_type;_}:I.ctor_content) -> ctor_type) (I.CMap.to_list kvmap) in
P_constant (C_variant, List.map type_expression_to_type_value_copypasted tlist)
| T_record kvmap ->
let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap)
@ -104,7 +105,6 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
| 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_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
)

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

@ -596,15 +596,16 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
let%bind type2 = evaluate_type e type2 in
return (T_arrow {type1;type2})
| T_sum m ->
let aux k v prev =
let aux k ({ctor_type;michelson_annotation} : I.ctor_content) prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
let%bind ctor_type = evaluate_type e ctor_type in
let%bind () = match Environment.get_constructor k e with
| 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
let v' : O.ctor_content = {ctor_type;michelson_annotation} in
ok @@ O.CMap.add (convert_constructor' k) v' prev'
in
let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
@ -647,10 +648,6 @@ 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
@ -744,8 +741,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind expr' = type_expression' e element in
( match t.type_content with
| T_sum c ->
let ct = O.CMap.find (O.Constructor s) c in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, ct) in
let {ctor_type ; _} : O.ctor_content = O.CMap.find (O.Constructor s) c in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, ctor_type) in
return (E_constructor {constructor = Constructor s; element=expr'}) t
| _ -> simple_fail "ll"
)

6
src/passes/9-self_ast_typed/contract_passes.ml
View File

@ -62,8 +62,10 @@ let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data
| E_literal (Literal_string ep) -> check_entrypoint_annotation_format ep entrypoint_exp
| _ -> fail @@ Errors.entrypoint_annotation_not_literal entrypoint_exp.location in
let%bind entrypoint_t = match dat.contract_type.parameter.type_content with
| T_sum cmap -> trace_option (Errors.unmatched_entrypoint entrypoint_exp.location)
@@ CMap.find_opt (Constructor entrypoint) cmap
| T_sum cmap ->
let%bind {ctor_type;_} = trace_option (Errors.unmatched_entrypoint entrypoint_exp.location) @@
CMap.find_opt (Constructor entrypoint) cmap in
ok ctor_type
| t -> ok {dat.contract_type.parameter with type_content = t} in
let%bind () =
trace_strong (bad_self_err ()) @@

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

@ -39,12 +39,8 @@ let rec check_no_nested_bigmap is_in_bigmap e =
let%bind _ = check_no_nested_bigmap false type1 in
let%bind _ = check_no_nested_bigmap false type2 in
ok ()
| T_operator (TC_michelson_or {l; r}) ->
let%bind _ = check_no_nested_bigmap false l in
let%bind _ = check_no_nested_bigmap false r in
ok ()
| T_sum s ->
let es = CMap.to_list s in
let es = List.map (fun {ctor_type;_} -> ctor_type) (CMap.to_list s) in
let%bind _ = bind_map_list (fun l -> check_no_nested_bigmap is_in_bigmap l) es in
ok ()
| T_record elm ->

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

@ -59,7 +59,7 @@ module Concrete_to_imperative = struct
| "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)
| "michelson_or" -> ok @@ TC_michelson_or (unit_expr,"",unit_expr,"")
| "contract" -> ok @@ TC_contract unit_expr
| _ -> simple_fail @@ "Not a built-in type (" ^ s ^ ")."

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

@ -5,6 +5,14 @@ open PP_helpers
include Stage_common.PP
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
@ -39,7 +47,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_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

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

@ -59,9 +59,9 @@ let t_sum ?loc m : type_expression =
let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2}
let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
let t_michelson_or ?loc l r : type_expression = make_t ?loc @@ T_operator (TC_michelson_or (l , r))
let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set key)
let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
let t_michelson_or ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_or (l, l_ann, r, r_ann))
(* TODO find a better way than using list*)
let t_operator ?loc op lst: type_expression result =
@ -71,7 +71,7 @@ let t_operator ?loc op lst: type_expression result =
| TC_option _ , [t] -> ok @@ t_option ?loc t
| TC_map (_,_) , [kt;vt] -> ok @@ t_map ?loc kt vt
| TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
| TC_michelson_or (_,_) , [l;r] -> ok @@ t_michelson_or ?loc l r
| TC_michelson_or (_,l_ann,_,r_ann) , [l;r] -> ok @@ t_michelson_or ?loc l l_ann r r_ann
| TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op

4
src/stages/1-ast_imperative/combinators.mli
View File

@ -42,6 +42,10 @@ val ez_t_sum : ?loc:Location.t -> ( string * type_expression ) list -> type_expr
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_michelson_or : ?loc:Location.t ->
type_expression ->
michelson_prct_annotation ->
type_expression -> michelson_prct_annotation -> type_expression
val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
val t_set : ?loc:Location.t -> type_expression -> type_expression

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

@ -15,6 +15,8 @@ type type_content =
and arrow = {type1: type_expression; type2: type_expression}
and michelson_prct_annotation = string
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
@ -22,7 +24,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_michelson_or of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation
| TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content; location: Location.t}

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

@ -4,6 +4,15 @@ open Format
open PP_helpers
include Stage_common.PP
include Stage_common.PP.Ast_PP_type(Ast_sugar_parameter)
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, {ctor_type;_}) = fprintf ppf "@[<h>%a -> %a@]" constructor k value ctor_type in
fprintf ppf "%a" (list_sep new_pp sep) lst
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
@ -15,7 +24,7 @@ let rec type_expression' :
-> unit =
fun f ppf te ->
match te.type_content with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m
| T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
@ -35,7 +44,6 @@ 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

2
src/stages/2-ast_sugar/combinators.ml
View File

@ -54,7 +54,7 @@ let t_record ?loc m : type_expression =
let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [("0",a) ; ("1",b)]
let t_tuple ?loc lst : type_expression = t_record_ez ?loc (tuple_to_record lst)
let ez_t_sum ?loc (lst:(string * type_expression) list) : type_expression =
let ez_t_sum ?loc (lst:((string * ctor_content) list)) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux CMap.empty lst in
make_t ?loc @@ T_sum map

4
src/stages/2-ast_sugar/combinators.mli
View File

@ -37,8 +37,8 @@ val t_tuple : ?loc:Location.t -> type_expression list -> type_expression
val t_record : ?loc:Location.t -> type_expression Map.String.t -> type_expression
val t_record_ez : ?loc:Location.t -> (string * type_expression) list -> type_expression
val t_sum : ?loc:Location.t -> type_expression Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ( string * type_expression ) list -> type_expression
val t_sum : ?loc:Location.t -> ctor_content Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ( string * ctor_content ) list -> type_expression
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression

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

@ -4,8 +4,12 @@ module Location = Simple_utils.Location
include Stage_common.Types
module Ast_sugar_parameter = struct
type type_meta = unit
end
type type_content =
| T_sum of type_expression constructor_map
| T_sum of ctor_content constructor_map
| T_record of type_expression label_map
| T_tuple of type_expression list
| T_arrow of arrow
@ -15,13 +19,14 @@ type type_content =
and arrow = {type1: type_expression; type2: type_expression}
and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| 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

2
src/stages/3-ast_core/combinators.ml
View File

@ -54,7 +54,7 @@ let t_record ?loc m : type_expression =
let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [("0",a) ; ("1",b)]
let t_tuple ?loc lst : type_expression = t_record_ez ?loc (tuple_to_record lst)
let ez_t_sum ?loc (lst:(string * type_expression) list) : type_expression =
let ez_t_sum ?loc (lst:(string * ctor_content) list) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux CMap.empty lst in
make_t ?loc @@ T_sum map

4
src/stages/3-ast_core/combinators.mli
View File

@ -37,8 +37,8 @@ val t_tuple : ?loc:Location.t -> type_expression list -> type_expression
val t_record : ?loc:Location.t -> type_expression Map.String.t -> type_expression
val t_record_ez : ?loc:Location.t -> (string * type_expression) list -> type_expression
val t_sum : ?loc:Location.t -> type_expression Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ( string * type_expression ) list -> type_expression
val t_sum : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expression
val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression
val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression

2
src/stages/3-ast_core/types.ml
View File

@ -8,8 +8,6 @@ end
include Stage_common.Types
(*include Ast_generic_type(Ast_core_parameter)
*)
include Ast_generic_type (Ast_core_parameter)
type inline = bool

6
src/stages/4-ast_typed/PP.ml
View File

@ -15,8 +15,7 @@ let label ppf (l:label) : unit =
let Label l = l in fprintf ppf "%s" l
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) m in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
@ -210,7 +209,7 @@ let rec type_expression' :
-> unit =
fun f ppf te ->
match te.type_content with
| T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
| T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) (List.map (fun (c,{ctor_type;_}) -> (c,ctor_type)) (CMap.to_kv_list m))
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
@ -234,7 +233,6 @@ and type_operator :
| 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 {l; r} -> Format.asprintf "michelson_or (%a,%a)" f l f r
| TC_arrow {type1; type2} -> Format.asprintf "arrow (%a,%a)" f type1 f type2
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in

4
src/stages/4-ast_typed/combinators.ml
View File

@ -67,7 +67,7 @@ let t_big_map ?loc k v ?s () = make_t ?loc (T_operator (TC_big_map { k ; v })) s
let t_map_or_big_map ?loc k v ?s () = make_t ?loc (T_operator (TC_map_or_big_map { k ; v })) s
let t_sum m ?loc ?s () : type_expression = make_t ?loc (T_sum m) s
let make_t_ez_sum ?loc (lst:(constructor' * type_expression) list) : type_expression =
let make_t_ez_sum ?loc (lst:(constructor' * ctor_content) list) : type_expression =
let aux prev (k, v) = CMap.add k v prev in
let map = List.fold_left aux CMap.empty lst in
make_t ?loc (T_sum map) None
@ -180,7 +180,7 @@ let get_t_function_full (t:type_expression) : (type_expression * type_expression
let (input,output) = aux 0 t in
ok @@ (t_record (LMap.of_list input) (),output)
let get_t_sum (t:type_expression) : type_expression constructor_map result = match t.type_content with
let get_t_sum (t:type_expression) : ctor_content constructor_map result = match t.type_content with
| T_sum m -> ok m
| _ -> fail @@ Errors.not_a_x_type "sum" t ()

6
src/stages/4-ast_typed/combinators.mli
View File

@ -32,8 +32,8 @@ val ez_t_record : ( label * type_expression ) list -> ?loc:Location.t -> ?s:S.ty
val t_map : ?loc:Location.t -> type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_map_or_big_map : ?loc:Location.t -> type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_sum : type_expression constructor_map -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val make_t_ez_sum : ?loc:Location.t -> ( constructor' * type_expression ) list -> type_expression
val t_sum : Types.te_cmap -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val make_t_ez_sum : ?loc:Location.t -> ( constructor' * ctor_content ) list -> type_expression
val t_function : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val t_shallow_closure : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val get_type_expression : expression -> type_expression
@ -64,7 +64,7 @@ val get_t_tuple : type_expression -> type_expression list result
val get_t_pair : type_expression -> ( type_expression * type_expression ) result
val get_t_function : type_expression -> ( type_expression * type_expression ) result
val get_t_function_full : type_expression -> ( type_expression * type_expression ) result
val get_t_sum : type_expression -> type_expression constructor_map result
val get_t_sum : type_expression -> ctor_content constructor_map result
val get_t_record : type_expression -> type_expression label_map result
val get_t_map : type_expression -> ( type_expression * type_expression ) result
val get_t_big_map : type_expression -> ( type_expression * type_expression ) result

2
src/stages/4-ast_typed/combinators_environment.ml
View File

@ -21,5 +21,5 @@ open Environment
let env_sum_type ?(env = full_empty)
?(type_name = Var.of_name "a_sum_type")
(lst : (constructor' * type_expression) list) =
(lst : (constructor' * ctor_content) list) =
add_type type_name (make_t_ez_sum lst) env

2
src/stages/4-ast_typed/combinators_environment.mli
View File

@ -16,4 +16,4 @@ val e_a_empty_record : expression label_map -> expression
val ez_e_a_empty_record : ( label * expression ) list -> expression
val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor' * type_expression) list -> full_environment
val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> full_environment

2
src/stages/4-ast_typed/environment.ml
View File

@ -51,7 +51,7 @@ let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expr
match type_.type_content with
| T_sum m ->
(match CMap.find_opt (convert_constructor' k) m with
Some km -> Some (km , type_)
Some {ctor_type ; _} -> Some (ctor_type , type_)
| None -> None)
| _ -> None
in

4
src/stages/4-ast_typed/helpers.ml
View File

@ -9,7 +9,6 @@ let map_type_operator f = function
| TC_map {k ; v} -> TC_map { k = f k ; v = f v }
| TC_big_map {k ; v}-> TC_big_map { k = f k ; v = f v }
| TC_map_or_big_map { k ; v }-> TC_map_or_big_map { k = f k ; v = f v }
| TC_michelson_or { l ; r } -> TC_michelson_or { l = f l ; r = f r }
| TC_arrow {type1 ; type2} -> TC_arrow { type1 = f type1 ; type2 = f type2 }
let bind_map_type_operator f = function
@ -20,7 +19,6 @@ let bind_map_type_operator f = function
| TC_map {k ; v} -> let%bind k = f k in let%bind v = f v in ok @@ TC_map {k ; v}
| TC_big_map {k ; v} -> let%bind k = f k in let%bind v = f v in ok @@ TC_big_map {k ; v}
| TC_map_or_big_map {k ; v} -> let%bind k = f k in let%bind v = f v in ok @@ TC_map_or_big_map {k ; v}
| TC_michelson_or {l ; r}-> let%bind l = f l in let%bind r = f r in ok @@ TC_michelson_or {l ; r}
| TC_arrow {type1 ; type2}-> let%bind type1 = f type1 in let%bind type2 = f type2 in ok @@ TC_arrow {type1 ; type2}
let type_operator_name = function
@ -31,7 +29,6 @@ let type_operator_name = function
| 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
@ -71,7 +68,6 @@ let string_of_type_operator = function
| TC_map { k ; v } -> "TC_map" , [k ; v]
| TC_big_map { k ; v } -> "TC_big_map" , [k ; v]
| TC_map_or_big_map { k ; v } -> "TC_map_or_big_map" , [k ; v]
| TC_michelson_or { l ; r } -> "TC_michelson_or" , [l ; r]
| TC_arrow { type1 ; type2 } -> "TC_arrow" , [type1 ; type2]
let string_of_type_constant = function

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

@ -342,9 +342,8 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) :
| (TC_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb})
| (TC_big_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_big_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb})
-> ok @@ ([ka;va] ,[kb;vb])
| TC_michelson_or {l=la;r=ra}, TC_michelson_or {l=lb;r=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 _ )
| (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
in
if List.length lsta <> List.length lstb then
@ -357,7 +356,7 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) :
| T_sum sa, T_sum sb -> (
let sa' = CMap.to_kv_list sa in
let sb' = CMap.to_kv_list sb in
let aux ((ka, va), (kb, vb)) =
let aux ((ka, {ctor_type=va;_}), (kb, {ctor_type=vb;_})) =
let%bind _ =
Assert.assert_true ~msg:"different keys in sum types"
@@ (ka = kb) in

10
src/stages/4-ast_typed/types.ml
View File

@ -19,7 +19,7 @@ type type_constant =
| TC_timestamp
| TC_void
type te_cmap = type_expression constructor_map
type te_cmap = ctor_content constructor_map
and te_lmap = type_expression label_map
and type_meta = ast_core_type_expression option
@ -36,6 +36,13 @@ and arrow = {
type2: type_expression;
}
and annot_option = string option
and ctor_content = {
ctor_type : type_expression;
michelson_annotation : annot_option;
}
and type_map_args = {
k : type_expression;
v : type_expression;
@ -54,7 +61,6 @@ and type_operator =
| TC_map of type_map_args
| TC_big_map of type_map_args
| TC_map_or_big_map of type_map_args
| TC_michelson_or of michelson_or_args
| TC_arrow of arrow

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

@ -8,12 +8,6 @@ let constructor ppf (c:constructor') : unit =
let label ppf (l:label) : unit =
let Label l = l in fprintf ppf "%s" l
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
@ -35,7 +29,6 @@ let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple pp
fprintf ppf format_record (record_sep value (tag sep_record)) m
let list_sep_d x = list_sep x (tag " ,@ ")
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
@ -200,6 +193,14 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
open Agt
open Format
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, {ctor_type;_}) = fprintf ppf "@[<h>%a -> %a@]" constructor k value ctor_type in
fprintf ppf "%a" (list_sep new_pp sep) lst
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
@ -231,7 +232,6 @@ 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

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

@ -36,8 +36,10 @@ end
module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
open PARAMETER
type michelson_annotation = string
type type_content =
| T_sum of type_expression constructor_map
| T_sum of ctor_content constructor_map
| T_record of type_expression label_map
| T_arrow of arrow
| T_variable of type_variable
@ -46,6 +48,8 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
and arrow = {type1: type_expression; type2: type_expression}
and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
@ -54,7 +58,6 @@ 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
@ -69,7 +72,6 @@ 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
@ -80,7 +82,6 @@ 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
@ -91,7 +92,6 @@ 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
@ -131,7 +131,6 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| 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

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

@ -15,7 +15,6 @@ type constant_tag =
| C_variant (* ( label , * ) … -> * *)
| C_map (* * -> * -> * *)
| C_big_map (* * -> * -> * *)
| C_michelson_or (* * -> * -> * *)
| C_list (* * -> * *)
| C_set (* * -> * *)
| C_unit (* * *)
@ -76,11 +75,10 @@ let type_expression'_of_simple_c_constant = function
| C_set , [x] -> ok @@ Ast_typed.T_operator(TC_set x)
| C_map , [k ; v] -> ok @@ Ast_typed.T_operator(TC_map {k ; v})
| C_big_map , [k ; v] -> ok @@ Ast_typed.T_operator(TC_big_map {k ; v})
| C_michelson_or , [l ; r] -> ok @@ Ast_typed.T_operator(TC_michelson_or {l ; r})
| C_arrow , [x ; y] -> ok @@ Ast_typed.T_operator(TC_arrow {type1=x ; type2=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_michelson_or ), _ ->
| (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow ), _ ->
failwith "internal error: wrong number of arguments for type operator"
| C_unit , [] -> ok @@ Ast_typed.T_constant(TC_unit)

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

@ -0,0 +1,8 @@
type inner_storage is michelson_or(int,"one",nat,"two")
type storage is michelson_or (int,"three",inner_storage,"four")
type return is list(operation) * storage
function main (const action : unit; const store : storage) : return is block {
const foo : storage = (M_right ((M_left(1) : inner_storage)) : storage) ;
} with ((nil : list(operation)), (foo: storage))

4
src/test/contracts/michelson_or_tree.mligo
View File

@ -1,5 +1,5 @@
type inner_storage = (int,nat) michelson_or
type storage = (int,inner_storage) michelson_or
type inner_storage = (int,"one",nat,"two") michelson_or
type storage = (int,"three",inner_storage,"four") michelson_or
type return = operation list * storage

5
src/test/typer_tests.ml
View File

@ -55,8 +55,9 @@ module TestExpressions = struct
O.(make_t_ez_record [("0",t_int ()); ("1",t_string ())])
let constructor () : unit result =
let variant_foo_bar =
O.[(Typed.Constructor "foo", t_int ()); (Constructor "bar", t_string ())]
let variant_foo_bar : (Typed.constructor' * Typed.ctor_content) list = [
(Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None});
(Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None}) ]
in test_expression
~env:(E.env_sum_type variant_foo_bar)
I.(e_constructor "foo" (e_int 32))