fix: Be more precise on the definition and lookup of samplers

src/grader/grading.ml

@@ -164,8 +164,6 @@ let get_grade
           js = OCamlRes.(Res.find (Path.of_string "testing_dyn.js")
                            Embedded_grading_lib.root) };
       handle_error (internal_error [%i"while preparing the tests"]) @@
-      Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Test_lib|};
-      handle_error (internal_error [%i"while preparing the tests"]) @@
       Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Test_lib.Open_me|};
       (* Registering the samplers that may be defined in [test.ml] requires
          having their types and the definitions of the types they sample, hence

src/grader/introspection.ml

@@ -263,18 +263,31 @@ let register_sampler name f =
     in
     try sampler_path, Env.find_value sampler_path lookup_env
     with Not_found ->
-      Env.find_value_by_name (Longident.Lident sampler_name)
-        lookup_env
+      let sampler_path =
+        Path.Pdot (Path.Pdot (Path.Pident (Ident.create_persistent "Test_lib"),
+                              "Sampler_reg"),
+                   sampler_name)
+      in
+      sampler_path, Env.find_value sampler_path lookup_env
+      (* Env.find_value_by_name (Longident.Lident sampler_name)
+       *   lookup_env *)
   with
   | exception Not_found ->
       Format.ksprintf failwith "Bad sampler registration (function %s not found).@."
         sampler_name
-  | _sampler_path, sampler_desc ->
+  | sampler_path, sampler_desc ->
   match
-    Env.find_type_by_name (Longident.Lident name) lookup_env
+    let ty_path = match sampler_path with
+      | Path.Pdot (pp, _) -> Path.Pdot (pp, name)
+      | _ -> raise Not_found
+    in
+    try ty_path, Env.find_type ty_path lookup_env
+    with Not_found ->
+      Env.find_type_by_name (Longident.Lident name) lookup_env
   with
   | exception Not_found ->
-      Format.eprintf "Warning: unrecognised sampler definition (type %s not found).@."
+      Format.eprintf
+        "Warning: unrecognised sampler definition (type %s not found).@."
         name
   | sampled_ty_path, sampled_ty_decl ->
       let sampler_ty_expected =

src/grader/introspection_intf.mli

@@ -34,6 +34,9 @@ module type INTROSPECTION = sig
   val grab_stderr: unit -> unit
   val release_stderr: unit -> string
 
+  (* The sampler type is actually [['x sampler ->]* t sampler] with ['x] all the
+     type variables of [t]. It is dynamically checked at runtime, based on the
+     cmi of the module that must be already loaded and opened. *)
   val register_sampler: string -> ('a -> 'b) -> unit
   val get_sampler: 'a Ty.ty -> (unit -> 'a)
 

src/grader/test_lib.ml

@@ -1353,6 +1353,21 @@ module Intro = Pre_test.Introspection
       let ty = Typetexp.transl_type_scheme !Toploop.toplevel_env (Ty.obj [%ty: _ -> _ ]) in
       Intro.install_printer path ty.Typedtree.ctyp_type fun_printer
   end
+  module Sampler_reg = struct
+    include Sampler
+    let () = Intro.register_sampler "bool" sample_bool
+    let () = Intro.register_sampler "int" sample_int
+    let () = Intro.register_sampler "float" sample_float
+    let () = Intro.register_sampler "char" sample_char
+    let () = Intro.register_sampler "string" sample_string
+    let () = Intro.register_sampler "option" sample_option
+    let sample_array sample () = sample_array sample ()
+    let () = Intro.register_sampler "array" sample_array
+    let sample_list sample () = sample_list sample ()
+    let () = Intro.register_sampler "list" sample_list
+    type ('a, 'b) pair = 'a * 'b
+    let () = Intro.register_sampler "pair" sample_pair
+  end
 
   let (@@@) f g = fun x -> f x @ g x
   let (@@>) r1 f = if snd (Learnocaml_report.result r1) then r1 else f ()

src/grader/test_lib.mli

@@ -497,6 +497,21 @@
     val printable_fun : string -> (_ -> _ as 'f) -> 'f
   end
 
+  (** For internal use, needed for the default samplers registration *)
+  module Sampler_reg : sig
+    type 'a sampler = 'a Sampler.sampler
+    val sample_int : int sampler
+    val sample_float : float sampler
+    val sample_string : string sampler
+    val sample_char : char sampler
+    val sample_bool : bool sampler
+    val sample_list : 'a sampler -> 'a list sampler
+    val sample_array : 'a sampler -> 'a array sampler
+    val sample_option : 'a sampler -> 'a option sampler
+    type ('a, 'b) pair = 'a * 'b
+    val sample_pair : 'a sampler -> 'b sampler -> ('a, 'b) pair sampler
+  end
+
   (** {1 Grading functions for references and variables } *)
 
   (** Grading function for variables and references. *)