From 7a81f289ff5a186ae299d713e09ad4e2d8272f77 Mon Sep 17 00:00:00 2001
From: Arvid Jakobsson <arvid.jakobsson@nomadic-labs.com>
Date: Thu, 6 Oct 2022 09:13:31 +0200
Subject: [PATCH 1/6] Tezt: add [Parametric]

---
 tezt/lib/tezt.ml            |   3 ++
 tezt/lib_core/parametric.ml | 101 ++++++++++++++++++++++++++++++++++++
 tezt/lib_tezos/protocol.ml  |  34 ++++++++++--
 tezt/lib_tezos/protocol.mli |  10 ++++
 4 files changed, 145 insertions(+), 3 deletions(-)
 create mode 100644 tezt/lib_core/parametric.ml

diff --git a/tezt/lib/tezt.ml b/tezt/lib/tezt.ml
index 3ddf236977a2..1023e94cb346 100644
--- a/tezt/lib/tezt.ml
+++ b/tezt/lib/tezt.ml
@@ -165,3 +165,6 @@ module Test = struct
       It is available in [tezt] and [tezt.js]. *)
   let run = Main.run
 end
+
+(** Parametric tests. *)
+module Parametric = Parametric
diff --git a/tezt/lib_core/parametric.ml b/tezt/lib_core/parametric.ml
new file mode 100644
index 000000000000..fad804600d90
--- /dev/null
+++ b/tezt/lib_core/parametric.ml
@@ -0,0 +1,101 @@
+open Base
+
+type 'a param = {
+  to_string : 'a -> string;
+  name : string option;
+  values : 'a list;
+  tags : 'a -> string list;
+}
+
+let pair p1 p2 =
+  {
+    to_string = (fun (v1, v2) -> sf "%s,%s" (p1.to_string v1) (p2.to_string v2));
+    name = None;
+    values =
+      (* todo: error if p1. or p2. values is empty *)
+      List.concat_map
+        (fun v1 -> List.map (fun v2 -> (v1, v2)) p2.values)
+        p1.values;
+    tags = (fun (v1, v2) -> p1.tags v1 @ p2.tags v2);
+  }
+
+let tuple2 p q = pair p q
+
+let tuple3 p q r = pair p (tuple2 q r)
+
+let tuple4 p q r w = pair p (tuple3 q r w)
+
+let register :
+    __FILE__:string ->
+    title:string ->
+    tags:string list ->
+    ('a -> unit Lwt.t) ->
+    'a param ->
+    unit =
+ fun ~__FILE__ ~title ~tags f param ->
+  match param.values with
+  | [] ->
+      failwith
+        (sf
+           "test %s in %s was registered with an empty parameterization"
+           title
+           __FILE__)
+  | values ->
+      (Fun.flip List.iter) values @@ fun value ->
+      let tags = tags @ param.tags value in
+      let title = title ^ " [" ^ param.to_string value ^ "]" in
+      Test.register ~__FILE__ ~title ~tags (fun () -> f value)
+
+let parameterize (param : 'a param) f = f param
+
+let register_internal :
+    __FILE__:string ->
+    title:string ->
+    tags:string list ->
+    ('a -> unit Lwt.t) ->
+    'a param ->
+    unit =
+ fun ~__FILE__ ~title ~tags f param ->
+  Test.register ~__FILE__ ~title ~tags (fun () ->
+      (Fun.flip Lwt_list.iter_s) param.values @@ fun value ->
+      Log.info
+        "Running test %s with parameters [%s]"
+        title
+        (param.to_string value) ;
+      f value)
+
+let list ?name ~to_string values =
+  {name; to_string; tags = (fun v -> [to_string v]); values}
+
+let strings ?name values = list ?name ~to_string:Fun.id values
+
+let ints ?name values = list ?name ~to_string:string_of_int values
+
+let register_examples _protocols : unit =
+  let p1 = strings ["foo"; "bar"] in
+  let p2 = ints [1; 2] in
+  let () =
+    parameterize p1
+    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
+    @@ fun string_value ->
+    Log.info "My parameter is: %s" string_value ;
+    unit
+  in
+  let () =
+    parameterize (tuple2 p1 p2)
+    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
+    @@ fun (string_value, int_value) ->
+    Log.info "My parameters are: %s and %d" string_value int_value ;
+    unit
+  in
+  let () =
+    parameterize (tuple2 p1 p2)
+    @@ register_internal
+         ~__FILE__
+         ~title:"Example parametric test internal"
+         ~tags:["my"; "tags"]
+    @@ fun (string_value, int_value) ->
+    Log.info "My parameters are: %s and %d" string_value int_value ;
+    unit
+  in
+  ()
diff --git a/tezt/lib_tezos/protocol.ml b/tezt/lib_tezos/protocol.ml
index 420ee9f18f8b..adf3099032c1 100644
--- a/tezt/lib_tezos/protocol.ml
+++ b/tezt/lib_tezos/protocol.ml
@@ -185,10 +185,38 @@ let iter_on_supported_protocols ~title ~protocols ?(supports = Any_protocol) f =
 let add_to_test_parameters protocol title tags =
   (name protocol ^ ": " ^ title, tag protocol :: tags)
 
+let protocols_param ?(supports = Any_protocol) ~title protocols =
+  let protocols =
+    match List.filter (is_supported supports) protocols with
+    | [] ->
+        failwith
+          (sf
+             "test %s was registered with ~protocols:[%s] %s, which results in \
+              an empty list of protocols"
+             title
+             (String.concat ", " (List.map name protocols))
+             (show_supported_protocols supports))
+    | supported_protocols -> supported_protocols
+  in
+  Tezt_core.Parametric.
+    {
+      to_string = name;
+      name = Some "protocol";
+      values = protocols;
+      tags = (fun protocol -> [tag protocol]);
+    }
+
 let register_test ~__FILE__ ~title ~tags ?supports body protocols =
-  iter_on_supported_protocols ~title ~protocols ?supports @@ fun protocol ->
-  let title, tags = add_to_test_parameters protocol title tags in
-  Test.register ~__FILE__ ~title ~tags (fun () -> body protocol)
+  let open Parametric in
+  parameterize
+    (protocols_param ~title ?supports protocols)
+    (register ~__FILE__ ~title ~tags body)
+
+let register_parametric ~__FILE__ ~title ~tags ?supports body protocols param =
+  let open Parametric in
+  parameterize
+    (pair (protocols_param ~title ?supports protocols) param)
+    (register ~__FILE__ ~title ~tags body)
 
 let register_long_test ~__FILE__ ~title ~tags ?supports ?team ~executors
     ~timeout body protocols =
diff --git a/tezt/lib_tezos/protocol.mli b/tezt/lib_tezos/protocol.mli
index b42795ef0f41..b4a2dde28136 100644
--- a/tezt/lib_tezos/protocol.mli
+++ b/tezt/lib_tezos/protocol.mli
@@ -218,3 +218,13 @@ val register_regression_test :
   (t -> unit Lwt.t) ->
   t list ->
   unit
+
+val register_parametric :
+  __FILE__:string ->
+  title:string ->
+  tags:string list ->
+  ?supports:supported_protocols ->
+  (t * 'a -> unit Lwt.t) ->
+  t list ->
+  'a Tezt_core.Parametric.param ->
+  unit
-- 
GitLab


From cc774b44b288cc0c73d91e12166949ce13791c8f Mon Sep 17 00:00:00 2001
From: Arvid Jakobsson <arvid.jakobsson@nomadic-labs.com>
Date: Thu, 6 Oct 2022 09:13:39 +0200
Subject: [PATCH 2/6] Tezt: parametrize [bootstrap.ml] and
 [ghostnet_dictator_migration.ml]

---
 tezt/tests/bootstrap.ml                   | 66 ++++++++++++++---------
 tezt/tests/ghostnet_dictator_migration.ml | 35 +++++++-----
 2 files changed, 61 insertions(+), 40 deletions(-)

diff --git a/tezt/tests/bootstrap.ml b/tezt/tests/bootstrap.ml
index 93c60703d743..21b61398207e 100644
--- a/tezt/tests/bootstrap.ml
+++ b/tezt/tests/bootstrap.ml
@@ -68,7 +68,7 @@ let bootstrapped_event =
 
    b) Otherwise, we check that both nodes synchronize. In full mode, we also check
    that the savepoint is higher than when Node 2 was killed. *)
-let check_bootstrap_with_history_modes hmode1 hmode2 =
+let check_bootstrap_with_history_modes (protocol, (hmode1, hmode2)) =
   (* Number of calls to [octez-client bake for] once the protocol is activated,
      before we kill [node_2]. *)
   let bakes_before_kill = 9 in
@@ -166,22 +166,8 @@ let check_bootstrap_with_history_modes hmode1 hmode2 =
     Node.wait_for node "end_merging_stores.v0" @@ fun _json ->
     if !last_cycle_being_merged then Some () else None
   in
-  let hmode1s = Node.show_history_mode hmode1 in
-  let hmode2s = Node.show_history_mode hmode2 in
-  Protocol.register_test
-    ~__FILE__
-    ~title:(Format.sprintf "node synchronization (%s / %s)" hmode1s hmode2s)
-    ~tags:
-      [
-        "bootstrap";
-        "node";
-        "sync";
-        "activate";
-        "bake";
-        "primary_" ^ hmode1s;
-        "secondary_" ^ hmode2s;
-      ]
-  @@ fun protocol ->
+  (*   let hmode1s = Node.show_history_mode hmode1 in *)
+  (*   let hmode2s = Node.show_history_mode hmode2 in *)
   (* Initialize nodes and client. *)
   let* node_1 =
     Node.init [Synchronisation_threshold 0; Connections 1; History_mode hmode1]
@@ -302,14 +288,42 @@ let register ~protocols =
      blocks. Putting the number `0` in parameters allows to
      save 16 blocks. *)
   let rolling_0 = Node.Rolling (Some 0) in
-  check_bootstrap_with_history_modes archive archive protocols ;
-  check_bootstrap_with_history_modes archive full protocols ;
-  check_bootstrap_with_history_modes archive rolling protocols ;
-  check_bootstrap_with_history_modes full archive protocols ;
-  check_bootstrap_with_history_modes full full protocols ;
-  check_bootstrap_with_history_modes full rolling protocols ;
-  check_bootstrap_with_history_modes rolling_0 Archive protocols ;
-  check_bootstrap_with_history_modes rolling_0 rolling_0 protocols ;
-  check_bootstrap_with_history_modes rolling_0 full protocols
+
+  let param_hmodes =
+    let to_string (hmode1, hmode2) =
+      sf "%s,%s" (Node.show_history_mode hmode1) (Node.show_history_mode hmode2)
+    in
+    let tags (hmode1, hmode2) =
+      [
+        "primary_" ^ Node.show_history_mode hmode1;
+        "secondary_" ^ Node.show_history_mode hmode2;
+      ]
+    in
+    Parametric.
+      {
+        name = Some "hmodes";
+        to_string;
+        tags;
+        values =
+          [
+            (archive, archive);
+            (archive, full);
+            (archive, rolling);
+            (full, archive);
+            (full, full);
+            (full, rolling);
+            (rolling_0, Archive);
+            (rolling_0, rolling_0);
+            (rolling_0, full);
+          ];
+      }
+  in
+  Parametric.parameterize param_hmodes
+  @@ Protocol.register_parametric
+       ~__FILE__
+       ~title:"node synchronization"
+       ~tags:["bootstrap"; "node"; "sync"; "activate"; "bake"]
+       check_bootstrap_with_history_modes
+       protocols
 
 let register_protocol_independent () = check_rpc_force_bootstrapped ()
diff --git a/tezt/tests/ghostnet_dictator_migration.ml b/tezt/tests/ghostnet_dictator_migration.ml
index 660521f74f01..7635bbc58460 100644
--- a/tezt/tests/ghostnet_dictator_migration.ml
+++ b/tezt/tests/ghostnet_dictator_migration.ml
@@ -98,13 +98,7 @@ let init chain_id ~from_protocol ~to_protocol =
 
 let may_apply opt f = match opt with None -> Lwt.return_unit | Some v -> f v
 
-let register_migration_test chain_id =
-  Protocol.register_test
-    ~__FILE__
-    ~title:(sf "testnet dictator (%s, migration)" (string_of_chain_id chain_id))
-    ~tags:["amendment"; string_of_chain_id chain_id; "migration"]
-    ~supports:(From_protocol 014)
-  @@ fun to_protocol ->
+let register_migration_test (to_protocol, chain_id) =
   may_apply (Protocol.previous_protocol to_protocol) @@ fun from_protocol ->
   let* node, client = init chain_id ~from_protocol ~to_protocol in
   let* () = repeat 10 (fun () -> bake node client) in
@@ -150,10 +144,23 @@ let register_migration_test chain_id =
   return ()
 
 let register ~protocols =
-  (* Testing migration with the chain_id of Ghostnet.
-     From J to K it should set the constant `testnet_dictator`.
-     On any other migrations, it should leave it unset *)
-  register_migration_test Chain_id_ghostnet protocols ;
-  (* Testing migration with the chain_id of Mainnet.
-     It should leave `testnet_dictator` unset. *)
-  register_migration_test Chain_id_mainnet protocols
+  Parametric.(
+    parameterize
+    @@ list
+         ~to_string:string_of_chain_id
+         [
+           (* Testing migration with the chain_id of Ghostnet.
+              From J to K it should set the constant `testnet_dictator`.
+              On any other migrations, it should leave it unset *)
+           Chain_id_ghostnet;
+           (* Testing migration with the chain_id of Mainnet.
+              It should leave `testnet_dictator` unset. *)
+           Chain_id_mainnet;
+         ])
+  @@ Protocol.register_parametric
+       ~__FILE__
+       ~title:(sf "testnet dictator migration")
+       ~tags:["amendment"; "migration"]
+       ~supports:(From_protocol 014)
+       register_migration_test
+       protocols
-- 
GitLab


From c7fc00019f55b96313f05bf1b71f816c1c6c1d8a Mon Sep 17 00:00:00 2001
From: Arvid Jakobsson <arvid.jakobsson@nomadic-labs.com>
Date: Fri, 7 Oct 2022 11:34:30 +0200
Subject: [PATCH 3/6] some reorganization

---
 tezt/lib_core/parametric.ml        | 43 +++++-------------------------
 tezt/self_tests/main.ml            |  1 +
 tezt/self_tests/test_parametric.ml | 29 ++++++++++++++++++++
 3 files changed, 37 insertions(+), 36 deletions(-)
 create mode 100644 tezt/self_tests/test_parametric.ml

diff --git a/tezt/lib_core/parametric.ml b/tezt/lib_core/parametric.ml
index fad804600d90..090b33091736 100644
--- a/tezt/lib_core/parametric.ml
+++ b/tezt/lib_core/parametric.ml
@@ -25,6 +25,13 @@ let tuple3 p q r = pair p (tuple2 q r)
 
 let tuple4 p q r w = pair p (tuple3 q r w)
 
+let list ?name ~to_string values =
+  {name; to_string; tags = (fun v -> [to_string v]); values}
+
+let strings ?name values = list ?name ~to_string:Fun.id values
+
+let ints ?name values = list ?name ~to_string:string_of_int values
+
 let register :
     __FILE__:string ->
     title:string ->
@@ -63,39 +70,3 @@ let register_internal :
         title
         (param.to_string value) ;
       f value)
