From cf492f03cb40f6a39a58beb684affcb4e163e72c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 23 Apr 2020 22:28:12 +0100 Subject: [PATCH] Solve T_arrow vs. TC_arrow bug by removing TC_arrow --- src/passes/10-transpiler/transpiler.ml | 5 ----- src/passes/10-transpiler/untranspiler.ml | 6 ------ src/passes/4-imperative_to_sugar/imperative_to_sugar.ml | 6 ------ src/passes/6-sugar_to_core/sugar_to_core.ml | 6 ------ src/passes/8-typer-new/typer.ml | 4 ---- src/passes/8-typer-new/untyper.ml | 4 ---- src/passes/8-typer-new/wrap.ml | 2 -- src/passes/8-typer-old/typer.ml | 4 ---- src/passes/9-self_ast_typed/no_nested_big_map.ml | 4 ---- src/stages/1-ast_imperative/PP.ml | 1 - src/stages/1-ast_imperative/types.ml | 1 - src/stages/2-ast_sugar/PP.ml | 1 - src/stages/2-ast_sugar/types.ml | 1 - src/stages/4-ast_typed/PP.ml | 1 - src/stages/4-ast_typed/helpers.ml | 4 ---- src/stages/4-ast_typed/misc.ml | 4 ++-- src/stages/4-ast_typed/types.ml | 2 -- src/stages/common/PP.ml | 1 - src/stages/common/types.ml | 5 ----- src/stages/typesystem/core.ml | 2 +- src/stages/typesystem/misc.ml | 7 ++++--- 21 files changed, 7 insertions(+), 64 deletions(-) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 91a4eefe2..ed78a683d 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -268,11 +268,6 @@ 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 {type1=param ; type2=result}) -> ( - let%bind param' = transpile_type param in - let%bind result' = transpile_type result in - ok (T_function (param', result')) - ) | 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 = diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 94014e8b7..edec0b53f 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -203,12 +203,6 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in bind_fold_right_list aux init lst' ) - | TC_arrow _ -> ( - let%bind n = - trace_strong (wrong_mini_c_value "lambda as string" v) @@ - get_string v in - return (E_literal (Literal_string n)) - ) | TC_set ty -> ( let%bind lst = trace_strong (wrong_mini_c_value "set" v) @@ diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 99433d272..e5742ac5b 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -200,9 +200,6 @@ 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_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 _ | TC_michelson_pair _ -> fail @@ Errors.corner_case __LOC__ let rec compile_expression : I.expression -> O.expression result = @@ -663,9 +660,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_arrow (i,o) -> - let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in - ok @@ I.TC_arrow (i,o) let rec uncompile_expression' : O.expression -> I.expression result = fun e -> diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index ce1af8ae2..b0b91cd98 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -66,9 +66,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_arrow (i,o) -> - let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in - ok @@ O.TC_arrow (i,o) let rec compile_expression : I.expression -> O.expression result = fun e -> @@ -295,9 +292,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_arrow (i,o) -> - let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in - ok @@ I.TC_arrow (i,o) let rec uncompile_expression : O.expression -> I.expression result = fun e -> diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 4f3c1f77c..5f780f7de 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -188,10 +188,6 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu | 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 { type1=arg' ; type2=ret' } in return (T_operator (opt)) diff --git a/src/passes/8-typer-new/untyper.ml b/src/passes/8-typer-new/untyper.ml index 88dc7df67..eccd21fab 100644 --- a/src/passes/8-typer-new/untyper.ml +++ b/src/passes/8-typer-new/untyper.ml @@ -193,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_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' ) | O.TC_contract c-> let%bind c = untype_type_expression c in ok @@ I.TC_contract c diff --git a/src/passes/8-typer-new/wrap.ml b/src/passes/8-typer-new/wrap.ml index 51dcc794f..d5125e362 100644 --- a/src/passes/8-typer-new/wrap.ml +++ b/src/passes/8-typer-new/wrap.ml @@ -71,7 +71,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_arrow { type1 ; type2 } -> (C_arrow, [ type1 ; type2 ]) | TC_list l -> (C_list, [l]) | TC_contract c -> (C_contract, [c]) ) @@ -107,7 +106,6 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v | TC_big_map ( k , v ) -> (C_big_map, [k;v]) | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) | TC_contract c -> (C_contract, [c]) - | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) ) in p_constant csttag (List.map type_expression_to_type_value_copypasted args) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 3e3d0b646..18786393e 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -649,10 +649,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_arrow ( arg , ret ) -> - let%bind arg' = evaluate_type e arg in - let%bind ret' = evaluate_type e ret in - ok @@ O.TC_arrow { type1=arg' ; type2=ret' } | TC_contract c -> let%bind c = evaluate_type e c in ok @@ O.TC_contract c 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 710f1b3e4..c92034d3d 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 @@ -35,10 +35,6 @@ let rec check_no_nested_bigmap is_in_bigmap e = 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 { type1 ; type2 }) -> - let%bind _ = check_no_nested_bigmap false type1 in - let%bind _ = check_no_nested_bigmap false type2 in - ok () | T_sum s -> 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 diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 0b9827d4a..8115de660 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -55,7 +55,6 @@ and type_operator : | 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_pair (l,_, r,_) -> Format.asprintf "Michelson_pair (%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 fprintf ppf "(TO_%s)" s diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 49909998e..adb4cbbf5 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -24,7 +24,6 @@ and type_operator = | TC_set of type_expression | TC_map of type_expression * type_expression | TC_big_map of type_expression * type_expression - | TC_arrow of type_expression * type_expression | TC_michelson_or of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation | TC_michelson_pair of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 22f726ff6..2c266f787 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -51,7 +51,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_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in fprintf ppf "(TO_%s)" s diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 18295b7a5..c2007d945 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -30,7 +30,6 @@ and type_operator = | TC_set of type_expression | TC_map of type_expression * type_expression | TC_big_map of type_expression * type_expression - | TC_arrow of type_expression * type_expression and type_expression = {type_content: type_content; location: Location.t} diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index fd6f10ec2..2eefdad38 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -248,7 +248,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_arrow {type1; type2} -> Format.asprintf "arrow (%a,%a)" f type1 f type2 | TC_contract te -> Format.asprintf "Contract (%a)" f te in fprintf ppf "(type_operator: %s)" s diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml index b0ae3b657..7bcc4a934 100644 --- a/src/stages/4-ast_typed/helpers.ml +++ b/src/stages/4-ast_typed/helpers.ml @@ -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_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 @@ -19,7 +18,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_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" @@ -29,7 +27,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_arrow _ -> "TC_arrow" let type_expression'_of_string = function | "TC_contract" , [x] -> ok @@ T_operator(TC_contract x) @@ -67,7 +64,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_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 990c53288..daa4efd6b 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -342,8 +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_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 _ ) + | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ ), + (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ ) -> fail @@ different_operators opa opb in if List.length lsta <> List.length lstb then diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index e06b7ccd2..450559d1b 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -65,8 +65,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_arrow of arrow - and type_expression = { type_content: type_content; diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 5667b32c4..914a8bad6 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -249,7 +249,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_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in fprintf ppf "(type_operator: %s)" s diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 175d8e434..fff182fc4 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -59,7 +59,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_arrow of type_expression * type_expression and type_expression = {type_content: type_content; location: Location.t; type_meta: type_meta} @@ -73,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_arrow (x, y) -> TC_arrow (f x, f y) let bind_map_type_operator f = function TC_contract x -> let%bind x = f x in ok @@ TC_contract x @@ -83,7 +81,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_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 TC_contract _ -> "TC_contract" @@ -93,7 +90,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_arrow _ -> "TC_arrow" let type_expression'_of_string = function | "TC_contract" , [x] -> ok @@ T_operator(TC_contract x) @@ -131,7 +127,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_arrow (x , y) -> "TC_arrow" , [x ; y] let string_of_type_constant = function | TC_unit -> "TC_unit", [] diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index 07f78184e..1fc668ace 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -39,7 +39,7 @@ let type_expression'_of_simple_c_constant : constant_tag * type_expression list | 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_arrow , [x ; y] -> ok @@ Ast_typed.T_operator(TC_arrow {type1=x ; type2=y}) + | C_arrow , [x ; y] -> ok @@ Ast_typed.T_arrow {type1=x ; type2=y} (* For now, the arrow type constructor is special *) | 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 ), _ -> diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index f060a2810..17c1d3eff 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -85,9 +85,10 @@ module Substitution = struct | T.T_operator type_name_and_args -> let%bind type_name_and_args = T.Helpers.bind_map_type_operator (s_type_expression ~substs) type_name_and_args in ok @@ T.T_operator type_name_and_args - | T.T_arrow _ -> - let _TODO = substs in - failwith "TODO: T_function" + | T.T_arrow { type1; type2 } -> + let%bind type1 = s_type_expression ~substs type1 in + let%bind type2 = s_type_expression ~substs type2 in + ok @@ T.T_arrow { type1; type2 } and s_abstr_type_content : Ast_core.type_content w = fun ~substs -> function | Ast_core.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression sum"