From ccad660eac89b3fe328ae7fe46dd9cb915fe91c6 Mon Sep 17 00:00:00 2001 From: Ulf Norell Date: Mon, 25 Feb 2019 13:44:23 +0100 Subject: [PATCH] add compiler function to translate a vm value to Sophia AST --- src/aeso_ast_infer_types.erl | 27 ++++++-- src/aeso_compiler.erl | 115 ++++++++++++++++++++++++++++++++++- 2 files changed, 135 insertions(+), 7 deletions(-) diff --git a/src/aeso_ast_infer_types.erl b/src/aeso_ast_infer_types.erl index 8eb049a..ac399d4 100644 --- a/src/aeso_ast_infer_types.erl +++ b/src/aeso_ast_infer_types.erl @@ -12,7 +12,7 @@ -module(aeso_ast_infer_types). --export([infer/1, infer/2, infer_constant/1]). +-export([infer/1, infer/2, infer_constant/1, unfold_types_in_type/3]). -type utype() :: {fun_t, aeso_syntax:ann(), named_args_t(), [utype()], utype()} | {app_t, aeso_syntax:ann(), utype(), [utype()]} @@ -491,7 +491,7 @@ map_t(As, K, V) -> {app_t, As, {id, As, "map"}, [K, V]}. infer(Contracts) -> infer(Contracts, []). --type option() :: permissive_address_literals. +-type option() :: permissive_address_literals | return_env. -spec init_env(list(option())) -> env(). init_env(Options) -> @@ -515,13 +515,17 @@ infer(Contracts, Options) -> Env = init_env(Options), create_options(Options), ets_new(type_vars, [set]), - infer1(Env, Contracts, []) + {Env1, Decls} = infer1(Env, Contracts, []), + case proplists:get_value(return_env, Options, false) of + false -> Decls; + true -> {Env1, Decls} + end after clean_up_ets() end. --spec infer1(env(), [aeso_syntax:decl()], [aeso_syntax:decl()]) -> [aeso_syntax:decl()]. -infer1(_, [], Acc) -> lists:reverse(Acc); +-spec infer1(env(), [aeso_syntax:decl()], [aeso_syntax:decl()]) -> {env(), [aeso_syntax:decl()]}. +infer1(Env, [], Acc) -> {Env, lists:reverse(Acc)}; infer1(Env, [{contract, Ann, ConName, Code} | Rest], Acc) -> %% do type inference on each contract independently. check_scope_name_clash(Env, contract, ConName), @@ -1548,7 +1552,8 @@ unfold_types_in_type(Env, T) -> unfold_types_in_type(Env, T, []). unfold_types_in_type(Env, {app_t, Ann, Id, Args}, Options) when ?is_type_id(Id) -> - UnfoldRecords = proplists:get_value(unfold_record_types, Options, false), + UnfoldRecords = proplists:get_value(unfold_record_types, Options, false), + UnfoldVariants = proplists:get_value(unfold_variant_types, Options, false), case lookup_type(Env, Id) of {_, {_, {Formals, {record_t, Fields}}}} when UnfoldRecords, length(Formals) == length(Args) -> {record_t, @@ -1556,6 +1561,11 @@ unfold_types_in_type(Env, {app_t, Ann, Id, Args}, Options) when ?is_type_id(Id) subst_tvars(lists:zip(Formals, Args), Fields), Options)}; {_, {_, {Formals, {alias_t, Type}}}} when length(Formals) == length(Args) -> unfold_types_in_type(Env, subst_tvars(lists:zip(Formals, Args), Type), Options); + {_, {_, {Formals, {variant_t, Constrs}}}} when UnfoldVariants, length(Formals) == length(Args) -> + %% TODO: unfolding variant types will not work well if we add recursive types! + {variant_t, + unfold_types_in_type(Env, + subst_tvars(lists:zip(Formals, Args), Constrs), Options)}; _ -> %% Not a record type, or ill-formed record type. {app_t, Ann, Id, unfold_types_in_type(Env, Args, Options)} @@ -1563,9 +1573,12 @@ unfold_types_in_type(Env, {app_t, Ann, Id, Args}, Options) when ?is_type_id(Id) unfold_types_in_type(Env, Id, Options) when ?is_type_id(Id) -> %% Like the case above, but for types without parameters. UnfoldRecords = proplists:get_value(unfold_record_types, Options, false), + UnfoldVariants = proplists:get_value(unfold_variant_types, Options, false), case lookup_type(Env, Id) of {_, {_, {[], {record_t, Fields}}}} when UnfoldRecords -> {record_t, unfold_types_in_type(Env, Fields, Options)}; + {_, {_, {[], {variant_t, Constrs}}}} when UnfoldVariants -> + {variant_t, unfold_types_in_type(Env, Constrs, Options)}; {_, {_, {[], {alias_t, Type1}}}} -> unfold_types_in_type(Env, Type1, Options); _ -> @@ -1574,6 +1587,8 @@ unfold_types_in_type(Env, Id, Options) when ?is_type_id(Id) -> end; unfold_types_in_type(Env, {field_t, Attr, Name, Type}, Options) -> {field_t, Attr, Name, unfold_types_in_type(Env, Type, Options)}; +unfold_types_in_type(Env, {constr_t, Ann, Con, Types}, Options) -> + {constr_t, Ann, Con, unfold_types_in_type(Env, Types, Options)}; unfold_types_in_type(Env, T, Options) when is_tuple(T) -> list_to_tuple(unfold_types_in_type(Env, tuple_to_list(T), Options)); unfold_types_in_type(Env, [H|T], Options) -> diff --git a/src/aeso_compiler.erl b/src/aeso_compiler.erl index 7a82115..7aaa77a 100644 --- a/src/aeso_compiler.erl +++ b/src/aeso_compiler.erl @@ -15,6 +15,8 @@ , create_calldata/3 , version/0 , sophia_type_to_typerep/1 + , to_sophia_value/2 + , to_sophia_value/3 ]). -include_lib("aebytecode/include/aeb_opcodes.hrl"). @@ -101,7 +103,8 @@ join_errors(Prefix, Errors, Pfun) -> Ess = [ Pfun(E) || E <- Errors ], list_to_binary(string:join([Prefix|Ess], "\n")). --define(CALL_NAME, "__call"). +-define(CALL_NAME, "__call"). +-define(DECODE_NAME, "__decode"). %% Takes a string containing a contract with a declaration/prototype of a %% function (foo, say) and a function __call() = foo(args) calling this @@ -142,6 +145,100 @@ check_call(ContractString, Options) -> fun (E) -> io_lib:format("~p", [E]) end)} end. +-spec to_sophia_value(string(), aeso_sophia:data()) -> + {ok, aeso_syntax:expr()} | {error, term()}. +to_sophia_value(ContractString, Data) -> + to_sophia_value(ContractString, Data, []). + +-spec to_sophia_value(string(), aeso_sophia:data(), options()) -> + {ok, aeso_syntax:expr()} | {error, term()}. +to_sophia_value(ContractString, Data, Options) -> + try + Ast = parse(ContractString, Options), + ok = pp_sophia_code(Ast, Options), + ok = pp_ast(Ast, Options), + {Env, TypedAst} = aeso_ast_infer_types:infer(Ast, [return_env]), + {ok, Type0} = get_decode_type(TypedAst), + Type = aeso_ast_infer_types:unfold_types_in_type(Env, Type0, [unfold_record_types, unfold_variant_types]), + ok = pp_typed_ast(TypedAst, Options), + Icode = to_icode(TypedAst, Options), + {ok, VmType} = get_decode_vm_type(Icode), + ok = pp_icode(Icode, Options), + try + {ok, translate_vm_value(VmType, Type, Data)} + catch throw:cannot_translate_to_sophia -> + Type0Str = prettypr:format(aeso_pretty:type(Type0)), + {error, join_errors("Translation error", [io_lib:format("Cannot translate VM value ~p\n of type ~p\n to Sophia type ~s\n", + [Data, VmType, Type0Str])], + fun (E) -> E end)} + end + catch + error:{parse_errors, Errors} -> + {error, join_errors("Parse errors", Errors, fun (E) -> E end)}; + error:{type_errors, Errors} -> + {error, join_errors("Type errors", Errors, fun (E) -> E end)}; + error:{badmatch, {error, missing_decode_function}} -> + {error, join_errors("Type errors", ["missing __decode function"], + fun (E) -> E end)}; + throw:Error -> %Don't ask + {error, join_errors("Code errors", [Error], + fun (E) -> io_lib:format("~p", [E]) end)} + end. + +address_literal(N) -> {hash, [], <>}. % TODO + +%% TODO: somewhere else +translate_vm_value(word, {id, _, "address"}, N) -> address_literal(N); +translate_vm_value(word, {app_t, _, {id, _, "oracle"}, _}, N) -> address_literal(N); +translate_vm_value(word, {app_t, _, {id, _, "oracle_query"}, _}, N) -> address_literal(N); +translate_vm_value(word, {id, _, "hash"}, N) -> {hash, [], <>}; +translate_vm_value(word, {id, _, "int"}, N) -> {int, [], N}; +translate_vm_value(word, {id, _, "bits"}, N) -> error({todo, bits, N}); +translate_vm_value(word, {id, _, "bool"}, N) -> {bool, [], N /= 0}; +translate_vm_value({tuple, [word, word]}, {id, _, "signature"}, {tuple, [Hi, Lo]}) -> + {hash, [], <>}; +translate_vm_value(string, {id, _, "string"}, S) -> {string, [], S}; +translate_vm_value({list, VmType}, {app_t, _, {id, _, "list"}, [Type]}, List) -> + {list, [], [translate_vm_value(VmType, Type, X) || X <- List]}; +translate_vm_value({option, VmType}, {app_t, _, {id, _, "option"}, [Type]}, Val) -> + case Val of + none -> {con, [], "None"}; + {some, X} -> {app, [], {con, [], "Some"}, [translate_vm_value(VmType, Type, X)]} + end; +translate_vm_value({variant, [[], [VmType]]}, {app_t, _, {id, _, "option"}, [Type]}, Val) -> + case Val of + {variant, 0, []} -> {con, [], "None"}; + {variant, 1, [X]} -> {app, [], {con, [], "Some"}, [translate_vm_value(VmType, Type, X)]} + end; +translate_vm_value({tuple, VmTypes}, {tuple_t, _, Types}, Val) + when length(VmTypes) == length(Types), + length(VmTypes) == tuple_size(Val) -> + {tuple, [], [translate_vm_value(VmType, Type, X) + || {VmType, Type, X} <- lists:zip3(VmTypes, Types, tuple_to_list(Val))]}; +translate_vm_value({tuple, VmTypes}, {record_t, Fields}, Val) + when length(VmTypes) == length(Fields), + length(VmTypes) == tuple_size(Val) -> + {record, [], [ {field, [], [{proj, [], FName}], translate_vm_value(VmType, FType, X)} + || {VmType, {field_t, _, FName, FType}, X} <- lists:zip3(VmTypes, Fields, tuple_to_list(Val)) ]}; +translate_vm_value({map, VmKeyType, VmValType}, {app_t, _, {id, _, "map"}, [KeyType, ValType]}, Map) + when is_map(Map) -> + {map, [], [ {translate_vm_value(VmKeyType, KeyType, Key), + translate_vm_value(VmValType, ValType, Val)} + || {Key, Val} <- maps:to_list(Map) ]}; +translate_vm_value({variant, VmCons}, {variant_t, Cons}, {variant, Tag, Args}) + when length(VmCons) == length(Cons), + length(VmCons) > Tag -> + VmTypes = lists:nth(Tag + 1, VmCons), + ConType = lists:nth(Tag + 1, Cons), + translate_vm_value(VmTypes, ConType, Args); +translate_vm_value(VmTypes, {constr_t, _, Con, Types}, Args) + when length(VmTypes) == length(Types), + length(VmTypes) == length(Args) -> + {app, [], Con, [ translate_vm_value(VmType, Type, Arg) + || {VmType, Type, Arg} <- lists:zip3(VmTypes, Types, Args) ]}; +translate_vm_value(_VmType, _Type, _Data) -> + throw(cannot_translate_to_sophia). + -spec create_calldata(map(), string(), string()) -> {ok, binary(), aeso_sophia:type(), aeso_sophia:type()} | {error, argument_syntax_error}. @@ -189,6 +286,22 @@ get_call_type([_ | Contracts]) -> %% The __call should be in the final contract get_call_type(Contracts). +get_decode_type([{contract, _, _, Defs}]) -> + case [ DecodeType + || {letfun, _, {id, _, ?DECODE_NAME}, [{arg, _, _, DecodeType}], _Ret, _} <- Defs ] of + [Type] -> {ok, Type}; + [] -> {error, missing_call_function} + end; +get_decode_type([_ | Contracts]) -> + %% The __decode should be in the final contract + get_decode_type(Contracts). + +get_decode_vm_type(#{ functions := Funs }) -> + case [ VMType || {[_, ?DECODE_NAME], _, [{_, VMType}], _, _} <- Funs ] of + [Type] -> {ok, Type}; + [] -> {error, missing_decode_function} + end. + %% Translate an icode value (error if not value) to an Erlang term that can be %% consumed by aeso_heap:to_binary(). icode_to_term(word, {integer, N}) -> N;