From 238ffdc8e05d8cb23f47ddcbea1852df6d3634c1 Mon Sep 17 00:00:00 2001 From: Ulf Norell Date: Tue, 14 Jan 2020 10:08:27 +0100 Subject: [PATCH] Allow pattern matching in left-hand sides --- src/aeso_aci.erl | 2 +- src/aeso_ast_infer_types.erl | 67 ++++++------- src/aeso_ast_to_fcode.erl | 15 ++- src/aeso_ast_to_icode.erl | 10 +- src/aeso_compiler.erl | 4 +- src/aeso_parser.erl | 13 +-- src/aeso_pretty.erl | 2 +- src/aeso_syntax.erl | 2 +- src/aeso_syntax_utils.erl | 2 +- test/aeso_compiler_tests.erl | 160 +++++++++++++++++--------------- test/aeso_parser_tests.erl | 2 +- test/contracts/factorial.aes | 8 +- test/contracts/lhs_matching.aes | 22 +++++ test/contracts/stack.aes | 7 +- 14 files changed, 183 insertions(+), 133 deletions(-) create mode 100644 test/contracts/lhs_matching.aes diff --git a/src/aeso_aci.erl b/src/aeso_aci.erl index 7f9f7a9..274be69 100644 --- a/src/aeso_aci.erl +++ b/src/aeso_aci.erl @@ -129,7 +129,7 @@ encode_anon_args(Types) -> encode_args(Args) -> [ encode_arg(A) || A <- Args ]. -encode_arg({arg, _, Id, T}) -> +encode_arg({typed, _, Id, T}) -> #{name => encode_type(Id), type => encode_type(T)}. diff --git a/src/aeso_ast_infer_types.erl b/src/aeso_ast_infer_types.erl index dd9f657..e5fcc68 100644 --- a/src/aeso_ast_infer_types.erl +++ b/src/aeso_ast_infer_types.erl @@ -679,7 +679,7 @@ process_block(Ann, [Decl | Decls]) -> process_block(Ann, Rest)]; {letfun, Ann1, Id = {id, _, Name}, _, _, _} -> {Clauses, Rest} = lists:splitwith(IsThis(Name), [Decl | Decls]), - [{fun_clauses, Ann1, Id, {id, [{origin, system}], "_"}, Clauses} | + [{fun_clauses, Ann1, Id, {id, [{origin, system} | Ann1], "_"}, Clauses} | process_block(Ann, Rest)] end. @@ -815,9 +815,9 @@ check_type(Env, T) -> check_type(Env, T = {tvar, _, _}, Arity) -> [ type_error({higher_kinded_typevar, T}) || Arity /= 0 ], check_tvar(Env, T); -check_type(_Env, X = {id, _, "_"}, Arity) -> +check_type(_Env, X = {id, Ann, "_"}, Arity) -> ensure_base_type(X, Arity), - X; + fresh_uvar(Ann); check_type(Env, X = {Tag, _, _}, Arity) when Tag == con; Tag == qcon; Tag == id; Tag == qid -> case lookup_type(Env, X) of {Q, {_, Def}} -> @@ -1011,44 +1011,49 @@ infer_letrec(Env, Defs) -> infer_letfun(Env, {fun_clauses, Ann, Fun = {id, _, Name}, Type, Clauses}) -> Type1 = check_type(Env, Type), - {NameSigs, Clauses1} = lists:unzip([ infer_letfun(Env, Clause) || Clause <- Clauses ]), + {NameSigs, Clauses1} = lists:unzip([ infer_letfun1(Env, Clause) || Clause <- Clauses ]), {_, Sigs = [Sig | _]} = lists:unzip(NameSigs), _ = [ begin ClauseT = typesig_to_fun_t(ClauseSig), unify(Env, ClauseT, Type1, {check_typesig, Name, ClauseT, Type1}) end || ClauseSig <- Sigs ], {{Name, Sig}, desugar_clauses(Ann, Fun, Sig, Clauses1)}; -infer_letfun(Env0, {letfun, Attrib, Fun = {id, NameAttrib, Name}, Args, What, Body}) -> +infer_letfun(Env, LetFun = {letfun, Ann, Fun, _, _, _}) -> + {{Name, Sig}, Clause} = infer_letfun1(Env, LetFun), + {{Name, Sig}, desugar_clauses(Ann, Fun, Sig, [Clause])}. + +infer_letfun1(Env0, {letfun, Attrib, Fun = {id, NameAttrib, Name}, Args, What, Body}) -> Env = Env0#env{ stateful = aeso_syntax:get_ann(stateful, Attrib, false), current_function = Fun }, - check_unique_arg_names(Fun, Args), - ArgTypes = [{ArgName, check_type(Env, arg_type(ArgAnn, T))} || {arg, ArgAnn, ArgName, T} <- Args], + {NewEnv, {typed, _, {tuple, _, TypedArgs}, {tuple_t, _, ArgTypes}}} = infer_pattern(Env, {tuple, [{origin, system} | NameAttrib], Args}), ExpectedType = check_type(Env, arg_type(NameAttrib, What)), - NewBody={typed, _, _, ResultType} = check_expr(bind_vars(ArgTypes, Env), Body, ExpectedType), - NewArgs = [{arg, A1, {id, A2, ArgName}, T} - || {{_, T}, {arg, A1, {id, A2, ArgName}, _}} <- lists:zip(ArgTypes, Args)], + NewBody={typed, _, _, ResultType} = check_expr(NewEnv, Body, ExpectedType), NamedArgs = [], - TypeSig = {type_sig, Attrib, none, NamedArgs, [T || {arg, _, _, T} <- NewArgs], ResultType}, + TypeSig = {type_sig, Attrib, none, NamedArgs, ArgTypes, ResultType}, {{Name, TypeSig}, - {letfun, Attrib, {id, NameAttrib, Name}, NewArgs, ResultType, NewBody}}. + {letfun, Attrib, {id, NameAttrib, Name}, TypedArgs, ResultType, NewBody}}. desugar_clauses(Ann, Fun, {type_sig, _, _, _, ArgTypes, RetType}, Clauses) -> - NoAnn = [{origin, system}], - Args = [ {arg, NoAnn, {id, NoAnn, "x#" ++ integer_to_list(I)}, Type} - || {I, Type} <- indexed(1, ArgTypes) ], - ArgTuple = {tuple, NoAnn, [X || {arg, _, X, _} <- Args]}, - ArgType = {tuple_t, NoAnn, ArgTypes}, - {letfun, Ann, Fun, Args, RetType, - {switch, NoAnn, {typed, NoAnn, ArgTuple, ArgType}, - [ {'case', AnnC, {tuple, AnnC, [ {typed, AnnA, Pat, PatT} || {arg, AnnA, Pat, PatT} <- ArgsC ]}, Body} - || {letfun, AnnC, _, ArgsC, _, Body} <- Clauses ]}}. - -check_unique_arg_names(Fun, Args) -> - Name = fun({arg, _, {id, _, X}, _}) -> X end, - Names = lists:map(Name, Args), - Dups = lists:usort(Names -- lists:usort(Names)), - [ type_error({repeated_arg, Fun, Arg}) || Arg <- Dups ], - ok. + NeedDesugar = + case Clauses of + [{letfun, _, _, As, _, _}] -> lists:any(fun({typed, _, {id, _, _}, _}) -> false; (_) -> true end, As); + _ -> true + end, + case NeedDesugar of + false -> [Clause] = Clauses, Clause; + true -> + NoAnn = [{origin, system}], + Args = [ {typed, NoAnn, {id, NoAnn, "x#" ++ integer_to_list(I)}, Type} + || {I, Type} <- indexed(1, ArgTypes) ], + Tuple = fun([X]) -> X; + (As) -> {typed, NoAnn, {tuple, NoAnn, As}, {tuple_t, NoAnn, ArgTypes}} + end, + {letfun, Ann, Fun, Args, RetType, + {typed, NoAnn, + {switch, NoAnn, Tuple(Args), + [ {'case', AnnC, Tuple(ArgsC), Body} + || {letfun, AnnC, _, ArgsC, _, Body} <- Clauses ]}, RetType}} + end. print_typesig({Name, TypeSig}) -> ?PRINT_TYPES("Inferred ~s : ~s\n", [Name, pp(TypeSig)]). @@ -1141,9 +1146,9 @@ get_call_chains(Graph, Visited, Queue, Stop, Acc) -> end. check_expr(Env, Expr, Type) -> - E = {typed, _, _, Type1} = infer_expr(Env, Expr), + {typed, Ann, Expr1, Type1} = infer_expr(Env, Expr), unify(Env, Type1, Type, {check_expr, Expr, Type1, Type}), - E. + {typed, Ann, Expr1, Type}. %% Keep the user-given type infer_expr(_Env, Body={bool, As, _}) -> {typed, As, Body, {id, As, "bool"}}; @@ -1428,7 +1433,7 @@ infer_pattern(Env, Pattern) -> end, NewEnv = bind_vars([{Var, fresh_uvar(Ann1)} || Var = {id, Ann1, _} <- Vars], Env#env{ in_pattern = true }), NewPattern = infer_expr(NewEnv, Pattern), - {NewEnv, NewPattern}. + {NewEnv#env{ in_pattern = Env#env.in_pattern }, NewPattern}. infer_case(Env, Attrs, Pattern, ExprType, Branch, SwitchType) -> {NewEnv, NewPattern = {typed, _, _, PatType}} = infer_pattern(Env, Pattern), diff --git a/src/aeso_ast_to_fcode.erl b/src/aeso_ast_to_fcode.erl index 4a4955b..0f070e3 100644 --- a/src/aeso_ast_to_fcode.erl +++ b/src/aeso_ast_to_fcode.erl @@ -415,9 +415,12 @@ type_to_fcode(Env, Sub, {fun_t, _, Named, Args, Res}) -> type_to_fcode(_Env, _Sub, Type) -> error({todo, Type}). --spec args_to_fcode(env(), [aeso_syntax:arg()]) -> [{var_name(), ftype()}]. +-spec args_to_fcode(env(), [aeso_syntax:pattern()]) -> [{var_name(), ftype()}]. args_to_fcode(Env, Args) -> - [ {Name, type_to_fcode(Env, Type)} || {arg, _, {id, _, Name}, Type} <- Args ]. + [ case Arg of + {id, _, Name} -> {Name, type_to_fcode(Env, Type)}; + _ -> internal_error({bad_arg, Arg}) %% Pattern matching has been moved to the rhs at this point + end || {typed, _, Arg, Type} <- Args ]. -define(make_let(X, Expr, Body), make_let(Expr, fun(X) -> Body end)). @@ -722,7 +725,7 @@ validate_aens_resolve_type(Ann, {app_t, _, _, [Type]}, {variant, [[], [FType]]}) ensure_first_order_entrypoint(Ann, Id = {id, _, Name}, Args, Ret, FArgs, FRet) -> [ ensure_first_order(FT, {invalid_entrypoint, higher_order, Ann1, Id, {argument, X, T}}) - || {{arg, Ann1, X, T}, {_, FT}} <- lists:zip(Args, FArgs) ], + || {{typed, Ann1, X, T}, {_, FT}} <- lists:zip(Args, FArgs) ], [ ensure_first_order(FRet, {invalid_entrypoint, higher_order, Ann, Id, {result, Ret}}) || Name /= "init" ], %% init can return higher-order values, since they're written to the store %% rather than being returned. @@ -968,7 +971,11 @@ stmts_to_fcode(Env, [{letval, _, {typed, _, {id, _, X}, _}, Expr} | Stmts]) -> stmts_to_fcode(Env, [{letval, Ann, Pat, Expr} | Stmts]) -> expr_to_fcode(Env, {switch, Ann, Expr, [{'case', Ann, Pat, {block, Ann, Stmts}}]}); stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, Expr} | Stmts]) -> - {'let', X, expr_to_fcode(Env, {lam, Ann, Args, Expr}), + LamArgs = [ case Arg of + {typed, Ann1, Id, T} -> {arg, Ann1, Id, T}; + _ -> internal_error({bad_arg, Arg}) %% pattern matching has been desugared + end || Arg <- Args ], + {'let', X, expr_to_fcode(Env, {lam, Ann, LamArgs, Expr}), stmts_to_fcode(bind_var(Env, X), Stmts)}; stmts_to_fcode(Env, [Expr]) -> expr_to_fcode(Env, Expr); diff --git a/src/aeso_ast_to_icode.erl b/src/aeso_ast_to_icode.erl index 7a47905..48f6b82 100644 --- a/src/aeso_ast_to_icode.erl +++ b/src/aeso_ast_to_icode.erl @@ -131,7 +131,7 @@ contract_to_icode([Decl | Code], Icode) -> ast_id({id, _, Id}) -> Id; ast_id({qid, _, Id}) -> Id. -ast_args([{arg, _, Name, Type}|Rest], Acc, Icode) -> +ast_args([{typed, _, Name, Type}|Rest], Acc, Icode) -> ast_args(Rest, [{ast_id(Name), ast_typerep1(Type, Icode)}| Acc], Icode); ast_args([], Acc, _Icode) -> lists:reverse(Acc). @@ -355,7 +355,9 @@ ast_body({block, As, [{letval, _, Pat, E} | Rest]}, Icode) -> #switch{expr = E1, cases = [{Pat1, Rest1}]}; ast_body({block, As, [{letfun, Ann, F, Args, _Type, Expr} | Rest]}, Icode) -> - ast_body({block, As, [{letval, Ann, F, {lam, Ann, Args, Expr}} | Rest]}, Icode); + ToArg = fun({typed, Ann1, Id, T}) -> {arg, Ann1, Id, T} end, %% Pattern matching has been desugared + LamArgs = lists:map(ToArg, Args), + ast_body({block, As, [{letval, Ann, F, {lam, Ann, LamArgs, Expr}} | Rest]}, Icode); ast_body({block,_,[]}, _Icode) -> #tuple{cpts=[]}; ast_body({block,_,[E]}, Icode) -> @@ -804,10 +806,10 @@ check_entrypoint_type(Ann, Name, Args, Ret) -> true -> ok end end, [ CheckFirstOrder(T, {invalid_entrypoint, higher_order, Ann1, Name, {argument, X, T}}) - || {arg, Ann1, X, T} <- Args ], + || {typed, Ann1, X, T} <- Args ], CheckFirstOrder(Ret, {invalid_entrypoint, higher_order, Ann, Name, {result, Ret}}), [ CheckMonomorphic(T, {invalid_entrypoint, polymorphic, Ann1, Name, {argument, X, T}}) - || {arg, Ann1, X, T} <- Args ], + || {typed, Ann1, X, T} <- Args ], CheckMonomorphic(Ret, {invalid_entrypoint, polymorphic, Ann, Name, {result, Ret}}). check_oracle_type(Ann, Type = ?oracle_t(QType, RType)) -> diff --git a/src/aeso_compiler.erl b/src/aeso_compiler.erl index 6327f00..c677119 100644 --- a/src/aeso_compiler.erl +++ b/src/aeso_compiler.erl @@ -389,8 +389,8 @@ decode_calldata(ContractString, FunName, Calldata, Options0) -> #{ typed_ast := TypedAst, type_env := TypeEnv} = Code, {ok, Args, _} = get_decode_type(FunName, TypedAst), - DropArg = fun({arg, _, _, T}) -> T; (T) -> T end, - ArgTypes = lists:map(DropArg, Args), + GetType = fun({typed, _, _, T}) -> T; (T) -> T end, + ArgTypes = lists:map(GetType, Args), Type0 = {tuple_t, [], ArgTypes}, %% user defined data types such as variants needed to match against Type = aeso_ast_infer_types:unfold_types_in_type(TypeEnv, Type0, [unfold_record_types, unfold_variant_types]), diff --git a/src/aeso_parser.erl b/src/aeso_parser.erl index 0ffce9a..74a329c 100644 --- a/src/aeso_parser.erl +++ b/src/aeso_parser.erl @@ -176,14 +176,15 @@ valdef() -> fundef() -> choice( - [ ?RULE(id(), args(), tok('='), body(), {letfun, get_ann(_1), _1, _2, type_wildcard(), _4}) + [ ?RULE(id(), args(), tok('='), body(), {letfun, get_ann(_1), _1, _2, type_wildcard(get_ann(_1)), _4}) , ?RULE(id(), args(), tok(':'), type(), tok('='), body(), {letfun, get_ann(_1), _1, _2, _4, _6}) ]). -args() -> paren_list(arg()). +args() -> paren_list(pattern()). +lam_args() -> paren_list(arg()). arg() -> choice( - ?RULE(id(), {arg, get_ann(_1), _1, type_wildcard()}), + ?RULE(id(), {arg, get_ann(_1), _1, type_wildcard(get_ann(_1))}), ?RULE(id(), tok(':'), type(), {arg, get_ann(_1), _1, _3})). %% -- Types ------------------------------------------------------------------ @@ -254,7 +255,7 @@ expr100() -> Expr100 = ?LAZY_P(expr100()), Expr200 = ?LAZY_P(expr200()), choice( - [ ?RULE(args(), keyword('=>'), body(), {lam, _2, _1, _3}) %% TODO: better location + [ ?RULE(lam_args(), keyword('=>'), body(), {lam, _2, _1, _3}) %% TODO: better location , {'if', keyword('if'), parens(Expr100), Expr200, right(tok(else), Expr100)} , ?RULE(Expr200, optional(right(tok(':'), type())), case _2 of @@ -500,8 +501,8 @@ infix(L, Op, R) -> set_ann(format, infix, {app, get_ann(L), Op, [L, R]}). prefixes(Ops, E) -> lists:foldr(fun prefix/2, E, Ops). prefix(Op, E) -> set_ann(format, prefix, {app, get_ann(Op), Op, [E]}). -type_wildcard() -> - {id, [{origin, system}], "_"}. +type_wildcard(Ann) -> + {id, [{origin, system} | Ann], "_"}. block_e(Stmts) -> group_ifs(Stmts, []). diff --git a/src/aeso_pretty.erl b/src/aeso_pretty.erl index f5eb688..bf00107 100644 --- a/src/aeso_pretty.erl +++ b/src/aeso_pretty.erl @@ -200,7 +200,7 @@ name({typed, _, Name, _}) -> name(Name). letdecl(Let, {letval, _, P, E}) -> block_expr(0, hsep([text(Let), expr(P), text("=")]), E); letdecl(Let, {letfun, _, F, Args, T, E}) -> - block_expr(0, hsep([text(Let), typed(beside(name(F), args(Args)), T), text("=")]), E). + block_expr(0, hsep([text(Let), typed(beside(name(F), expr({tuple, [], Args})), T), text("=")]), E). -spec args([aeso_syntax:arg()]) -> doc(). args(Args) -> diff --git a/src/aeso_syntax.erl b/src/aeso_syntax.erl index 514781c..61011da 100644 --- a/src/aeso_syntax.erl +++ b/src/aeso_syntax.erl @@ -50,7 +50,7 @@ -type letbind() :: {letval, ann(), pat(), expr()} - | {letfun, ann(), id(), [arg()], type(), expr()}. + | {letfun, ann(), id(), [pat()], type(), expr()}. -type arg() :: {arg, ann(), id(), type()}. diff --git a/src/aeso_syntax_utils.erl b/src/aeso_syntax_utils.erl index a7b5988..71c7c90 100644 --- a/src/aeso_syntax_utils.erl +++ b/src/aeso_syntax_utils.erl @@ -50,7 +50,7 @@ fold(Alg = #alg{zero = Zero, plus = Plus, scoped = Scoped}, Fun, K, X) -> {fun_decl, _, _, T} -> Type(T); {letval, _, P, E} -> Scoped(BindExpr(P), Expr(E)); {letfun, _, F, Xs, T, E} -> Sum([BindExpr(F), Type(T), Expr(Xs ++ [E])]); - {fun_clauses, _, _, T, Cs} -> Sum([Type(T), Decl(Cs)]); + {fun_clauses, _, _, T, Cs} -> Sum([Type(T) | [Decl(C) || C <- Cs]]); %% typedef() {alias_t, T} -> Type(T); {record_t, Fs} -> Type(Fs); diff --git a/test/aeso_compiler_tests.erl b/test/aeso_compiler_tests.erl index 8a36646..c45b9ec 100644 --- a/test/aeso_compiler_tests.erl +++ b/test/aeso_compiler_tests.erl @@ -164,7 +164,8 @@ compilable_contracts() -> "unapplied_builtins", "underscore_number_literals", "qualified_constructor", - "let_patterns" + "let_patterns", + "lhs_matching" ]. not_yet_compilable(fate) -> []; @@ -299,9 +300,22 @@ failing_contracts() -> "Repeated name x in pattern\n" " x :: x (at line 26, column 7)">>, <>, - <>, + "Repeated names x, y in pattern\n" + " (x : int, y, x : string, y : bool) (at line 44, column 14)">>, + <>, + <>, <>, < <>]) , ?TYPE_ERROR(bad_address_literals, - [<>, - <>, - <>, - <>, - <>, - <>, - <>, - <>, - <>, - < " ak_2gx9MEFxKvY9vMG5YnqnXWv1hCsX7rgnfvBLJS4aQurustR1rt : address\n" "against the expected type\n" " bytes(32)">>, + <>, + <>, + <>, + <>, + <>, + <>, + <>, + <>, + <>, < "Failed to resolve byte array lengths in call to Bytes.split with argument of type\n" " - 'f (at line 12, column 20)\n" "and result types\n" - " - 'e (at line 13, column 5)\n" + " - 'e (at line 12, column 25)\n" " - bytes(20) (at line 12, column 29)">>, < " - 'b (at line 18, column 20)\n" "and result types\n" " - bytes(20) (at line 18, column 25)\n" - " - 'a (at line 19, column 5)">>]) + " - 'a (at line 18, column 37)">>]) , ?TYPE_ERROR(wrong_compiler_version, [< " function id(x) = x\n", ?assertMatch( [{contract, _, {con, _, "Identity"}, - [{letfun, _, {id, _, "id"}, [{arg, _, {id, _, "x"}, {id, _, "_"}}], {id, _, "_"}, + [{letfun, _, {id, _, "id"}, [{id, _, "x"}], {id, _, "_"}, {id, _, "x"}}]}], parse_string(Text)), ok end}, diff --git a/test/contracts/factorial.aes b/test/contracts/factorial.aes index 46ca1a6..88a8869 100644 --- a/test/contracts/factorial.aes +++ b/test/contracts/factorial.aes @@ -11,7 +11,7 @@ contract Factorial = stateful entrypoint set_worker(worker) = put(state{worker = worker}) - entrypoint fac(x : int) : int = - if(x == 0) 1 - else x * state.worker.fac(x - 1) - + entrypoint + fac : int => int + fac(0) = 1 + fac(x) = x * state.worker.fac(x - 1) diff --git a/test/contracts/lhs_matching.aes b/test/contracts/lhs_matching.aes new file mode 100644 index 0000000..2cafa9d --- /dev/null +++ b/test/contracts/lhs_matching.aes @@ -0,0 +1,22 @@ +contract LHSMatching = + + function from_some(Some(x)) = x + + function + length : list('a) => int + length([]) = 0 + length(_ :: xs) = 1 + length(xs) + + function + append([], ys) = ys + append(x :: xs, ys) = x :: append(xs, ys) + + function local_match(xs : list('a)) = + let null([]) = true + let null(_ :: _) = false + !null(xs) + + entrypoint main() = + from_some(Some([0])) + ++ append([length([true]), 2, 3], [4, 5, 6]) + ++ [7 | if (local_match([false]))] diff --git a/test/contracts/stack.aes b/test/contracts/stack.aes index 2372114..15177dd 100644 --- a/test/contracts/stack.aes +++ b/test/contracts/stack.aes @@ -8,10 +8,9 @@ contract Stack = entrypoint init(ss : list(string)) = { stack = ss, size = length(ss) } - function length(xs) = - switch(xs) - [] => 0 - _ :: xs => length(xs) + 1 + function + length([]) = 0 + length(_ :: xs) = length(xs) + 1 stateful entrypoint pop() : string = switch(state.stack)