-
-let list ?name ~to_string values =
-  {name; to_string; tags = (fun v -> [to_string v]); values}
-
-let strings ?name values = list ?name ~to_string:Fun.id values
-
-let ints ?name values = list ?name ~to_string:string_of_int values
-
-let register_examples _protocols : unit =
-  let p1 = strings ["foo"; "bar"] in
-  let p2 = ints [1; 2] in
-  let () =
-    parameterize p1
-    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
-    @@ fun string_value ->
-    Log.info "My parameter is: %s" string_value ;
-    unit
-  in
-  let () =
-    parameterize (tuple2 p1 p2)
-    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
-    @@ fun (string_value, int_value) ->
-    Log.info "My parameters are: %s and %d" string_value int_value ;
-    unit
-  in
-  let () =
-    parameterize (tuple2 p1 p2)
-    @@ register_internal
-         ~__FILE__
-         ~title:"Example parametric test internal"
-         ~tags:["my"; "tags"]
-    @@ fun (string_value, int_value) ->
-    Log.info "My parameters are: %s and %d" string_value int_value ;
-    unit
-  in
-  ()
diff --git a/tezt/self_tests/main.ml b/tezt/self_tests/main.ml
index c6aed9f06cd2..f6a4dcb0f7f1 100644
--- a/tezt/self_tests/main.ml
+++ b/tezt/self_tests/main.ml
@@ -30,4 +30,5 @@ let () =
   Test_daemon.register () ;
   Test_retry.register () ;
   Test_diff.register () ;
