wip: rewrite case tree compiler to handle catch-alls
still with debug printing, and can't compile it yet
This commit is contained in:
Ulf Norell
parent
ab13222d29
commit
e2c48e1069
@ -29,19 +29,20 @@
|
|||||||
-type fexpr() :: {integer, integer()}
|
-type fexpr() :: {integer, integer()}
|
||||||
| {bool, false | true}
|
| {bool, false | true}
|
||||||
| {var, var_name()}
|
| {var, var_name()}
|
||||||
|
| {tuple, [fexpr()]}
|
||||||
| {binop, ftype(), binop(), fexpr(), fexpr()}
|
| {binop, ftype(), binop(), fexpr(), fexpr()}
|
||||||
| {'if', fexpr(), fexpr(), fexpr()}
|
| {'if', fexpr(), fexpr(), fexpr()}
|
||||||
| {'let', var_name(), fexpr(), fexpr()}
|
| {'let', var_name(), fexpr(), fexpr()}
|
||||||
| {switch, fcase()}.
|
| {switch, fsplit()}.
|
||||||
|
|
||||||
-type fcase() :: {split, ftype(), var_name(), [fsplit_case()], fdefault()}
|
-type fsplit() :: {split, ftype(), var_name(), [fcase()]}
|
||||||
| {nosplit, [var_name()], fexpr()}.
|
| {nosplit, fexpr()}.
|
||||||
|
|
||||||
|
-type fcase() :: {'case', fsplit_pat(), fsplit()}.
|
||||||
|
|
||||||
-type fsplit_case() :: {'case', fsplit_pat(), fcase()}.
|
|
||||||
-type fsplit_pat() :: {bool, false | true}
|
-type fsplit_pat() :: {bool, false | true}
|
||||||
| {tuple, [var_name()]}.
|
| {tuple, [var_name()]}
|
||||||
|
| {var, var_name()}.
|
||||||
-type fdefault() :: nodefault | {default, fcase()}.
|
|
||||||
|
|
||||||
%% Intermediate format before case trees (fcase() and fsplit()).
|
%% Intermediate format before case trees (fcase() and fsplit()).
|
||||||
-type falt() :: {'case', [fpat()], fexpr()}.
|
-type falt() :: {'case', [fpat()], fexpr()}.
|
||||||
@ -202,10 +203,17 @@ expr_to_fcode(Env, _Type, {'if', _, Cond, Then, Else}) ->
|
|||||||
expr_to_fcode(Env, Else)};
|
expr_to_fcode(Env, Else)};
|
||||||
|
|
||||||
%% Switch
|
%% Switch
|
||||||
expr_to_fcode(Env, _, {switch, _, Expr = {typed, _, _, Type}, Alts}) ->
|
expr_to_fcode(Env, _, {switch, _, Expr = {typed, _, E, Type}, Alts}) ->
|
||||||
X = fresh_name(),
|
Switch = fun(X) ->
|
||||||
{'let', X, expr_to_fcode(Env, Expr),
|
{switch, alts_to_fcode(Env, type_to_fcode(Env, Type), X, Alts)}
|
||||||
{switch, alts_to_fcode(Env, type_to_fcode(Env, Type), X, Alts)}};
|
end,
|
||||||
|
case E of
|
||||||
|
{id, _, X} -> Switch(X);
|
||||||
|
_ ->
|
||||||
|
X = fresh_name(),
|
||||||
|
{'let', X, expr_to_fcode(Env, Expr),
|
||||||
|
Switch(X)}
|
||||||
|
end;
|
||||||
|
|
||||||
%% Blocks
|
%% Blocks
|
||||||
expr_to_fcode(Env, _Type, {block, _, Stmts}) ->
|
expr_to_fcode(Env, _Type, {block, _, Stmts}) ->
|
||||||
@ -221,68 +229,140 @@ expr_to_fcode(_Env, Type, Expr) ->
|
|||||||
|
|
||||||
binop_to_fcode(Op) when Op == '+'; Op == '-'; Op == '==' -> Op.
|
binop_to_fcode(Op) when Op == '+'; Op == '-'; Op == '==' -> Op.
|
||||||
|
|
||||||
-spec alts_to_fcode(env(), ftype(), var_name(), [aeso_syntax:alt()]) -> fcase().
|
-spec alts_to_fcode(env(), ftype(), var_name(), [aeso_syntax:alt()]) -> fsplit().
|
||||||
alts_to_fcode(Env, Type, X, Alts) ->
|
alts_to_fcode(Env, Type, X, Alts) ->
|
||||||
split_tree(Env, [{X, Type}], [alt_to_fcode(Env, Alt) || Alt <- Alts]).
|
FAlts = [alt_to_fcode(Env, Alt) || Alt <- Alts],
|
||||||
|
split_tree(Env, [{X, Type}], FAlts).
|
||||||
|
|
||||||
%% Invariant: the number of variables matches the number of patterns in each falt.
|
%% %% Invariant: the number of variables matches the number of patterns in each falt.
|
||||||
-spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fcase().
|
-spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fsplit().
|
||||||
split_tree(_Env, [], [{'case', [], Expr}]) ->
|
split_tree(_Env, _Vars, []) ->
|
||||||
{nosplit, Expr};
|
error(non_exhaustive_patterns); %% TODO: nice error
|
||||||
split_tree(Env, Vars, Alts) ->
|
split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) ->
|
||||||
case next_split(Alts) of
|
io:format("split_tree\n Vars = ~p\n Alts = ~120p\n", [Vars, Alts]),
|
||||||
{nosplit, Xs, Expr} -> {nosplit, Xs, Expr};
|
case next_split(Pats) of
|
||||||
{split, I, Splits} ->
|
false ->
|
||||||
{Vars1, [{X, T} | Vars2]} = lists:split(I, Vars),
|
Xs = [ X || {X, _} <- Vars ],
|
||||||
Cases = [{'case', Pat, split_tree(Env, Vars1 ++ split_vars(Pat, T) ++ Vars2, As)}
|
Ys = [ Y || {var, Y} <- Pats ],
|
||||||
|| {Pat, As} <- Splits],
|
Ren = [ {Y, X} || {Y, X} <- lists:zip(Ys, Xs), X /= Y, Y /= "_" ],
|
||||||
{split, T, X, Cases, nodefault}
|
%% TODO: Unreachable clauses error
|
||||||
|
io:format("Renaming: ~p in\n ~p\n", [Ren, Body]),
|
||||||
|
{nosplit, rename(Ren, Body)};
|
||||||
|
I when is_integer(I) ->
|
||||||
|
io:format(" split_at ~p\n", [I]),
|
||||||
|
{Vars0, [{X, Type} | Vars1]} = lists:split(I - 1, Vars),
|
||||||
|
SAlts = merge_alts(I, X, [ split_alt(I, A) || A <- Alts ]),
|
||||||
|
io:format(" SAlts = ~p\n", [SAlts]),
|
||||||
|
Cases = [ {'case', SPat, split_tree(Env, Vars0 ++ split_vars(SPat, Type) ++ Vars1, FAlts)}
|
||||||
|
|| {SPat, FAlts} <- SAlts ],
|
||||||
|
{split, Type, X, Cases}
|
||||||
end.
|
end.
|
||||||
|
|
||||||
|
-spec merge_alts(integer(), var_name(), [{fsplit_pat(), falt()}]) -> [{fsplit_pat(), [falt()]}].
|
||||||
|
merge_alts(I, X, Alts) ->
|
||||||
|
lists:foldr(fun(A, As) -> merge_alt(I, X, A, As) end,
|
||||||
|
[], Alts).
|
||||||
|
|
||||||
|
-spec merge_alt(integer(), var_name(), {fsplit_pat(), falt()}, Alts) -> Alts
|
||||||
|
when Alts :: [{fsplit_pat(), [falt()]}].
|
||||||
|
merge_alt(_, _, {P, A}, []) -> [{P, [A]}];
|
||||||
|
merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
|
||||||
|
Match = fun({var, _}, {var, _}) -> match;
|
||||||
|
({tuple, _}, {tuple, _}) -> match;
|
||||||
|
({bool, B}, {bool, B}) -> match;
|
||||||
|
({var, _}, _) -> expand;
|
||||||
|
(_, {var, _}) -> insert;
|
||||||
|
(_, _) -> mismatch
|
||||||
|
end,
|
||||||
|
|
||||||
|
case Match(P, Q) of
|
||||||
|
match -> [{Q, [A | As]} | Rest];
|
||||||
|
mismatch -> [{Q, As} | merge_alt(I, X, {P, A}, Rest)];
|
||||||
|
expand -> [{Q, [expand(I, X, Q, A) | As]} | Rest];
|
||||||
|
insert -> [{P, [A]}, {Q, As} | Rest]
|
||||||
|
end.
|
||||||
|
|
||||||
|
expand(I, X, Q, {'case', Ps, E}) ->
|
||||||
|
{Ps0, [{var, Y} | Ps1]} = lists:split(I - 1, Ps),
|
||||||
|
Qs = case Q of
|
||||||
|
{tuple, Xs} -> [{var, "_"} || _ <- Xs];
|
||||||
|
{bool, _} -> []
|
||||||
|
end,
|
||||||
|
{'case', Ps0 ++ Qs ++ Ps1, rename([{Y, X}], E)}.
|
||||||
|
|
||||||
|
-spec split_alt(integer(), falt()) -> {fsplit_pat(), falt()}.
|
||||||
|
split_alt(I, {'case', Pats, Body}) ->
|
||||||
|
{Pats0, [Pat | Pats1]} = lists:split(I - 1, Pats),
|
||||||
|
{SPat, InnerPats} = split_pat(Pat),
|
||||||
|
{SPat, {'case', Pats0 ++ InnerPats ++ Pats1, Body}}.
|
||||||
|
|
||||||
|
-spec split_pat(fpat()) -> {fsplit_pat(), [fpat()]}.
|
||||||
|
split_pat(P = {var, X}) -> {{var, fresh_if_blank(X)}, [P]};
|
||||||
|
split_pat({bool, B}) -> {{bool, B}, []};
|
||||||
|
split_pat({tuple, Pats}) ->
|
||||||
|
Var = fun({var, X}) -> fresh_if_blank(X); (_) -> fresh_name() end,
|
||||||
|
Xs = [Var(P) || P <- Pats],
|
||||||
|
{{tuple, Xs}, Pats}.
|
||||||
|
|
||||||
-spec split_vars(fsplit_pat(), ftype()) -> [{var_name(), ftype()}].
|
-spec split_vars(fsplit_pat(), ftype()) -> [{var_name(), ftype()}].
|
||||||
split_vars({bool, _}, boolean) -> [];
|
split_vars({bool, _}, boolean) -> [];
|
||||||
split_vars({tuple, Xs}, {tuple, Ts}) ->
|
split_vars({tuple, Xs}, {tuple, Ts}) ->
|
||||||
lists:zip(Xs, Ts).
|
lists:zip(Xs, Ts);
|
||||||
|
split_vars({var, X}, T) -> [{X, T}].
|
||||||
|
|
||||||
%% TODO: catchalls
|
-spec rename([{var_name(), var_name()}], fexpr()) -> fexpr().
|
||||||
-spec next_split([falt()]) -> {nosplit, [var_name()], fexpr()} | {split, integer(), [{fsplit_pat(), [falt()]}]}.
|
rename(Ren, Expr) ->
|
||||||
next_split([]) ->
|
case Expr of
|
||||||
{nosplit, {abort, <<"Non-exhaustive pattern">>}};
|
{integer, _} -> Expr;
|
||||||
next_split(Alts = [{'case', Pats, Body} | _]) ->
|
{bool, _} -> Expr;
|
||||||
NotMatch = fun({var, _}) -> true; (_) -> false end,
|
{var, X} -> {var, rename_var(Ren, X)};
|
||||||
case lists:splitwith(NotMatch, Pats) of
|
{tuple, Es} -> {tuple, [rename(Ren, E) || E <- Es]};
|
||||||
{Vars, []} -> {nosplit, [X || {var, X} <- Vars], Body};
|
{binop, T, Op, E1, E2} -> {binop, T, Op, rename(Ren, E1), rename(Ren, E2)};
|
||||||
{Vars, _} ->
|
{'if', A, B, C} -> {'if', rename(Ren, A), rename(Ren, B), rename(Ren, C)};
|
||||||
I = length(Vars),
|
{'let', X, E, Body} ->
|
||||||
Splits = group_by_split_pat([ split_alt(I, Alt) || Alt <- Alts ]),
|
{Z, Ren1} = rename_binding(Ren, X),
|
||||||
{split, I, Splits}
|
{'let', Z, rename(Ren, E), rename(Ren1, Body)};
|
||||||
|
{switch, Split} -> {switch, rename_split(Ren, Split)}
|
||||||
end.
|
end.
|
||||||
|
|
||||||
-spec split_alt(integer(), falt()) -> {fsplit_pat() | default, falt()}.
|
rename_var(Ren, X) -> proplists:get_value(X, Ren, X).
|
||||||
split_alt(I, {'case', Pats, Body}) ->
|
rename_binding(Ren, X) ->
|
||||||
{Pats1, [Pat | Pats2]} = lists:split(I, Pats),
|
Ren1 = lists:keydelete(X, 1, Ren),
|
||||||
{FPat, InnerPats} = split_pat(Pat),
|
case lists:keymember(X, 2, Ren) of
|
||||||
{FPat, {'case', Pats1 ++ InnerPats ++ Pats2, Body}}.
|
false -> {X, Ren1};
|
||||||
|
true ->
|
||||||
|
Z = fresh_name(),
|
||||||
|
{Z, [{X, Z} | Ren1]}
|
||||||
|
end.
|
||||||
|
|
||||||
-spec split_pat(fpat()) -> {fsplit_pat() | default, [fpat()]}.
|
rename_bindings(Ren, []) -> {[], Ren};
|
||||||
split_pat({var, X}) -> {default, [{var, X}]};
|
rename_bindings(Ren, [X | Xs]) ->
|
||||||
split_pat({bool, B}) -> {{bool, B}, []};
|
{Z, Ren1} = rename_binding(Ren, X),
|
||||||
split_pat({tuple, Pats}) ->
|
{Zs, Ren2} = rename_bindings(Ren1, Xs),
|
||||||
Var = fun({var, X}) -> X; (_) -> fresh_name() end,
|
{[Z | Zs], Ren2}.
|
||||||
Xs = [Var(P) || P <- Pats],
|
|
||||||
{{tuple, Xs}, Pats}.
|
|
||||||
|
|
||||||
-spec group_by_split_pat([{fsplit_pat() | default, falt()}]) -> [{fsplit_pat(), [falt()]}].
|
rename_pat(Ren, P = {bool, _}) -> {P, Ren};
|
||||||
group_by_split_pat(Alts) ->
|
rename_pat(Ren, {var, X}) ->
|
||||||
Tag = fun(default) -> default;
|
{Z, Ren1} = rename_binding(Ren, X),
|
||||||
({tuple, _}) -> tuple;
|
{{var, Z}, Ren1};
|
||||||
({bool, B}) -> B
|
rename_pat(Ren, {tuple, Xs}) ->
|
||||||
end,
|
{Zs, Ren1} = rename_bindings(Ren, Xs),
|
||||||
Grouped = maps:values(lists:foldr(
|
{{tuple, Zs}, Ren1}.
|
||||||
fun({Pat, _} = Alt, Map) ->
|
|
||||||
maps:update_with(Tag(Pat), fun(As) -> [Alt | As] end, [Alt], Map)
|
rename_split(Ren, {split, Type, X, Cases}) ->
|
||||||
end, #{}, Alts)),
|
{split, Type, rename_var(Ren, X), [rename_case(Ren, C) || C <- Cases]}.
|
||||||
[ {Pat, [As || {_, As} <- G]} || G = [{Pat, _} | _] <- Grouped ].
|
|
||||||
|
rename_case(Ren, {'case', Pat, Split}) ->
|
||||||
|
{Pat1, Ren1} = rename_pat(Ren, Pat),
|
||||||
|
{'case', Pat1, rename_split(Ren1, Split)}.
|
||||||
|
|
||||||
|
-spec next_split([fpat()]) -> integer() | false.
|
||||||
|
next_split(Pats) ->
|
||||||
|
IsVar = fun({var, _}) -> true; (_) -> false end,
|
||||||
|
case [ I || {I, P} <- indexed(Pats), not IsVar(P) ] of
|
||||||
|
[] -> false;
|
||||||
|
[I | _] -> I
|
||||||
|
end.
|
||||||
|
|
||||||
-spec alt_to_fcode(env(), aeso_syntax:alt()) -> falt().
|
-spec alt_to_fcode(env(), aeso_syntax:alt()) -> falt().
|
||||||
alt_to_fcode(Env, {'case', _, Pat, Expr}) ->
|
alt_to_fcode(Env, {'case', _, Pat, Expr}) ->
|
||||||
@ -395,8 +475,17 @@ fresh_name() ->
|
|||||||
put('%fresh', N + 1),
|
put('%fresh', N + 1),
|
||||||
lists:concat(["%", N]).
|
lists:concat(["%", N]).
|
||||||
|
|
||||||
|
-spec fresh_if_blank(var_name()) -> var_name().
|
||||||
|
fresh_if_blank("_") -> fresh_name();
|
||||||
|
fresh_if_blank(X) -> X.
|
||||||
|
|
||||||
%% -- Attributes --
|
%% -- Attributes --
|
||||||
|
|
||||||
get_attributes(Ann) ->
|
get_attributes(Ann) ->
|
||||||
[stateful || proplists:get_value(stateful, Ann, false)].
|
[stateful || proplists:get_value(stateful, Ann, false)].
|
||||||
|
|
||||||
|
%% -- Basic utilities --
|
||||||
|
|
||||||
|
indexed(Xs) ->
|
||||||
|
lists:zip(lists:seq(1, length(Xs)), Xs).
|
||||||
|
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user