Merge pull request #28 from aeternity/decode-vm-to-sophia

Add function to decode VM values to Sophia abstract syntax

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) ->
@@ -508,20 +508,24 @@ init_env(Options) ->
                         end, global_env(), [{"oracle", 2}, {"oracle_query", 2}])
     end.
 
--spec infer(aeso_syntax:ast(), list(option())) -> aeso_syntax:ast().
+-spec infer(aeso_syntax:ast(), list(option())) -> aeso_syntax:ast() | {env(), aeso_syntax:ast()}.
 infer(Contracts, Options) ->
     ets_init(), %% Init the ETS table state
     try
         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()].
+-spec infer1(env(), [aeso_syntax:decl()], [aeso_syntax:decl()]) -> {env(), [aeso_syntax:decl()]}.
-infer1(_, [], Acc) -> lists:reverse(Acc);
+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),
@@ -1549,6 +1553,7 @@ 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),
+    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) ->

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").
@@ -102,6 +104,7 @@ join_errors(Prefix, Errors, Pfun) ->
     list_to_binary(string:join([Prefix|Ess], "\n")).
 
 -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, [], <<N:256>>}.  % 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, [], <<N:256>>};
+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, [], <<Hi:256, Lo:256>>};
+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;

src/aeso_pretty.erl

@@ -307,6 +307,8 @@ expr_p(P, E = {app, _, F = {Op, _}, Args}) when is_atom(Op) ->
         {prefix, [A]}   -> prefix(P, Op, A);
         _               -> app(P, F, Args)
     end;
+expr_p(_, {app, _, C={Tag, _, _}, []}) when Tag == con; Tag == qcon ->
+    expr_p(0, C);
 expr_p(P, {app, _, F, Args}) ->
     app(P, F, Args);
 %% -- Constants

test/aeso_abi_tests.erl

@@ -54,27 +54,49 @@ encode_decode_test() ->
     ok.
 
 encode_decode_sophia_test() ->
-    {42} = encode_decode_sophia_string("int", "42"),
+    Check = fun(Type, Str) -> case {encode_decode_sophia_string(Type, Str), Str} of
-    {1} = encode_decode_sophia_string("bool", "true"),
+                                {X, X} -> ok;
-    {0} = encode_decode_sophia_string("bool", "false"),
+                                Other -> Other
-    {<<"Hello">>} = encode_decode_sophia_string("string", "\"Hello\""),
+                              end end,
-    {<<"Hello">>, [1,2,3], {variant, 1, [1]}} =
+    ok = Check("int", "42"),
-        encode_decode_sophia_string(
+    ok = Check("bool", "true"),
-          "(string, list(int), option(bool))",
+    ok = Check("bool", "false"),
-          "\"Hello\", [1,2,3], Some(true)"),
+    ok = Check("string", "\"Hello\""),
+    ok = Check("(string, list(int), option(bool))",
+               "(\"Hello\", [1, 2, 3], Some(true))"),
+    ok = Check("variant", "Blue({[\"x\"] = 1})"),
+    ok = Check("r", "{x = (\"foo\", 0), y = Red}"),
     ok.
 
 encode_decode_sophia_string(SophiaType, String) ->
     io:format("String ~p~n", [String]),
+    TypeDefs = ["  type an_alias('a) = (string, 'a)\n",
+                "  record r = {x : an_alias(int), y : variant}\n"
+                "  datatype variant = Red | Blue(map(string, int))\n"],
     Code = [ "contract MakeCall =\n"
-           , "  function foo : ", SophiaType, " => _\n"
+           , "  type arg_type = ", SophiaType, "\n"
+           , TypeDefs
+           , "  function foo : arg_type => _\n"
            , "  function __call() = foo(", String, ")\n" ],
-    {ok, _, {Types, _}, Args} = aeso_compiler:check_call(lists:flatten(Code), []),
+    case aeso_compiler:check_call(lists:flatten(Code), []) of
-    Arg  = list_to_tuple(Args),
+        {ok, _, {[Type], _}, [Arg]} ->
-    Type = {tuple, Types},
             io:format("Type ~p~n", [Type]),
             Data = encode(Arg),
-    decode(Type, Data).
+            Decoded = decode(Type, Data),
+            DecodeCode = [ "contract Decode =\n",
+                           TypeDefs,
+                           "  function __decode(_ : ", SophiaType, ") = ()\n" ],
+            case aeso_compiler:to_sophia_value(DecodeCode, Decoded) of
+                {ok, Sophia} ->
+                    lists:flatten(io_lib:format("~s", [prettypr:format(aeso_pretty:expr(Sophia))]));
+                {error, Err} ->
+                    io:format("~s\n", [Err]),
+                    {error, Err}
+            end;
+        {error, Err} ->
+            io:format("~s\n", [Err]),
+            {error, Err}
+    end.
 
 encode_decode(T, D) ->
     ?assertEqual(D, decode(T, encode(D))),