refactor: Rename and generalise recorder to ppx_autoregister

Functorising to add parameters so that it can be used to inject printer
registerers as well, for example.

Author: AltGr

src/ppx-metaquot/dune

@@ -20,17 +20,17 @@
  (libraries ppx_tools compiler-libs)
 )
 
-(library
- (name learnocaml_recorder)
- (wrapped false)
- (modules Recorder)
- (libraries ppxlib))
+;; (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 learnocaml_recorder)
- (modules Ppx_metaquot_register)
+ (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree ppxlib)
+ (modules Ppx_autoregister Ppx_metaquot_grader)
  (kind ppx_rewriter)
 )
 
@@ -43,7 +43,7 @@
  (section libexec)
  (package learn-ocaml)
  (files
-  (ppx_metaquot_main.exe as grading_ppx/learnocaml-ppx-metaquot))
+  (ppx_metaquot_main.exe as grading_ppx/learnocaml-ppx-grader))
 )
 
 (library

src/ppx-metaquot/ppx_autoregister.ml

@@ -0,0 +1,60 @@
+open Ppxlib
+
+module type ARG = sig
+  val val_prefix: string
+  val inject_def: string -> string loc -> expression
+end
+
+module Make (Arg: ARG) = struct
+
+let pattern_defs =
+  object
+    inherit [(string * string loc) 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 | Ppat_alias (_, var) -> (
+          match String.index_opt var.txt '_' with
+          | Some i when String.sub var.txt 0 i = Arg.val_prefix ->
+              let suffix =
+                String.sub var.txt (i + 1) (String.length var.txt - i - 1)
+              in
+              (suffix, var) :: acc
+          | _ -> acc)
+      | _ -> acc
+  end
+
+let rec get_defs bindings acc =
+  match bindings with
+  | [] -> List.rev @@ List.flatten acc
+  | binding :: rest ->
+      get_defs rest @@ (pattern_defs#pattern binding.pvb_pat [] :: acc)
+
+module Ast_builder = Ast_builder.Make (struct
+  let loc = Location.none
+end)
+
+let val_recorder s =
+  let open Ast_builder in
+  let create_val_registration defs =
+    let gen_expr (name, e) = Arg.inject_def name e in
+    let val_registration = List.map gen_expr defs |> esequence in
+    let register_toplevel =
+      [ value_binding ~pat:punit ~expr:val_registration ]
+    in
+    pstr_value Nonrecursive register_toplevel
+  in
+  List.fold_right
+    (fun si acc ->
+      match si.pstr_desc with
+      | Pstr_value (_, bindings) -> (
+          match get_defs bindings [] with
+          | [] -> si :: acc
+          | defs -> si :: create_val_registration defs :: acc)
+      | _ -> si :: acc)
+    s []
+
+let expand = val_recorder
+
+end

src/ppx-metaquot/ppx_autoregister.mli

@@ -0,0 +1,8 @@
+module type ARG = sig
+  val val_prefix: string
+  val inject_def: string -> string Ppxlib.loc -> Ppxlib.expression
+end
+
+module Make (_: ARG): sig
+  val expand: Ppxlib.structure -> Ppxlib.structure
+end

src/ppx-metaquot/ppx_metaquot_grader.ml

@@ -0,0 +1,16 @@
+module Sampler_recorder = Ppx_autoregister.Make(struct
+    let val_prefix = "sample"
+    let inject_def name var =
+      let open Ppxlib in
+      let open Ast_builder.Default in
+      let loc = var.Location.loc in
+      pexp_apply ~loc
+        (evar ~loc "Introspection.register_sampler")
+        [ Nolabel, estring ~loc name
+        ; Nolabel, evar ~loc var.txt]
+  end)
+
+let () =
+  Migrate_parsetree.Driver.register ~name:"ppx_metaquot" (module Migrate_parsetree.OCaml_412)
+    (fun _config _cookies -> Ppx_metaquot.Main.expander []);
+  Ppxlib.Driver.register_transformation "sample_recorder" ~impl:Sampler_recorder.expand