feat(ppx-metaquot): Add transformation introducing the register_sampler calls

* A new transformation has been added that inserts
  `let () = Introspection.register_sampler name fun`
  for each toplevel binding prefixed with `sample_*` in test.ml.

* Compilation units stored in `demo-repository/exercises/exercise_name/`
  during the precompilation are no longer staged.

Author: hernoufM

.gitignore

@@ -35,3 +35,8 @@ tests/corpuses/*
 detect-libs.*
 
 docs/odoc.html
+
+demo-repository/exercises/**/*.cmo
+demo-repository/exercises/**/*.cmi
+demo-repository/exercises/**/*.cma
+demo-repository/exercises/**/*.js

src/grader/grading_cli.mli

@@ -7,7 +7,7 @@
  * included LICENSE file for details. *)
 
 (** Take an exercise, a solution, and return the report, stdout,
-    stderr and outcomes of the toplevel, or raise ont of the
+    stderr and outcomes of the toplevel, or raise one of the
     exceptions defined in module {!Grading}. *)
 val get_grade:
   ?callback:(string -> unit) ->

src/ppx-metaquot/dune

@@ -20,10 +20,16 @@
  (libraries ppx_tools compiler-libs)
 )
 
+(library
+ (name learnocaml_recorder)
+ (wrapped false)
+ (modules Recorder)
+ (libraries ppxlib))
+
 (library
  (name learnocaml_ppx_metaquot)
  (wrapped false)
- (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree)
+ (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree learnocaml_recorder)
  (modules Ppx_metaquot_register)
  (kind ppx_rewriter)
 )

src/ppx-metaquot/ppx_metaquot_register.ml

@@ -1,3 +1,4 @@
 let () =
   Migrate_parsetree.Driver.register ~name:"ppx_metaquot" (module Migrate_parsetree.OCaml_412)
-    (fun _config _cookies -> Ppx_metaquot.Main.expander [])
+    (fun _config _cookies -> Ppx_metaquot.Main.expander []);
+  Ppxlib.Driver.register_transformation "sample_recorder" ~impl:Recorder.expand

src/ppx-metaquot/recorder.ml

@@ -0,0 +1,56 @@
+open Ppxlib
+
+let pattern_samplers =
+  object
+    inherit [string list] Ast_traverse.fold as super
+
+    method! pattern p acc =
+      let acc = super#pattern p acc in
+      match p.ppat_desc with
+      | Ppat_var var -> (
+          match String.index_opt var.txt '_' with
+          | Some i when String.sub var.txt 0 i = "sample" ->
+              let suffix =
+                String.sub var.txt (i + 1) (String.length var.txt - i - 1)
+              in
+              suffix :: acc
+          | _ -> acc)
+      | _ -> acc
+  end
+
+let rec get_samplers bindings acc =
+  match bindings with
+  | [] -> List.rev @@ List.flatten acc
+  | binding :: rest ->
+      get_samplers rest @@ (pattern_samplers#pattern binding.pvb_pat [] :: acc)
+
+module Ast_builder = Ast_builder.Make (struct
+  let loc = Location.none
+end)
+
+let sampler_recorder s =
+  let open Ast_builder in
+  let create_samplers_registration samplers =
+    let sampler_expr sampler =
+      pexp_apply
+        (evar @@ "Introspection.register_sampler") 
+        [ Nolabel,estring sampler
+        ; Nolabel,evar @@ "sample_" ^ sampler]
+    in
+    let samplers_registration = List.map sampler_expr samplers |> esequence in
+    let register_toplevel =
+      [ value_binding ~pat:punit ~expr:samplers_registration ]
+    in
+    pstr_value Nonrecursive register_toplevel
+  in
+  List.fold_right
+    (fun si acc ->
+      match si.pstr_desc with
+      | Pstr_value (_, bindings) -> (
+          match get_samplers bindings [] with
+          | [] -> si :: acc
+          | samplers -> si :: create_samplers_registration samplers :: acc)
+      | _ -> si :: acc)
+    s []
+
+let expand = sampler_recorder

src/repo/learnocaml_precompile_exercise.ml

@@ -61,7 +61,7 @@ let precompile ~exercise_dir =
      jsoo ~dir [] ~source:"exercise.cma" ~target:"exercise.js");
     (ocamlc ~dir ["-c";
                   "-I"; "+compiler-libs";
-                  "-ppx"; Filename.concat !grading_ppx_dir "learnocaml-ppx-metaquot" ]
+                  "-ppx"; Filename.concat !grading_ppx_dir "learnocaml-ppx-metaquot"]
        ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"; "Test_lib.Open_me"]
        ~source:["test.ml"]
        ~target:"test.cmo"

src/toploop/toploop_unix.mli

@@ -33,7 +33,7 @@ val flush_redirected_channel : redirection -> unit
 (** Flushes the channel and then cancel the redirection.
     The redirection must be the last one performed, otherwise an
     [Invalid_argument] will be raised.
-    A stack of redirections is maintained for all fire descriptors. So
+    A stack of redirections is maintained for all file descriptors. So
     the channel is then restored to either the previous redirection or
     to the original file descriptor. *)
 val stop_channel_redirection : redirection -> unit