+  Test_parametric.register () ;
   Test.run ()
diff --git a/tezt/self_tests/test_parametric.ml b/tezt/self_tests/test_parametric.ml
new file mode 100644
index 000000000000..13b97eabeb73
--- /dev/null
+++ b/tezt/self_tests/test_parametric.ml
@@ -0,0 +1,29 @@
+let register () =
+  let open Parametric in
+  let p1 = strings ["foo"; "bar"] in
+  let p2 = ints [1; 2] in
+  let () =
+    parameterize p1
+    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
+    @@ fun string_value ->
+    Log.info "My parameter is: %s" string_value ;
+    unit
+  in
+  let () =
+    parameterize (tuple2 p1 p2)
+    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
+    @@ fun (string_value, int_value) ->
+    Log.info "My parameters are: %s and %d" string_value int_value ;
+    unit
+  in
+  let () =
+    parameterize (tuple2 p1 p2)
+    @@ register_internal
+         ~__FILE__
+         ~title:"Example parametric test internal"
+         ~tags:["my"; "tags"]
+    @@ fun (string_value, int_value) ->
+    Log.info "My parameters are: %s and %d" string_value int_value ;
+    unit
+  in
+  ()
-- 
GitLab


From 29edf738d187769f193b72cc55517ca667b06c92 Mon Sep 17 00:00:00 2001
From: Arvid Jakobsson <arvid.jakobsson@nomadic-labs.com>
Date: Fri, 7 Oct 2022 11:45:51 +0200
Subject: [PATCH 4/6] moving register_parametric inside Test

