From ca41234055158b2f9a605feed8155d253d890ae1 Mon Sep 17 00:00:00 2001
From: X4lldux <x4lldux@vectron.io>
Date: Sat, 28 Mar 2020 11:19:29 +0100
Subject: [PATCH] Add shrinking indication parameter

Set's a `shrinking` parameter to `true` when property is being executed
during a shrinking phase. Also sets it to `done` after the shrinking is
done. Useful for adjusting generators during shrinking phase or for
`on_output` printers.
---
 src/proper.erl        | 16 ++++++++++++++++
 test/proper_tests.erl | 20 ++++++++++++++++++++
 2 files changed, 36 insertions(+)

diff --git a/src/proper.erl b/src/proper.erl
index 315c89c9..b4291087 100644
--- a/src/proper.erl
+++ b/src/proper.erl
@@ -581,6 +581,7 @@
 -type short_module_result() :: [mfa()] | error().
 -type module_result() :: long_module_result() | short_module_result().
 -type shrinking_result() :: {non_neg_integer(),imm_testcase()}.
+-type shrinking_states() :: 'false' | 'true' | 'done'.
 
 %%-----------------------------------------------------------------------------
 %% State handling functions
@@ -1701,11 +1702,23 @@ finalize_input(Instance) ->
 %% Shrinking functions
 %%-----------------------------------------------------------------------------
 
+-spec set_shrinking_param(shrinking_states()) -> ok.
+set_shrinking_param(Val) ->
+    OldParams = erlang:get('$parameters'),
+    case OldParams of
+        undefined ->
+            erlang:put('$parameters', [{shrinking, Val}]);
+        _ ->
+            erlang:put('$parameters', [{shrinking, Val} | OldParams])
+    end,
+    ok.
+
 -spec shrink(imm_testcase(), test(), fail_reason(), opts()) ->
 	  {'ok',imm_testcase()} | error().
 shrink(ImmTestCase, Test, Reason,
        #opts{expect_fail = false, noshrink = false, max_shrinks = MaxShrinks,
 	     output_fun = Print, nocolors = NoColors} = Opts) ->
+    set_shrinking_param(true),                % needs to be set before printing
     case NoColors of
         true ->
             Print("~nShrinking ", []);
@@ -1736,10 +1749,12 @@ shrink(ImmTestCase, Test, Reason,
 	    end
     catch
 	throw:non_boolean_result ->
+        set_shrinking_param(done),
 	    Print("~n", []),
 	    {error, non_boolean_result}
     end;
 shrink(ImmTestCase, _Test, _Reason, _Opts) ->
+    set_shrinking_param(done),
     {ok, ImmTestCase}.
 
 -spec fix_shrink(imm_testcase(), stripped_test(), fail_reason(),
@@ -2125,6 +2140,7 @@ report_shrinking(Shrinks, MinImmTestCase, MinActions, Print, NoColors) ->
         true -> Print("(~b time(s))~n", [Shrinks]);
         false -> Print("\033[01;34m(~b time(s))\033[00m~n", [Shrinks])
     end,
+    set_shrinking_param(done),
     print_imm_testcase(MinImmTestCase, "", Print),
     execute_actions(MinActions).
 
diff --git a/test/proper_tests.erl b/test/proper_tests.erl
index 44429f95..654b538e 100644
--- a/test/proper_tests.erl
+++ b/test/proper_tests.erl
@@ -898,6 +898,26 @@ native_type_props_test_() ->
 -record(untyped, {a, b = 12}).
 -type untyped() :: #untyped{}.
 
+shrinking_param_phases_test_() ->
+    ?_test(begin
+               ?assertMatch(
+                  false,
+                  proper:quickcheck(
+                    ?FORALL(_, 1, false),
+                    [{numtests, 1},
+                     {on_output,
+                      fun(_,_) ->
+                              S = proper_types:parameter(shrinking, false),
+                              put({shrink_phase_mark, S}, true)
+                      end}])),
+               ?assertEqual(true, get({shrink_phase_mark, false})),
+               ?assertEqual(true, get({shrink_phase_mark, true})),
+               ?assertEqual(true, get({shrink_phase_mark, done})),
+               [erase({shrink_phase_mark, P}) || P <- [false, true, done]],
+               proper:clean_garbage(),
+               ?assert(state_is_clean())
+           end).
+
 true_props_test_() ->
     [?_passes(?FORALL(X,integer(),X < X + 1)),
      ?_passes(?FORALL(A,atom(),list_to_atom(atom_to_list(A)) =:= A)),