fix: Allow printer registration in prepare/prelude & Fix print callba…

…cks' usage

src/grader/grading.ml

@@ -96,12 +96,20 @@ let get_grade
            in the solutions: provide dummy implementations here *)
         Toploop_ext.load_cmi_from_string
           OCamlRes.(Res.find (Path.of_string "learnocaml_callback.cmi") Embedded_grading_lib.root) ;
-        let module Learnocaml_callback: Introspection_intf.LEARNOCAML_CALLBACK = struct
-          let print_html _ = ()
-          let print_svg _ = ()
+        let module Learnocaml_callback: Learnocaml_internal_intf.CALLBACKS = struct
+          let print_html s = output_string stdout s
+          let print_svg s = output_string stdout s
         end in
         Toploop_ext.inject_global "Learnocaml_callback"
-          (Obj.repr (module Learnocaml_callback: Introspection_intf.LEARNOCAML_CALLBACK));
+          (Obj.repr (module Learnocaml_callback: Learnocaml_internal_intf.CALLBACKS));
+      in
+      let () =
+        let module Learnocaml_internal: Learnocaml_internal_intf.INTERNAL = struct
+          let install_printer = Toploop_ext.install_printer
+          exception Undefined
+        end in
+        Toploop_ext.inject_global "Learnocaml_internal"
+          (Obj.repr (module Learnocaml_internal: Learnocaml_internal_intf.INTERNAL))
       in
 
       set_progress [%i"Preparing the test environment."] ;
@@ -123,6 +131,7 @@ let get_grade
       handle_error (internal_error [%i"while preparing the tests"]) @@
       Toploop_ext.use_string ~print_outcome:false ~ppf_answer
         {|include Prepare|};
+      handle_error (internal_error [%i"while preparing the tests"]) @@
       Toploop_ext.use_string ~print_outcome:false ~ppf_answer
         {|module Prepare = struct end|};
 

src/grader/introspection.ml

@@ -167,126 +167,9 @@ let get_value lid ty =
       else
         failwith (Format.asprintf "Wrong type %a." Printtyp.type_sch val_type)
 
-(* Replacement for [Toploop.print_value] that doesn't segfault on yet
-   unregistered extension constructors.
-
-   Note: re-instanciating [Genprintval.Make] means we lose any previously
-   defined printers through [Topdirs.dir_install_printer]. *)
-module Printer = Genprintval.Make(Obj)(struct
-    type valu = Obj.t
-    exception Error
-    let eval_address = function
-      | Env.Aident id ->
-          if Ident.persistent id || Ident.global id then
-            Symtable.get_global_value id
-          else begin
-            let name = Translmod.toplevel_name id in
-            try Toploop.getvalue name
-            with _ -> raise Error
-          end
-      | Env.Adot(_, _) ->
-          (* in this case we bail out because this may refer to a
-             yet-unregistered extension constructor within the current module.
-             The printer has a reasonable fallback. *)
-          raise Error
-    let same_value v1 v2 = (v1 == v2)
-  end)
-
 let base_print_value env obj ppf ty =
   !Oprint.out_value ppf @@
