From 79593e6f3eeeb27a92029eb8d1153ef9977d06d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 10 Apr 2020 04:39:44 +0200 Subject: [PATCH] Turned some of the tuples into records --- src/passes/10-transpiler/transpiler.ml | 14 +++---- src/passes/10-transpiler/untranspiler.ml | 8 ++-- src/passes/8-typer-new/solver.ml | 18 ++++---- src/passes/8-typer-new/typer.ml | 20 ++++----- src/passes/8-typer-old/typer.ml | 14 +++---- .../9-self_ast_typed/no_nested_big_map.ml | 32 +++++++------- src/stages/4-ast_typed/PP.ml | 10 ++--- src/stages/4-ast_typed/combinators.ml | 14 +++---- src/stages/4-ast_typed/helpers.ml | 42 +++++++++---------- src/stages/4-ast_typed/misc.ml | 13 +++--- src/stages/4-ast_typed/types.ml | 20 ++++++--- src/stages/typesystem/core.ml | 8 ++-- 12 files changed, 112 insertions(+), 101 deletions(-) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 42579a86f..93c172572 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -250,15 +250,15 @@ let rec transpile_type (t:AST.type_expression) : type_value result = | T_operator (TC_contract x) -> let%bind x' = transpile_type x in ok (T_contract x') - | T_operator (TC_map (key,value)) -> - let%bind kv' = bind_map_pair transpile_type (key, value) in + | T_operator (TC_map {k;v}) -> + let%bind kv' = bind_map_pair transpile_type (k, v) in ok (T_map kv') - | T_operator (TC_big_map (key,value)) -> - let%bind kv' = bind_map_pair transpile_type (key, value) in + | T_operator (TC_big_map {k;v}) -> + let%bind kv' = bind_map_pair transpile_type (k, v) in 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" - | T_operator (TC_michelson_or (l,r)) -> + | 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'))) @@ -271,7 +271,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result = | T_operator (TC_option o) -> let%bind o' = transpile_type o in ok (T_option o') - | T_operator (TC_arrow (param , result)) -> ( + | T_operator (TC_arrow {type1=param ; type2=result}) -> ( let%bind param' = transpile_type param in let%bind result' = transpile_type result in ok (T_function (param', result')) diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 85aeabc7f..1e6b86272 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -150,7 +150,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind s' = untranspile s o in ok (e_a_empty_some s') ) - | TC_map (k_ty,v_ty)-> ( + | TC_map {k=k_ty;v=v_ty}-> ( let%bind map = trace_strong (wrong_mini_c_value "map" v) @@ get_map v in @@ -168,7 +168,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in bind_fold_right_list aux init map' ) - | TC_big_map (k_ty, v_ty) -> ( + | TC_big_map {k=k_ty; v=v_ty} -> ( let%bind big_map = trace_strong (wrong_mini_c_value "big_map" v) @@ get_big_map v in @@ -185,8 +185,8 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in bind_fold_right_list aux init big_map' ) - | TC_map_or_big_map (_, _) -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c" - | TC_michelson_or (l_ty, r_ty) -> ( + | 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 -> diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 81c53ed9a..7f06acc93 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -66,15 +66,15 @@ module Wrap = struct P_constant (csttag, []) | T_operator (type_operator) -> let (csttag, args) = Core.(match type_operator with - | TC_option o -> (C_option, [o]) - | TC_set s -> (C_set, [s]) - | TC_map ( k , v ) -> (C_map, [k;v]) - | TC_big_map ( k , v) -> (C_big_map, [k;v]) - | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) - | TC_michelson_or ( k , v) -> (C_michelson_or, [k;v]) - | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) - | TC_list l -> (C_list, [l]) - | TC_contract c -> (C_contract, [c]) + | TC_option o -> (C_option, [o]) + | TC_set s -> (C_set, [s]) + | TC_map { k ; v } -> (C_map, [k;v]) + | TC_big_map { k ; v } -> (C_big_map, [k;v]) + | TC_map_or_big_map { k ; v } -> (C_map, [k;v]) + | TC_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]) ) in P_constant (csttag, List.map type_expression_to_type_value args) diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 2b2036122..e6bd25cc0 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -608,26 +608,26 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu | TC_map (k,v) -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in - ok @@ O.TC_map (k,v) + ok @@ O.TC_map {k;v} | TC_big_map (k,v) -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in - ok @@ O.TC_big_map (k,v) + ok @@ O.TC_big_map {k;v} | TC_map_or_big_map (k,v) -> 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) + 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) + ok @@ O.TC_michelson_or {l;r} | TC_contract c -> let%bind c = evaluate_type e c in ok @@ O.TC_contract c | TC_arrow ( arg , ret ) -> let%bind arg' = evaluate_type e arg in let%bind ret' = evaluate_type e ret in - ok @@ O.TC_arrow ( arg' , ret' ) + ok @@ O.TC_arrow { type1=arg' ; type2=ret' } in return (T_operator (opt)) @@ -1117,23 +1117,23 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul | O.TC_set t -> let%bind t' = untype_type_expression t in ok @@ I.TC_set t' - | O.TC_map (k,v) -> + | O.TC_map {k;v} -> let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in ok @@ I.TC_map (k,v) - | O.TC_big_map (k,v) -> + | O.TC_big_map {k;v} -> let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in ok @@ I.TC_big_map (k,v) - | O.TC_map_or_big_map (k,v) -> + | O.TC_map_or_big_map {k;v} -> 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) -> + | 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 { type1=arg ; type2=ret } -> let%bind arg' = untype_type_expression arg in let%bind ret' = untype_type_expression ret in ok @@ I.TC_arrow ( arg' , ret' ) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index d14eb44ed..6e054ae39 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -638,23 +638,23 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu | TC_map (k,v) -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in - ok @@ O.TC_map (k,v) + ok @@ O.TC_map {k;v} | TC_big_map (k,v) -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in - ok @@ O.TC_big_map (k,v) + ok @@ O.TC_big_map {k;v} | TC_map_or_big_map (k,v) -> 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) + 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) + 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 - ok @@ O.TC_arrow ( arg' , ret' ) + ok @@ O.TC_arrow { type1=arg' ; type2=ret' } | TC_contract c -> let%bind c = evaluate_type e c in ok @@ O.TC_contract c @@ -809,11 +809,11 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression (* this special case is here force annotation of the untyped lambda generated by pascaligo's for_collect loop *) let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in - let tv_col = get_type_expression v_col in (* this is the type of the collection *) + let tv_col = get_type_expression v_col in (* this is the type of the collection *) let tv_out = get_type_expression v_initr in (* this is the output type of the lambda*) let%bind input_type = match tv_col.type_content with | O.T_operator ( TC_list t | TC_set t) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",t)]) - | O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])]) + | O.T_operator ( TC_map {k;v}| TC_big_map {k;v}) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])]) | _ -> let wtype = Format.asprintf "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in diff --git a/src/passes/9-self_ast_typed/no_nested_big_map.ml b/src/passes/9-self_ast_typed/no_nested_big_map.ml index 364859e2c..f90a9b203 100644 --- a/src/passes/9-self_ast_typed/no_nested_big_map.ml +++ b/src/passes/9-self_ast_typed/no_nested_big_map.ml @@ -15,15 +15,15 @@ end let rec check_no_nested_bigmap is_in_bigmap e = match e.type_content with - | T_operator (TC_big_map (_, _)) when is_in_bigmap -> + | T_operator (TC_big_map _) when is_in_bigmap -> fail @@ Errors.no_nested_bigmap - | T_operator (TC_big_map (key, value)) -> - let%bind _ = check_no_nested_bigmap false key in - let%bind _ = check_no_nested_bigmap true value in + | T_operator (TC_big_map {k ; v}) -> + let%bind _ = check_no_nested_bigmap false k in + let%bind _ = check_no_nested_bigmap true v in ok () - | T_operator (TC_map_or_big_map (key, value)) -> - let%bind _ = check_no_nested_bigmap false key in - let%bind _ = check_no_nested_bigmap true value in + | T_operator (TC_map_or_big_map {k ; v}) -> + let%bind _ = check_no_nested_bigmap false k in + let%bind _ = check_no_nested_bigmap true v in ok () | T_operator (TC_contract t) | T_operator (TC_option t) @@ -31,17 +31,17 @@ let rec check_no_nested_bigmap is_in_bigmap e = | T_operator (TC_set t) -> let%bind _ = check_no_nested_bigmap is_in_bigmap t in ok () - | T_operator (TC_map (a, b)) -> - let%bind _ = check_no_nested_bigmap is_in_bigmap a in - let%bind _ = check_no_nested_bigmap is_in_bigmap b in + | T_operator (TC_map { k ; v }) -> + let%bind _ = check_no_nested_bigmap is_in_bigmap k in + let%bind _ = check_no_nested_bigmap is_in_bigmap v in ok () - | T_operator (TC_arrow (a, b)) -> - let%bind _ = check_no_nested_bigmap false a in - let%bind _ = check_no_nested_bigmap false b in + | T_operator (TC_arrow { type1 ; type2 }) -> + let%bind _ = check_no_nested_bigmap false type1 in + let%bind _ = check_no_nested_bigmap false type2 in ok () - | T_operator (TC_michelson_or (a, b)) -> - let%bind _ = check_no_nested_bigmap false a in - let%bind _ = check_no_nested_bigmap false b in + | 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 diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index bdc100b63..e6e828e10 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -231,11 +231,11 @@ and type_operator : | TC_option te -> Format.asprintf "option(%a)" f te | TC_list te -> Format.asprintf "list(%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_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_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 fprintf ppf "(TO_%s)" s diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 2c6e50590..e36524561 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -62,9 +62,9 @@ let ez_t_record lst ?s () : type_expression = t_record m ?s () let t_pair a b ?s () : type_expression = ez_t_record [(Label "0",a) ; (Label "1",b)] ?s () -let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s -let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s -let t_map_or_big_map key value ?s () = make_t (T_operator (TC_map_or_big_map (key,value))) s +let t_map k v ?s () = make_t (T_operator (TC_map { k ; v })) s +let t_big_map k v ?s () = make_t (T_operator (TC_big_map { k ; v })) s +let t_map_or_big_map k v ?s () = make_t (T_operator (TC_map_or_big_map { k ; v })) s let t_sum m ?s () : type_expression = make_t (T_sum m) s let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression = @@ -190,14 +190,14 @@ let get_t_record (t:type_expression) : type_expression label_map result = match let get_t_map (t:type_expression) : (type_expression * type_expression) result = match t.type_content with - | T_operator (TC_map (k,v)) -> ok (k, v) - | T_operator (TC_map_or_big_map (k,v)) -> ok (k, v) + | T_operator (TC_map { k ; v }) -> ok (k, v) + | T_operator (TC_map_or_big_map { k ; v }) -> ok (k, v) | _ -> fail @@ Errors.not_a_x_type "map" t () let get_t_big_map (t:type_expression) : (type_expression * type_expression) result = match t.type_content with - | T_operator (TC_big_map (k,v)) -> ok (k, v) - | T_operator (TC_map_or_big_map (k,v)) -> ok (k, v) + | T_operator (TC_big_map { k ; v }) -> ok (k, v) + | T_operator (TC_map_or_big_map { k ; v }) -> ok (k, v) | _ -> fail @@ Errors.not_a_x_type "big_map" t () let get_t_map_key : type_expression -> type_expression result = fun t -> diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml index 006cae6cb..bb3962846 100644 --- a/src/stages/4-ast_typed/helpers.ml +++ b/src/stages/4-ast_typed/helpers.ml @@ -6,22 +6,22 @@ let map_type_operator f = function | TC_option x -> TC_option (f x) | TC_list x -> TC_list (f x) | TC_set x -> TC_set (f x) - | 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) + | 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 TC_contract x -> let%bind x = f x in ok @@ TC_contract x | TC_option x -> let%bind x = f x in ok @@ TC_option x | TC_list x -> let%bind x = f x in ok @@ TC_list x | TC_set x -> let%bind x = f x in ok @@ TC_set x - | 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) + | 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 TC_contract _ -> "TC_contract" @@ -39,8 +39,8 @@ let type_expression'_of_string = function | "TC_option" , [x] -> ok @@ T_operator(TC_option x) | "TC_list" , [x] -> ok @@ T_operator(TC_list x) | "TC_set" , [x] -> ok @@ T_operator(TC_set x) - | "TC_map" , [x ; y] -> ok @@ T_operator(TC_map (x , y)) - | "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map (x, y)) + | "TC_map" , [k ; v] -> ok @@ T_operator(TC_map { k ; v }) + | "TC_big_map" , [k ; v] -> ok @@ T_operator(TC_big_map { k ; v }) | ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ -> failwith "internal error: wrong number of arguments for type operator" @@ -64,15 +64,15 @@ let type_expression'_of_string = function failwith "internal error: unknown type operator" let string_of_type_operator = function - | TC_contract x -> "TC_contract" , [x] - | TC_option x -> "TC_option" , [x] - | TC_list x -> "TC_list" , [x] - | TC_set x -> "TC_set" , [x] - | TC_map (x , y) -> "TC_map" , [x ; y] - | TC_big_map (x , y) -> "TC_big_map" , [x ; y] - | TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] - | TC_michelson_or (x , y) -> "TC_michelson_or" , [x ; y] - | TC_arrow (x , y) -> "TC_arrow" , [x ; y] + | TC_contract x -> "TC_contract" , [x] + | TC_option x -> "TC_option" , [x] + | TC_list x -> "TC_list" , [x] + | TC_set x -> "TC_set" , [x] + | TC_map { 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 | TC_unit -> "TC_unit", [] diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 89c55cf19..4c708ad8c 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -339,12 +339,13 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : | TC_list la, TC_list lb | TC_contract la, TC_contract lb | TC_set la, TC_set lb -> ok @@ ([la], [lb]) - | (TC_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_map (kb,vb) | TC_map_or_big_map (kb,vb)) - | (TC_big_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_big_map (kb,vb) | TC_map_or_big_map (kb,vb)) - -> ok @@ ([ka;va] ,[kb;vb]) - | TC_michelson_or (la,ra), TC_michelson_or (lb,rb) -> ok @@ ([la;ra] , [lb;rb]) - | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ | TC_michelson_or _ ), - (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ | TC_michelson_or _ ) -> fail @@ different_operators opa opb + | (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 _ ) + -> fail @@ different_operators opa opb in if List.length lsta <> List.length lstb then fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 751daf385..48e33f924 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -32,16 +32,26 @@ and arrow = { type2: type_expression } +and type_map_args = { + k : type_expression; + v : type_expression; + } + +and michelson_or_args = { + l : type_expression; + r : type_expression; + } + 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_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_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 and type_expression = { diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index fd62f2467..f6e362c3b 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -74,10 +74,10 @@ let type_expression'_of_simple_c_constant = function | C_option , [x] -> ok @@ Ast_typed.T_operator(TC_option x) | C_list , [x] -> ok @@ Ast_typed.T_operator(TC_list 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_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_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 ), _ ->