---
 tezt/lib_core/parametric.ml        | 45 +++++--------------------
 tezt/lib_core/test.ml              | 53 +++++++++++++++++++++++++++++-
 tezt/lib_core/test.mli             | 16 +++++++++
 tezt/lib_tezos/protocol.ml         | 22 ++++++++-----
 tezt/self_tests/test_parametric.ml | 34 ++++++++++++++-----
 5 files changed, 114 insertions(+), 56 deletions(-)

diff --git a/tezt/lib_core/parametric.ml b/tezt/lib_core/parametric.ml
index 090b33091736..6647f8d08753 100644
--- a/tezt/lib_core/parametric.ml
+++ b/tezt/lib_core/parametric.ml
@@ -19,6 +19,14 @@ let pair p1 p2 =
     tags = (fun (v1, v2) -> p1.tags v1 @ p2.tags v2);
   }
 
+let unit =
+  {
+    to_string = (fun () -> "()");
+    name = None;
+    values = [()];
+    tags = (fun () -> []);
+  }
+
 let tuple2 p q = pair p q
 
 let tuple3 p q r = pair p (tuple2 q r)
@@ -32,41 +40,4 @@ let strings ?name values = list ?name ~to_string:Fun.id values
 
 let ints ?name values = list ?name ~to_string:string_of_int values
 
