diff options
Diffstat (limited to 'lib/syntax_tools/src')
| -rw-r--r-- | lib/syntax_tools/src/Makefile | 21 | ||||
| -rw-r--r-- | lib/syntax_tools/src/merl.erl | 1230 | ||||
| -rw-r--r-- | lib/syntax_tools/src/merl_tests.erl | 539 | ||||
| -rw-r--r-- | lib/syntax_tools/src/merl_transform.erl | 262 | ||||
| -rw-r--r-- | lib/syntax_tools/src/syntax_tools.app.src | 2 |
5 files changed, 2053 insertions, 1 deletions
diff --git a/lib/syntax_tools/src/Makefile b/lib/syntax_tools/src/Makefile index c9fbad8f9a..2c565cee7f 100644 --- a/lib/syntax_tools/src/Makefile +++ b/lib/syntax_tools/src/Makefile @@ -22,6 +22,9 @@ RELSYSDIR = $(RELEASE_PATH)/lib/syntax_tools-$(VSN) # EBIN = ../ebin +INCLUDE=../include + +ERL_COMPILE_FLAGS += -pa $(EBIN) -pa ./ -I$(INCLUDE) ifeq ($(NATIVE_LIBS_ENABLED),yes) ERL_COMPILE_FLAGS += +native @@ -30,10 +33,15 @@ ERL_COMPILE_FLAGS += +nowarn_shadow_vars +warn_unused_import -Werror # +warn_mis SOURCES=erl_syntax.erl erl_prettypr.erl erl_syntax_lib.erl \ erl_comment_scan.erl erl_recomment.erl erl_tidy.erl \ - epp_dodger.erl prettypr.erl igor.erl + epp_dodger.erl prettypr.erl igor.erl \ + merl.erl merl_transform.erl + +INCLUDE_FILES = merl.hrl OBJECTS=$(SOURCES:%.erl=$(EBIN)/%.$(EMULATOR)) $(APP_TARGET) $(APPUP_TARGET) +INCLUDE_DELIVERABLES = $(INCLUDE_FILES:%=$(INCLUDE)/%) + APP_FILE= syntax_tools.app APP_SRC= $(APP_FILE).src APP_TARGET= $(EBIN)/$(APP_FILE) @@ -52,6 +60,7 @@ all: $(OBJECTS) clean: + rm -f ./merl_transform.beam rm -f $(OBJECTS) rm -f core *~ @@ -64,6 +73,14 @@ realclean: clean $(EBIN)/%.$(EMULATOR):%.erl $(erlc_verbose)erlc -W $(ERL_COMPILE_FLAGS) -o$(EBIN) $< +# special rules and dependencies to apply the transform to itself +$(EBIN)/merl_transform.beam: $(EBIN)/merl.beam ./merl_transform.beam \ + ../include/merl.hrl +./merl_transform.beam: ./merl_transform.erl $(EBIN)/merl.beam \ + ../include/merl.hrl + $(V_ERLC) -DMERL_NO_TRANSFORM $(ERL_COMPILE_FLAGS) -o ./ $< + + # ---------------------------------------------------- # Special Build Targets # ---------------------------------------------------- @@ -84,6 +101,8 @@ release_spec: opt $(INSTALL_DATA) $(OBJECTS) "$(RELSYSDIR)/ebin" $(INSTALL_DIR) "$(RELSYSDIR)/src" $(INSTALL_DATA) $(SOURCES) "$(RELSYSDIR)/src" + $(INSTALL_DIR) "$(RELSYSDIR)/include" + $(INSTALL_DATA) $(INCLUDE_DELIVERABLES) "$(RELSYSDIR)/include" release_docs_spec: diff --git a/lib/syntax_tools/src/merl.erl b/lib/syntax_tools/src/merl.erl new file mode 100644 index 0000000000..690306c17b --- /dev/null +++ b/lib/syntax_tools/src/merl.erl @@ -0,0 +1,1230 @@ +%% --------------------------------------------------------------------- +%% 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. +%% +%% Note: EDoc uses @@ and @} as escape sequences, so in the doc text below, +%% `@@' must be written `@@@@' and `@}' must be written `@@}'. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2010-2015 Richard Carlsson +%% +%% @doc Metaprogramming in Erlang. +%% Merl is a more user friendly interface to the `erl_syntax' module, making +%% it easy both to build new ASTs from scratch and to +%% match and decompose existing ASTs. For details that are outside the scope +%% of Merl itself, please see the documentation of {@link erl_syntax}. +%% +%% == Quick start == +%% +%% To enable the full power of Merl, your module needs to include the Merl +%% header file: +%% ```-include_lib("syntax_tools/include/merl.hrl").''' +%% +%% Then, you can use the `?Q(Text)' macros in your code to create ASTs or match +%% on existing ASTs. For example: +%% ```Tuple = ?Q("{foo, 42}"), +%% ?Q("{foo, _@Number}") = Tuple, +%% Call = ?Q("foo:bar(_@Number)")''' +%% +%% Calling `merl:print(Call)' will then print the following code: +%% ```foo:bar(42)''' +%% +%% The `?Q' macros turn the quoted code fragments into ASTs, and lifts +%% metavariables such as `_@Tuple' and `_@Number' to the level of your Erlang +%% code, so you can use the corresponding Erlang variables `Tuple' and `Number' +%% directly. This is the most straightforward way to use Merl, and in many +%% cases it's all you need. +%% +%% You can even write case switches using `?Q' macros as patterns. For example: +%% ```case AST of +%% ?Q("{foo, _@Foo}") -> handle(Foo); +%% ?Q("{bar, _@Bar}") when erl_syntax:is_integer(Bar) -> handle(Bar); +%% _ -> handle_default() +%% end''' +%% +%% These case switches only allow `?Q(...)' or `_' as clause patterns, and the +%% guards may contain any expressions, not just Erlang guard expressions. +%% +%% If the macro `MERL_NO_TRANSFORM' is defined before the `merl.hrl' header +%% file is included, the parse transform used by Merl will be disabled, and in +%% that case, the match expressions `?Q(...) = ...', case switches using +%% `?Q(...)' patterns, and automatic metavariables like `_@Tuple' cannot be +%% used in your code, but the Merl macros and functions still work. To do +%% metavariable substitution, you need to use the `?Q(Text, Map)' macro, e.g.: +%% ```Tuple = ?Q("{foo, _@bar, _@baz}", [{bar, Bar}, {baz,Baz}])''' +%% +%% The text given to a `?Q(Text)' macro can be either a single string, or a +%% list of strings. The latter is useful when you need to split a long +%% expression over multiple lines, e.g.: +%% ```?Q(["case _@Expr of", +%% " {foo, X} -> f(X);", +%% " {bar, X} -> g(X)", +%% " _ -> h(X)" +%% "end"])''' +%% If there is a syntax error somewhere in the text (like the missing semicolon +%% in the second clause above) this allows Merl to generate an error message +%% pointing to the exact line in your source code. (Just remember to +%% comma-separate the strings in the list, otherwise Erlang will concatenate +%% the string fragments as if they were a single string.) +%% +%% == Metavariable syntax == +%% +%% There are several ways to write a metavariable in your quoted code: +%% <ul> +%% <li>Atoms starting with `@', for example `` '@foo' '' or `` '@Foo' ''</li> +%% <li>Variables starting with `_@', for example `_@bar' or `_@Bar'</li> +%% <li>Strings starting with ``"'@'', for example ``"'@File"''</li> +%% <li>Integers starting with 909, for example `9091' or `909123'</li> +%% </ul> +%% Following the prefix, one or more `_' or `0' characters may be used to +%% indicate "lifting" of the variable one or more levels, and after that, a `@' +%% or `9' character indicates a glob metavariable (matching zero or more +%% elements in a sequence) rather than a normal metavariable. For example: +%% <ul> +%% <li>`` '@_foo' '' is lifted one level, and `_@__foo' is lifted two +%% levels</li> +%% <li>`_@@@@bar' is a glob variable, and `_@_@bar' is a lifted glob +%% variable</li> +%% <li>`90901' is a lifted variable,`90991' is a glob variable, and `9090091' +%% is a glob variable lifted two levels</li> +%% </ul> +%% (Note that the last character in the name is never considered to be a lift +%% or glob marker, hence, `_@__' and `90900' are only lifted one level, not +%% two. Also note that globs only matter for matching; when doing +%% substitutions, a non-glob variable can be used to inject a sequence of +%% elements, and vice versa.) +%% +%% If the name after the prefix and any lift and glob markers is `_' or `0', +%% the variable is treated as an anonymous catch-all pattern in matches. For +%% example, `_@_', `_@@@@_', `_@__', or even `_@__@_'. +%% +%% Finally, if the name without any prefixes or lift/glob markers begins with +%% an uppercase character, as in `_@Foo' or `_@_@Foo', it will become a +%% variable on the Erlang level, and can be used to easily deconstruct and +%% construct syntax trees: +%% ```case Input of +%% ?Q("{foo, _@Number}") -> ?Q("foo:bar(_@Number)"); +%% ...''' +%% We refer to these as "automatic metavariables". If in addition the name ends +%% with `@', as in `_@Foo@', the value of the variable as an Erlang term will +%% be automatically converted to the corresponding abstract syntax tree when +%% used to construct a larger tree. For example, in: +%% ```Bar = {bar, 42}, +%% Foo = ?Q("{foo, _@Bar@@}")''' +%% (where Bar is just some term, not a syntax tree) the result `Foo' will be a +%% syntax tree representing `{foo, {bar, 42}}'. This avoids the need for +%% temporary variables in order to inject data, as in +%% ```TmpBar = erl_syntax:abstract(Bar), +%% Foo = ?Q("{foo, _@TmpBar}")''' +%% +%% If the context requires an integer rather than a variable, an atom, or a +%% string, you cannot use the uppercase convention to mark an automatic +%% metavariable. Instead, if the integer (without the `909'-prefix and +%% lift/glob markers) ends in a `9', the integer will become an Erlang-level +%% variable prefixed with `Q', and if it ends with `99' it will also be +%% automatically abstracted. For example, the following will increment the +%% arity of the exported function f: +%% ```case Form of +%% ?Q("-export([f/90919]).") -> +%% Q2 = erl_syntax:concrete(Q1) + 1, +%% ?Q("-export([f/909299])."); +%% ...''' +%% +%% == When to use the various forms of metavariables == +%% +%% Merl can only parse a fragment of text if it follows the basic syntactical +%% rules of Erlang. In most places, a normal Erlang variable can be used as +%% metavariable, for example: +%% ```?Q("f(_@Arg)") = Expr''' +%% but if you want to match on something like the name of a function, you have +%% to use an atom as metavariable: +%% ```?Q("'@Name'() -> _@@@@_." = Function''' +%% (note the anonymous glob variable `_@@@@_' to ignore the function body). +%% +%% In some contexts, only a string or an integer is allowed. For example, the +%% directive `-file(Name, Line)' requires that `Name' is a string literal and +%% `Line' an integer literal: +%% +%% ```?Q("-file(\"'@File\", 9090).") = ?Q("-file(\"foo.erl\", 42).")).''' +%% This will extract the string literal `"foo.erl"' into the variable `Foo'. +%% Note the use of the anonymous variable `9090' to ignore the line number. To +%% match and also bind a metavariable that must be an integer literal, we can +%% use the convention of ending the integer with a 9, turning it into a +%% Q-prefixed variable on the Erlang level (see the previous section). +%% +%% === Globs === +%% +%% Whenever you want to match out a number of elements in a sequence (zero or +%% more) rather than a fixed set of elements, you need to use a glob. For +%% example: +%% ```?Q("{_@@@@Elements}") = ?Q({a, b, c})''' +%% will bind Elements to the list of individual syntax trees representing the +%% atoms `a', `b', and `c'. This can also be used with static prefix and suffix +%% elements in the sequence. For example: +%% ```?Q("{a, b, _@@@@Elements}") = ?Q({a, b, c, d})''' +%% will bind Elements to the list of the `c' and `d' subtrees, and +%% ```?Q("{_@@@@Elements, c, d}") = ?Q({a, b, c, d})''' +%% will bind Elements to the list of the `a' and `b' subtrees. You can even use +%% plain metavariables in the prefix or suffix: +%% ```?Q("{_@First, _@@@@Rest}") = ?Q({a, b, c})''' +%% or +%% ```?Q("{_@@@@_, _@Last}") = ?Q({a, b, c})''' +%% (ignoring all but the last element). You cannot however have two globs as +%% part of the same sequence. +%% +%% === Lifted metavariables === +%% +%% In some cases, the Erlang syntax rules make it impossible to place a +%% metavariable directly where you would like it. For example, you cannot +%% write: +%% ```?Q("-export([_@@@@Name]).")''' +%% to match out all name/arity pairs in the export list, or to insert a list of +%% exports in a declaration, because the Erlang parser only allows elements on +%% the form `A/I' (where `A' is an atom and `I' an integer) in the export list. +%% A variable like the above is not allowed, but neither is a single atom or +%% integer, so `` '@@@@Name' '' or `909919' wouldn't work either. +%% +%% What you have to do in such cases is to write your metavariable in a +%% syntactically valid position, and use lifting markers to denote where it +%% should really apply, as in: +%% ```?Q("-export(['@@_@@Name'/0]).")''' +%% This causes the variable to be lifted (after parsing) to the next higher +%% level in the syntax tree, replacing that entire subtree. In this case, the +%% `` '@@_@@Name'/0 '' will be replaced with `` '@@@@Name' '', and the ``/0'' +%% part was just used as dummy notation and will be discarded. +%% +%% You may even need to apply lifting more than once. To match the entire +%% export list as a single syntax tree, you can write: +%% ```?Q("-export(['@@__Name'/0]).")''' +%% using two underscores, but with no glob marker this time. This will make the +%% entire ``['@@__Name'/0]'' part be replaced with `` '@@Name' ''. +%% +%% Sometimes, the tree structure of a code fragment isn't very obvious, and +%% parts of the structure may be invisible when printed as source code. For +%% instance, a simple function definition like the following: +%% ```zero() -> 0.''' +%% consists of the name (the atom `zero'), and a list of clauses containing the +%% single clause `() -> 0'. The clause consists of an argument list (empty), a +%% guard (empty), and a body (which is always a list of expressions) containing +%% the single expression `0'. This means that to match out the name and the +%% list of clauses of any function, you'll need to use a pattern like +%% ``?Q("'@Name'() -> _@_@Body.")'', using a dummy clause whose body is a glob +%% lifted one level. +%% +%% To visualize the structure of a syntax tree, you can use the function +%% `merl:show(T)', which prints a summary. For example, entering +%% ```merl:show(merl:quote("inc(X, Y) when Y > 0 -> X + Y."))''' +%% in the Erlang shell will print the following (where the `+' signs separate +%% groups of subtrees on the same level): +%% ```function: inc(X, Y) when ... -> X + Y. +%% atom: inc +%% + +%% clause: (X, Y) when ... -> X + Y +%% variable: X +%% variable: Y +%% + +%% disjunction: Y > 0 +%% conjunction: Y > 0 +%% infix_expr: Y > 0 +%% variable: Y +%% + +%% operator: > +%% + +%% integer: 0 +%% + +%% infix_expr: X + Y +%% variable: X +%% + +%% operator: + +%% + +%% variable: Y''' +%% +%% This shows another important non-obvious case: a clause guard, even if it's +%% as simple as `Y > 0', always consists of a single disjunction of one or more +%% conjunctions of tests, much like a tuple of tuples. Thus: +%% <ul> +%% <li>``"when _@Guard ->"'' will only match a guard with exactly one +%% test</li> +%% <li>``"when _@@@@Guard ->"'' will match a guard with one or more +%% comma-separated tests (but no semicolons), binding `Guard' to the list +%% of tests</li> +%% <li>``"when _@_Guard ->"'' will match just like the previous pattern, but +%% binds `Guard' to the conjunction subtree</li> +%% <li>``"when _@_@Guard ->"'' will match an arbitrary nonempty guard, +%% binding `Guard' to the list of conjunction subtrees</li> +%% <li>``"when _@__Guard ->"'' will match like the previous pattern, but +%% binds `Guard' to the whole disjunction subtree</li> +%% <li>and finally, ``"when _@__@Guard ->"'' will match any clause, +%% binding `Guard' to `[]' if the guard is empty and to `[Disjunction]' +%% otherwise</li> +%% </ul> +%% +%% Thus, the following pattern matches all possible clauses: +%% ```"(_@@Args) when _@__@Guard -> _@@Body"''' +%% @end + +-module(merl). + +-export([term/1, var/1, print/1, show/1]). + +-export([quote/1, quote/2, qquote/2, qquote/3]). + +-export([template/1, tree/1, subst/2, tsubst/2, alpha/2, match/2, switch/2]). + +-export([template_vars/1, meta_template/1]). + +-export([compile/1, compile/2, compile_and_load/1, compile_and_load/2]). + +%% NOTE: this module may not include merl.hrl! + +-type tree() :: erl_syntax:syntaxTree(). + +-type tree_or_trees() :: tree() | [tree()]. + +-type pattern() :: tree() | template(). + +-type pattern_or_patterns() :: pattern() | [pattern()]. + +-type env() :: [{Key::id(), pattern_or_patterns()}]. + +-type id() :: atom() | integer(). + +%% A list of strings or binaries is assumed to represent individual lines, +%% while a flat string or binary represents source code containing newlines. +-type text() :: string() | binary() | [string()] | [binary()]. + +-type location() :: erl_anno:location(). + + +%% ------------------------------------------------------------------------ +%% Compiling and loading code directly to memory + +%% @equiv compile(Code, []) +compile(Code) -> + compile(Code, []). + +%% @doc Compile a syntax tree or list of syntax trees representing a module +%% into a binary BEAM object. +%% @see compile_and_load/2 +%% @see compile/1 +compile(Code, Options) when not is_list(Code)-> + case type(Code) of + form_list -> compile(erl_syntax:form_list_elements(Code)); + _ -> compile([Code], Options) + end; +compile(Code, Options0) when is_list(Options0) -> + Forms = [erl_syntax:revert(F) || F <- Code], + Options = [verbose, report_errors, report_warnings, binary | Options0], + compile:noenv_forms(Forms, Options). + + +%% @equiv compile_and_load(Code, []) +compile_and_load(Code) -> + compile_and_load(Code, []). + +%% @doc Compile a syntax tree or list of syntax trees representing a module +%% and load the resulting module into memory. +%% @see compile/2 +%% @see compile_and_load/1 +compile_and_load(Code, Options) -> + case compile(Code, Options) of + {ok, ModuleName, Binary} -> + _ = code:load_binary(ModuleName, "", Binary), + {ok, Binary}; + Other -> Other + end. + + +%% ------------------------------------------------------------------------ +%% Utility functions + + +-spec var(atom()) -> tree(). + +%% @doc Create a variable. + +var(Name) -> + erl_syntax:variable(Name). + + +-spec term(term()) -> tree(). + +%% @doc Create a syntax tree for a constant term. + +term(Term) -> + erl_syntax:abstract(Term). + + +%% @doc Pretty-print a syntax tree or template to the standard output. This +%% is a utility function for development and debugging. + +print(Ts) when is_list(Ts) -> + lists:foreach(fun print/1, Ts); +print(T) -> + io:put_chars(erl_prettypr:format(tree(T))), + io:nl(). + +%% @doc Print the structure of a syntax tree or template to the standard +%% output. This is a utility function for development and debugging. + +show(Ts) when is_list(Ts) -> + lists:foreach(fun show/1, Ts); +show(T) -> + io:put_chars(pp(tree(T), 0)), + io:nl(). + +pp(T, I) -> + [lists:duplicate(I, $\s), + limit(lists:flatten([atom_to_list(type(T)), ": ", + erl_prettypr:format(erl_syntax_lib:limit(T,3))]), + 79-I), + $\n, + pp_1(lists:filter(fun (X) -> X =/= [] end, subtrees(T)), I+2) + ]. + +pp_1([G], I) -> + pp_2(G, I); +pp_1([G | Gs], I) -> + [pp_2(G, I), lists:duplicate(I, $\s), "+\n" | pp_1(Gs, I)]; +pp_1([], _I) -> + []. + +pp_2(G, I) -> + [pp(E, I) || E <- G]. + +%% limit string to N characters, stay on a single line and compact whitespace +limit([$\n | Cs], N) -> limit([$\s | Cs], N); +limit([$\r | Cs], N) -> limit([$\s | Cs], N); +limit([$\v | Cs], N) -> limit([$\s | Cs], N); +limit([$\t | Cs], N) -> limit([$\s | Cs], N); +limit([$\s, $\s | Cs], N) -> limit([$\s | Cs], N); +limit([C | Cs], N) when C < 32 -> limit(Cs, N); +limit([C | Cs], N) when N > 3 -> [C | limit(Cs, N-1)]; +limit([_C1, _C2, _C3, _C4 | _Cs], 3) -> "..."; +limit(Cs, 3) -> Cs; +limit([_C1, _C2, _C3 | _], 2) -> ".."; +limit(Cs, 2) -> Cs; +limit([_C1, _C2 | _], 1) -> "."; +limit(Cs, 1) -> Cs; +limit(_, _) -> []. + +%% ------------------------------------------------------------------------ +%% Parsing and instantiating code fragments + + +-spec qquote(Text::text(), Env::env()) -> tree_or_trees(). + +%% @doc Parse text and substitute meta-variables. +%% +%% @equiv qquote(1, Text, Env) + +qquote(Text, Env) -> + qquote(1, Text, Env). + + +-spec qquote(StartPos::location(), Text::text(), Env::env()) -> tree_or_trees(). + +%% @doc Parse text and substitute meta-variables. Takes an initial scanner +%% starting position as first argument. +%% +%% The macro `?Q(Text, Env)' expands to `merl:qquote(?LINE, Text, Env)'. +%% +%% @see quote/2 + +qquote(StartPos, Text, Env) -> + subst(quote(StartPos, Text), Env). + + +-spec quote(Text::text()) -> tree_or_trees(). + +%% @doc Parse text. +%% +%% @equiv quote(1, Text) + +quote(Text) -> + quote(1, Text). + + +-spec quote(StartPos::location(), Text::text()) -> tree_or_trees(). + +%% @doc Parse text. Takes an initial scanner starting position as first +%% argument. +%% +%% The macro `?Q(Text)' expands to `merl:quote(?LINE, Text, Env)'. +%% +%% @see quote/1 + +quote({Line, Col}, Text) + when is_integer(Line), is_integer(Col) -> + quote_1(Line, Col, Text); +quote(StartPos, Text) when is_integer(StartPos) -> + quote_1(StartPos, undefined, Text). + +quote_1(StartLine, StartCol, Text) -> + %% be backwards compatible as far as R12, ignoring any starting column + StartPos = case erlang:system_info(version) of + "5.6" ++ _ -> StartLine; + "5.7" ++ _ -> StartLine; + "5.8" ++ _ -> StartLine; + _ when StartCol =:= undefined -> StartLine; + _ -> {StartLine, StartCol} + end, + FlatText = flatten_text(Text), + {ok, Ts, _} = erl_scan:string(FlatText, StartPos), + merge_comments(StartLine, erl_comment_scan:string(FlatText), parse_1(Ts)). + +parse_1(Ts) -> + %% if dot tokens are present, it is assumed that the text represents + %% complete forms, not dot-terminated expressions or similar + case split_forms(Ts) of + {ok, Fs} -> parse_forms(Fs); + error -> + parse_2(Ts) + end. + +split_forms(Ts) -> + split_forms(Ts, [], []). + +split_forms([{dot,_}=T|Ts], Fs, As) -> + split_forms(Ts, [lists:reverse(As, [T]) | Fs], []); +split_forms([T|Ts], Fs, As) -> + split_forms(Ts, Fs, [T|As]); +split_forms([], Fs, []) -> + {ok, lists:reverse(Fs)}; +split_forms([], [], _) -> + error; % no dot tokens found - not representing form(s) +split_forms([], _, [T|_]) -> + fail("incomplete form after ~p", [T]). + +parse_forms([Ts | Tss]) -> + case erl_parse:parse_form(Ts) of + {ok, Form} -> [Form | parse_forms(Tss)]; + {error, R} -> parse_error(R) + end; +parse_forms([]) -> + []. + +parse_2(Ts) -> + %% one or more comma-separated expressions? + %% (recall that Ts has no dot tokens if we get to this stage) + case erl_parse:parse_exprs(Ts ++ [{dot,0}]) of + {ok, Exprs} -> Exprs; + {error, E} -> + parse_3(Ts ++ [{'end',0}, {dot,0}], [E]) + end. + +parse_3(Ts, Es) -> + %% try-clause or clauses? + case erl_parse:parse_exprs([{'try',0}, {atom,0,true}, {'catch',0} | Ts]) of + {ok, [{'try',_,_,_,_,_}=X]} -> + %% get the right kind of qualifiers in the clause patterns + erl_syntax:try_expr_handlers(X); + {error, E} -> + parse_4(Ts, [E|Es]) + end. + +parse_4(Ts, Es) -> + %% fun-clause or clauses? (`(a)' is also a pattern, but `(a,b)' isn't, + %% so fun-clauses must be tried before normal case-clauses + case erl_parse:parse_exprs([{'fun',0} | Ts]) of + {ok, [{'fun',_,{clauses,Cs}}]} -> Cs; + {error, E} -> + parse_5(Ts, [E|Es]) + end. + +parse_5(Ts, Es) -> + %% case-clause or clauses? + case erl_parse:parse_exprs([{'case',0}, {atom,0,true}, {'of',0} | Ts]) of + {ok, [{'case',_,_,Cs}]} -> Cs; + {error, E} -> + %% select the best error to report + parse_error(lists:last(lists:sort([E|Es]))) + end. + +-dialyzer({nowarn_function, parse_error/1}). % no local return + +parse_error({L, M, R}) when is_atom(M), is_integer(L) -> + fail("~w: ~s", [L, M:format_error(R)]); +parse_error({{L,C}, M, R}) when is_atom(M), is_integer(L), is_integer(C) -> + fail("~w:~w: ~s", [L,C,M:format_error(R)]); +parse_error({_, M, R}) when is_atom(M) -> + fail(M:format_error(R)); +parse_error(R) -> + fail("unknown parse error: ~p", [R]). + +%% ------------------------------------------------------------------------ +%% Templates, substitution and matching + +%% Leaves are normal syntax trees, and inner nodes are tuples +%% {template,Type,Attrs,Groups} where Groups are lists of lists of nodes. +%% Metavariables are 1-tuples {VarName}, where VarName is an atom or an +%% integer. {'_'} and {0} work as anonymous variables in matching. Glob +%% metavariables are tuples {'*',VarName}, and {'*','_'} and {'*',0} are +%% anonymous globs. + +%% Note that although template() :: tree() | ..., it is implied that these +%% syntax trees are free from metavariables, so pattern() :: tree() | +%% template() is in fact a wider type than template(). + +-type template() :: tree() + | {id()} + | {'*',id()} + | {template, atom(), term(), [[template()]]}. + +-type template_or_templates() :: template() | [template()]. + +-spec template(pattern_or_patterns()) -> template_or_templates(). + +%% @doc Turn a syntax tree or list of trees into a template or templates. +%% Templates can be instantiated or matched against, and reverted back to +%% normal syntax trees using {@link tree/1}. If the input is already a +%% template, it is not modified further. +%% +%% @see subst/2 +%% @see match/2 +%% @see tree/1 + +template(Trees) when is_list(Trees) -> + [template_0(T) || T <- Trees]; +template(Tree) -> + template_0(Tree). + +template_0({template, _, _, _}=Template) -> Template; +template_0({'*',_}=Template) -> Template; +template_0({_}=Template) -> Template; +template_0(Tree) -> + case template_1(Tree) of + false -> Tree; + {Name} when is_list(Name) -> + fail("bad metavariable: '~s'", [tl(Name)]); % drop v/n from name + Template -> Template + end. + +%% returns either a template or a lifted metavariable {String}, or 'false' +%% if Tree contained no metavariables +template_1(Tree) -> + case subtrees(Tree) of + [] -> + case metavar(Tree) of + {"v_"++Cs}=V when Cs =/= [] -> V; % to be lifted + {"n0"++Cs}=V when Cs =/= [] -> V; % to be lifted + {"v@"++Cs} when Cs =/= [] -> {'*',list_to_atom(Cs)}; + {"n9"++Cs} when Cs =/= [] -> {'*',list_to_integer(Cs)}; + {"v"++Cs} -> {list_to_atom(Cs)}; + {"n"++Cs} -> {list_to_integer(Cs)}; + false -> false + end; + Gs -> + case template_2(Gs, [], false) of + Gs1 when is_list(Gs1) -> + {template, type(Tree), erl_syntax:get_attrs(Tree), Gs1}; + Other -> + Other + end + end. + +template_2([G | Gs], As, Bool) -> + case template_3(G, [], false) of + {"v_"++Cs}=V when Cs =/= [] -> V; % lift further + {"n0"++Cs}=V when Cs =/= [] -> V; % lift further + {"v@"++Cs} when Cs =/= [] -> {'*',list_to_atom(Cs)}; % stop + {"n9"++Cs} when Cs =/= [] -> {'*',list_to_integer(Cs)}; % stop + {"v"++Cs} when is_list(Cs) -> {list_to_atom(Cs)}; % stop + {"n"++Cs} when is_list(Cs) -> {list_to_integer(Cs)}; % stop + false -> template_2(Gs, [G | As], Bool); + G1 -> template_2(Gs, [G1 | As], true) + end; +template_2([], _As, false) -> false; +template_2([], As, true) -> lists:reverse(As). + +template_3([T | Ts], As, Bool) -> + case template_1(T) of + {"v_"++Cs} when Cs =/= [] -> {"v"++Cs}; % lift + {"n0"++Cs} when Cs =/= [] -> {"n"++Cs}; % lift + false -> template_3(Ts, [T | As], Bool); + T1 -> template_3(Ts, [T1 | As], true) + end; +template_3([], _As, false) -> false; +template_3([], As, true) -> lists:reverse(As). + + +%% @doc Turn a template into a syntax tree representing the template. +%% Meta-variables in the template are turned into normal Erlang variables if +%% their names (after the metavariable prefix characters) begin with an +%% uppercase character. E.g., `_@Foo' in the template becomes the variable +%% `Foo' in the meta-template. Furthermore, variables ending with `@' are +%% automatically wrapped in a call to merl:term/1, so e.g. `_@Foo@ in the +%% template becomes `merl:term(Foo)' in the meta-template. + +-spec meta_template(template_or_templates()) -> tree_or_trees(). + +meta_template(Templates) when is_list(Templates) -> + [meta_template_1(T) || T <- Templates]; +meta_template(Template) -> + meta_template_1(Template). + +meta_template_1({template, Type, Attrs, Groups}) -> + erl_syntax:tuple( + [erl_syntax:atom(template), + erl_syntax:atom(Type), + erl_syntax:abstract(Attrs), + erl_syntax:list([erl_syntax:list([meta_template_1(T) || T <- G]) + || G <- Groups])]); +meta_template_1({Var}=V) -> + meta_template_2(Var, V); +meta_template_1({'*',Var}=V) -> + meta_template_2(Var, V); +meta_template_1(Leaf) -> + erl_syntax:abstract(Leaf). + +meta_template_2(Var, V) when is_atom(Var) -> + case atom_to_list(Var) of + [C|_]=Name when C >= $A, C =< $Z ; C >= $À, C =< $Þ, C /= $× -> + case lists:reverse(Name) of + "@"++([_|_]=RevRealName) -> % don't allow empty RealName + RealName = lists:reverse(RevRealName), + erl_syntax:application(erl_syntax:atom(merl), + erl_syntax:atom(term), + [erl_syntax:variable(RealName)]); + _ -> + %% plain automatic metavariable + erl_syntax:variable(Name) + end; + _ -> + erl_syntax:abstract(V) + end; +meta_template_2(Var, V) when is_integer(Var) -> + if Var > 9, (Var rem 10) =:= 9 -> + %% at least 2 digits, ends in 9: make it a Q-variable + if Var > 99, (Var rem 100) =:= 99 -> + %% at least 3 digits, ends in 99: wrap in merl:term/1 + Name = "Q" ++ integer_to_list(Var div 100), + erl_syntax:application(erl_syntax:atom(merl), + erl_syntax:atom(term), + [erl_syntax:variable(Name)]); + true -> + %% plain automatic Q-variable + Name = integer_to_list(Var div 10), + erl_syntax:variable("Q" ++ Name) + end; + true -> + erl_syntax:abstract(V) + end. + + + +-spec template_vars(template_or_templates()) -> [id()]. + +%% @doc Return an ordered list of the metavariables in the template. + +template_vars(Template) -> + template_vars(Template, []). + +template_vars(Templates, Vars) when is_list(Templates) -> + lists:foldl(fun template_vars_1/2, Vars, Templates); +template_vars(Template, Vars) -> + template_vars_1(Template, Vars). + +template_vars_1({template, _, _, Groups}, Vars) -> + lists:foldl(fun (G, V) -> lists:foldl(fun template_vars_1/2, V, G) end, + Vars, Groups); +template_vars_1({Var}, Vars) -> + ordsets:add_element(Var, Vars); +template_vars_1({'*',Var}, Vars) -> + ordsets:add_element(Var, Vars); +template_vars_1(_, Vars) -> + Vars. + + +-spec tree(template_or_templates()) -> tree_or_trees(). + +%% @doc Revert a template to a normal syntax tree. Any remaining +%% metavariables are turned into `@'-prefixed atoms or `909'-prefixed +%% integers. +%% @see template/1 + +tree(Templates) when is_list(Templates) -> + [tree_1(T) || T <- Templates]; +tree(Template) -> + tree_1(Template). + +tree_1({template, Type, Attrs, Groups}) -> + %% flattening here is needed for templates created via source transforms + Gs = [lists:flatten([tree_1(T) || T <- G]) || G <- Groups], + erl_syntax:set_attrs(make_tree(Type, Gs), Attrs); +tree_1({Var}) when is_atom(Var) -> + erl_syntax:atom(list_to_atom("@"++atom_to_list(Var))); +tree_1({Var}) when is_integer(Var) -> + erl_syntax:integer(list_to_integer("909"++integer_to_list(Var))); +tree_1({'*',Var}) when is_atom(Var) -> + erl_syntax:atom(list_to_atom("@@"++atom_to_list(Var))); +tree_1({'*',Var}) when is_integer(Var) -> + erl_syntax:integer(list_to_integer("9099"++integer_to_list(Var))); +tree_1(Leaf) -> + Leaf. % any syntax tree, not necessarily atomic (due to substitutions) + + +-spec subst(pattern_or_patterns(), env()) -> tree_or_trees(). + +%% @doc Substitute metavariables in a pattern or list of patterns, yielding +%% a syntax tree or list of trees as result. Both for normal metavariables +%% and glob metavariables, the substituted value may be a single element or +%% a list of elements. For example, if a list representing `1, 2, 3' is +%% substituted for `var' in either of `[foo, _@var, bar]' or `[foo, _@@var, +%% bar]', the result represents `[foo, 1, 2, 3, bar]'. + +subst(Trees, Env) when is_list(Trees) -> + [subst_0(T, Env) || T <- Trees]; +subst(Tree, Env) -> + subst_0(Tree, Env). + +subst_0(Tree, Env) -> + tree_1(subst_1(template(Tree), Env)). + + +-spec tsubst(pattern_or_patterns(), env()) -> template_or_templates(). + +%% @doc Like subst/2, but does not convert the result from a template back +%% to a tree. Useful if you want to do multiple separate substitutions. +%% @see subst/2 +%% @see tree/1 + +tsubst(Trees, Env) when is_list(Trees) -> + [subst_1(template(T), Env) || T <- Trees]; +tsubst(Tree, Env) -> + subst_1(template(Tree), Env). + +subst_1({template, Type, Attrs, Groups}, Env) -> + Gs1 = [lists:flatten([subst_1(T, Env) || T <- G]) || G <- Groups], + {template, Type, Attrs, Gs1}; +subst_1({Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, TreeOrTrees} -> TreeOrTrees; + false -> V + end; +subst_1({'*',Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, TreeOrTrees} -> TreeOrTrees; + false -> V + end; +subst_1(Leaf, _Env) -> + Leaf. + + +-spec alpha(pattern_or_patterns(), [{id(), id()}]) -> template_or_templates(). + +%% @doc Alpha converts a pattern (renames variables). Similar to tsubst/1, +%% but only renames variables (including globs). +%% @see tsubst/2 + +alpha(Trees, Env) when is_list(Trees) -> + [alpha_1(template(T), Env) || T <- Trees]; +alpha(Tree, Env) -> + alpha_1(template(Tree), Env). + +alpha_1({template, Type, Attrs, Groups}, Env) -> + Gs1 = [lists:flatten([alpha_1(T, Env) || T <- G]) || G <- Groups], + {template, Type, Attrs, Gs1}; +alpha_1({Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, NewVar} -> {NewVar}; + false -> V + end; +alpha_1({'*',Var}=V, Env) -> + case lists:keyfind(Var, 1, Env) of + {Var, NewVar} -> {'*',NewVar}; + false -> V + end; +alpha_1(Leaf, _Env) -> + Leaf. + + +-spec match(pattern_or_patterns(), tree_or_trees()) -> + {ok, env()} | error. + +%% @doc Match a pattern against a syntax tree (or patterns against syntax +%% trees) returning an environment mapping variable names to subtrees; the +%% environment is always sorted on keys. Note that multiple occurrences of +%% metavariables in the pattern is not allowed, but is not checked. +%% +%% @see template/1 +%% @see switch/2 + +match(Patterns, Trees) when is_list(Patterns), is_list(Trees) -> + try {ok, match_1(Patterns, Trees, [])} + catch + error -> error + end; +match(Patterns, Tree) when is_list(Patterns) -> match(Patterns, [Tree]); +match(Pattern, Trees) when is_list(Trees) -> match([Pattern], Trees); +match(Pattern, Tree) -> + try {ok, match_template(template(Pattern), Tree, [])} + catch + error -> error + end. + +match_1([P|Ps], [T | Ts], Dict) -> + match_1(Ps, Ts, match_template(template(P), T, Dict)); +match_1([], [], Dict) -> + Dict; +match_1(_, _, _Dict) -> + erlang:error(merl_match_arity). + +%% match a template against a syntax tree +match_template({template, Type, _, Gs}, Tree, Dict) -> + case type(Tree) of + Type -> match_template_1(Gs, subtrees(Tree), Dict); + _ -> throw(error) % type mismatch + end; +match_template({Var}, _Tree, Dict) + when Var =:= '_' ; Var =:= 0 -> + Dict; % anonymous variable +match_template({Var}, Tree, Dict) -> + orddict:store(Var, Tree, Dict); +match_template(Tree1, Tree2, Dict) -> + %% if Tree1 is not a template, Tree1 and Tree2 are both syntax trees + case compare_trees(Tree1, Tree2) of + true -> Dict; + false -> throw(error) % different trees + end. + +match_template_1([G1 | Gs1], [G2 | Gs2], Dict) -> + match_template_2(G1, G2, match_template_1(Gs1, Gs2, Dict)); +match_template_1([], [], Dict) -> + Dict; +match_template_1(_, _, _Dict) -> + throw(error). % shape mismatch + +match_template_2([{Var} | Ts1], [_ | Ts2], Dict) + when Var =:= '_' ; Var =:= 0 -> + match_template_2(Ts1, Ts2, Dict); % anonymous variable +match_template_2([{Var} | Ts1], [Tree | Ts2], Dict) -> + match_template_2(Ts1, Ts2, orddict:store(Var, Tree, Dict)); +match_template_2([{'*',Var} | Ts1], Ts2, Dict) -> + match_glob(lists:reverse(Ts1), lists:reverse(Ts2), Var, Dict); +match_template_2([T1 | Ts1], [T2 | Ts2], Dict) -> + match_template_2(Ts1, Ts2, match_template(T1, T2, Dict)); +match_template_2([], [], Dict) -> + Dict; +match_template_2(_, _, _Dict) -> + throw(error). % shape mismatch + +%% match the tails in reverse order; no further globs allowed +match_glob([{'*',Var} | _], _, _, _) -> + fail("multiple glob variables in same match group: ~w", [Var]); +match_glob([T1 | Ts1], [T2 | Ts2], Var, Dict) -> + match_glob(Ts1, Ts2, Var, match_template(T1, T2, Dict)); +match_glob([], _Group, Var, Dict) when Var =:= '_' ; Var =:= 0 -> + Dict; % anonymous glob variable +match_glob([], Group, Var, Dict) -> + orddict:store(Var, lists:reverse(Group), Dict); +match_glob(_, _, _, _Dict) -> + throw(error). % shape mismatch + + +%% compare two syntax trees for equivalence +compare_trees(T1, T2) -> + Type1 = type(T1), + case type(T2) of + Type1 -> + case subtrees(T1) of + [] -> + case subtrees(T2) of + [] -> compare_leaves(Type1, T1, T2); + _Gs2 -> false % shape mismatch + end; + Gs1 -> + case subtrees(T2) of + [] -> false; % shape mismatch + Gs2 -> compare_trees_1(Gs1, Gs2) + end + end; + _Type2 -> + false % different tree types + end. + +compare_trees_1([G1 | Gs1], [G2 | Gs2]) -> + compare_trees_2(G1, G2) andalso compare_trees_1(Gs1, Gs2); +compare_trees_1([], []) -> + true; +compare_trees_1(_, _) -> + false. % shape mismatch + +compare_trees_2([T1 | Ts1], [T2 | Ts2]) -> + compare_trees(T1, T2) andalso compare_trees_2(Ts1, Ts2); +compare_trees_2([], []) -> + true; +compare_trees_2(_, _) -> + false. % shape mismatch + +compare_leaves(Type, T1, T2) -> + case Type of + atom -> + erl_syntax:atom_value(T1) + =:= erl_syntax:atom_value(T2); + char -> + erl_syntax:char_value(T1) + =:= erl_syntax:char_value(T2); + float -> + erl_syntax:float_value(T1) + =:= erl_syntax:float_value(T2); + integer -> + erl_syntax:integer_value(T1) + =:= erl_syntax:integer_value(T2); + string -> + erl_syntax:string_value(T1) + =:= erl_syntax:string_value(T2); + operator -> + erl_syntax:operator_name(T1) + =:= erl_syntax:operator_name(T2); + text -> + erl_syntax:text_string(T1) + =:= erl_syntax:text_string(T2); + variable -> + erl_syntax:variable_name(T1) + =:= erl_syntax:variable_name(T2); + _ -> + true % trivially equal nodes + end. + + +%% @doc Match against one or more clauses with patterns and optional guards. +%% +%% Note that clauses following a default action will be ignored. +%% +%% @see match/2 + +-type switch_clause() :: + {pattern_or_patterns(), guarded_actions()} + | {pattern_or_patterns(), guard_test(), switch_action()} + | default_action(). + +-type guarded_actions() :: guarded_action() | [guarded_action()]. + +-type guarded_action() :: switch_action() | {guard_test(), switch_action()}. + +-type switch_action() :: fun( (env()) -> any() ). + +-type guard_test() :: fun( (env()) -> boolean() ). + +-type default_action() :: fun( () -> any() ). + + +-spec switch(tree_or_trees(), [switch_clause()]) -> any(). + +switch(Trees, [{Patterns, GuardedActions} | Cs]) when is_list(GuardedActions) -> + switch_1(Trees, Patterns, GuardedActions, Cs); +switch(Trees, [{Patterns, GuardedAction} | Cs]) -> + switch_1(Trees, Patterns, [GuardedAction], Cs); +switch(Trees, [{Patterns, Guard, Action} | Cs]) -> + switch_1(Trees, Patterns, [{Guard, Action}], Cs); +switch(_Trees, [Default | _Cs]) when is_function(Default, 0) -> + Default(); +switch(_Trees, []) -> + erlang:error(merl_switch_clause); +switch(_Tree, _) -> + erlang:error(merl_switch_badarg). + +switch_1(Trees, Patterns, GuardedActions, Cs) -> + case match(Patterns, Trees) of + {ok, Env} -> + switch_2(Env, GuardedActions, Trees, Cs); + error -> + switch(Trees, Cs) + end. + +switch_2(Env, [{Guard, Action} | Bs], Trees, Cs) + when is_function(Guard, 1), is_function(Action, 1) -> + case Guard(Env) of + true -> Action(Env); + false -> switch_2(Env, Bs, Trees, Cs) + end; +switch_2(Env, [Action | _Bs], _Trees, _Cs) when is_function(Action, 1) -> + Action(Env); +switch_2(_Env, [], Trees, Cs) -> + switch(Trees, Cs); +switch_2(_Env, _, _Trees, _Cs) -> + erlang:error(merl_switch_badarg). + + +%% ------------------------------------------------------------------------ +%% Internal utility functions + +-dialyzer({nowarn_function, fail/1}). % no local return + +fail(Text) -> + fail(Text, []). + +fail(Fs, As) -> + throw({error, lists:flatten(io_lib:format(Fs, As))}). + +flatten_text([L | _]=Lines) when is_list(L) -> + lists:foldr(fun(S, T) -> S ++ [$\n | T] end, "", Lines); +flatten_text([B | _]=Lines) when is_binary(B) -> + lists:foldr(fun(S, T) -> binary_to_list(S) ++ [$\n | T] end, "", Lines); +flatten_text(Text) when is_binary(Text) -> + binary_to_list(Text); +flatten_text(Text) -> + Text. + +-spec metavar(tree()) -> {string()} | false. + +%% Check if a syntax tree represents a metavariable. If not, 'false' is +%% returned; otherwise, this returns a 1-tuple with a string containing the +%% variable name including lift/glob prefixes but without any leading +%% metavariable prefix, and instead prefixed with "v" for a variable or "i" +%% for an integer. +%% +%% Metavariables are atoms starting with @, variables starting with _@, +%% strings starting with "'@, or integers starting with 909. Following the +%% prefix, one or more _ or 0 characters (unless it's the last character in +%% the name) may be used to indicate "lifting" of the variable one or more +%% levels , and after that, a @ or 9 character indicates a glob metavariable +%% rather than a normal metavariable. If the name after the prefix is _ or +%% 0, the variable is treated as an anonymous catch-all pattern in matches. + +metavar(Tree) -> + case type(Tree) of + atom -> + case erl_syntax:atom_name(Tree) of + "@" ++ Cs when Cs =/= [] -> {"v"++Cs}; + _ -> false + end; + variable -> + case erl_syntax:variable_literal(Tree) of + "_@" ++ Cs when Cs =/= [] -> {"v"++Cs}; + _ -> false + end; + integer -> + case erl_syntax:integer_value(Tree) of + N when N >= 9090 -> + case integer_to_list(N) of + "909" ++ Cs -> {"n"++Cs}; + _ -> false + end; + _ -> false + end; + string -> + case erl_syntax:string_value(Tree) of + "'@" ++ Cs -> {"v"++Cs}; + _ -> false + end; + _ -> + false + end. + +%% wrappers around erl_syntax functions to provide more uniform shape of +%% generic subtrees (maybe this can be fixed in syntax_tools one day) + +type(T) -> + case erl_syntax:type(T) of + nil -> list; + Type -> Type + end. + +subtrees(T) -> + case erl_syntax:type(T) of + tuple -> + [erl_syntax:tuple_elements(T)]; %% don't treat {} as a leaf + nil -> + [[], []]; %% don't treat [] as a leaf, but as a list + list -> + case erl_syntax:list_suffix(T) of + none -> + [erl_syntax:list_prefix(T), []]; + S -> + [erl_syntax:list_prefix(T), [S]] + end; + binary_field -> + [[erl_syntax:binary_field_body(T)], + erl_syntax:binary_field_types(T)]; + clause -> + case erl_syntax:clause_guard(T) of + none -> + [erl_syntax:clause_patterns(T), [], + erl_syntax:clause_body(T)]; + G -> + [erl_syntax:clause_patterns(T), [G], + erl_syntax:clause_body(T)] + end; + receive_expr -> + case erl_syntax:receive_expr_timeout(T) of + none -> + [erl_syntax:receive_expr_clauses(T), [], []]; + E -> + [erl_syntax:receive_expr_clauses(T), [E], + erl_syntax:receive_expr_action(T)] + end; + record_expr -> + case erl_syntax:record_expr_argument(T) of + none -> + [[], [erl_syntax:record_expr_type(T)], + erl_syntax:record_expr_fields(T)]; + V -> + [[V], [erl_syntax:record_expr_type(T)], + erl_syntax:record_expr_fields(T)] + end; + record_field -> + case erl_syntax:record_field_value(T) of + none -> + [[erl_syntax:record_field_name(T)], []]; + V -> + [[erl_syntax:record_field_name(T)], [V]] + end; + _ -> + erl_syntax:subtrees(T) + end. + +make_tree(list, [P, []]) -> erl_syntax:list(P); +make_tree(list, [P, [S]]) -> erl_syntax:list(P, S); +make_tree(tuple, [E]) -> erl_syntax:tuple(E); +make_tree(binary_field, [[B], Ts]) -> erl_syntax:binary_field(B, Ts); +make_tree(clause, [P, [], B]) -> erl_syntax:clause(P, none, B); +make_tree(clause, [P, [G], B]) -> erl_syntax:clause(P, G, B); +make_tree(receive_expr, [C, [], _A]) -> erl_syntax:receive_expr(C); +make_tree(receive_expr, [C, [E], A]) -> erl_syntax:receive_expr(C, E, A); +make_tree(record_expr, [[], [T], F]) -> erl_syntax:record_expr(T, F); +make_tree(record_expr, [[E], [T], F]) -> erl_syntax:record_expr(E, T, F); +make_tree(record_field, [[N], []]) -> erl_syntax:record_field(N); +make_tree(record_field, [[N], [E]]) -> erl_syntax:record_field(N, E); +make_tree(Type, Groups) -> + erl_syntax:make_tree(Type, Groups). + +merge_comments(_StartLine, [], [T]) -> T; +merge_comments(_StartLine, [], Ts) -> Ts; +merge_comments(StartLine, Comments, Ts) -> + merge_comments(StartLine, Comments, Ts, []). + +merge_comments(_StartLine, [], [], [T]) -> T; +merge_comments(_StartLine, [], [T], []) -> T; +merge_comments(_StartLine, [], Ts, Acc) -> + lists:reverse(Acc, Ts); +merge_comments(StartLine, Cs, [], Acc) -> + merge_comments(StartLine, [], [], + [erl_syntax:set_pos( + erl_syntax:comment(Indent, Text), + StartLine + Line - 1) + || {Line, _, Indent, Text} <- Cs] ++ Acc); +merge_comments(StartLine, [C|Cs], [T|Ts], Acc) -> + {Line, _Col, Indent, Text} = C, + CommentLine = StartLine + Line - 1, + case erl_syntax:get_pos(T) of + Pos when Pos < CommentLine -> + %% TODO: traverse sub-tree rather than only the top level nodes + merge_comments(StartLine, [C|Cs], Ts, [T|Acc]); + CommentLine -> + Tc = erl_syntax:add_postcomments( + [erl_syntax:comment(Indent, Text)], T), + merge_comments(StartLine, Cs, [Tc|Ts], Acc); + _ -> + Tc = erl_syntax:add_precomments( + [erl_syntax:comment(Indent, Text)], T), + merge_comments(StartLine, Cs, [Tc|Ts], Acc) + end. diff --git a/lib/syntax_tools/src/merl_tests.erl b/lib/syntax_tools/src/merl_tests.erl new file mode 100644 index 0000000000..c1aae3100e --- /dev/null +++ b/lib/syntax_tools/src/merl_tests.erl @@ -0,0 +1,539 @@ +%% --------------------------------------------------------------------- +%% 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 Unit tests for merl. +%% @private + +-module(merl_tests). + +%-define(MERL_NO_TRANSFORM, true). +-include("merl.hrl"). + +-include_lib("eunit/include/eunit.hrl"). + + +%% utilities + +f(Ts) when is_list(Ts) -> + lists:flatmap(fun erl_prettypr:format/1, Ts); +f(T) -> + erl_prettypr:format(T). + +fe(Env) -> [{Key, f(T)} || {Key, T} <- Env]. + +g_exported_() -> + %% for testing the parse transform, autoexported to avoid complaints + {ok, merl:quote(?LINE, "42")}. + + +ok({ok, X}) -> X. + + +%% +%% tests +%% + +parse_error_test_() -> + [?_assertThrow({error, "1: syntax error before: '{'" ++ _}, + f(merl:quote("{"))) + ]. + +term_test_() -> + [?_assertEqual(tuple, erl_syntax:type(merl:term({}))), + ?_assertEqual("{foo, 42}", f(merl:term({foo, 42}))) + ]. + +quote_form_test_() -> + [?_assertEqual("f(X) -> {ok, X}.", + f(?Q("f(X) -> {ok, X}."))), + ?_assertEqual("-module(foo).", + f(?Q("-module(foo)."))), + ?_assertEqual("-import(bar, [f/1, g/2]).", + f(?Q("-import(bar, [f/1, g/2])."))), + ?_assertEqual(("-module(foo)." + "-export([f/1])." + "f(X) -> {ok, X}."), + f(?Q(["-module(foo).", + "-export([f/1]).", + "f(X) -> {ok, X}."]))) + ]. + +quote_term_test_() -> + [?_assertEqual("foo", + f(?Q("foo"))), + ?_assertEqual("42", + f(?Q("42"))), + ?_assertEqual("{foo, 42}", + f(?Q("{foo, 42}"))), + ?_assertEqual(("1" ++ "2" ++ "3"), + f(?Q("1, 2, 3"))), + ?_assertEqual(("foo" "42" "{}" "true"), + f(?Q("foo, 42, {}, (true)"))) + ]. + +quote_expr_test_() -> + [?_assertEqual("2 + 2", + f(?Q("2 + 2"))), + ?_assertEqual("f(foo, 42)", + f(?Q("f(foo, 42)"))), + ?_assertEqual("case X of\n a -> 1;\n b -> 2\nend", + f(?Q("case X of a -> 1; b -> 2 end"))), + ?_assertEqual(("2 + 2" ++ "f(42)" ++ "catch 22"), + f(?Q("2 + 2, f(42), catch 22"))) + ]. + +quote_try_clause_test_() -> + [?_assertEqual("(error:R) when R =/= foo -> ok", + f(?Q("error:R when R =/= foo -> ok"))), + %% note that without any context, clauses are printed as fun-clauses + ?_assertEqual(("(error:badarg) -> badarg" + "(exit:normal) -> normal" + "(_) -> other"), + f(?Q(["error:badarg -> badarg;", + "exit:normal -> normal;" + "_ -> other"]))) + ]. + +quote_fun_clause_test_() -> + [?_assertEqual("(X, Y) when X < Y -> {ok, X}", + f(?Q("(X, Y) when X < Y -> {ok, X}"))), + ?_assertEqual(("(X, Y) when X < Y -> less" + "(X, Y) when X > Y -> greater" + "(_, _) -> equal"), + f(?Q(["(X, Y) when X < Y -> less;", + "(X, Y) when X > Y -> greater;" + "(_, _) -> equal"])))]. + +quote_case_clause_test_() -> + [?_assertEqual("({X, Y}) when X < Y -> X", + f(?Q("{X, Y} when X < Y -> X"))), + ?_assertEqual(("({X, Y}) when X < Y -> -1" + "({X, Y}) when X > Y -> 1" + "(_) -> 0"), + f(?Q(["{X, Y} when X < Y -> -1;", + "{X, Y} when X > Y -> 1;" + "_ -> 0"])))]. + +quote_comment_test_() -> + [?_assertEqual("%% comment preserved\n" + "{foo, 42}", + f(?Q(["%% comment preserved", + "{foo, 42}"]))), + ?_assertEqual("{foo, 42}" + "%% comment preserved\n", + f(?Q(["{foo, 42}", + "%% comment preserved"]))), + ?_assertEqual(" % just a comment (with indent)\n", + f(?Q(" % just a comment (with indent)"))) + ]. + +metavar_test_() -> + [?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("'@foo'"))))), + ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("_@foo"))))), + ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("\"'@foo\""))))), + ?_assertEqual("{'@foo'}", f(merl:tree(merl:template(?Q("{_@foo}"))))), + ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("{_@_foo}"))))), + ?_assertEqual("909123", f(merl:tree(merl:template(?Q("{9090123}"))))), + ?_assertEqual("{'@foo'}", + f(merl:tree(merl:template(?Q("{{{_@__foo}}}"))))), + ?_assertEqual("{909123}", + f(merl:tree(merl:template(?Q("{{{90900123}}}"))))), + ?_assertEqual("{'@@foo'}", + f(merl:tree(merl:template(?Q("{{{_@__@foo}}}"))))), + ?_assertEqual("{9099123}", + f(merl:tree(merl:template(?Q("{{{909009123}}}"))))) + ]. + +subst_test_() -> + [?_assertEqual("42", + f(merl:subst(?Q("_@foo"), [{foo, merl:term(42)}]))), + ?_assertEqual("'@foo'", + f(merl:subst(?Q("_@foo"), []))), + ?_assertEqual("{42}", + f(merl:subst(?Q("{_@foo}"), + [{foo, merl:term(42)}]))), + ?_assertEqual("{'@foo'}", + f(merl:subst(?Q("{_@foo}"), []))), + ?_assertEqual("fun bar/0", + f(merl:subst(merl:template(?Q("fun '@foo'/0")), + [{foo, merl:term(bar)}]))), + ?_assertEqual("fun foo/3", + f(merl:subst(merl:template(?Q("fun foo/9091")), + [{1, merl:term(3)}]))), + ?_assertEqual("[42]", + f(merl:subst(merl:template(?Q("[_@foo]")), + [{foo, merl:term(42)}]))), + ?_assertEqual("[foo, bar]", + f(merl:subst(merl:template(?Q("[_@foo]")), + [{foo, [merl:term(foo),merl:term(bar)]}]))), + ?_assertEqual("{fee, fie, foe, fum}", + f(merl:subst(merl:template(?Q("{fee, _@foo, fum}")), + [{foo, [merl:term(fie),merl:term(foe)]}]))), + ?_assertEqual("[foo, bar]", + f(merl:subst(merl:template(?Q("[_@@foo]")), + [{foo, [merl:term(foo),merl:term(bar)]}]))), + ?_assertEqual("{fee, fie, foe, fum}", + f(merl:subst(merl:template(?Q("{fee, _@@foo, fum}")), + [{foo, [merl:term(fie),merl:term(foe)]}]))), + ?_assertEqual("['@@foo']", + f(merl:subst(merl:template(?Q("[_@@foo]")), []))), + ?_assertEqual("foo", + f(merl:subst(merl:template(?Q("[_@_foo]")), + [{foo, merl:term(foo)}]))), + ?_assertEqual("{'@foo'}", + f(merl:subst(merl:template(?Q("{[_@_foo]}")), []))), + ?_assertEqual("{'@@foo'}", + f(merl:subst(merl:template(?Q("{[_@_@foo]}")), []))), + ?_assertEqual("-export([foo/1, bar/2]).", + f(merl:subst(merl:template(?Q("-export(['@_@foo'/0]).")), + [{foo, [erl_syntax:arity_qualifier( + merl:term(foo), + merl:term(1)), + erl_syntax:arity_qualifier( + merl:term(bar), + merl:term(2)) + ]} + ]))) + ]. + +match_test_() -> + [?_assertEqual({ok, []}, merl:match(?Q("foo"), ?Q("foo"))), + ?_assertEqual(error, merl:match(?Q("foo"), ?Q("bar"))), + ?_assertEqual({ok,[]}, merl:match(?Q("{foo,42}"), ?Q("{foo,42}"))), + ?_assertEqual(error, merl:match(?Q("{foo,42}"), ?Q("{foo,bar}"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[42]]"), ?Q("[foo,[42]]"))), + ?_assertEqual(error, merl:match(?Q("[foo,[42]]"), ?Q("[foo,{42}]"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[_@_]]"), + ?Q("[foo,[42]]"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[9090]]"), + ?Q("[foo,[42]]"))), + ?_assertEqual({ok,[]}, merl:match(?Q("{_@_,[_@_,2]}"), + ?Q("{foo,[1,2]}"))), + ?_assertEqual(error, merl:match(?Q("{_@_,[_@_,2]}"), + ?Q("{foo,[1,3]}"))), + ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[9090,9090]]"), + ?Q("[foo,[1,2]]"))), + ?_assertEqual(error, merl:match(?Q("[foo,[9090,9090]]"), + ?Q("[foo,[1,2,3]]"))), + ?_assertEqual([{foo,"42"}], + fe(ok(merl:match(?Q("_@foo"), ?Q("42"))))), + ?_assertEqual([{foo,"42"}], + fe(ok(merl:match(?Q("{_@foo}"), ?Q("{42}"))))), + ?_assertEqual([{1,"0"},{foo,"bar"}], + fe(ok(merl:match(?Q("fun '@foo'/9091"), + ?Q("fun bar/0"))))), + ?_assertEqual([{line,"17"},{text,"\"hello\""}], + fe(ok(merl:match(?Q("{_@line, _@text}"), + ?Q("{17, \"hello\"}"))))), + ?_assertEqual([{line,"17"},{text,"\"hello\""}], + fe(ok(merl:match(?Q("foo(_@line, _@text)"), + ?Q("foo(17, \"hello\")"))))), + ?_assertEqual([{foo,""}], + fe(ok(merl:match(?Q("f(_@@foo)"), + ?Q("f()"))))), + ?_assertEqual([{foo,"fee"}], + fe(ok(merl:match(?Q("f(_@@foo)"), + ?Q("f(fee)"))))), + ?_assertEqual([{foo,"feefiefum"}], + fe(ok(merl:match(?Q("f(_@@foo)"), + ?Q("f(fee, fie, fum)"))))), + ?_assertEqual([{foo,""}], + fe(ok(merl:match(?Q("[_@@foo]"), + ?Q("[]"))))), + ?_assertEqual([{foo,"fee"}], + fe(ok(merl:match(?Q("[_@@foo]"), + ?Q("[fee]"))))), + ?_assertEqual([{foo,"feefiefoefum"}], + fe(ok(merl:match(?Q("[_@@foo]"), + ?Q("[fee, fie, foe, fum]"))))), + ?_assertEqual([{foo,""}], + fe(ok(merl:match(?Q("{_@@foo}"), + ?Q("{}"))))), + ?_assertEqual([{foo,"fee"}], + fe(ok(merl:match(?Q("{_@@foo}"), + ?Q("{fee}"))))), + ?_assertEqual([{foo,"feefiefoefum"}], + fe(ok(merl:match(?Q("{_@@foo}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fie"}], + fe(ok(merl:match(?Q("{fee, _@@foo}"), + ?Q("{fee, fie}"))))), + ?_assertEqual([{foo,"fiefoefum"}], + fe(ok(merl:match(?Q("{fee, _@@foo}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fie"}], + fe(ok(merl:match(?Q("{_@@foo, foe, fum}"), + ?Q("{fie, foe, fum}"))))), + ?_assertEqual([{foo,"feefie"}], + fe(ok(merl:match(?Q("{_@@foo, foe, fum}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fie"}], + fe(ok(merl:match(?Q("{fee, _@@foo, fum}"), + ?Q("{fee, fie, fum}"))))), + ?_assertEqual([{foo,"fiefoe"}], + fe(ok(merl:match(?Q("{fee, _@@foo, fum}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{foo,"fiefoe"},{post,"fum"},{pre,"fee"}], + fe(ok(merl:match(?Q("{_@pre, _@@foo, _@post}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertThrow({error, "multiple glob variables"++_}, + fe(ok(merl:match(?Q("{_@@foo, _@@bar}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([], + fe(ok(merl:match(?Q("{fee, _@@_}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([], + fe(ok(merl:match(?Q("{_@@_, foe, fum}"), + ?Q("{fee, fie, foe, fum}"))))), + ?_assertEqual([{post,"fum"},{pre,"fee"}], + fe(ok(merl:match(?Q("{_@pre, _@@_, _@post}"), + ?Q("{fee, fie, foe, fum}"))))) + ]. + +switch_test_() -> + [?_assertEqual(42, merl:switch(?Q("foo"), [fun () -> 42 end])), + ?_assertEqual(17, merl:switch(?Q("foo"), [fun () -> 17 end, + fun () -> 42 end])), + ?_assertEqual(17, merl:switch(?Q("foo"), [{?Q("foo"), + fun ([]) -> 17 end}, + fun () -> 42 end])), + ?_assertEqual(17, + merl:switch(?Q("foo"), [{?Q("bar"), fun ([]) -> 0 end}, + {?Q("foo"), fun ([]) -> 17 end}, + fun () -> 42 end])), + ?_assertEqual([{foo,"17"}], + merl:switch(?Q("{foo,17}"), + [{?Q("{bar, _@foo}"), fun (_) -> 0 end}, + {?Q("{foo, _@foo}"), fun fe/1}, + fun () -> 42 end])), + ?_assertEqual(17, + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + fun ([{foo, X}]) -> f(X) =:= "17" end, + fun (_) -> 17 end}, + fun () -> 42 end])), + ?_assertEqual([{foo,"17"}], + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + fun ([{foo, X}]) -> f(X) =:= "42" end, + fun (_) -> 0 end}, + {?Q("{foo, _@foo}"), fun fe/1}, + fun () -> 42 end])), + ?_assertEqual(17, + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + [{fun ([{foo, X}]) -> f(X) =:= "17" end, + fun (_) -> 17 end}, + fun (_) -> 0 end]}, + fun () -> 42 end])), + ?_assertEqual([{foo,"17"}], + merl:switch(?Q("{foo, 17}"), + [{?Q("{foo, _@foo}"), + [{fun ([{foo, X}]) -> f(X) =:= "42" end, + fun (_) -> 0 end}, + fun fe/1]}, + fun () -> 42 end])) + ]. + +-ifndef(MERL_NO_TRANSFORM). + +inline_meta_test_() -> + [?_assertEqual("{foo}", + f(begin + Foo = ?Q("foo"), + ?Q("{_@Foo}") + end)), + ?_assertEqual("{foo, '@bar'}", + f(begin + Foo = ?Q("foo"), + ?Q("{_@Foo,_@bar}") + end)), + ?_assertEqual("{foo, '@bar'}", + f(begin + Q1 = ?Q("foo"), + ?Q("{90919,_@bar}") + end)) + ]. + +inline_meta_autoabstract_test_() -> + [?_assertEqual("{foo}", + f(begin + Foo = foo, + ?Q("{_@Foo@}") + end)), + ?_assertEqual("{foo, '@bar@'}", + f(begin + Foo = foo, + ?Q("{_@Foo@,_@bar@}") + end)), + ?_assertEqual("{foo, '@bar@'}", + f(begin + Q1 = foo, + ?Q("{909199,_@bar@}") + end)) + ]. + +meta_match_test_() -> + [?_assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{foo, _@Bar, '@Baz'}") = Tree, + ?Q("{_@Bar, _@Baz}") + end)), + ?_assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{foo, 90919, 90929}") = Tree, + ?Q("{_@Q1, _@Q2}") + end)), + ?_assertError({badmatch,error}, + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + ?Q("{fie, _@Bar, '@Baz'}") = Tree, + ?Q("{_@Bar, _@Baz}") + end)) + ]. + +meta_case_test_() -> + [?_assertEqual("{[bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}") + end + end)), + ?_assertEqual("{foo, [bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{fie, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}"); + _ -> Tree + end + end)), + ?_assertError(merl_switch_clause, + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{fie, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}") + end + end)), + ?_assertEqual("{foo, 4}", + f(begin + Tree = ?Q("{foo, 3}"), + case Tree of + ?Q("{foo, _@N}") -> + N1 = erl_syntax:concrete(N) + 1, + ?Q("{foo, _@N1@}"); + _ -> Tree + end + end)), + ?_assertEqual("-export([f/4]).", + f(begin + Tree = ?Q("-export([f/3])."), + case Tree of + ?Q("-export([f/90919]).") -> + Q2 = erl_syntax:concrete(Q1) + 1, + ?Q("-export([f/909299])."); + _ -> Tree + end + end)), + ?_assertEqual("{1, [bar], baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> + ?Q("{1, _@Bar, _@Baz}"); + ?Q("{fie, _@Bar, '@Baz'}") -> + ?Q("{2, _@Bar, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, [bar], baz()}", + f(begin + Tree = ?Q("{fie, [bar], baz()}"), + case Tree of + ?Q("{foo, _@Bar, '@Baz'}") -> + ?Q("{1, _@Bar, _@Baz}"); + ?Q("{fie, _@Bar, '@Baz'}") -> + ?Q("{2, _@Bar, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, baz()}", + f(begin + Tree = ?Q("{foo, [bar], baz()}"), + case Tree of + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, foo) -> + ?Q("{1, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar) -> + ?Q("{2, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") -> + ?Q("{3, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, 42}", + f(begin + Tree = ?Q("{foo, [bar], 42}"), + case Tree of + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 17) -> + ?Q("{1, _@Bar}"); + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 42) -> + ?Q("{2, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") -> + ?Q("{3, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, 42}", + f(begin + Tree = ?Q("{foo, [baz], 42}"), + case Tree of + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 17) + ; erl_syntax:is_atom(Bar, baz), + erl_syntax:is_integer(Baz, 17) -> + ?Q("{1, _@Bar}"); + ?Q("{foo, [_@Bar], '@Baz'}") + when erl_syntax:is_atom(Bar, bar), + erl_syntax:is_integer(Baz, 42) + ; erl_syntax:is_atom(Bar, baz), + erl_syntax:is_integer(Baz, 42) -> + ?Q("{2, _@Baz}"); + ?Q("{foo, [_@Bar], '@Baz'}") -> + ?Q("{3, _@Baz}"); + _ -> Tree + end + end)), + ?_assertEqual("{2, foo, Bar, Baz, Bar(), Baz()}", + f(begin + Tree = ?Q("foo(Bar, Baz) -> Bar(), Baz()."), + case Tree of + ?Q("'@Func'(_@Args) -> _@Body.") -> + ?Q("{1, _@Func, _@Args, _@Body}"); + ?Q("'@Func'(_@@Args) -> _@@Body.") -> + ?Q("{2, _@Func, _@Args, _@Body}"); + ?Q("'@Func'(_@Args, Baz) -> _@Body1, _@Body2.") -> + ?Q("{3, _@Func, _@Args, _@Body1, _@Body2}") + end + end)) + ]. + +-endif. 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. diff --git a/lib/syntax_tools/src/syntax_tools.app.src b/lib/syntax_tools/src/syntax_tools.app.src index 0d8d100d9c..e207901def 100644 --- a/lib/syntax_tools/src/syntax_tools.app.src +++ b/lib/syntax_tools/src/syntax_tools.app.src @@ -11,6 +11,8 @@ erl_syntax_lib, erl_tidy, igor, + merl, + merl_transform, prettypr]}, {registered,[]}, {applications, [stdlib]}, |