-  Printer.outval_of_value 300 100 (fun _ _ _ -> None) env obj ty
-
-(** Relies on the env (already loaded cmi) to get the correct type parameters
-    for the [Printer] functions *)
-let install_printer modname id tyname pr =
-  let open Types in
-  let modident = Ident.create_persistent modname in
-  let printer_path = Path.Pdot (Path.Pident modident, id) in
-  let env = !Toploop.toplevel_env in
-  let ( @-> ) a b = Ctype.newty (Tarrow (Asttypes.Nolabel, a, b, Cunknown)) in
-  let gen_printer_type ty =
-    let format_ty =
-      let ( +. ) a b = Path.Pdot (a, b) in
-      Path.Pident (Ident.create_persistent "Stdlib") +. "Format" +. "formatter"
-    in
-    (Ctype.newty (Tconstr (format_ty, [], ref Mnil))
-     @-> ty
-     @-> Predef.type_unit)
-  in
-  let ty_path1 = Path.Pdot (Path.Pident modident, tyname) in
-  match
-    Env.find_value printer_path env,
-    try ty_path1, Env.find_type ty_path1 env
-    with Not_found -> Env.find_type_by_name (Longident.Lident tyname) env
-  with
-  | exception Not_found ->
-      Format.kasprintf failwith "Warning: bad printer definition %s.print_%s. The type \
-                      and printer must be found in the cmi file.@."
-        modname tyname
-  | printer_desc, (ty_path, ty_decl) ->
-      Ctype.begin_def();
-      let ty_args = List.map (fun _ -> Ctype.newvar ()) ty_decl.type_params in
-      let ty_target =
-        Ctype.expand_head env
-          (Ctype.newty (Tconstr (ty_path, ty_args, ref Mnil)))
-      in
-      let printer_ty_expected =
-        List.fold_right (fun argty ty -> gen_printer_type argty @-> ty)
-          ty_args
-          (gen_printer_type ty_target)
-      in
-      (try
-         Ctype.unify env
-           printer_ty_expected
-           (Ctype.instance printer_desc.val_type)
-       with Ctype.Unify _ ->
-         Format.kasprintf failwith
-           "Mismatching type for print function %s.print_%s.@;\
-            The type must be@ @[<hov>%aformatter -> %a%s -> unit@]@."
-           modname tyname
-           (Format.pp_print_list
-              (fun ppf -> Format.fprintf ppf "(formatter -> %a -> unit) ->@ "
-                  (Printtyp.type_expr)))
-           ty_args
-           (fun ppf -> function
-              | [] -> ()
-              | [arg] -> Format.fprintf ppf "%a " Printtyp.type_expr arg
-              | args ->
-                  Format.fprintf ppf "(%a) "
-                    (Format.pp_print_list
-                       ~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ")
-                       Printtyp.type_expr)
-                    args)
-           ty_args
-           tyname);
-      Ctype.end_def ();
-      Ctype.generalize printer_ty_expected;
-      let register_as_path = Path.(Pdot (Pident modident, "print_"^tyname)) in
-      let rec build_generic v = function
-        | [] ->
-            Genprintval.Zero
-              (fun formatter repr -> Obj.obj v formatter (Obj.obj repr))
-        | _ :: args ->
-            Genprintval.Succ
-              (fun fn -> build_generic ((Obj.obj v : _ -> Obj.t) fn) args)
-      in
-      match ty_decl.type_params, ty_target.desc with
-      | [], _ ->
-          Printer.install_printer register_as_path ty_target
-            (fun ppf repr -> Obj.magic pr ppf (Obj.obj repr))
-      | _, (Tconstr (ty_path, args, _) | Tlink {desc = Tconstr (ty_path, args, _); _})
-        when Ctype.all_distinct_vars env args ->
-          Printer.install_generic_printer' register_as_path ty_path
-            (build_generic (Obj.repr pr) ty_decl.type_params)
-      | _, ty ->
-          Format.kasprintf failwith
-            "Invalid printer for %a = %a: OCaml doesn't support printers for \
-             types with partially instanciated variables. Define a generic \
-             printer and a printer for the type of your variable instead."
-            Printtyp.path ty_path
-            Printtyp.type_expr (Ctype.newty ty)
-
-
+  Toploop_ext.Printer.outval_of_value 300 100 (fun _ _ _ -> None) env obj ty
 let print_value ppf v ty =
   let { Typedtree.ctyp_type = ty; _ } =
     Typetexp.transl_type_scheme !Toploop.toplevel_env (Ty.obj ty) in
@@ -546,8 +429,7 @@ let allow_introspection ~divert =
       stderr_cb := bad_stderr_cb ;
       res
 
-    let install_printer_internal pr = install_printer pr
-    let install_printer path ty pr = Printer.install_printer path ty pr
+    let install_printer path ty pr = Toploop_ext.Printer.install_printer path ty pr
     let get_printer ty = fun ppf v -> print_value ppf v ty
 
     let register_sampler name f = register_sampler name f

src/grader/introspection_intf.mli

@@ -50,15 +50,6 @@ module type INTROSPECTION = sig
      cmi of the module that must be already loaded and opened. *)
   val register_sampler:
     string -> string -> string -> ('a -> 'b) -> unit
