Add experimental support for ct --retry option

This commit adds a common test hook along with the cth_readable stuff
whose role is to track failing test cases, and create a test
specification out of them.

The test specification is dumped on disk at
_build/<profile>/logs/retry.spec and can be accessed by calling
'rebar3 ct --retry'. This will auto-load the spec file if it can be
found and re-run the failing cases.

If any other argument is found on the list specifying tests, the
'--retry' argument is ignored.

All code for this is marked as experimental in case we end up (keeping
and then) dropping the feature.

2 files changed, 184 insertions, 5 deletions

diff --git a/src/cth_retry.erl b/src/cth_retry.erl
new file mode 100644
index 0000000..e7b1663
--- /dev/null
+++ b/src/cth_retry.erl
@@ -0,0 +1,161 @@
+-module(cth_retry).
+
+%% Callbacks
+-export([id/1]).
+-export([init/2]).
+
+-export([pre_init_per_suite/3]).
+-export([post_init_per_suite/4]).
+-export([pre_end_per_suite/3]).
+-export([post_end_per_suite/4]).
+
+-export([pre_init_per_group/3]).
+-export([post_init_per_group/4]).
+-export([pre_end_per_group/3]).
+-export([post_end_per_group/4]).
+
+-export([pre_init_per_testcase/3]).
+-export([post_end_per_testcase/4]).
+
+-export([on_tc_fail/3]).
+-export([on_tc_skip/3, on_tc_skip/4]).
+
+-export([terminate/1]).
+
+-record(state, {id, suite, groups, acc=[]}).
+
+%% @doc Return a unique id for this CTH.
+id(_Opts) ->
+    {?MODULE, make_ref()}.
+
+%% @doc Always called before any other callback function. Use this to initiate
+%% any common state.
+init(Id, _Opts) ->
+    {ok, #state{id=Id}}.
+
+%% @doc Called before init_per_suite is called.
+pre_init_per_suite(Suite,Config,State) ->
+    {Config, State#state{suite=Suite, groups=[]}}.
+
+%% @doc Called after init_per_suite.
+post_init_per_suite(_Suite,_Config,Return,State) ->
+    {Return, State}.
+
+%% @doc Called before end_per_suite.
+pre_end_per_suite(_Suite,Config,State) ->
+    {Config, State}.
+
+%% @doc Called after end_per_suite.
+post_end_per_suite(_Suite,_Config,Return,State) ->
+    {Return, State#state{suite=undefined, groups=[]}}.
+
+%% @doc Called before each init_per_group.
+pre_init_per_group(_Group,Config,State) ->
+    {Config, State}.
+
+%% @doc Called after each init_per_group.
+post_init_per_group(Group,_Config,Return, State=#state{groups=Groups}) ->
+    {Return, State#state{groups=[Group|Groups]}}.
+
+%% @doc Called after each end_per_group.
+pre_end_per_group(_Group,Config,State) ->
+    {Config, State}.
+
+%% @doc Called after each end_per_group.
+post_end_per_group(_Group,_Config,Return, State=#state{groups=Groups}) ->
+    {Return, State#state{groups=tl(Groups)}}.
+
+%% @doc Called before each test case.
+pre_init_per_testcase(_TC,Config,State) ->
+    {Config, State}.
+
+%% @doc Called after each test case.
+post_end_per_testcase(_TC,_Config,ok,State) ->
+    {ok, State};
+post_end_per_testcase(_TC,_Config,{skip,_},State) ->
+    {ok, State}; % manual skip
+post_end_per_testcase(TC,_Config,Error,State=#state{suite=Suite, groups=Groups, acc=Acc}) ->
+    Test = case TC of
+        {_Group, Case} -> Case;
+        TC -> TC
+    end,
+    {Error, State#state{acc=[{Suite, Groups, Test}|Acc]}}.
+
+%% @doc Called after post_init_per_suite, post_end_per_suite, post_init_per_group,
+%% post_end_per_group and post_end_per_testcase if the suite, group or test case failed.
+on_tc_fail(_TC, _Reason, State) ->
+    State.
+
+%% @doc Called when a test case is skipped by either user action
+%% or due to an init function failing. (>= 19.3)
+on_tc_skip(Suite, TC, {tc_auto_skip, _R}, State=#state{suite=Suite, groups=Groups, acc=Acc}) ->
+    NewAcc = case TC of
+        init_per_testcase -> Acc;
+        end_per_testcase -> Acc;
+        {init_per_group,_} -> Acc;
+        {end_per_group, _} -> Acc;
+        init_per_suite -> Acc;
+        end_per_suite -> Acc;
+        {Case,_Group} -> [{Suite, Groups, Case}|Acc];
+        TC -> [{Suite, Groups, TC}|Acc]
+    end,
+    State#state{suite=Suite, acc=NewAcc};
+on_tc_skip(Suite, _TC, _Reason, State) ->
+    State#state{suite=Suite}.
+
+%% @doc Called when a test case is skipped by either user action
+%% or due to an init function failing. (Pre-19.3)
+on_tc_skip(TC, {tc_auto_skip, _R}, State=#state{suite=Suite, groups=Groups, acc=Acc}) ->
+    NewAcc = case TC of
+        init_per_testcase -> Acc;
+        end_per_testcase -> Acc;
+        {init_per_group,_} -> Acc;
+        {end_per_group, _} -> Acc;
+        init_per_suite -> Acc;
+        end_per_suite -> Acc;
+        {Case, _Group} -> [{Suite, Groups, Case}|Acc];
+        TC -> [{Suite, Groups, TC}|Acc]
+    end,
+    State#state{acc=NewAcc};
+on_tc_skip(_TC, _Reason, State) ->
+    State.
+
+%% @doc Called when the scope of the CTH is done
+terminate(#state{acc=[]}) ->
+    ok;
+terminate(#state{acc=Acc}) ->
+    Spec = to_spec(Acc),
+    {ok, Cwd} = file:get_cwd(),
+    Path = filename:join(lists:droplast(filename:split(Cwd))++["retry.spec"]),
+    io:format(user,
+              "EXPERIMENTAL: Writing retry specification at ~s~n"
+              "              call rebar3 ct with '--retry' to re-run failing cases.~n",
+             [Path]),
+    file:write_file(Path, Spec),
+    ok.
+
+%%% Helpers
+to_spec(List) ->
+    [to_spec_entry(X) || X <- merge(List)].
+
+merge([]) -> [];
+merge([{Suite, Groups, Case}|T]) when is_atom(Case) ->
+    merge([{Suite, Groups, [Case]}|T]);
+merge([{Suite, Groups, Cases}, {Suite, Groups, Case} | T]) ->
+    merge([{Suite, Groups, [Case|Cases]}|T]);
+merge([{Suite, Groups, Cases} | T]) ->
+    [{Suite, Groups, Cases} | merge(T)].
+
+to_spec_entry({Suite, [], Cases}) ->
+    Dir = filename:dirname(proplists:get_value(source, Suite:module_info(compile))),
+    io_lib:format("~p.~n", [{cases, Dir, Suite, Cases}]);
+to_spec_entry({Suite, Groups, Cases}) ->
+    Dir = filename:dirname(proplists:get_value(source, Suite:module_info(compile))),
+    ExpandedGroups = expand_groups(lists:reverse(Groups)),
+    io_lib:format("~p.~n", [{groups, Dir, Suite, ExpandedGroups, {cases,Cases}}]).
+
+expand_groups([Group]) ->
+    {Group, []};
+expand_groups([H|T]) ->
+    {H,[],[expand_groups(T)]}.
+
diff --git a/src/rebar_prv_common_test.erl b/src/rebar_prv_common_test.erl
index 2443710..a88753c 100644
--- a/src/rebar_prv_common_test.erl
+++ b/src/rebar_prv_common_test.erl
@@ -213,10 +213,10 @@ add_hooks(Opts, State) ->
         {false, _} ->
             Opts;
         {true, false} ->
-            [{ct_hooks, [cth_readable_failonly, cth_readable_shell]} | Opts];
+            [{ct_hooks, [cth_readable_failonly, cth_readable_shell, cth_retry]} | Opts];
         {true, {ct_hooks, Hooks}} ->
             %% Make sure hooks are there once only.
-            ReadableHooks = [cth_readable_failonly, cth_readable_shell],
+            ReadableHooks = [cth_readable_failonly, cth_readable_shell, cth_retry],
             NewHooks =  (Hooks -- ReadableHooks) ++ ReadableHooks,
             lists:keyreplace(ct_hooks, 1, Opts, {ct_hooks, NewHooks})
     end.
@@ -272,6 +272,15 @@ is_any_defined([Key|Keys],Opts) ->
 is_any_defined([],_Opts) ->
     false.
 
+should_retry(State, Opts) ->
+    case proplists:get_value(retry, Opts, false) of
+        false ->
+            false;
+        true ->
+            Path = filename:join([rebar_dir:base_dir(State), "logs", "retry.spec"]),
+            filelib:is_file(Path) andalso {true, Path}
+    end.
+
 sys_config_list(CmdOpts, CfgOpts) ->
     CmdSysConfigs = split_string(proplists:get_value(sys_config, CmdOpts, "")),
     case proplists:get_value(sys_config, CfgOpts, []) of
@@ -285,9 +294,15 @@ sys_config_list(CmdOpts, CfgOpts) ->
 
 discover_tests(State, ProjectApps, Opts) ->
     case is_any_defined([spec,dir,suite],Opts) of
+        true  -> {ok, Opts};
         %% no tests defined, try using `$APP/test` and `$ROOT/test` as dirs
-        false -> {ok, [default_tests(State, ProjectApps)|Opts]};
-        true  -> {ok, Opts}
+        false ->
+            case should_retry(State, Opts) of
+                false ->
+                    {ok, [default_tests(State, ProjectApps)|Opts]};
+                {true, Path} ->
+                    {ok, [{spec, Path} | Opts]}
+            end
     end.
 
 default_tests(State, ProjectApps) ->
@@ -751,7 +766,8 @@ ct_opts(_State) ->
      {sname, undefined, "sname", atom, help(sname)},
      {setcookie, undefined, "setcookie", atom, help(setcookie)},
      {sys_config, undefined, "sys_config", string, help(sys_config)}, %% comma-separated list
-     {compile_only, undefined, "compile_only", boolean, help(compile_only)}
+     {compile_only, undefined, "compile_only", boolean, help(compile_only)},
+     {retry, undefined, "retry", boolean, help(retry)}
     ].
 
 help(compile_only) ->
@@ -820,5 +836,7 @@ help(sname) ->
     "Gives a short name to the node";
 help(setcookie) ->
     "Sets the cookie if the node is distributed";
+help(retry) ->
+    "Experimental feature. If any specification for previously failing test is found, runs them.";
 help(_) ->
     "".