From eb77ae4137a93b8bd46cc48526f7bede6b9591fe Mon Sep 17 00:00:00 2001 From: Gaith Hallak Date: Fri, 24 Jun 2022 15:12:16 +0400 Subject: [PATCH] Move invalid_oracle_type error to type checker --- src/aeso_ast_infer_types.erl | 48 ++++++++++++++- src/aeso_ast_to_fcode.erl | 32 +--------- src/aeso_code_errors.erl | 9 --- test/aeso_compiler_tests.erl | 58 +++++++++---------- .../higher_order_query_type.aes | 0 .../higher_order_response_type.aes | 0 .../polymorphic_query_type.aes | 0 .../polymorphic_response_type.aes | 0 8 files changed, 75 insertions(+), 72 deletions(-) rename test/contracts/{code_errors => }/higher_order_query_type.aes (100%) rename test/contracts/{code_errors => }/higher_order_response_type.aes (100%) rename test/contracts/{code_errors => }/polymorphic_query_type.aes (100%) rename test/contracts/{code_errors => }/polymorphic_response_type.aes (100%) diff --git a/src/aeso_ast_infer_types.erl b/src/aeso_ast_infer_types.erl index c76f5e4..87dabf5 100644 --- a/src/aeso_ast_infer_types.erl +++ b/src/aeso_ast_infer_types.erl @@ -88,8 +88,10 @@ | {add_bytes, aeso_syntax:ann(), concat | split, utype(), utype(), utype()}. -type aens_resolve_constraint() :: {aens_resolve_type, utype()}. +-type oracle_type_constraint() :: {oracle_type, aeso_syntax:ann(), utype()}. --type constraint() :: named_argument_constraint() | field_constraint() | byte_constraint() | aens_resolve_constraint(). +-type constraint() :: named_argument_constraint() | field_constraint() | byte_constraint() + | aens_resolve_constraint() | oracle_type_constraint(). -record(field_info, { ann :: aeso_syntax:ann() @@ -1648,6 +1650,14 @@ is_first_order(Ts) when is_list(Ts) -> lists:all(fun is_first_order/1, Ts); is_first_order(Tup) when is_tuple(Tup) -> is_first_order(tuple_to_list(Tup)); is_first_order(_) -> true. +ensure_monomorphic(Type, Err) -> + is_monomorphic(Type) orelse type_error(Err). + +is_monomorphic({tvar, _, _}) -> false; +is_monomorphic(Ts) when is_list(Ts) -> lists:all(fun is_monomorphic/1, Ts); +is_monomorphic(Tup) when is_tuple(Tup) -> is_monomorphic(tuple_to_list(Tup)); +is_monomorphic(_) -> true. + check_state_init(Env) -> Top = Env#env.namespace, StateType = lookup_type(Env, {id, [{origin, system}], "state"}), @@ -1822,6 +1832,9 @@ infer_expr(Env, {app, Ann, Fun, Args0} = App) -> when_warning(warn_negative_spend, fun() -> warn_potential_negative_spend(Ann, NewFun1, NewArgs) end), [ add_constraint({aens_resolve_type, GeneralResultType}) || element(3, FunName) =:= ["AENS", "resolve"] ], + [ add_constraint({oracle_type, Ann, OType}) + || OType <- [get_oracle_type(FunName, ArgTypes, GeneralResultType)], + OType =/= false ], add_constraint( #dependent_type_constraint{ named_args_t = NamedArgsVar, named_args = NamedArgs1, @@ -2347,10 +2360,14 @@ destroy_and_report_unsolved_constraints(Env) -> ({add_bytes, _, _, _, _, _}) -> true; (_) -> false end, OtherCs3), - {AensResolveCs, []} = + {AensResolveCs, OtherCs5} = lists:partition(fun({aens_resolve_type, _}) -> true; (_) -> false end, OtherCs4), + {OracleTypeCs, []} = + lists:partition(fun({oracle_type, _, _}) -> true; + (_) -> false + end, OtherCs5), Unsolved = [ S || S <- [ solve_constraint(Env, dereference_deep(C)) || C <- NamedArgCs ], S == unsolved ], @@ -2369,9 +2386,19 @@ destroy_and_report_unsolved_constraints(Env) -> check_is_contract_constraints(Env, ContractCs), check_bytes_constraints(Env, BytesCs), check_aens_resolve_constraints(Env, AensResolveCs), + check_oracle_type_constraints(Env, OracleTypeCs), destroy_constraints(). +get_oracle_type({qid, _, ["Oracle", "register"]}, _ , OType) -> OType; +get_oracle_type({qid, _, ["Oracle", "query"]}, [OType| _], _ ) -> OType; +get_oracle_type({qid, _, ["Oracle", "get_question"]}, [OType| _], _ ) -> OType; +get_oracle_type({qid, _, ["Oracle", "get_answer"]}, [OType| _], _ ) -> OType; +get_oracle_type({qid, _, ["Oracle", "check"]}, [OType| _], _ ) -> OType; +get_oracle_type({qid, _, ["Oracle", "check_query"]}, [OType| _], _ ) -> OType; +get_oracle_type({qid, _, ["Oracle", "respond"]}, [OType| _], _ ) -> OType; +get_oracle_type(_Fun, _Args, _Ret) -> false. + %% -- Named argument constraints -- %% If false, a type error has been emitted, so it's safe to drop the constraint. @@ -2513,6 +2540,17 @@ check_aens_resolve_constraints(Env, [{aens_resolve_type, Type} | Rest]) -> end, check_aens_resolve_constraints(Env, Rest). +check_oracle_type_constraints(_Env, []) -> + ok; +check_oracle_type_constraints(Env, [{oracle_type, Ann, OType} | Rest]) -> + Type = unfold_types_in_type(Env, instantiate(OType)), + {app_t, _, {id, _, "oracle"}, [QType, RType]} = Type, + ensure_monomorphic(QType, {invalid_oracle_type, polymorphic, query, Ann, Type}), + ensure_monomorphic(RType, {invalid_oracle_type, polymorphic, response, Ann, Type}), + ensure_first_order(QType, {invalid_oracle_type, higher_order, query, Ann, Type}), + ensure_first_order(RType, {invalid_oracle_type, higher_order, response, Ann, Type}), + check_oracle_type_constraints(Env, Rest). + %% -- Field constraints -- check_record_create_constraints(_, []) -> ok; @@ -3588,6 +3626,12 @@ mk_error({invalid_aens_resolve_type, Ann, T}) -> "It must be a `string` or a pubkey type (`address`, `oracle`, etc)", [pp_type(" `", T)]), mk_t_err(pos(Ann), Msg); +mk_error({invalid_oracle_type, Why, What, Ann, Type}) -> + WhyS = case Why of higher_order -> "higher-order (contain function types)"; + polymorphic -> "polymorphic (contain type variables)" end, + Msg = io_lib:format("Invalid oracle type\n~s`", [pp_type(" `", Type)]), + Cxt = io_lib:format("The ~s type must not be ~s", [What, WhyS]), + mk_t_err(pos(Ann), Msg, Cxt); mk_error(Err) -> Msg = io_lib:format("Unknown error: ~p", [Err]), mk_t_err(pos(0, 0), Msg). diff --git a/src/aeso_ast_to_fcode.erl b/src/aeso_ast_to_fcode.erl index 5adecf2..f9f6787 100644 --- a/src/aeso_ast_to_fcode.erl +++ b/src/aeso_ast_to_fcode.erl @@ -534,7 +534,7 @@ expr_to_fcode(_Env, _Type, {bytes, _, B}) -> {lit, {bytes, B}}; %% Variables expr_to_fcode(Env, _Type, {id, _, X}) -> resolve_var(Env, [X]); -expr_to_fcode(Env, Type, {qid, Ann, X}) -> +expr_to_fcode(Env, Type, {qid, _, X}) -> case resolve_var(Env, X) of {builtin_u, B, Ar} when B =:= oracle_query; B =:= oracle_get_question; @@ -545,7 +545,6 @@ expr_to_fcode(Env, Type, {qid, Ann, X}) -> B =:= oracle_check_query -> OType = get_oracle_type(B, Type), {oracle, QType, RType} = type_to_fcode(Env, OType), - validate_oracle_type(Ann, OType, QType, RType), TypeArgs = [{lit, {typerep, QType}}, {lit, {typerep, RType}}], {builtin_u, B, Ar, TypeArgs}; {builtin_u, B = aens_resolve, Ar} -> @@ -803,35 +802,6 @@ get_oracle_type(oracle_check, {fun_t, _, _, [OType | _], _}) -> OType; get_oracle_type(oracle_check_query, {fun_t, _, _, [OType | _], _}) -> OType; get_oracle_type(oracle_respond, {fun_t, _, _, [OType | _], _}) -> OType. -validate_oracle_type(Ann, Type, QType, RType) -> - ensure_monomorphic(QType, {invalid_oracle_type, polymorphic, query, Ann, Type}), - ensure_monomorphic(RType, {invalid_oracle_type, polymorphic, response, Ann, Type}), - ensure_first_order(QType, {invalid_oracle_type, higher_order, query, Ann, Type}), - ensure_first_order(RType, {invalid_oracle_type, higher_order, response, Ann, Type}), - ok. - -ensure_monomorphic(Type, Err) -> - case is_monomorphic(Type) of - true -> ok; - false -> fcode_error(Err) - end. - -ensure_first_order(Type, Err) -> - case is_first_order(Type) of - true -> ok; - false -> fcode_error(Err) - end. - -is_monomorphic({tvar, _}) -> false; -is_monomorphic(Ts) when is_list(Ts) -> lists:all(fun is_monomorphic/1, Ts); -is_monomorphic(Tup) when is_tuple(Tup) -> is_monomorphic(tuple_to_list(Tup)); -is_monomorphic(_) -> true. - -is_first_order({function, _, _}) -> false; -is_first_order(Ts) when is_list(Ts) -> lists:all(fun is_first_order/1, Ts); -is_first_order(Tup) when is_tuple(Tup) -> is_first_order(tuple_to_list(Tup)); -is_first_order(_) -> true. - %% -- Pattern matching -- -spec alts_to_fcode(env(), ftype(), var_name(), [aeso_syntax:alt()], aeso_syntax:expr()) -> fsplit(). diff --git a/src/aeso_code_errors.erl b/src/aeso_code_errors.erl index a87631f..19a4aad 100644 --- a/src/aeso_code_errors.erl +++ b/src/aeso_code_errors.erl @@ -10,12 +10,6 @@ -export([format/1, pos/1]). -format({invalid_oracle_type, Why, What, Ann, Type}) -> - WhyS = case Why of higher_order -> "higher-order (contain function types)"; - polymorphic -> "polymorphic (contain type variables)" end, - Msg = io_lib:format("Invalid oracle type\n~s", [pp_type(2, Type)]), - Cxt = io_lib:format("The ~s type must not be ~s.", [What, WhyS]), - mk_err(pos(Ann), Msg, Cxt); format({var_args_not_set, Expr}) -> mk_err( pos(Expr), "Could not deduce type of variable arguments list" , "When compiling " ++ pp_expr(Expr) @@ -36,9 +30,6 @@ pp_expr(E) -> pp_expr(N, E) -> prettypr:format(prettypr:nest(N, aeso_pretty:expr(E))). -pp_type(N, T) -> - prettypr:format(prettypr:nest(N, aeso_pretty:type(T))). - mk_err(Pos, Msg) -> aeso_errors:new(code_error, Pos, lists:flatten(Msg)). diff --git a/test/aeso_compiler_tests.erl b/test/aeso_compiler_tests.erl index c46cc5e..199ae26 100644 --- a/test/aeso_compiler_tests.erl +++ b/test/aeso_compiler_tests.erl @@ -45,12 +45,6 @@ simple_compile_test_() -> check_errors(ExpectedErrors, Errors) end} || {ContractName, ExpectedErrors} <- failing_contracts() ] ++ - [ {"Testing code generation error messages of " ++ ContractName, - fun() -> - Errors = compile(ContractName), - check_errors([ExpectedError], Errors) - end} || - {ContractName, ExpectedError} <- failing_code_gen_contracts()] ++ [ {"Testing include with explicit files", fun() -> FileSystem = maps:from_list( @@ -1076,30 +1070,34 @@ failing_contracts() -> " `list(int)`\n" "It must be a `string` or a pubkey type (`address`, `oracle`, etc)">> ]) - ]. - --define(Path(File), "code_errors/" ??File). --define(Msg(File, Line, Col, Err), <>). - --define(FATE_ERR(File, Line, Col, Err), {?Path(File), ?Msg(File, Line, Col, Err)}). - -failing_code_gen_contracts() -> - [ ?FATE_ERR(polymorphic_query_type, 3, 5, - "Invalid oracle type\n" - " oracle('a, 'b)\n" - "The query type must not be polymorphic (contain type variables).") - , ?FATE_ERR(polymorphic_response_type, 3, 5, - "Invalid oracle type\n" - " oracle(string, 'r)\n" - "The response type must not be polymorphic (contain type variables).") - , ?FATE_ERR(higher_order_query_type, 3, 5, - "Invalid oracle type\n" - " oracle((int) => int, string)\n" - "The query type must not be higher-order (contain function types).") - , ?FATE_ERR(higher_order_response_type, 3, 5, - "Invalid oracle type\n" - " oracle(string, (int) => int)\n" - "The response type must not be higher-order (contain function types).") + , ?TYPE_ERROR(polymorphic_query_type, + [<>, + <> + ]) + , ?TYPE_ERROR(polymorphic_response_type, + [<> + ]) + , ?TYPE_ERROR(higher_order_query_type, + [< int, string)`\n" + "The query type must not be higher-order (contain function types)">> + ]) + , ?TYPE_ERROR(higher_order_response_type, + [< int)`\n" + "The response type must not be higher-order (contain function types)">> + ]) ]. validation_test_() -> diff --git a/test/contracts/code_errors/higher_order_query_type.aes b/test/contracts/higher_order_query_type.aes similarity index 100% rename from test/contracts/code_errors/higher_order_query_type.aes rename to test/contracts/higher_order_query_type.aes diff --git a/test/contracts/code_errors/higher_order_response_type.aes b/test/contracts/higher_order_response_type.aes similarity index 100% rename from test/contracts/code_errors/higher_order_response_type.aes rename to test/contracts/higher_order_response_type.aes diff --git a/test/contracts/code_errors/polymorphic_query_type.aes b/test/contracts/polymorphic_query_type.aes similarity index 100% rename from test/contracts/code_errors/polymorphic_query_type.aes rename to test/contracts/polymorphic_query_type.aes diff --git a/test/contracts/code_errors/polymorphic_response_type.aes b/test/contracts/polymorphic_response_type.aes similarity index 100% rename from test/contracts/code_errors/polymorphic_response_type.aes rename to test/contracts/polymorphic_response_type.aes