-  val install_printer_internal:
-    string -> string -> string -> ('a -> 'b) -> unit
-end
-
-(** Interface of the module that gets automatically injected in the environment
-    before the Prelude is loaded. *)
-module type LEARNOCAML_CALLBACK = sig
-  val print_html: string -> unit
-  val print_svg: string -> unit
 end
 
 (** Interface of the module that gets automatically injected in the environment

src/grader/learnocaml_callback.mli

@@ -1 +1 @@
-include Introspection_intf.LEARNOCAML_CALLBACK
+include Learnocaml_internal_intf.CALLBACKS

src/grader/learnocaml_internal.mli

@@ -1,4 +1,4 @@
 (* This interface is used to pre-compile modules for the toplevel, giving them
    access to specific toplevel functions. It should not be made accessible to
    the non-precompiled code running in the toplevel *)
-include Learnocaml_internal_intf.S
+include Learnocaml_internal_intf.INTERNAL

src/ppx-metaquot/dune

@@ -20,14 +20,33 @@
  (libraries ppx_tools compiler-libs)
 )
 
+(library
+ (name ppx_autoregister)
+ (wrapped false)
+ (libraries ppxlib)
+ (modules Ppx_autoregister Printer_recorder))
+
+(library
+ (name exercise_ppx)
+ (wrapped false)
+ (libraries ppx_autoregister)
+ (modules Exercise_ppx)
+ (kind ppx_rewriter)
+)
+
 (library
  (name grader_ppx)
  (wrapped false)
- (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree ppxlib)
- (modules Ppx_autoregister Grader_ppx)
+ (libraries learnocaml_ppx_metaquot_lib ty fun_ty ppx_autoregister)
+ (modules Sampler_recorder Grader_ppx)
  (kind ppx_rewriter)
 )
 
