Move invalid_oracle_type error to type checker

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

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().

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

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)">>
                   ])
-    ].
+    , ?TYPE_ERROR(polymorphic_query_type,
-
+                  [<<?Pos(3,5)
--define(Path(File), "code_errors/" ??File).
+                     "Invalid oracle type\n"
--define(Msg(File, Line, Col, Err), <<?Pos("Code generation", ?Path(File), Line, Col) Err>>).
+                     "  `oracle('a, 'b)`\n"
-
+                     "The query type must not be polymorphic (contain type variables)">>,
--define(FATE_ERR(File, Line, Col, Err), {?Path(File), ?Msg(File, Line, Col, Err)}).
+                   <<?Pos(3,5)
-
+                     "Invalid oracle type\n"
-failing_code_gen_contracts() ->
+                     "  `oracle('a, 'b)`\n"
-    [ ?FATE_ERR(polymorphic_query_type, 3, 5,
+                     "The response type must not be polymorphic (contain type variables)">>
-            "Invalid oracle type\n"
+                  ])
-            "  oracle('a, 'b)\n"
+    , ?TYPE_ERROR(polymorphic_response_type,
-            "The query type must not be polymorphic (contain type variables).")
+                  [<<?Pos(3,5)
-    , ?FATE_ERR(polymorphic_response_type, 3, 5,
+                     "Invalid oracle type\n"
-            "Invalid oracle type\n"
+                     "  `oracle(string, 'r)`\n"
-            "  oracle(string, 'r)\n"
+                     "The response type must not be polymorphic (contain type variables)">>
-            "The response type must not be polymorphic (contain type variables).")
+                  ])
-    , ?FATE_ERR(higher_order_query_type, 3, 5,
+    , ?TYPE_ERROR(higher_order_query_type,
-            "Invalid oracle type\n"
+                  [<<?Pos(3,5)
-            "  oracle((int) => int, string)\n"
+                     "Invalid oracle type\n"
-            "The query type must not be higher-order (contain function types).")
+                     "  `oracle((int) => int, string)`\n"
-    , ?FATE_ERR(higher_order_response_type, 3, 5,
+                     "The query type must not be higher-order (contain function types)">>
-            "Invalid oracle type\n"
+                  ])
-            "  oracle(string, (int) => int)\n"
+    , ?TYPE_ERROR(higher_order_response_type,
-            "The response type must not be higher-order (contain function types).")
+                  [<<?Pos(3,5)
+                     "Invalid oracle type\n"
+                     "  `oracle(string, (int) => int)`\n"
+                     "The response type must not be higher-order (contain function types)">>
+                  ])
     ].
 
 validation_test_() ->