-let register :
-    __FILE__:string ->
-    title:string ->
-    tags:string list ->
-    ('a -> unit Lwt.t) ->
-    'a param ->
-    unit =
- fun ~__FILE__ ~title ~tags f param ->
-  match param.values with
-  | [] ->
-      failwith
-        (sf
-           "test %s in %s was registered with an empty parameterization"
-           title
-           __FILE__)
-  | values ->
-      (Fun.flip List.iter) values @@ fun value ->
-      let tags = tags @ param.tags value in
-      let title = title ^ " [" ^ param.to_string value ^ "]" in
-      Test.register ~__FILE__ ~title ~tags (fun () -> f value)
-
 let parameterize (param : 'a param) f = f param
-
-let register_internal :
-    __FILE__:string ->
-    title:string ->
-    tags:string list ->
-    ('a -> unit Lwt.t) ->
-    'a param ->
-    unit =
- fun ~__FILE__ ~title ~tags f param ->
-  Test.register ~__FILE__ ~title ~tags (fun () ->
-      (Fun.flip Lwt_list.iter_s) param.values @@ fun value ->
-      Log.info
-        "Running test %s with parameters [%s]"
-        title
-        (param.to_string value) ;
-      f value)
diff --git a/tezt/lib_core/test.ml b/tezt/lib_core/test.ml
index 1dbe065c7822..684c4c9b9dbb 100644
--- a/tezt/lib_core/test.ml
+++ b/tezt/lib_core/test.ml
@@ -770,7 +770,7 @@ let output_junit filename =
 
 let next_id = ref 0
 
-let register ~__FILE__ ~title ~tags body =
+let register_aux ~__FILE__ ~title ~tags body =
   let file = Filename.basename __FILE__ in
   (match String_map.find_opt title !registered with
   | None -> ()
@@ -809,6 +809,57 @@ let register ~__FILE__ ~title ~tags body =
     in
     registered := String_map.add title test !registered
 
+let register_parametric :
+    __FILE__:string ->
+    title:string ->
+    tags:string list ->
+    ('a -> unit Lwt.t) ->
+    'a Parametric.param ->
+    unit =
+ fun ~__FILE__ ~title ~tags f param ->
+  match param.values with
+  | [] ->
+      failwith
+        (sf
+           "test %s in %s was registered with an empty parameterization"
+           title
+           __FILE__)
+  | values ->
+      (Fun.flip List.iter) values @@ fun value ->
+      let tags = tags @ param.tags value in
+      let title =
+        (* A hack to preserve original titles *)
+        match param.to_string value with
+        | "()" -> title
+        | value_s -> title ^ " [" ^ value_s ^ "]"
+      in
+      register_aux ~__FILE__ ~title ~tags (fun () -> f value)
+
+let register_parametric_internal :
+    __FILE__:string ->
+    title:string ->
+    tags:string list ->
+    ('a -> unit Lwt.t) ->
+    'a Parametric.param ->
+    unit =
+ fun ~__FILE__ ~title ~tags f param ->
+  register_aux ~__FILE__ ~title ~tags (fun () ->
+      (Fun.flip Lwt_list.iter_s) param.values @@ fun value ->
+      Log.info
+        "Running test %s with parameters [%s]"
+        title
+        (param.to_string value) ;
+      f value)
+
+let register :
+    __FILE__:string ->
+    title:string ->
+    tags:string list ->
+    (unit -> unit Lwt.t) ->
+    unit =
+ fun ~__FILE__ ~title ~tags f ->
+  register_parametric ~__FILE__ ~title ~tags f Parametric.unit
+
 module type SCHEDULER = sig
   type request = Run_test of {test_title : string}
 
diff --git a/tezt/lib_core/test.mli b/tezt/lib_core/test.mli
index 8c2cd2e9a55d..ba1e173de113 100644
--- a/tezt/lib_core/test.mli
+++ b/tezt/lib_core/test.mli
@@ -78,6 +78,22 @@ val register :
   (unit -> unit Lwt.t) ->
   unit
 
+val register_parametric_internal :
+  __FILE__:string ->
+  title:string ->
+  tags:string list ->
+  ('a -> unit Lwt.t) ->
+  'a Parametric.param ->
+  unit
+
+val register_parametric :
+  __FILE__:string ->
+  title:string ->
+  tags:string list ->
+  ('a -> unit Lwt.t) ->
+  'a Parametric.param ->
+  unit
+
 (** Get the current worker id.
 
     In single-process mode (with [-j 1]), this always returns [None].
diff --git a/tezt/lib_tezos/protocol.ml b/tezt/lib_tezos/protocol.ml
index adf3099032c1..2925deab4ee1 100644
--- a/tezt/lib_tezos/protocol.ml
+++ b/tezt/lib_tezos/protocol.ml
@@ -198,7 +198,7 @@ let protocols_param ?(supports = Any_protocol) ~title protocols =
              (show_supported_protocols supports))
     | supported_protocols -> supported_protocols
   in
-  Tezt_core.Parametric.
+  Parametric.
     {
       to_string = name;
       name = Some "protocol";
@@ -207,17 +207,21 @@ let protocols_param ?(supports = Any_protocol) ~title protocols =
     }
 
 let register_test ~__FILE__ ~title ~tags ?supports body protocols =
-  let open Parametric in
-  parameterize
+  Parametric.parameterize
     (protocols_param ~title ?supports protocols)
-    (register ~__FILE__ ~title ~tags body)
+    (Test.register_parametric ~__FILE__ ~title ~tags body)
 
 let register_parametric ~__FILE__ ~title ~tags ?supports body protocols param =
-  let open Parametric in
-  parameterize
-    (pair (protocols_param ~title ?supports protocols) param)
-    (register ~__FILE__ ~title ~tags body)
-
+  Parametric.parameterize
+    (Parametric.pair (protocols_param ~title ?supports protocols) param)
+    (Test.register_parametric ~__FILE__ ~title ~tags body)
+
+(* TODO: there should be parametric versions of these functions. They
+   could call new functions
+   e.g. [Long_test.register_parametric]. However, this new
+   proliferatino of new registration functions is unfortunate. Some
+   bright person could come up with a more composable way of creating
+   registration functions. *)
 let register_long_test ~__FILE__ ~title ~tags ?supports ?team ~executors
     ~timeout body protocols =
   iter_on_supported_protocols ~title ~protocols ?supports @@ fun protocol ->
diff --git a/tezt/self_tests/test_parametric.ml b/tezt/self_tests/test_parametric.ml
index 13b97eabeb73..a4d650733ae0 100644
--- a/tezt/self_tests/test_parametric.ml
+++ b/tezt/self_tests/test_parametric.ml
@@ -1,24 +1,30 @@
 let register () =
-  let open Parametric in
-  let p1 = strings ["foo"; "bar"] in
-  let p2 = ints [1; 2] in
+  let p1 = Parametric.strings ["foo"; "bar"] in
+  let p2 = Parametric.ints [1; 2] in
+  (* Some parametric tests *)
   let () =
-    parameterize p1
-    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
+    Parametric.parameterize p1
+    @@ Test.register_parametric
+         ~__FILE__
+         ~title:"Example parametric test"
+         ~tags:["my"; "tags"]
     @@ fun string_value ->
     Log.info "My parameter is: %s" string_value ;
     unit
   in
   let () =
-    parameterize (tuple2 p1 p2)
-    @@ register ~__FILE__ ~title:"Example parametric test" ~tags:["my"; "tags"]
+    Parametric.(parameterize (tuple2 p1 p2))
+    @@ Test.register_parametric
+         ~__FILE__
+         ~title:"Example parametric test"
+         ~tags:["my"; "tags"]
     @@ fun (string_value, int_value) ->
     Log.info "My parameters are: %s and %d" string_value int_value ;
     unit
   in
   let () =
-    parameterize (tuple2 p1 p2)
-    @@ register_internal
+    Parametric.(parameterize (tuple2 p1 p2))
+    @@ Test.register_parametric_internal
          ~__FILE__
          ~title:"Example parametric test internal"
          ~tags:["my"; "tags"]
@@ -26,4 +32,14 @@ let register () =
     Log.info "My parameters are: %s and %d" string_value int_value ;
     unit
   in
+  (* A normal tests (parametric under the hood) *)
+  let () =
+    Test.register
+      ~__FILE__
+      ~title:"Example non-parametric test"
+      ~tags:["my"; "tags"]
+    @@ fun () ->
+    Log.info "My non-parametric test" ;
+    unit
+  in
   ()
-- 
GitLab


From 591e6a1fd6a0ae042bba79fbc6ce68192c783020 Mon Sep 17 00:00:00 2001
From: Arvid Jakobsson <arvid.jakobsson@nomadic-labs.com>
Date: Fri, 7 Oct 2022 12:09:41 +0200
Subject: [PATCH 5/6] a version preserving original title of protocol tests, at
 the cost of some complications

---
 tezt/lib_core/parametric.ml        | 22 +++++++++++++++--
 tezt/lib_core/test.ml              | 14 ++++++++---
 tezt/lib_tezos/protocol.ml         |  2 ++
 tezt/self_tests/test_parametric.ml | 39 ++++++++++++++++++++++++++----
 4 files changed, 67 insertions(+), 10 deletions(-)

diff --git a/tezt/lib_core/parametric.ml b/tezt/lib_core/parametric.ml
index 6647f8d08753..9d3faf8cd813 100644
--- a/tezt/lib_core/parametric.ml
+++ b/tezt/lib_core/parametric.ml
@@ -5,6 +5,8 @@ type 'a param = {
   name : string option;
   values : 'a list;
   tags : 'a -> string list;
+  title_tag : 'a -> string option;
+  title_prefix : 'a -> string option;
 }
 
 let pair p1 p2 =
@@ -17,6 +19,18 @@ let pair p1 p2 =
         (fun v1 -> List.map (fun v2 -> (v1, v2)) p2.values)
         p1.values;
     tags = (fun (v1, v2) -> p1.tags v1 @ p2.tags v2);
+    title_tag =
+      (fun (v1, v2) ->
+        match (p1.title_tag v1, p2.title_tag v2) with
+        | Some t1, Some t2 -> Some (sf "%s,%s" t1 t2)
+        | None, Some t | Some t, None -> Some t
+        | None, None -> None);
+    title_prefix =
+      (fun (v1, v2) ->
+        match (p1.title_prefix v1, p2.title_prefix v2) with
+        | Some t1, Some t2 -> Some (sf "%s,%s" t1 t2)
+        | None, Some t | Some t, None -> Some t
+        | None, None -> None);
   }
 
 let unit =
@@ -25,6 +39,8 @@ let unit =
     name = None;
     values = [()];
     tags = (fun () -> []);
+    title_tag = Fun.const None;
+    title_prefix = Fun.const None;
   }
 
 let tuple2 p q = pair p q
@@ -33,8 +49,10 @@ let tuple3 p q r = pair p (tuple2 q r)
 
 let tuple4 p q r w = pair p (tuple3 q r w)
 
-let list ?name ~to_string values =
-  {name; to_string; tags = (fun v -> [to_string v]); values}
+let list ?name ~to_string ?(tags = fun v -> [to_string v])
+    ?(title_tag = fun v -> Some (to_string v)) ?(title_prefix = fun _ -> None)
+    values =
+  {name; to_string; title_tag; title_prefix; values; tags}
 
 let strings ?name values = list ?name ~to_string:Fun.id values
 
diff --git a/tezt/lib_core/test.ml b/tezt/lib_core/test.ml
index 684c4c9b9dbb..6f82533e27fa 100644
--- a/tezt/lib_core/test.ml
+++ b/tezt/lib_core/test.ml
@@ -829,9 +829,17 @@ let register_parametric :
       let tags = tags @ param.tags value in
       let title =
         (* A hack to preserve original titles *)
-        match param.to_string value with
-        | "()" -> title
-        | value_s -> title ^ " [" ^ value_s ^ "]"
+        let title =
+          match param.title_prefix value with
+          | Some prefix -> sf "%s: %s" prefix title
+          | None -> title
+        in
+        let title =
+          match param.title_tag value with
+          | Some title_tag -> sf "%s [%s]" title title_tag
+          | None -> title
+        in
+        title
       in
       register_aux ~__FILE__ ~title ~tags (fun () -> f value)
 
diff --git a/tezt/lib_tezos/protocol.ml b/tezt/lib_tezos/protocol.ml
index 2925deab4ee1..55061aea6c9c 100644
--- a/tezt/lib_tezos/protocol.ml
+++ b/tezt/lib_tezos/protocol.ml
@@ -204,6 +204,8 @@ let protocols_param ?(supports = Any_protocol) ~title protocols =
       name = Some "protocol";
       values = protocols;
       tags = (fun protocol -> [tag protocol]);
+      title_prefix = (fun proto -> Some (name proto));
+      title_tag = (fun _ -> None);
     }
 
 let register_test ~__FILE__ ~title ~tags ?supports body protocols =
diff --git a/tezt/self_tests/test_parametric.ml b/tezt/self_tests/test_parametric.ml
index a4d650733ae0..e6399635b3bf 100644
--- a/tezt/self_tests/test_parametric.ml
+++ b/tezt/self_tests/test_parametric.ml
@@ -1,9 +1,9 @@
 let register () =
-  let p1 = Parametric.strings ["foo"; "bar"] in
-  let p2 = Parametric.ints [1; 2] in
+  let string_param = Parametric.strings ["foo"; "bar"] in
+  let int_param = Parametric.ints [1; 2] in
   (* Some parametric tests *)
   let () =
-    Parametric.parameterize p1
+    Parametric.parameterize string_param
     @@ Test.register_parametric
          ~__FILE__
          ~title:"Example parametric test"
@@ -13,7 +13,7 @@ let register () =
     unit
   in
   let () =
-    Parametric.(parameterize (tuple2 p1 p2))
+    Parametric.(parameterize (tuple2 string_param int_param))
     @@ Test.register_parametric
          ~__FILE__
          ~title:"Example parametric test"
@@ -23,7 +23,7 @@ let register () =
     unit
   in
   let () =
-    Parametric.(parameterize (tuple2 p1 p2))
+    Parametric.(parameterize (tuple2 string_param int_param))
     @@ Test.register_parametric_internal
          ~__FILE__
          ~title:"Example parametric test internal"
@@ -42,4 +42,33 @@ let register () =
     Log.info "My non-parametric test" ;
     unit
   in
+  (* Protocol tests *)
+  let () =
+    Protocol.register_test
+      ~__FILE__
+      ~title:"Example non-parametric test"
+      ~tags:["my"; "tags"]
+      (fun proto ->
+        Log.info
+          "My non-parametric test using protocol %s"
+          (Protocol.name proto) ;
+        unit)
+      Protocol.all
+  in
+  (* Protocol test with parameters *)
+  let () =
+    Parametric.(parameterize (tuple2 string_param int_param))
+    @@ Protocol.register_parametric
+         ~__FILE__
+         ~title:"Example non-parametric test"
+         ~tags:["my"; "tags"]
+         (fun (proto, (string_value, int_value)) ->
+           Log.info
+             "My non-parametric test using protocol %s, param %s and %d"
+             (Protocol.name proto)
+             string_value
+             int_value ;
+           unit)
+         Protocol.all
+  in
   ()
-- 
GitLab


From 55eeda64e675c953efe82b88faee268e10297b7b Mon Sep 17 00:00:00 2001
From: Arvid Jakobsson <arvid.jakobsson@nomadic-labs.com>
Date: Fri, 7 Oct 2022 13:07:59 +0200
Subject: [PATCH 6/6] lazy and arbitrary parameters

---
 tezt/lib_core/dune                 |  3 +-
 tezt/lib_core/parametric.ml        | 85 ++++++++++++++++++++++++++++++
 tezt/self_tests/test_parametric.ml | 64 ++++++++++++++++++++++
 3 files changed, 151 insertions(+), 1 deletion(-)

diff --git a/tezt/lib_core/dune b/tezt/lib_core/dune
index 024680ba6907..87c7e232c4df 100644
--- a/tezt/lib_core/dune
+++ b/tezt/lib_core/dune
@@ -8,5 +8,6 @@
   re
   lwt
   unix
-  ezjsonm)
+  ezjsonm
+  qcheck-core)
  (js_of_ocaml))
diff --git a/tezt/lib_core/parametric.ml b/tezt/lib_core/parametric.ml
index 9d3faf8cd813..676f81a93997 100644
--- a/tezt/lib_core/parametric.ml
+++ b/tezt/lib_core/parametric.ml
@@ -59,3 +59,88 @@ let strings ?name values = list ?name ~to_string:Fun.id values
 let ints ?name values = list ?name ~to_string:string_of_int values
 
 let parameterize (param : 'a param) f = f param
+
+module Lazy = struct
+  let list ?name values =
+    let to_string (value_tag, _thunk) = value_tag in
+    {
+      name;
+      to_string;
+      values;
+      tags = (fun v -> [to_string v]);
+      title_tag = (fun v -> Some (to_string v));
+      title_prefix = Fun.const None;
+    }
+end
+
+(* This does not compose well with regression tests, as there is no
+   mapping between the test's title and the values that are generated.
+
+   If we put values instead of indexes in the titles, we get this
+   mapping, but we have to make sure that titles are unique (no
+   repeated generated values). Furthermore, it might be tricky to
+   ensure that the state of the random generator is "stable". This
+   means that the set of tests (the set of title tests), will
+   fluctuate, which I do not think is a good idea.
+*)
+
+module Arbitrary = struct
+  let n = 3
+
+  let arb ?name ~to_string gen =
+    let st = Random.State.make [||] in
+    let values = List.init n (fun idx -> (idx, gen st)) in
+    let to_string (_idx, value) = to_string value in
+    {
+      name;
+      to_string;
+      values;
+      (* I don't think tags make sense here *)
+      tags = (fun _ -> ["arbitrary"]);
+      title_tag = (fun (idx, _v) -> Some (sf "#%d" idx));
+      title_prefix = Fun.const None;
+    }
+
+  let int = arb ~to_string:string_of_int (fun st -> Random.State.int st 10)
+
+  let float =
+    arb ~to_string:string_of_float (fun st -> Random.State.float st 10.0)
+
+  (* With this setup, a pair becomes the cross-product of the values
+     of the underlying params. This might be unexpected, it is not how
+     e.g. QCheck does it.  There, the componetns of the pair is
+     individually generated. To resolve this, I think
+     we'd have to stratify [arb] into [gen] and [arb] like QCheck does.
+
+     However, at that point, why not use the QCheck generators?
+  *)
+  let pair (p1 : (int * 'a) param) (p2 : (int * 'b) param) =
+    let values =
+      List.concat_map
+        (fun (_idx1, v1) -> List.map (fun (_idx2, v2) -> (v1, v2)) p2.values)
+        p1.values
+    in
+    let values = List.mapi (fun i v -> (i, v)) values in
+    {
+      name = None;
+      to_string =
+        (fun (_idx, (v1, v2)) ->
+          (* the zeroes here are unfortunate but required to get the underlying to_string *)
+          sf "%s,%s" (p1.to_string (0, v1)) (p2.to_string (0, v2)));
+      values;
+      (* I don't think tags make sense here *)
+      tags = (fun _ -> ["arbitrary"]);
+      title_tag = (fun (idx, _v) -> Some (sf "#%d" idx));
+      title_prefix = Fun.const None;
+    }
+
+  let of_qcheck ?name (qcheck_arb : 'a QCheck.arbitrary) =
+    let gen = QCheck.get_gen qcheck_arb in
+    let to_string =
+      match QCheck.get_print qcheck_arb with
+      (* A wart *)
+      | None -> fun _ -> ""
+      | Some to_string -> to_string
+    in
+    arb ?name ~to_string gen
+end
diff --git a/tezt/self_tests/test_parametric.ml b/tezt/self_tests/test_parametric.ml
index e6399635b3bf..19a424d6b13a 100644
--- a/tezt/self_tests/test_parametric.ml
+++ b/tezt/self_tests/test_parametric.ml
@@ -71,4 +71,68 @@ let register () =
            unit)
          Protocol.all
   in
+  (* Test with lazy parameters *)
+  let () =
+    (* Temporary files cannot be created outside of tests. If you want
+       to paramtrize your test by such a value, it can be created in a
+       lazy parameter *)
+    Parametric.(
+      parameterize
+        (Lazy.list
+           ~name:"temp-file"
+           [
+             ("temp_file1", fun () -> Temp.file "foo");
+             ("temp_file2", fun () -> Temp.file "bar");
+           ]))
+    @@ Test.register_parametric
+         ~__FILE__
+         ~title:"Example non-parametric test"
+         ~tags:["my"; "tags"]
+         (* The test does not really need [_temp_value_name], it's another wart *)
+         (fun (_temp_value_name, temp_file) ->
+           (* It is unfortunate by the thunk has to force inside the test function.
+              It could be circumvented by creating [Test.register_lazy_parametric]
+              but would create another set of register functions :( *)
+           let temp_file = temp_file () in
+           Log.info "My parametric test using the lazy temp-file %S" temp_file ;
+           unit)
+  in
+  (* Test with arbitrary parameters *)
+  let () =
+    Parametric.(parameterize Arbitrary.int)
+    @@ Test.register_parametric
+         ~__FILE__
+         ~title:"Example test with arbitrary values"
+         ~tags:["my"; "tags"]
+         (* Again the [_idx] tag here is a wart that could be solved in the same manner as above ... *)
+         (fun (_idx, arb_int_value) ->
+           Log.info "My arbitrary test, value %d" arb_int_value ;
+           unit)
+  in
+  let () =
+    Parametric.(parameterize (Arbitrary.of_qcheck QCheck.int))
+    @@ Test.register_parametric
+         ~__FILE__
+         ~title:"Example test with arbitrary values from a QCheck generator"
+         ~tags:["my"; "tags"]
+         (* Again the [_idx] tag here is a wart that could be solved in the same manner as above ... *)
+         (fun (_idx, arb_int_value) ->
+           Log.info "My arbitrary test, value %d" arb_int_value ;
+           unit)
+  in
+  let () =
+    Parametric.(parameterize Arbitrary.(pair int float))
+    @@ Test.register_parametric
+         ~__FILE__
+         ~title:"Example test with pairs of arbitrary values"
+         ~tags:["my"; "tags"]
+         (* Again the [_idx] tag here is a wart that could be solved in the same manner as above ... *)
+         (fun (_idx, (arb_int_value, arb_float_value)) ->
+           Log.info
+             "My arbitrary test, value %d and %f"
+             arb_int_value
+             arb_float_value ;
+           unit)
+  in
+
   ()
-- 
GitLab