+(executable
+ (name exercise_ppx_main)
+ (modules exercise_ppx_main)
+ (libraries exercise_ppx))
+
 (executable
  (name grader_ppx_main)
  (modules grader_ppx_main)
@@ -36,7 +55,8 @@
 (install
  (section libexec)
  (package learn-ocaml)
- (files (grader_ppx_main.exe as test_lib/grader-ppx))
+ (files (exercise_ppx_main.exe as test_lib/exercise-ppx)
+        (grader_ppx_main.exe as test_lib/grader-ppx))
 )
 
 (library

src/ppx-metaquot/exercise_ppx.ml

@@ -0,0 +1,2 @@
+let () =
+  Ppxlib.Driver.register_transformation "print_recorder" ~impl:Printer_recorder.expand

src/ppx-metaquot/exercise_ppx_main.ml

@@ -0,0 +1,2 @@
+let () =
+  Migrate_parsetree.Driver.run_main ~exit_on_error:true ()

src/ppx-metaquot/grader_ppx.ml

@@ -1,40 +1,3 @@
-
-let modname var =
-  (* This is fragile. Do we have a better way to recover the current
-     compilation unit name in a ppx ? *)
-  String.capitalize_ascii @@
-  Filename.basename @@
-  Filename.remove_extension @@
-  var.Location.loc.Location.loc_start.Lexing.pos_fname
-
-module Printer_recorder = Ppx_autoregister.Make(struct
-    let val_prefix = "print"
-    let inject_def id name var =
-      let open Ppxlib in
-      let open Ast_builder.Default in
-      let loc = var.Location.loc in
-      pexp_apply ~loc
-        (evar ~loc "Introspection.install_printer_internal")
-        [ Nolabel, estring ~loc (modname var);
-          Nolabel, estring ~loc id;
-          Nolabel, estring ~loc name;
-          Nolabel, evar ~loc var.txt ]
-  end)
-
-module Sampler_recorder = Ppx_autoregister.Make(struct
-    let val_prefix = "sample"
-    let inject_def id 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 (modname var);
-          Nolabel, estring ~loc id;
-          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 []);

src/ppx-metaquot/ppx_autoregister.ml

@@ -74,3 +74,11 @@ let val_recorder s =
 let expand = val_recorder
 
 end
+
+let modname var =
+  (* This is fragile. Do we have a better way to recover the current
+     compilation unit name in a ppx ? *)
+  String.capitalize_ascii @@
+  Filename.basename @@
+  Filename.remove_extension @@
+  var.Location.loc.Location.loc_start.Lexing.pos_fname

src/ppx-metaquot/ppx_autoregister.mli

@@ -6,3 +6,7 @@ end
 module Make (_: ARG): sig
   val expand: Ppxlib.structure -> Ppxlib.structure
 end
+
+(** Helper function extracting the module name from the location of a variable
+   (only at top-level) *)
+val modname: 'a Location.loc -> string

src/ppx-metaquot/printer_recorder.ml

@@ -0,0 +1,13 @@
+include Ppx_autoregister.Make(struct
+    let val_prefix = "print"
+    let inject_def id name var =
+      let open Ppxlib in
+      let open Ast_builder.Default in
+      let loc = var.Location.loc in
+      pexp_apply ~loc
+        (evar ~loc "Learnocaml_internal.install_printer")
+        [ Nolabel, estring ~loc (Ppx_autoregister.modname var);
+          Nolabel, estring ~loc id;
+          Nolabel, estring ~loc name;
+          Nolabel, evar ~loc var.txt ]
+  end)

src/ppx-metaquot/printer_recorder.mli

@@ -0,0 +1 @@
+val expand: Ppxlib.structure -> Ppxlib.structure

src/ppx-metaquot/sampler_recorder.ml

@@ -0,0 +1,13 @@
+include Ppx_autoregister.Make(struct
+    let val_prefix = "sample"
+    let inject_def id 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 (Ppx_autoregister.modname var);
+          Nolabel, estring ~loc id;
+          Nolabel, estring ~loc name;
+          Nolabel, evar ~loc var.txt]
+  end)

src/ppx-metaquot/sampler_recorder.mli

@@ -0,0 +1 @@
+val expand: Ppxlib.structure -> Ppxlib.structure

src/repo/learnocaml_precompile_exercise.ml

@@ -26,9 +26,14 @@ let is_fresh =
       mt > exe_mtime && List.for_all (fun f -> mt > mtime f) srcs
     with Unix.Unix_error _ -> false
 
-let ocamlc ?(dir=Sys.getcwd ()) ?(opn=[]) ~source ~target args =
+let ocamlc ?(dir=Sys.getcwd ()) ?(opn=[]) ?(ppx=[]) ~source ~target args =
   let d = Filename.concat dir in
   if is_fresh ~dir target source then Lwt.return_unit else
+  let args =
+    List.fold_right (fun ppx args ->
+        "-ppx" :: Filename.concat !grading_cmis_dir (ppx^" --as-ppx") :: args)
+      ppx args
+  in
   let args = "-I" :: dir :: "-I" :: !grading_cmis_dir :: args in
   let args = args @ List.map d source @ ["-o"; d target] in
   let args = List.fold_right (fun m acc -> "-open" :: m :: acc) opn args in
@@ -37,7 +42,7 @@ let ocamlc ?(dir=Sys.getcwd ()) ?(opn=[]) ~source ~target args =
 let jsoo ?(dir=Sys.getcwd ()) ~source ~target args =
   let d = Filename.concat dir in
   if is_fresh ~dir target [source] then Lwt.return_unit else
-  let args = "--wrap-with=dynload" :: args in
+  let args = "--wrap-with=dynload" :: "--pretty" :: args in
   let args = args @ [d source; "-o"; d target] in
   run "js_of_ocaml" args
 
@@ -70,10 +75,10 @@ let precompile ~exercise_dir =
   ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"]
     ~source:["prelude.ml"] ~target:"prelude.cmo"
   >>= fun () ->
-  ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"; "Prelude"]
+  ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"; "Prelude"] ~ppx:["exercise-ppx"]
     ~source:["prepare.ml"] ~target:"prepare.cmo"
   >>= fun () ->
-  ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"]
+  ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"] ~ppx:["exercise-ppx"]
     ~source:["solution.ml"] ~target:"solution.cmo"
   >>= fun () ->
   Lwt.join [
@@ -82,10 +87,8 @@ let precompile ~exercise_dir =
        ~target:"exercise.cma"
      >>= fun () ->
      jsoo ~dir [] ~source:"exercise.cma" ~target:"exercise.js");
-    (ocamlc ~dir (["-c";
-                   "-I"; "+compiler-libs";
-                   "-ppx"; Filename.concat !grading_cmis_dir "grader-ppx --as-ppx"]
-                  @ grader_flags)
+    (ocamlc ~dir (["-c"; "-I"; "+compiler-libs"] @ grader_flags)
+       ~ppx:["grader-ppx"]
        ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"; "Test_lib.Open_me"]
        ~source:["test.ml"]
        ~target:"test.cmo"