diff --git a/src/ppx-metaquot/dune b/src/ppx-metaquot/dune index 90421c4d0..6253671a5 100644 --- a/src/ppx-metaquot/dune +++ b/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 diff --git a/src/ppx-metaquot/ppx_autoregister.ml b/src/ppx-metaquot/ppx_autoregister.ml new file mode 100644 index 000000000..21b67b33f --- /dev/null +++ b/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 diff --git a/src/ppx-metaquot/ppx_autoregister.mli b/src/ppx-metaquot/ppx_autoregister.mli new file mode 100644 index 000000000..69dd05be6 --- /dev/null +++ b/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 diff --git a/src/ppx-metaquot/ppx_metaquot_grader.ml b/src/ppx-metaquot/ppx_metaquot_grader.ml new file mode 100644 index 000000000..3c7dbfc0b --- /dev/null +++ b/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 diff --git a/src/ppx-metaquot/ppx_metaquot_register.ml b/src/ppx-metaquot/ppx_metaquot_register.ml deleted file mode 100644 index 3ec201163..000000000 --- a/src/ppx-metaquot/ppx_metaquot_register.ml +++ /dev/null @@ -1,4 +0,0 @@ -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:Recorder.expand diff --git a/src/ppx-metaquot/recorder.ml b/src/ppx-metaquot/recorder.ml deleted file mode 100644 index 0264b13e3..000000000 --- a/src/ppx-metaquot/recorder.ml +++ /dev/null @@ -1,56 +0,0 @@ -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