diff options
Diffstat (limited to 'lib/syntax_tools/src/merl_transform.erl')
| -rw-r--r-- | lib/syntax_tools/src/merl_transform.erl | 262 |
1 files changed, 262 insertions, 0 deletions
diff --git a/lib/syntax_tools/src/merl_transform.erl b/lib/syntax_tools/src/merl_transform.erl new file mode 100644 index 0000000000..66b06c8137 --- /dev/null +++ b/lib/syntax_tools/src/merl_transform.erl @@ -0,0 +1,262 @@ +%% --------------------------------------------------------------------- +%% Licensed under the Apache License, Version 2.0 (the "License"); you may +%% not use this file except in compliance with the License. You may obtain +%% a copy of the License at <http://www.apache.org/licenses/LICENSE-2.0> +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012-2015 Richard Carlsson +%% @doc Parse transform for merl. Enables the use of automatic metavariables +%% and using quasi-quotes in matches and case switches. Also optimizes calls +%% to functions in `merl' by partially evaluating them, turning strings to +%% templates, etc., at compile-time. +%% +%% Using `-include_lib("syntax_tools/include/merl.hrl").' enables this +%% transform, unless the macro `MERL_NO_TRANSFORM' is defined first. + +-module(merl_transform). + +-export([parse_transform/2]). + +%% NOTE: We cannot use inline metavariables or any other parse transform +%% features in this module, because it must be possible to compile it with +%% the parse transform disabled! +-include("merl.hrl"). + +%% TODO: unroll calls to switch? it will probably get messy + +%% TODO: use Igor to make resulting code independent of merl at runtime? + +parse_transform(Forms, _Options) -> + erl_syntax:revert_forms(expand(erl_syntax:form_list(Forms))). + +expand(Tree0) -> + Tree = pre(Tree0), + post(case erl_syntax:subtrees(Tree) of + [] -> + Tree; + Gs -> + erl_syntax:update_tree(Tree, + [[expand(T) || T <- G] || G <- Gs]) + end). + +pre(T) -> + merl:switch( + T, + [{?Q("merl:quote(_@line, _@text) = _@expr"), + fun ([{expr,_}, {line,Line}, {text,Text}]) -> + erl_syntax:is_literal(Text) andalso erl_syntax:is_literal(Line) + end, + fun ([{expr,Expr}, {line,Line}, {text,Text}]) -> + pre_expand_match(Expr, erl_syntax:concrete(Line), + erl_syntax:concrete(Text)) + end}, + {?Q(["case _@expr of", + " merl:quote(_@_, _@text) when _@__@_ -> _@@_; _@_@_ -> 0", + "end"]), + fun case_guard/1, + fun (As) -> case_body(As, T) end}, + fun () -> T end + ]). + +case_guard([{expr,_}, {text,Text}]) -> + erl_syntax:is_literal(Text). + +case_body([{expr,Expr}, {text,_Text}], T) -> + pre_expand_case(Expr, erl_syntax:case_expr_clauses(T), + erl_syntax:get_pos(T)). + +post(T) -> + merl:switch( + T, + [{?Q("merl:_@function(_@@args)"), + [{fun ([{args, As}, {function, F}]) -> + lists:all(fun erl_syntax:is_literal/1, [F|As]) + end, + fun ([{args, As}, {function, F}]) -> + Line = erl_syntax:get_pos(F), + [F1|As1] = lists:map(fun erl_syntax:concrete/1, [F|As]), + eval_call(Line, F1, As1, T) + end}, + fun ([{args, As}, {function, F}]) -> + merl:switch( + F, + [{?Q("qquote"), fun ([]) -> expand_qquote(As, T, 1) end}, + {?Q("subst"), fun ([]) -> expand_template(F, As, T) end}, + {?Q("match"), fun ([]) -> expand_template(F, As, T) end}, + fun () -> T end + ]) + end]}, + fun () -> T end]). + +expand_qquote([Line, Text, Env], T, _) -> + case erl_syntax:is_literal(Line) of + true -> + expand_qquote([Text, Env], T, erl_syntax:concrete(Line)); + false -> + T + end; +expand_qquote([Text, Env], T, Line) -> + case erl_syntax:is_literal(Text) of + true -> + As = [Line, erl_syntax:concrete(Text)], + %% expand further if possible + expand(merl:qquote(Line, "merl:subst(_@tree, _@env)", + [{tree, eval_call(Line, quote, As, T)}, + {env, Env}])); + false -> + T + end; +expand_qquote(_As, T, _StartPos) -> + T. + +expand_template(F, [Pattern | Args], T) -> + case erl_syntax:is_literal(Pattern) of + true -> + Line = erl_syntax:get_pos(Pattern), + As = [erl_syntax:concrete(Pattern)], + merl:qquote(Line, "merl:_@function(_@pattern, _@args)", + [{function, F}, + {pattern, eval_call(Line, template, As, T)}, + {args, Args}]); + false -> + T + end; +expand_template(_F, _As, T) -> + T. + +eval_call(Line, F, As, T) -> + try apply(merl, F, As) of + T1 when F =:= quote -> + %% lift metavariables in a template to Erlang variables + Template = merl:template(T1), + Vars = merl:template_vars(Template), + case lists:any(fun is_inline_metavar/1, Vars) of + true when is_list(T1) -> + merl:qquote(Line, "merl:tree([_@template])", + [{template, merl:meta_template(Template)}]); + true -> + merl:qquote(Line, "merl:tree(_@template)", + [{template, merl:meta_template(Template)}]); + false -> + merl:term(T1) + end; + T1 -> + merl:term(T1) + catch + throw:_Reason -> T + end. + +pre_expand_match(Expr, Line, Text) -> + {Template, Out, _Vars} = rewrite_pattern(Line, Text), + merl:qquote(Line, "{ok, _@out} = merl:match(_@template, _@expr)", + [{expr, Expr}, + {out, Out}, + {template, erl_syntax:abstract(Template)}]). + +rewrite_pattern(Line, Text) -> + %% we must rewrite the metavariables in the pattern to use lowercase, + %% and then use real matching to bind the Erlang-level variables + T0 = merl:template(merl:quote(Line, Text)), + Vars = [V || V <- merl:template_vars(T0), is_inline_metavar(V)], + {merl:alpha(T0, [{V, var_to_tag(V)} || V <- Vars]), + erl_syntax:list([erl_syntax:tuple([erl_syntax:abstract(var_to_tag(V)), + erl_syntax:variable(var_name(V))]) + || V <- Vars]), + Vars}. + +var_name(V) when is_integer(V) -> + V1 = if V > 99, (V rem 100) =:= 99 -> + V div 100; + V > 9, (V rem 10) =:= 9 -> + V div 10; + true -> V + end, + list_to_atom("Q" ++ integer_to_list(V1)); +var_name(V) -> V. + +var_to_tag(V) when is_integer(V) -> V; +var_to_tag(V) -> + list_to_atom(string:to_lower(atom_to_list(V))). + +pre_expand_case(Expr, Clauses, Line) -> + merl:qquote(Line, "merl:switch(_@expr, _@clauses)", + [{clauses, erl_syntax:list([pre_expand_case_clause(C) + || C <- Clauses])}, + {expr, Expr}]). + +pre_expand_case_clause(T) -> + %% note that the only allowed non ``?Q(...) -> ...'' clause is ``_ -> ...'' + merl:switch( + T, + [{?Q("(merl:quote(_@line, _@text)) when _@__@guard -> _@@body"), + fun ([{body,_}, {guard,_}, {line,Line}, {text,Text}]) -> + erl_syntax:is_literal(Text) andalso erl_syntax:is_literal(Line) + end, + fun ([{body,Body}, {guard,Guard}, {line,Line}, {text,Text}]) -> + pre_expand_case_clause(Body, Guard, erl_syntax:concrete(Line), + erl_syntax:concrete(Text)) + end}, + {?Q("_ -> _@@body"), + fun (Env) -> merl:qquote("fun () -> _@body end", Env) end} + ]). + +pre_expand_case_clause(Body, Guard, Line, Text) -> + %% this is similar to a meta-match ``?Q("...") = Term'' + %% (note that the guards may in fact be arbitrary expressions) + {Template, Out, Vars} = rewrite_pattern(Line, Text), + GuardExprs = rewrite_guard(Guard), + Param = [{body, Body}, + {guard,GuardExprs}, + {out, Out}, + {template, erl_syntax:abstract(Template)}, + {unused, dummy_uses(Vars)}], + case GuardExprs of + [] -> + merl:qquote(Line, ["{_@template, ", + " fun (_@out) -> _@unused, _@body end}"], + Param); + _ -> + merl:qquote(Line, ["{_@template, ", + " fun (_@out) -> _@unused, _@guard end, ", + " fun (_@out) -> _@unused, _@body end}"], + Param) + end. + +%% We have to insert dummy variable uses at the beginning of the "guard" and +%% "body" function bodies to avoid warnings for unused variables in the +%% generated code. (Expansions at the Erlang level can't be marked up as +%% compiler generated to allow later compiler stages to ignore them.) +dummy_uses(Vars) -> + [?Q("_ = _@var", [{var, erl_syntax:variable(var_name(V))}]) + || V <- Vars]. + +rewrite_guard([]) -> []; +rewrite_guard([D]) -> [make_orelse(erl_syntax:disjunction_body(D))]. + +make_orelse([]) -> []; +make_orelse([C]) -> make_andalso(erl_syntax:conjunction_body(C)); +make_orelse([C | Cs]) -> + ?Q("_@expr orelse _@rest", + [{expr, make_andalso(erl_syntax:conjunction_body(C))}, + {rest, make_orelse(Cs)}]). + +make_andalso([E]) -> E; +make_andalso([E | Es]) -> + ?Q("_@expr andalso _@rest", [{expr, E}, {rest, make_andalso(Es)}]). + +is_inline_metavar(Var) when is_atom(Var) -> + is_erlang_var(atom_to_list(Var)); +is_inline_metavar(Var) when is_integer(Var) -> + Var > 9 andalso (Var rem 10) =:= 9; +is_inline_metavar(_) -> false. + +is_erlang_var([C|_]) when C >= $A, C =< $Z ; C >= $À, C =< $Þ, C /= $× -> + true; +is_erlang_var(_) -> + false. |