/usr/lib64/erlang/lib/syntax_tools-2.6/src/ Current File: //usr/lib64/erlang/lib/syntax_tools-2.6/src/merl_transform.erl
%% ---------------------------------------------------------------------
%% 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.
%%
%% Alternatively, you may use this file under the terms of the GNU Lesser
%% General Public License (the "LGPL") as published by the Free Software
%% Foundation; either version 2.1, or (at your option) any later version.
%% If you wish to allow use of your version of this file only under the
%% terms of the LGPL, you should delete the provisions above and replace
%% them with the notice and other provisions required by the LGPL; see
%% <http://www.gnu.org/licenses/>. If you do not delete the provisions
%% above, a recipient may use your version of this file under the terms of
%% either the Apache License or the LGPL.
%%
%% @author Richard Carlsson <carlsson.richard@gmail.com>
%% @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), get_location(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 = get_location(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)],
            case eval_call(Line, quote, As, failed) of
                failed ->
                    T;
                T1 ->
                    %% expand further if possible
                    expand(merl:qquote(Line, "merl:subst(_@tree, _@env)",
                                       [{tree, T1},
                                        {env, Env}]))
            end;
        false ->
            T
    end;
expand_qquote(_As, T, _StartPos) ->
    T.

expand_template(F, [Pattern | Args], T) ->
    case erl_syntax:is_literal(Pattern) of
        true ->
            Line = get_location(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:lowercase(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.

get_location(T) ->
    Pos = erl_syntax:get_pos(T),
    case erl_anno:is_anno(Pos) of
        true ->
            erl_anno:location(Pos);
        false ->
            Pos
    end.