Skip to content
Browse files

Simplify function generator, fixes bug found by Tuncer Ayaz

  • Loading branch information...
1 parent 6fb09ce commit 2b833ba3b40a0e097a031fa47d012fc36244a163 @manopapad committed Apr 8, 2011
Showing with 169 additions and 246 deletions.
  1. +11 −6 README
  2. +1 −0 include/proper_internal.hrl
  3. +1 −1 rebar.config
  4. +10 −7 src/proper.erl
  5. +0 −222 src/proper_funserver.erl
  6. +41 −4 src/proper_gen.erl
  7. +6 −6 src/proper_types.erl
  8. +99 −0 src/vararg.erl
View
17 README
@@ -982,7 +982,7 @@ is useful for zipping a command sequence with its (failing) execution history.
Examples of sample properties to check can be found at examples/pdict_statem
and examples/ets_statem. These modules contain an abstract state machine
-specification for testing operations on the process dictionary and ets tables
+specification for testing operations on the process dictionary and ets tables
respectively.
@@ -1030,7 +1030,7 @@ suitable concurrent tasks for each test. In this case, an 'f' is printed on
screen to inform the user.
An example of a sample property for parallel testing can be found at
-examples/ets_statem, where we test concurrent operations on a public ets table.
+examples/ets_statem, where we test concurrent operations on a public ets table.
--------------------------------------------------------------------------------
@@ -1041,10 +1041,15 @@ The following errors may be encountered during testing. The term provided for
each error is the error type returned by proper:quickcheck in case such an error
occurs. Normaly, a message is also printed on screen describing the error.
-* 'cant_generate': The instance generation subsystem has failed to produce an
- instance that satisfies some ?SUCHTHAT constraint. You should either increase
- the 'constraint_tries' limit, loosen the failing constraint, or make it
- non-strict. This error should only be encountered during normal operation.
+* 'arity_limit': The random instance generation subsystem has failed to produce
+ a function of the desired arity. Please recompile PropEr with a suitable value
+ for ?MAX_ARITY (defined in proper_internal.hrl). This error should only be
+ encountered during normal operation.
+* 'cant_generate': The random instance generation subsystem has failed to
+ produce an instance that satisfies some ?SUCHTHAT constraint. You should
+ either increase the 'constraint_tries' limit, loosen the failing constraint,
+ or make it non-strict. This error should only be encountered during normal
+ operation.
* 'cant_satisfy': All the tests were rejected because no produced test case
would pass all ?IMPLIES checks. You should loosen the failing ?IMPLIES
constraint(s). This error should only be encountered during normal operation.
View
1 include/proper_internal.hrl
@@ -43,6 +43,7 @@
%%------------------------------------------------------------------------------
-define(SEED_RANGE, 4294967296).
+-define(MAX_ARITY, 20).
-define(MAX_TRIES_FACTOR, 5).
-define(ANY_SIMPLE_PROB, 3).
-define(ANY_BINARY_PROB, 1).
View
2 rebar.config
@@ -4,7 +4,7 @@
%% WARNING: To compile on versions of Erlang/OTP older than R13B4, add
%% {d,'NO_TYPES'} to erl_opts.
-{erl_first_files, ["strip_types.erl"]}.
+{erl_first_files, ["src/strip_types.erl", "src/vararg.erl"]}.
{erl_opts, [debug_info,
report_warnings, {warn_format,1}, warn_export_vars,
warn_obsolete_guard, warn_unused_import,
View
17 src/proper.erl
@@ -180,8 +180,8 @@
-type exc_kind() :: 'throw' | 'error' | 'exit'.
-type exc_reason() :: term().
-type stacktrace() :: [{atom(),atom(),arity() | [term()]}].
--type error_reason() :: 'cant_generate' | 'cant_satisfy' | 'rejected'
- | 'shrinking_error' | 'too_many_instances'
+-type error_reason() :: 'arity_limit' | 'cant_generate' | 'cant_satisfy'
+ | 'rejected' | 'shrinking_error' | 'too_many_instances'
| 'type_mismatch' | 'wrong_type' | {'typeserver',term()}
| {'unexpected',any()} | {'unrecognized_option',term()}.
@@ -270,20 +270,17 @@ global_state_init(#opts{start_size = StartSize, constraint_tries = CTries,
put('$any_type',AnyType),
proper_arith:rand_start(Crypto),
proper_typeserver:start(),
- proper_funserver:start(),
ok.
-spec global_state_reset(opts()) -> 'ok'.
global_state_reset(#opts{start_size = StartSize} = Opts) ->
clean_garbage(),
put('$size', StartSize - 1),
put('$left', 0),
- grow_size(Opts),
- proper_funserver:reset().
+ grow_size(Opts).
-spec global_state_erase() -> 'ok'.
global_state_erase() ->
- proper_funserver:stop(),
proper_typeserver:stop(),
proper_arith:rand_stop(),
erase('$any_type'),
@@ -702,7 +699,6 @@ perform(ToPass, ToPass, _TriesLeft, _Test, Samples, Printers, _Opts) ->
#pass{samples = Samples, printers = Printers, performed = ToPass};
perform(Passed, ToPass, TriesLeft, Test, Samples, Printers,
#opts{output_fun = Print} = Opts) ->
- proper_funserver:reset(),
case run(Test) of
#pass{reason = true_prop, samples = MoreSamples,
printers = MorePrinters} ->
@@ -719,6 +715,8 @@ perform(Passed, ToPass, TriesLeft, Test, Samples, Printers,
#fail{} = FailResult ->
Print("!", []),
FailResult#fail{performed = Passed + 1};
+ {error, arity_limit} = Error ->
+ Error;
{error, cant_generate} = Error ->
Error;
{error, rejected} ->
@@ -922,6 +920,8 @@ apply_args(Args, Prop, Ctx) ->
false ->
create_fail_result(Ctx, {exception,error,ErrReason,Trace})
end;
+ throw:'$arity_limit' ->
+ {error, arity_limit};
throw:'$cant_generate' ->
{error, cant_generate};
throw:{'$typeserver',SubReason} ->
@@ -1254,6 +1254,9 @@ report_rerun_result({error,Reason}, #opts{output_fun = Print}) ->
%% @private
-spec report_error(error_reason(), output_fun()) -> 'ok'.
+report_error(arity_limit, Print) ->
+ Print("Error: Couldn't produce a function of the desired arity, please "
+ "recompile PropEr with an increased value for ?MAX_ARITY.~n", []);
report_error(cant_generate, Print) ->
Print("Error: Couldn't produce an instance that satisfies all strict "
"constraints after ~b tries.~n", [get('$constraint_tries')]);
View
222 src/proper_funserver.erl
@@ -1,222 +0,0 @@
-%%% Copyright 2010 Manolis Papadakis (manopapad@gmail.com)
-%%% and Kostis Sagonas (kostis@cs.ntua.gr)
-%%%
-%%% This file is part of PropEr.
-%%%
-%%% PropEr is free software: you can redistribute it and/or modify
-%%% it under the terms of the GNU General Public License as published by
-%%% the Free Software Foundation, either version 3 of the License, or
-%%% (at your option) any later version.
-%%%
-%%% PropEr is distributed in the hope that it will be useful,
-%%% but WITHOUT ANY WARRANTY; without even the implied warranty of
-%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-%%% GNU General Public License for more details.
-%%%
-%%% You should have received a copy of the GNU General Public License
-%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>.
-
-%%% @author Manolis Papadakis <manopapad@gmail.com>
-%%% @copyright 2010 Manolis Papadakis and Kostis Sagonas
-%%% @version {@version}
-%%% @doc This module contains the server responsible for tge generation of
-%%% random functions.
-%%% @private
-
--module(proper_funserver).
--behaviour(gen_server).
-
--export([start/0, stop/0, reset/0, create_fun/3]).
--export([get_ret_type/1, function_body/3]).
--export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2,
- code_change/3]).
-
--include("proper_internal.hrl").
-
-
-%%------------------------------------------------------------------------------
-%% Types
-%%------------------------------------------------------------------------------
-
--type fun_seed() :: {non_neg_integer(),non_neg_integer()}.
--type imm_ret_type() :: {'type',proper_types:type()} | {'bin',binary()}.
--record(state, {temp_mod = new_temp_mod_name() :: mod_name(),
- forms = [] :: [abs_form()],
- next_fun_num = 1 :: pos_integer()}).
--opaque state() :: #state{}.
-
--type server_call() :: 'reset'
- | {'create_fun',arity(),proper_types:type(),fun_seed()}.
--type server_response() :: 'ok' | function().
-
-
-%%------------------------------------------------------------------------------
-%% Server interface functions
-%%------------------------------------------------------------------------------
-
--spec start() -> 'ok'.
-start() ->
- {ok,FunserverPid} = gen_server:start_link(?MODULE, dummy, []),
- put('$funserver_pid', FunserverPid),
- %% TODO: To make PropEr multi-threaded, this should be copied to each
- %% spawned worker process.
- ok.
-
--spec stop() -> 'ok'.
-stop() ->
- FunserverPid = get('$funserver_pid'),
- erase('$funserver_pid'),
- gen_server:cast(FunserverPid, stop).
-
--spec reset() -> 'ok'.
-reset() ->
- FunserverPid = get('$funserver_pid'),
- gen_server:call(FunserverPid, reset).
-
--spec create_fun(arity(), proper_types:type(), fun_seed()) -> function().
-create_fun(Arity, RetType, FunSeed) ->
- FunserverPid = get('$funserver_pid'),
- gen_server:call(FunserverPid, {create_fun,Arity,RetType,FunSeed}).
-
-
-%%------------------------------------------------------------------------------
-%% Implementation of gen_server interface
-%%------------------------------------------------------------------------------
-
--spec init(_) -> {'ok',state()}.
-init(_) ->
- {ok, #state{}}.
-
--spec handle_call(server_call(), _, state()) ->
- {'reply',server_response(),state()}.
-handle_call(reset, _From, State) ->
- %% TODO: To make PropEr multi-threaded, this should erase only those
- %% functions that have been created for the calling process, then
- %% reload temp_mod with all the remaining functions.
- remove_temp_mod(State),
- {reply, ok, #state{}};
-handle_call({create_fun,Arity,RetType,FunSeed}, _From, State) ->
- {Fun,NewState} = create_fun(Arity, RetType, FunSeed, State),
- {reply, Fun, NewState}.
-
--spec handle_cast('stop', state()) -> {'stop','normal',state()}.
-handle_cast(stop, State) ->
- {stop, normal, State}.
-
--spec handle_info(term(), state()) -> {'stop',{'received_info',term()},state()}.
-handle_info(Info, State) ->
- {stop, {received_info,Info}, State}.
-
--spec terminate(term(), state()) -> 'ok'.
-terminate(_Reason, State) ->
- %% TODO: Remove temp_mod here or in handle_cast(stop)?
- %% TODO: This may take a while to complete - is that OK?
- remove_temp_mod(State),
- ok.
-
--spec code_change(term(), state(), _) -> {'ok',state()}.
-code_change(_OldVsn, State, _) ->
- {ok, State}.
-
-
-%%------------------------------------------------------------------------------
-%% Function-generation functions
-%%------------------------------------------------------------------------------
-
--spec new_temp_mod_name() -> mod_name().
-new_temp_mod_name() ->
- TempModStr = lists:flatten(io_lib:format("$temp_mod$~w$~w",[self(),now()])),
- list_to_atom([case C of $. -> $$; _ -> C end || C <- TempModStr]).
-
--spec create_fun(arity(), proper_types:type(), fun_seed(), state()) ->
- {function(),state()}.
-create_fun(0, RetType, FunSeed, State) ->
- {fun() -> ?MODULE:function_body([],{type,RetType},FunSeed) end, State};
-create_fun(1, RetType, FunSeed, State) ->
- {fun(A) -> ?MODULE:function_body([A],{type,RetType},FunSeed) end, State};
-create_fun(2, RetType, FunSeed, State) ->
- {fun(A,B) -> ?MODULE:function_body([A,B],{type,RetType},FunSeed) end,
- State};
-create_fun(3, RetType, FunSeed, State) ->
- {fun(A,B,C) -> ?MODULE:function_body([A,B,C],{type,RetType},FunSeed) end,
- State};
-create_fun(4, RetType, FunSeed, State) ->
- {fun(A,B,C,D) ->
- ?MODULE:function_body([A,B,C,D],{type,RetType},FunSeed)
- end,
- State};
-create_fun(Arity,RetType,FunSeed,#state{temp_mod = TempMod, forms = Forms,
- next_fun_num = NextFunNum} = State) ->
- FunName = list_to_atom("f" ++ integer_to_list(NextFunNum)),
- Fun = erlang:make_fun(TempMod, FunName, Arity),
- Args = [{var,0,list_to_atom("X" ++ integer_to_list(N))}
- || N <- lists:seq(1,Arity)],
- ArgsList = lists:foldr(fun(X,Acc) -> {cons,0,X,Acc} end, {nil,0}, Args),
- Body = [{call, 0, {remote,0,{atom,0,?MODULE},{atom,0,function_body}},
- [ArgsList,
- erl_parse:abstract({bin,proper_types:to_binary(RetType)}),
- erl_parse:abstract(FunSeed)]}],
- Form = {function,0,FunName,Arity,[{clause,0,Args,[],Body}]},
- NewState = State#state{forms = [Form|Forms], next_fun_num = NextFunNum + 1},
- reload_temp_mod(NewState),
- {Fun, NewState}.
-
--spec remove_temp_mod(state()) -> 'ok'.
-remove_temp_mod(#state{temp_mod = TempMod}) ->
- case code:is_loaded(TempMod) of
- %% For this to work we must purge the old code everytime we load a new
- %% version of temp_mod.
- false ->
- ok;
- {file,_Loaded} ->
- true = code:delete(TempMod),
- %% TODO: Do a hard purge instead?
- purge_old_code(TempMod),
- ok
- end.
-
--spec reload_temp_mod(state()) -> 'ok'.
-reload_temp_mod(#state{forms = []}) ->
- %% TODO: To make PropEr multi-threaded, the reloading will need to occur
- %% even if no more functions are present.
- ok;
-reload_temp_mod(#state{temp_mod = TempMod, forms = RawForms}) ->
- Forms = [{attribute,0,module,TempMod} | RawForms],
- %% TODO: verbose and report options?
- {ok,TempMod,Code} = compile:forms(Forms, [export_all]),
- {module,TempMod} = code:load_binary(TempMod, "no_file", Code),
- purge_old_code(TempMod),
- ok.
-
--spec purge_old_code(mod_name()) -> 'ok'.
-purge_old_code(Mod) ->
- case code:soft_purge(Mod) of
- true -> ok;
- false -> purge_old_code(Mod)
- end.
-
--spec get_ret_type(function()) -> proper_types:type().
-get_ret_type(Fun) ->
- {arity,Arity} = erlang:fun_info(Fun, arity),
- put('$get_ret_type', true),
- RetType = apply(Fun, lists:duplicate(Arity,dummy)),
- erase('$get_ret_type'),
- RetType.
-
--spec function_body([term()], imm_ret_type(), fun_seed()) ->
- proper_types:type() | proper_gen:instance().
-function_body(Args, ImmRetType, {Seed1,Seed2}) ->
- RetType = case ImmRetType of
- {type,T} -> T;
- {bin,B} -> proper_types:from_binary(B)
- end,
- case get('$get_ret_type') of
- true ->
- RetType;
- _ ->
- SavedSeed = get(random_seed),
- put(random_seed, {Seed1,Seed2,erlang:phash2(Args,?SEED_RANGE)}),
- Ret = proper_gen:clean_instance(proper_gen:generate(RetType)),
- put(random_seed, SavedSeed),
- proper_symb:internal_eval(Ret)
- end.
View
45 src/proper_gen.erl
@@ -26,7 +26,8 @@
-export([pick/1, pick/2, sample/1, sample/3, sampleshrink/1, sampleshrink/2]).
-export([safe_generate/1]).
--export([generate/1, normal_gen/1, alt_gens/1, clean_instance/1]).
+-export([generate/1, normal_gen/1, alt_gens/1, clean_instance/1,
+ get_ret_type/1]).
-export([integer_gen/3, float_gen/3, atom_gen/1, atom_rev/1, binary_gen/1,
binary_str_gen/1, binary_rev/1, binary_len_gen/1, binary_len_str_gen/1,
bitstring_gen/1, bitstring_rev/1, bitstring_len_gen/1, list_gen/2,
@@ -46,6 +47,7 @@
%% @private_type alt_gens
-include("proper_internal.hrl").
+-compile({parse_transform, vararg}).
%%-----------------------------------------------------------------------------
@@ -59,6 +61,7 @@
| instance()
| {'$used', imm_instance(), imm_instance()}
| {'$to_part', imm_instance()}.
+-type error_reason() :: 'arity_limit' | 'cant_generate' | {'typeserver',term()}.
-type sized_generator() :: fun((size()) -> imm_instance()).
-type nosize_generator() :: fun(() -> imm_instance()).
@@ -69,6 +72,7 @@
-type reverse_gen() :: fun((instance()) -> imm_instance()).
-type combine_fun() :: fun((instance()) -> imm_instance()).
-type alt_gens() :: fun(() -> [imm_instance()]).
+-type fun_seed() :: {non_neg_integer(),non_neg_integer()}.
%%-----------------------------------------------------------------------------
@@ -77,12 +81,12 @@
%% @private
-spec safe_generate(proper_types:raw_type()) ->
- {'ok',imm_instance()}
- | {'error','cant_generate' | {'typeserver',term()}}.
+ {'ok',imm_instance()} | {'error',error_reason()}.
safe_generate(RawType) ->
try generate(RawType) of
ImmInstance -> {ok, ImmInstance}
catch
+ throw:'$arity_limit' -> {error, arity_limit};
throw:'$cant_generate' -> {error, cant_generate};
throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}}
end.
@@ -499,7 +503,7 @@ fixed_list_gen(ProperFields) ->
function_gen(Arity, RetType) ->
FunSeed = {proper_arith:rand_int(0, ?SEED_RANGE - 1),
proper_arith:rand_int(0, ?SEED_RANGE - 1)},
- proper_funserver:create_fun(Arity, RetType, FunSeed).
+ create_fun(Arity, RetType, FunSeed).
%% @private
-spec any_gen(size()) -> imm_instance().
@@ -540,3 +544,36 @@ native_type_gen(Mod, TypeStr) ->
{ok,Type} -> Type;
{error,Reason} -> throw({'$typeserver',Reason})
end.
+
+
+%%------------------------------------------------------------------------------
+%% Function-generation functions
+%%------------------------------------------------------------------------------
+
+-spec create_fun(arity(), proper_types:type(), fun_seed()) -> function().
+create_fun(Arity, RetType, FunSeed) ->
+ Handler = fun(Args) -> function_body(Args, RetType, FunSeed) end,
+ Err = fun() -> throw('$arity_limit') end,
+ 'MAKE_FUN'(Arity, Handler, Err).
+
+-spec get_ret_type(function()) -> proper_types:type().
+get_ret_type(Fun) ->
+ {arity,Arity} = erlang:fun_info(Fun, arity),
+ put('$get_ret_type', true),
+ RetType = apply(Fun, lists:duplicate(Arity,dummy)),
+ erase('$get_ret_type'),
+ RetType.
+
+-spec function_body([term()], proper_types:type(), fun_seed()) ->
+ proper_types:type() | instance().
+function_body(Args, RetType, {Seed1,Seed2}) ->
+ case get('$get_ret_type') of
+ true ->
+ RetType;
+ _ ->
+ SavedSeed = get(random_seed),
+ put(random_seed, {Seed1,Seed2,erlang:phash2(Args,?SEED_RANGE)}),
+ Ret = clean_instance(generate(RetType)),
+ put(random_seed, SavedSeed),
+ proper_symb:internal_eval(Ret)
+ end.
View
12 src/proper_types.erl
@@ -26,7 +26,7 @@
-export([is_inst/2, is_inst/3]).
-export([integer/2, float/2, atom/0, binary/0, binary/1, bitstring/0,
- bitstring/1, list/1, vector/2, union/1, weighted_union/1,tuple/1,
+ bitstring/1, list/1, vector/2, union/1, weighted_union/1,tuple/1,
loose_tuple/1, exactly/1, fixed_list/1, function/2, any/0]).
-export([integer/0, non_neg_integer/0, pos_integer/0, neg_integer/0, range/2,
float/0, non_neg_float/0, number/0, boolean/0, byte/0, char/0,
@@ -42,7 +42,7 @@
is_instance/2, unwrap/1, weakly/1, strongly/1, satisfies_all/2,
new_type/2, list_get_indices/1]).
-export([lazy/1, sized/1, bind/3, shrinkwith/2, add_constraint/3,
- native_type/2, distlist/3, with_parameter/3, with_parameters/2,
+ native_type/2, distlist/3, with_parameter/3, with_parameters/2,
parameter/1, parameter/2]).
-export_type([type/0, raw_type/0]).
@@ -150,7 +150,7 @@
%% A list of constraints on instances of this type: each constraint is a
%% tuple of a fun that must return 'true' for each valid instance and a
%% boolean field that specifies whether the condition is strict.
- |{'parameters',[{atom(),value()}]}.
+ |{'parameters',[{atom(),value()}]}.
%%------------------------------------------------------------------------------
@@ -374,7 +374,7 @@ satisfies_all(Instance, Type) ->
%%------------------------------------------------------------------------------
%% Type definition functions
%%------------------------------------------------------------------------------
-
+
%% @private
-spec lazy(proper_gen:nosize_generator()) -> proper_types:type().
lazy(Gen) ->
@@ -741,7 +741,7 @@ function(RawArgTypes, RawRetType) ->
function_test(X, Arity, RetType) ->
is_function(X, Arity)
%% TODO: what if it's not a function we produced?
- andalso equal_types(RetType, proper_funserver:get_ret_type(X)).
+ andalso equal_types(RetType, proper_gen:get_ret_type(X)).
-spec any() -> proper_types:type().
any() ->
@@ -921,7 +921,7 @@ parameter(Param) ->
-spec parameter(atom(), value()) -> value().
parameter(Param, Default) ->
- Parameters =
+ Parameters =
case erlang:get('$parameters') of
undefined -> [];
List -> List
View
99 src/vararg.erl
@@ -0,0 +1,99 @@
+%%% Copyright 2010-2011 Manolis Papadakis (manopapad@gmail.com)
+%%% and Kostis Sagonas (kostis@cs.ntua.gr)
+%%%
+%%% This file is part of PropEr.
+%%%
+%%% PropEr is free software: you can redistribute it and/or modify
+%%% it under the terms of the GNU General Public License as published by
+%%% the Free Software Foundation, either version 3 of the License, or
+%%% (at your option) any later version.
+%%%
+%%% PropEr is distributed in the hope that it will be useful,
+%%% but WITHOUT ANY WARRANTY; without even the implied warranty of
+%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+%%% GNU General Public License for more details.
+%%%
+%%% You should have received a copy of the GNU General Public License
+%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>.
+
+%%% @author Manolis Papadakis <manopapad@gmail.com>
+%%% @copyright 2010-2011 Manolis Papadakis and Kostis Sagonas
+%%% @version {@version}
+%%% @doc This module contains a helper parse transform that allows the creation
+%%% of functions of arbitrary arity.
+%%% @private
+
+-module(vararg).
+-export([parse_transform/2]).
+
+-include("proper_internal.hrl").
+
+%% 'MAKE_FUN'(Arity,Handler,Err) will be replaced with this case clause:
+%% case Arity of
+%% 0 -> fun() -> Handler([]) end;
+%% 1 -> fun(X1) -> Handler([X1]) end;
+%% 2 -> fun(X2,X1) -> Handler([X2,X1]) end;
+%% 3 -> fun(X3,X2,X1) -> Handler([X3,X2,X1]) end;
+%% ...
+%% k -> fun(Xk,...,X1) -> Handler([Xk,...,X1]) end;
+%% _ -> Err()
+%% end
+%% where k = ?MAX_ARITY
+
+%% CAUTION: This conversion works on a syntactic level:
+%% 'Arity' will usually be a variable or a function call (it certainly doesn't
+%% make sense for it to be a simple numeric value).
+%% 'Handler' gets copied many times, therefore it should not be a complex
+%% expression. It will usually be a variable, an external fun declaration, or
+%% even simply the name of a local function.
+%% 'Err' can be anything that evaluates to a 0-arity fun value.
+
+
+%%------------------------------------------------------------------------------
+%% Top-level functions
+%%------------------------------------------------------------------------------
+
+-spec parse_transform([abs_form()], [compile:option()]) -> [abs_form()].
+parse_transform(Forms, _Options) ->
+ process(Forms).
+
+-spec process(term()) -> term().
+process({call,_,{atom,_,'MAKE_FUN'},[Arity,Handler,Err]}) ->
+ add_vararg_wrapper(Arity, Handler, Err);
+process(List) when is_list(List) ->
+ [process(X) || X <- List];
+process(Tuple) when is_tuple(Tuple) ->
+ list_to_tuple(process(tuple_to_list(Tuple)));
+process(Other) ->
+ Other.
+
+-spec add_vararg_wrapper(abs_expr(), abs_expr(), abs_expr()) -> abs_expr().
+add_vararg_wrapper(Arity, Handler, Err) ->
+ RevClauses = wrapper_clauses(?MAX_ARITY, Handler),
+ CatchAll = {clause,0,[{var,0,'_'}],[],[{call,0,Err,[]}]},
+ Clauses = lists:reverse([CatchAll | RevClauses]),
+ {'case',0,Arity,Clauses}.
+
+-spec wrapper_clauses(arity(), abs_expr()) -> [abs_clause()].
+wrapper_clauses(MaxArity, Handler) ->
+ wrapper_clauses(0, MaxArity, Handler, [], [], {nil,0}).
+
+-spec wrapper_clauses(arity(), arity(), abs_expr(), [abs_clause()],
+ [abs_expr()], abs_expr()) -> [abs_clause()].
+wrapper_clauses(MaxArity, MaxArity, Handler, Clauses, Args, ArgsList) ->
+ FinalClause = wrapper_clause(MaxArity, Handler, Args, ArgsList),
+ [FinalClause | Clauses];
+wrapper_clauses(N, MaxArity, Handler, Clauses, Args, ArgsList) ->
+ NewClause = wrapper_clause(N, Handler, Args, ArgsList),
+ NewClauses = [NewClause | Clauses],
+ NewArg = {var,0,list_to_atom("X" ++ integer_to_list(N+1))},
+ NewArgs = [NewArg | Args],
+ NewArgsList = {cons,0,NewArg,ArgsList},
+ wrapper_clauses(N+1, MaxArity, Handler, NewClauses, NewArgs, NewArgsList).
+
+-spec wrapper_clause(arity(), abs_expr(), [abs_expr()], abs_expr()) ->
+ abs_clause().
+wrapper_clause(N, Handler, Args, ArgsList) ->
+ Body = [{call,0,Handler,[ArgsList]}],
+ Fun = {'fun',0,{clauses,[{clause,0,Args,[],Body}]}},
+ {clause,0,[{integer,0,N}],[],[Fun]}.

0 comments on commit 2b833ba

Please sign in to comment.
Something went wrong with that request. Please try again.