From b03bdfe5a7c9ed5d4677b1ee2eb11d37e953cbe3 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 1 Apr 2022 14:33:03 +0200 Subject: [PATCH 01/41] feat!: Implement pre-compilation of exercises and graders to cmi, cma and js. Includes changes to the toploop to handle the dynamic loading. --- README.md | 6 +- dune | 2 +- dune-project | 2 +- src/app/learnocaml_description_main.ml | 2 +- src/app/learnocaml_exercise_main.ml | 27 +- src/grader/dune | 106 +++- src/grader/grader_cli.ml | 47 +- src/grader/grader_cli.mli | 18 +- src/grader/grader_jsoo_worker.ml | 20 +- src/grader/grading.ml | 205 ++++--- src/grader/grading.mli | 17 +- src/grader/grading_cli.ml | 67 ++- src/grader/grading_cli.mli | 2 +- src/grader/grading_jsoo.ml | 5 - src/grader/introspection.ml | 77 ++- src/grader/introspection.mli | 6 +- src/grader/introspection_intf.mli | 19 + src/grader/learnocaml_callback.mli | 1 + src/grader/mutation_test.ml | 3 +- src/grader/mutation_test.mli | 2 +- src/grader/pre_test.mli | 9 + src/grader/test_lib.ml | 531 ++---------------- src/grader/test_lib.mli | 23 +- src/main/learnocaml_client.ml | 10 +- src/main/learnocaml_main.ml | 34 +- src/ppx-metaquot/dune | 14 +- src/ppx-metaquot/ppx_metaquot_main.ml | 3 +- src/ppx-metaquot/ppx_metaquot_register.ml | 3 + src/repo/dune | 3 +- src/repo/learnocaml_exercise.ml | 173 ++++-- src/repo/learnocaml_exercise.mli | 31 +- src/repo/learnocaml_precompile_exercise.ml | 75 +++ .../learnocaml_process_exercise_repository.ml | 67 ++- src/toplevel/learnocaml_toplevel.ml | 32 ++ src/toplevel/learnocaml_toplevel.mli | 19 + .../learnocaml_toplevel_worker_caller.ml | 13 + .../learnocaml_toplevel_worker_caller.mli | 13 + .../learnocaml_toplevel_worker_main.ml | 19 + .../learnocaml_toplevel_worker_messages.mli | 2 + src/toploop/dune | 3 +- src/toploop/toploop_ext.ml | 32 ++ src/toploop/toploop_ext.mli | 13 + src/toploop/toploop_jsoo.ml | 23 + src/toploop/toploop_jsoo.mli | 3 + src/toploop/toploop_unix.ml | 22 + src/toploop/toploop_unix.mli | 3 + src/utils/learnocaml_partition_create.ml | 3 +- 47 files changed, 952 insertions(+), 858 deletions(-) create mode 100644 src/grader/learnocaml_callback.mli create mode 100644 src/grader/pre_test.mli create mode 100644 src/ppx-metaquot/ppx_metaquot_register.ml create mode 100644 src/repo/learnocaml_precompile_exercise.ml diff --git a/README.md b/README.md index babacbb3b..b2ee64025 100644 --- a/README.md +++ b/README.md @@ -53,7 +53,7 @@ The Inconsolata font is released under the Open Font License. See [http://www.levien.com/type/myfonts/inconsolata.html](http://www.levien.com/type/myfonts/inconsolata.html). The Biolinum font is licensed under the GNU General Public License with -a the 'Font-Exception'. +a 'Font-Exception'. See [http://www.linuxlibertine.org](http://www.linuxlibertine.org). The public instance of Learn OCaml uses the Fontin font instead of @@ -78,9 +78,9 @@ It was written by OCamlPro from 2015 to 2018. The current main contributors are Érik Martin-Dorel, Yann Régis-Gianas, and Louis Gesbert. -The initial authors were Benjamin Canou, Çağdaş Bozman, and Grégoire Henry. +The initial authors were Benjamin Canou, Çağdaş Bozman, Grégoire Henry, and Louis Gesbert. -It builds on the previous experience of Try OCaml, by Çağdaş Bozman, and Fabrice Le Fessant. +It builds on the previous experience of Try OCaml, by Çağdaş Bozman and Fabrice Le Fessant. We heavily use js_of_ocaml, so thanks to the Ocsigen team. diff --git a/dune b/dune index cacc11a85..39cdae163 100644 --- a/dune +++ b/dune @@ -7,7 +7,7 @@ ) (env - (release (flags -safe-string -w +a-4-42-44-45-48-3-58) + (release (flags -safe-string -w +a-4-42-44-45-48-3-58-32-33) (ocamlc_flags) (ocamlopt_flags)) ) diff --git a/dune-project b/dune-project index fbcc6d71b..9b0bd8e86 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.3) +(lang dune 2.4) (name learn-ocaml) (version 0.16.0) (allow_approximate_merlin) diff --git a/src/app/learnocaml_description_main.ml b/src/app/learnocaml_description_main.ml index 6484d9f2a..e16f06b2f 100644 --- a/src/app/learnocaml_description_main.ml +++ b/src/app/learnocaml_description_main.ml @@ -71,7 +71,7 @@ let () = init_tabs (); exercise_fetch >>= fun (ex_meta, exo, _deadline) -> (* display exercise questions and prelude *) - setup_tab_text_prelude_pane Learnocaml_exercise.(decipher File.prelude exo); + setup_tab_text_prelude_pane Learnocaml_exercise.(decipher File.prelude_ml exo); let text_iframe = Dom_html.createIframe Dom_html.document in Manip.replaceChildren title_container Tyxml_js.Html5.[ h1 [ txt ex_meta.title] ]; diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index ad4187c39..392e0c7cc 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -123,16 +123,21 @@ let () = in let after_init top = exercise_fetch >>= fun (_meta, exo, _deadline) -> - begin match Learnocaml_exercise.(decipher File.prelude exo) with - | "" -> Lwt.return true - | prelude -> - Learnocaml_toplevel.load ~print_outcome:true top - ~message: [%i"loading the prelude..."] - prelude - end >>= fun r1 -> - Learnocaml_toplevel.load ~print_outcome:false top - (Learnocaml_exercise.(decipher File.prepare exo)) >>= fun r2 -> - if not r1 || not r2 then failwith [%i"error in prelude"] ; + let exercise_js = Learnocaml_exercise.(decipher File.exercise_js exo) in + Learnocaml_toplevel.load_cmi_from_string top + Learnocaml_exercise.(decipher File.prelude_cmi exo) >>= fun _ -> + Learnocaml_toplevel.load_cmi_from_string top + Learnocaml_exercise.(decipher File.prepare_cmi exo) >>= fun _ -> + Learnocaml_toplevel.load_js ~print_outcome:false top + ~message: [%i"loading the prelude..."] + exercise_js + >>= fun r -> + if not r then Lwt.fail_with [%i"error in prelude"] else + Learnocaml_toplevel.load top "open! Prelude ;;" >>= fun r -> + if not r then Lwt.fail_with [%i"error in prelude"] else + Learnocaml_toplevel.load top "open! Prepare ;;" >>= fun r -> + if not r then Lwt.fail_with [%i"error in prelude"] else + (* TODO: maybe remove Prelude, Prepare modules from the env ? *) Learnocaml_toplevel.set_checking_environment top >>= fun () -> Lwt.return () in let toplevel_launch = @@ -189,7 +194,7 @@ let () = EB.eval top select_tab; let typecheck = typecheck top ace editor in (*------------- prelude -----------------*) - setup_prelude_pane ace Learnocaml_exercise.(decipher File.prelude exo); + setup_prelude_pane ace Learnocaml_exercise.(decipher File.prelude_ml exo); Js.Opt.case (text_iframe##.contentDocument) (fun () -> failwith "cannot edit iframe document") diff --git a/src/grader/dune b/src/grader/dune index a8df1184d..d9a219e8c 100644 --- a/src/grader/dune +++ b/src/grader/dune @@ -13,8 +13,41 @@ (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) ) +;; needs to be a separate lib because the module is shared between evaluator +;; parts (Grading) and dynamic parts (Test_lib) (library - (name testing) + (name introspection_intf) + (wrapped false) + (modules introspection_intf) + (modules_without_implementation introspection_intf) + (libraries learnocaml_report ty)) + +;; dynamic part, on which Prelude/Prepare/Test_lib etc. depend +(library + (name learnocaml_callback) + (wrapped false) + (modules learnocaml_callback) + (modules_without_implementation learnocaml_callback) + ;; hack: learnocaml_callback actually does have an implementation, but it is inserted + ;; into the toplevel later on, through registered callbacks. Defining this lib + ;; ensures the compilation of `learnocaml_callback.cmi` + (libraries compiler-libs learnocaml_report introspection_intf)) + +;; dynamic part, on which Test_lib depends +(library + (name pre_test) + (wrapped false) + (modules pre_test) + (modules_without_implementation pre_test) + ;; hack: pre_test actually does have an implementation, but it is dynamically + ;; generated and injected in the environment during grading. We are interested + ;; in pre_test.cmi to compile test_lib.cmo, then test_lib.cmo should only be + ;; loaded in the specific grading toplevel env. + (libraries compiler-libs learnocaml_report introspection_intf)) + +;; dynamic (but pre-compiled) part +(library + (name testing_dyn) (wrapped false) (modes byte) (library_flags :standard -linkall) @@ -24,18 +57,23 @@ learnocaml_ppx_metaquot_lib ocplib-json-typed learnocaml_report - learnocaml_repository) - (modules Introspection_intf - Introspection - Test_lib - Mutation_test) - (modules_without_implementation Introspection_intf) + learnocaml_repository + introspection_intf + ;; dynamic dependencies + learnocaml_callback + pre_test + ) + (modules Test_lib) (preprocess (pps learnocaml_ppx_metaquot)) ) +(rule + (target testing_dyn.js) + (deps testing_dyn.cma) + (action (run js_of_ocaml %{deps} --wrap-with dynload --pretty))) (rule (targets test_lib.odoc) - (deps .testing.objs/byte/test_lib.cmti) + (deps .testing_dyn.objs/byte/test_lib.cmti) (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) ) @@ -138,39 +176,47 @@ ) (rule - (targets embedded_grading_cmis.ml) - (deps (:compiler-cmis - %{ocaml-config:standard_library}/compiler-libs/longident.cmi - %{ocaml-config:standard_library}/compiler-libs/asttypes.cmi - %{ocaml-config:standard_library}/compiler-libs/ast_helper.cmi - %{ocaml-config:standard_library}/compiler-libs/ast_mapper.cmi - %{ocaml-config:standard_library}/compiler-libs/parsetree.cmi - %{ocaml-config:standard_library}/compiler-libs/location.cmi - %{ocaml-config:standard_library}/compiler-libs/parse.cmi - %{ocaml-config:standard_library}/compiler-libs/pprintast.cmi) - (:generated-cmis - ../ppx-metaquot/.ty.objs/byte/ty.cmi - ../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi - .testing.objs/byte/introspection_intf.cmi - .learnocaml_report.objs/byte/learnocaml_report.cmi - .testing.objs/byte/test_lib.cmi - .testing.objs/byte/mutation_test.cmi)) + (targets embedded_grading_lib.ml) + (deps + .learnocaml_callback.objs/byte/learnocaml_callback.cmi + ;; .pre_test.objs/byte/pre_test.cmi -- only test_lib should be needed + .testing_dyn.objs/byte/test_lib.cmi + testing_dyn.cma + testing_dyn.js) (action (with-stdout-to %{targets} - (run ocp-ocamlres -format ocamlres %{compiler-cmis} %{generated-cmis}))) + (run ocp-ocamlres -format ocamlres %{deps}))) +) + +;; cmis that are needed to precompile the graders for exercises +(install + (section share) + (package learn-ocaml) + (files + (../ppx-metaquot/.ty.objs/byte/ty.cmi as grading_cmis/ty.cmi) + (../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi as grading_cmis/fun_ty.cmi) + (.introspection_intf.objs/byte/introspection_intf.cmi as grading_cmis/introspection_intf.cmi) + (.pre_test.objs/byte/pre_test.cmi as grading_cmis/pre_test.cmi) + (.learnocaml_report.objs/byte/learnocaml_report.cmi as grading_cmis/learnocaml_report.cmi) + (.learnocaml_callback.objs/byte/learnocaml_callback.cmi as grading_cmis/learnocaml_callback.cmi) + (.testing_dyn.objs/byte/test_lib.cmi as grading_cmis/test_lib.cmi)) ) + (library (name grading) (wrapped false) (modes byte) (library_flags :standard -linkall) - (libraries testing - learnocaml_ppx_metaquot + (libraries learnocaml_ppx_metaquot ocplib-ocamlres.runtime + toploop + introspection_intf embedded_cmis ocplib_i18n - learnocaml_report) - (modules Embedded_grading_cmis + learnocaml_report + learnocaml_repository) + (modules Introspection + Embedded_grading_lib Grading) (preprocess (per_module ((pps ppx_ocplib_i18n learnocaml_ppx_metaquot) Grading))) ) diff --git a/src/grader/grader_cli.ml b/src/grader/grader_cli.ml index 19e0149ea..7654ac230 100644 --- a/src/grader/grader_cli.ml +++ b/src/grader/grader_cli.ml @@ -7,9 +7,6 @@ * included LICENSE file for details. *) let display_std_outputs = ref false -let dump_outputs = ref None -let dump_reports = ref None -let display_callback = ref false let display_outcomes = ref false let grade_student = ref None let individual_timeout = ref None @@ -47,29 +44,25 @@ let read_student_file exercise_dir path = else Lwt_io.with_file ~mode:Lwt_io.Input fn Lwt_io.read -let grade ?(print_result=false) ?dirname meta exercise output_json = +let grade ?(print_result=false) ?dirname + ~dump_outputs ~dump_reports ~display_callback + meta exercise output_json = Lwt.catch (fun () -> let code_to_grade = match !grade_student with | Some path -> read_student_file (Sys.getcwd ()) path - | None -> - Lwt.return (Learnocaml_exercise.(decipher File.solution exercise)) in + | None -> Lwt.return (Learnocaml_exercise.(decipher File.solution exercise)) in let callback = - if !display_callback then Some (Printf.eprintf "[ %s ]%!\r\027[K") else None in + if display_callback then Some (Printf.eprintf "[ %s ]%!\r\027[K") else None in let timeout = !individual_timeout in code_to_grade >>= fun code -> Grading_cli.get_grade ?callback ?timeout ?dirname exercise code >>= fun (result, stdout_contents, stderr_contents, outcomes) -> flush stderr; match result with - | Error exn -> + | Error err -> let dump_error ppf = - begin match Grading.string_of_exn exn with - | Some msg -> - Format.fprintf ppf "%s@." msg - | None -> - Format.fprintf ppf "%a@." Location.report_exception exn - end; + Format.fprintf ppf "%s@." (Grading.string_of_err err); if stdout_contents <> "" then begin Format.fprintf ppf "grader stdout:@.%s@." stdout_contents end ; @@ -79,7 +72,7 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = if outcomes <> "" then begin Format.fprintf ppf "grader outcomes:@.%s@." outcomes end in - begin match !dump_outputs with + begin match dump_outputs with | None -> () | Some prefix -> let oc = open_out (prefix ^ ".error") in @@ -92,7 +85,7 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = let (max, failure) = Learnocaml_report.result report in if !display_reports then Learnocaml_report.print (Format.formatter_of_out_channel stderr) report; - begin match !dump_reports with + begin match dump_reports with | None -> () | Some prefix -> let oc = open_out (prefix ^ ".report.txt") in @@ -103,7 +96,7 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = close_out oc end ; if stderr_contents <> "" then begin - begin match !dump_outputs with + begin match dump_outputs with | None -> () | Some prefix -> let oc = open_out (prefix ^ ".stderr") in @@ -114,7 +107,7 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = Format.eprintf "%s" stderr_contents end ; if stdout_contents <> "" then begin - begin match !dump_outputs with + begin match dump_outputs with | None -> () | Some prefix -> let oc = open_out (prefix ^ ".stdout") in @@ -125,7 +118,7 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = Format.printf "%s" stdout_contents end ; if outcomes <> "" then begin - begin match !dump_outputs with + begin match dump_outputs with | None -> () | Some prefix -> let oc = open_out (prefix ^ ".outcomes") in @@ -163,7 +156,8 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = Lwt.return (Ok ()) end) (fun exn -> - begin match !dump_outputs with + Lwt.wrap @@ fun () -> + begin match dump_outputs with | None -> () | Some prefix -> let oc = open_out (prefix ^ ".error") in @@ -172,10 +166,13 @@ let grade ?(print_result=false) ?dirname meta exercise output_json = "%a@!" Location.report_exception exn ; close_out oc end ; - Format.eprintf "%a" Location.report_exception exn ; - Lwt.return (Error (-1))) + Format.eprintf "%a" Location.report_exception exn; + Error (-1)) -let grade_from_dir ?(print_result=false) exercise_dir output_json = +let grade_from_dir + ?(print_result=false) + ~dump_outputs ~dump_reports ~display_callback + exercise_dir output_json = let exercise_dir = remove_trailing_slash exercise_dir in read_exercise exercise_dir >>= fun exo -> Lwt_io.(with_file ~mode:Input (String.concat Filename.dir_sep [exercise_dir; "meta.json"]) read) >>= fun content -> @@ -183,4 +180,6 @@ let grade_from_dir ?(print_result=false) exercise_dir output_json = | "" -> `O [] | s -> Ezjsonm.from_string s) |> Json_encoding.destruct Learnocaml_data.Exercise.Meta.enc in - grade ~print_result ~dirname:exercise_dir meta exo output_json + grade + ~dump_outputs ~dump_reports ~display_callback + ~print_result ~dirname:exercise_dir meta exo output_json diff --git a/src/grader/grader_cli.mli b/src/grader/grader_cli.mli index 838a3896c..c08cb4dfb 100644 --- a/src/grader/grader_cli.mli +++ b/src/grader/grader_cli.mli @@ -11,15 +11,6 @@ (** Should stdout / stderr of the grader be echoed *) val display_std_outputs: bool ref -(** Should outputs of the grader be saved and where *) -val dump_outputs: string option ref - -(** Should the reports be saved and where *) -val dump_reports: string option ref - -(** Should the message from 'test.ml' be displayed on stdout ? *) -val display_callback: bool ref - (** Should compiler outcome be printed ? *) val display_outcomes: bool ref @@ -39,9 +30,14 @@ val dump_dot: string option ref (** Runs the grading process *) val grade: - ?print_result:bool -> ?dirname:string -> Learnocaml_data.Exercise.Meta.t -> Learnocaml_exercise.t -> string option -> + ?print_result:bool -> ?dirname:string -> + dump_outputs:string option -> dump_reports:string option -> + display_callback:bool -> + Learnocaml_data.Exercise.Meta.t -> Learnocaml_exercise.t -> string option -> (unit, int) result Lwt.t val grade_from_dir: - ?print_result:bool -> string -> string option -> + ?print_result:bool -> + dump_outputs:string option -> dump_reports:string option -> display_callback:bool -> + string -> string option -> (unit, int) result Lwt.t diff --git a/src/grader/grader_jsoo_worker.ml b/src/grader/grader_jsoo_worker.ml index 7f14b8e34..1fd379fea 100644 --- a/src/grader/grader_jsoo_worker.ml +++ b/src/grader/grader_jsoo_worker.ml @@ -23,7 +23,6 @@ let get_grade ?callback exo solution = | OCamlRes.Res.Error _ -> () in rec_mount [] (OCamlRes.Res.Dir ("worker_cmis", Embedded_cmis.root)); - rec_mount [] (OCamlRes.Res.Dir ("grading_cmis", Embedded_grading_cmis.root)); (try Toploop_jsoo.initialize ["/worker_cmis"; "/grading_cmis"] with | Typetexp.Error (loc, env, error) -> Js_utils.log "FAILED INIT %a at %a" @@ -34,7 +33,16 @@ let get_grade ?callback exo solution = let divert name chan cb = let redirection = Toploop_jsoo.redirect_channel name chan cb in fun () -> Toploop_jsoo.stop_channel_redirection redirection in - Grading.get_grade ?callback ~divert exo solution + let load_code compiled_code = + try + Toploop_jsoo.use_compiled_string compiled_code.Learnocaml_exercise.js; + flush_all (); + Toploop_ext.Ok (true, []) + with exn -> + prerr_endline (Printexc.to_string exn); + Toploop_ext.Ok (false, []) + in + Grading.get_grade ?callback ~divert ~load_code exo solution open Grader_jsoo_messages @@ -51,8 +59,8 @@ let () = match get_grade ~callback exercise solution with | Ok report, stdout, stderr, outcomes -> Answer (report, stdout, stderr, outcomes) - | Error exn, stdout, stderr, outcomes -> - let msg = match exn with + | Error err, stdout, stderr, outcomes -> + let msg = match err with | Grading.User_code_error err -> Format.asprintf [%if"Error in your solution:\n%a\n%!"] Location.print_report (Toploop_results.to_error err) @@ -61,9 +69,7 @@ let () = step Location.print_report (Toploop_results.to_error err) | Grading.Invalid_grader -> - [%i"Internal error:\nThe grader did not return a report."] - | exn -> - [%i"Unexpected error:\n"] ^ Printexc.to_string exn in + [%i"Internal error:\nThe grader did not return a report."] in let report = Learnocaml_report.[ Message ([ Code msg ], Failure) ] in Answer (report, stdout, stderr, outcomes) | exception exn -> diff --git a/src/grader/grading.ml b/src/grader/grading.ml index b5c8e0cbf..606ec544c 100644 --- a/src/grader/grading.ml +++ b/src/grader/grading.ml @@ -6,40 +6,37 @@ * Learn-OCaml is distributed under the terms of the MIT license. See the * included LICENSE file for details. *) -exception Internal_error of string * Toploop_ext.error -exception User_code_error of Toploop_ext.error -exception Invalid_grader +(* Define a non-extensible type to allow marshalling *) +type error = + | Internal_error of string * Toploop_ext.error + | User_code_error of Toploop_ext.error + | Invalid_grader -let string_of_exn = function +exception Grading_error of error + +let string_of_err = function | Internal_error (msg, error) -> - let msg = - Format.asprintf [%if"Exercise definition error %s:\n%a\n%!"] - msg Location.print_report (Toploop_results.to_error error) - in - Some msg + Format.asprintf [%if"Exercise definition error %s:\n%a\n%!"] + msg Location.print_report (Toploop_results.to_error error) | User_code_error error -> - let msg = - Format.asprintf [%if"Error in user code:\n\n%a\n%!"] - Location.print_report (Toploop_results.to_error error) - in - Some msg - | _ -> None + Format.asprintf [%if"Error in user code:\n\n%a\n%!"] + Location.print_report (Toploop_results.to_error error) + | Invalid_grader -> + [%i"The grader is invalid"] let () = - Location.register_error_of_exn (fun exn -> - match string_of_exn exn with - | Some msg -> Some (Location.error msg) - | None -> None) - + Location.register_error_of_exn (function + | Grading_error e -> Some (Location.error (string_of_err e)) + | _ -> None) let internal_error name err = - raise (Internal_error (name, err)) + raise (Grading_error (Internal_error (name, err))) let user_code_error err = - raise (User_code_error err) + raise (Grading_error (User_code_error err)) let get_grade - ?callback ?timeout ?(dirname="") ~divert + ?callback ?timeout ?(dirname="") ~divert ~load_code (exo : Learnocaml_exercise.t) code = let file f = String.concat Filename.dir_sep [dirname; f] in @@ -93,115 +90,105 @@ let get_grade fail err in let result = try - handle_error (internal_error [%i"while preparing the tests"]) @@ - Toploop_ext.use_string ~print_outcome ~ppf_answer - {|let print_html _ = assert false|}; - - set_progress [%i"Loading the prelude."] ; - handle_error (internal_error [%i"while loading the prelude"]) @@ - Toploop_ext.use_string ~print_outcome ~ppf_answer ~filename:(file "prelude.ml") - (Learnocaml_exercise.(decipher File.prelude exo)) ; + let saved_toplevel_state = Symtable.current_state () in + let () = + (* Prelude/Prepare might use these callbacks, but they shouldn't appear + 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 _ = () + end in + Toploop_ext.inject_global "Learnocaml_callback" + (Obj.repr (module Learnocaml_callback: Introspection_intf.LEARNOCAML_CALLBACK)); + in set_progress [%i"Preparing the test environment."] ; + Toploop_ext.load_cmi_from_string (Learnocaml_exercise.(decipher File.prelude_cmi exo)) ; + Toploop_ext.load_cmi_from_string (Learnocaml_exercise.(decipher File.prepare_cmi exo)) ; + handle_error (internal_error [%i"while preparing the tests"]) @@ - Toploop_ext.use_string ~print_outcome ~ppf_answer ~filename:(file "prepare.ml") - (Learnocaml_exercise.(decipher File.prepare exo)) ; + load_code Learnocaml_exercise.{ + cma = decipher File.exercise_cma exo ; + js = decipher File.exercise_js exo ; + }; + + handle_error (internal_error [%i"while preparing the tests"]) @@ + Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Prelude|}; + handle_error (internal_error [%i"while preparing the tests"]) @@ + Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Prepare|}; + set_progress [%i"Loading your code."] ; handle_error user_code_error @@ Toploop_ext.use_mod_string ~print_outcome ~ppf_answer ~modname:"Code" ~filename:(file "solution.ml") code ; - set_progress [%i"Loading the solution."] ; - handle_error (internal_error [%i"while loading the solution"]) @@ - Toploop_ext.use_mod_string ~print_outcome ~ppf_answer ~modname:"Solution" - (Learnocaml_exercise.(decipher File.solution exo)) ; + Toploop_ext.load_cmi_from_string (Learnocaml_exercise.(decipher File.solution_cmi exo)) ; set_progress [%i"Preparing to launch the tests."] ; - Introspection.allow_introspection ~divert ; - Introspection.insert_mod_ast_in_env ~var_name: "code_ast" code ; - let get_result = - Introspection.create_ref "results" - [%ty: Learnocaml_report.t option] - None in - Introspection.register_callback "set_progress" - [%ty: string] - set_progress ; - Introspection.insert_in_env "timeout" [%ty: int option] timeout ; + let module Intro_inner = + (val Introspection.allow_introspection ~divert) + in + let code_ast = Introspection.get_mod_ast ~var_name:"code_ast" code in + let results: Learnocaml_report.t option ref = ref None in + let get_result () = !results in + let () = + let module Pre_test: Introspection_intf.PRE_TEST = struct + module Introspection = Intro_inner + let code_ast = code_ast + let results = results + let set_progress = set_progress + let timeout = timeout + end in + (* Hack: register Pre_test as a compilation unit usable by the compiled + modules loaded later-on *) + Toploop_ext.inject_global "Pre_test" + (Obj.repr (module Pre_test: Introspection_intf.PRE_TEST)); + in + Toploop_ext.load_cmi_from_string + OCamlRes.(Res.find (Path.of_string "test_lib.cmi") + Embedded_grading_lib.root) ; handle_error (internal_error [%i"while preparing the tests"]) @@ - Toploop_ext.use_string ~print_outcome ~ppf_answer - "module Test_lib = Test_lib.Make(struct\n\ - \ let results = results\n\ - \ let set_progress = set_progress\n\ - \ let timeout = timeout\n\ - \ module Introspection = Introspection\n\ - end)" ; + load_code + { Learnocaml_exercise. + cma = OCamlRes.(Res.find (Path.of_string "testing_dyn.cma") + Embedded_grading_lib.root) ; + 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 ~ppf_answer - "module Report = Learnocaml_report" ; - (* The following 3 lines are just a workaround for issue #457 *) + 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 ~ppf_answer - "module Introspection = Introspection" ; - set_progress [%i"Launching the test bench."] ; - - let () = - let open Learnocaml_exercise in - let files = File.dependencies (access File.depend exo) in - let rec load_dependencies signatures = function - | [] -> () (* signatures without implementation are ignored *) - | file::fs -> - let path = File.key file - and content = decipher file exo in - let modname = String.capitalize_ascii @@ - Filename.remove_extension @@ Filename.basename path in - match Filename.extension path with - | ".mli" -> load_dependencies ((modname,content) :: signatures) fs - | ".ml" -> - let included,content = - (* the first line of an .ml file can contain an annotation *) - (* [@@@included] which denotes that this file has to be included *) - (* directly in the toplevel environment, and not in an module. *) - match String.index_opt content '\n' with - | None -> (false,content) - | Some i -> - (match String.trim (String.sub content 0 i) with - | "[@@@included]" -> - let content' = String.sub content i @@ - (String.length content - i) - in (true,content') - | _ -> (false,content)) - in - (handle_error (internal_error [%i"while loading user dependencies"]) @@ - match included with - | true -> Toploop_ext.use_string ~print_outcome ~ppf_answer - ~filename:(Filename.basename path) content - | false -> - let use_mod = - Toploop_ext.use_mod_string ~print_outcome ~ppf_answer ~modname in - match List.assoc_opt modname signatures with - | Some sig_code -> use_mod ~sig_code content - | None -> use_mod content); - load_dependencies signatures fs - | _ -> failwith ("uninterpreted dependency \"" ^ path ^ - "\", file extension expected : .ml or .mli") in - load_dependencies [] files - in - + 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 + the need for an opened [test_cmi]*) + Toploop_ext.load_cmi_from_string (Learnocaml_exercise.(decipher File.test_cmi exo)) ; + handle_error (internal_error [%i"while preparing the tests"]) @@ + Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Test|}; handle_error (internal_error [%i"while testing your solution"]) @@ - Toploop_ext.use_string ~print_outcome ~ppf_answer ~filename:(file "test.ml") - (Learnocaml_exercise.(decipher File.test exo)) ; + load_code Learnocaml_exercise.{ + cma = decipher File.test_cma exo ; + js = decipher File.test_js exo ; + }; (* Memory cleanup... *) Toploop.initialize_toplevel_env () ; - (* TODO: Also clear the object table, once the OCaml's Toploop allows to. *) + Symtable.restore_state saved_toplevel_state; + (* TODO: Also clear the object table, once the OCaml's Toploop allows to. + Toploop.toplevel_value_bindings := String.Map.empty; (* not exported :( *) + here we run in a forked sub-process then exit as a workaround *) !flush_stderr () ; !flush_stdout () ; match get_result () with | Some report -> Ok report | None -> Error Invalid_grader - with exn -> - Error exn in + with + | Grading_error err -> Error err + | e -> Error (Internal_error (Printexc.to_string e, + ((Location.none, ""),[]))) + in Format.fprintf ppf_answer "@." ; (result, Buffer.contents stdout_buffer, diff --git a/src/grader/grading.mli b/src/grader/grading.mli index 4963d90d6..a3c41afb0 100644 --- a/src/grader/grading.mli +++ b/src/grader/grading.mli @@ -8,22 +8,27 @@ open Toploop_ext -exception Internal_error of string * error -exception User_code_error of error -exception Invalid_grader +type error = + | Internal_error of string * Toploop_ext.error + | User_code_error of Toploop_ext.error + | Invalid_grader + +exception Grading_error of error (** Take an exercise, a solution, and return the report, stdout, stderr and outcomes of the toplevel, or raise ont of the exceptions above. The divert mechanism is a platform dependent way of rerouting the standard channel descriptors, as implemented by - {!Toploop_unix} and {!Toploop_jsoo}. *) + {!Toploop_unix} and {!Toploop_jsoo}. {load_code} is expected to load + compiled code, either in {cmo} or {js} depending on the backend. *) val get_grade: ?callback:(string -> unit) -> ?timeout:int -> ?dirname:string -> divert:(string -> out_channel -> (string -> unit) -> (unit -> unit)) -> - Learnocaml_exercise.t -> string -> (Learnocaml_report.t, exn) result * string * string * string + load_code:(Learnocaml_exercise.compiled_lib -> bool Toploop_ext.toplevel_result) -> + Learnocaml_exercise.t -> string -> (Learnocaml_report.t, error) result * string * string * string (** Returns user-friendly messages when called on [Internal_error] or [User_code_error] *) -val string_of_exn: exn -> string option +val string_of_err: error -> string diff --git a/src/grader/grading_cli.ml b/src/grader/grading_cli.ml index a90f1576b..5a2875b57 100644 --- a/src/grader/grading_cli.ml +++ b/src/grader/grading_cli.ml @@ -23,7 +23,7 @@ let with_temp_dir f = let d = Filename.concat (Filename.get_temp_dir_name ()) - (Printf.sprintf "grader_%6X" (Random.int 0xFFFFFF)) + (Printf.sprintf "grader_%06X" (Random.int 0xFFFFFF)) in Lwt.catch (fun () -> Lwt_unix.mkdir d 0o700 >>= fun () -> Lwt.return d) @@ function @@ -35,18 +35,57 @@ let with_temp_dir f = (fun () -> f dir >>= fun res -> remove_dir dir >>= fun () -> Lwt.return res) (fun e -> remove_dir dir >>= fun () -> Lwt.fail e) +(* The answer of the grader will be returned marshalled through a pipe: + type it explicitely and avoid any exceptions inside. *) +type grader_answer = + (Learnocaml_report.t, Grading.error) Stdlib.result * string * string * string + let get_grade ?callback ?timeout ?dirname exo solution = with_temp_dir @@ fun cmis_dir -> - let module ResDump = - OCamlResFormats.Files (OCamlResSubFormats.Raw) in - let dump_cmis = - ResDump.output { OCamlResFormats.base_output_dir = cmis_dir } in - dump_cmis Embedded_cmis.root ; - dump_cmis Embedded_grading_cmis.root ; - Load_path.init [ cmis_dir ] ; - Toploop_unix.initialize () ; - let divert name chan cb = - let redirection = Toploop_unix.redirect_channel name chan cb in - fun () -> Toploop_unix.stop_channel_redirection redirection in - Lwt.wrap @@ fun () -> - Grading.get_grade ?callback ?timeout ?dirname ~divert exo solution + Lwt_io.flush_all () >>= fun () -> + flush_all (); + let in_fd, out_fd = Unix.pipe ~cloexec:true () in + match Lwt_unix.fork () with + | 0 -> + (* /!\ there must be strictly no Lwt calls in the child *) + Unix.close in_fd; + let oc = Unix.out_channel_of_descr out_fd in + let (ret: grader_answer) = + let module ResDump = + OCamlResFormats.Files (OCamlResSubFormats.Raw) in + let dump_cmis = + ResDump.output { OCamlResFormats.base_output_dir = cmis_dir } in + dump_cmis Embedded_cmis.root ; + (* dump_cmis Embedded_grading_cmis.root ; *) + Load_path.init [ cmis_dir ] ; + Toploop_unix.initialize () ; + let divert name chan cb = + let redirection = Toploop_unix.redirect_channel name chan cb in + fun () -> Toploop_unix.stop_channel_redirection redirection in + let load_code compiled_code = + try + Toploop_unix.use_compiled_string compiled_code.Learnocaml_exercise.cma; + Toploop_ext.Ok (true, []) + with _ -> Toploop_ext.Ok (false, []) + in + Grading.get_grade ?callback ?timeout ?dirname ~divert ~load_code + exo solution + in + output_value oc ret; + flush_all (); + Unix._exit 0 + | child_pid -> + Unix.close out_fd; + let ic = Lwt_io.of_unix_fd ~mode:Lwt_io.Input in_fd in + Lwt.catch + (fun () -> Lwt_io.read_value ic >|= Option.some) + (function End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) + >>= fun (ans: grader_answer option) -> + Lwt_unix.waitpid [] child_pid >>= fun (_pid, stat) -> + match ans, stat with + | _, Unix.WSIGNALED n -> + Printf.ksprintf Lwt.fail_with "Grading sub-process was killed (%d)" n + | Some ans, Unix.WEXITED 0 -> + Lwt.return ans + | _ -> + Lwt.fail_with "Grading sub-process error" diff --git a/src/grader/grading_cli.mli b/src/grader/grading_cli.mli index bf3e8c6d0..61d9cdcba 100644 --- a/src/grader/grading_cli.mli +++ b/src/grader/grading_cli.mli @@ -14,4 +14,4 @@ val get_grade: ?timeout:int -> ?dirname:string -> Learnocaml_exercise.t -> string -> - ((Learnocaml_report.t, exn) result * string * string * string) Lwt.t + ((Learnocaml_report.t, Grading.error) result * string * string * string) Lwt.t diff --git a/src/grader/grading_jsoo.ml b/src/grader/grading_jsoo.ml index f60a31b52..bc574212c 100644 --- a/src/grader/grading_jsoo.ml +++ b/src/grader/grading_jsoo.ml @@ -21,12 +21,9 @@ let get_grade let t, u = Lwt.task () in let worker = Worker.create worker_js_file in Lwt.on_cancel t (fun () -> - Js_utils.js_warn "Grading worker END"; worker##terminate) ; let onmessage (ev : Json_repr_browser.Repr.value Worker.messageEvent Js.t) = let json = ev##.data in - Js_utils.js_warn ("msg from grading worker:"); - Js_utils.js_warn json; begin match Json_repr_browser.Json_encoding.destruct from_worker_enc json with | Callback text -> callback text | Answer (report, stdout, stderr, outcomes) -> @@ -52,8 +49,6 @@ let get_grade fun solution -> let req = { exercise ; solution } in let json = Json_repr_browser.Json_encoding.construct to_worker_enc req in - Js_utils.js_warn ("Sending to grading worker: "); - Js_utils.js_warn json; worker##(postMessage json) ; let timer = Lwt_js.sleep timeout >>= fun () -> diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index 55370faca..2869c3dc6 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -8,6 +8,9 @@ (** Introspection *) +exception Introspection_failure of string +let failwith msg = raise (Introspection_failure msg) + let split s c = let rec loop i = match String.index_from s i c with @@ -59,7 +62,7 @@ let insert_in_env (type t) name (ty : t Ty.ty) (value : t) = end; Toploop.setvalue name (Obj.repr value) -let insert_mod_ast_in_env ~var_name impl_code = +let get_mod_ast ~var_name impl_code = let init_loc lb filename = Location.input_name := filename; Location.input_lexbuf := Some lb; @@ -92,15 +95,14 @@ let insert_mod_ast_in_env ~var_name impl_code = Pstr_module { pmb_expr = { pmod_desc = Pmod_constraint ({ pmod_desc = Pmod_structure s; _ }, _); _ }; _ }; _}] -> - let ty = Ty.repr (Ast_helper.(Typ.constr (Location.mknoloc (parse_lid "Parsetree.structure")) [])) in - insert_in_env var_name (ty : Parsetree.structure Ty.ty) s + s | _ (* should not happen *) -> assert false) let treat_lookup_errors fn = match fn () with | result -> result | exception Not_found -> Absent - | exception Failure msg -> + | exception Introspection_failure msg -> Incompatible msg | exception Ctype.Unify args -> Incompatible @@ -204,6 +206,48 @@ let print_value ppf v ty = Format.fprintf ppf "@]" end +let register_sampler name f = + let sampler_name = "sample_" ^ name in + (* FIXME TODO: type-check the specified samplers ! *) + (* let sampled_ty_path, sampled_ty_decl = + * Env.find_type_by_name (Longident.Lident name) !Toploop.toplevel_env + * in + * let sampled_ty = + * match sampled_ty_decl.Types.type_manifest with + * | Some ty -> ty + * | None -> failwith "Type is not public for sampling" + * in + * let sampler_ty_computed = + * (\* The given sampler must be a function with one argument for every type param *\) + * let sampler ty = (\* ['a sampler] == [unit -> 'a] *\) + * Types.Tarrow (Asttypes.Nolabel, Predef.type_unit, ty, Types.Cok) + * in + * List.fold_right (fun typaram ty -> + * Types.Tarrow (Asttypes.Nolabel, Btype.newgenty (sampler typaram), Btype.newgenty ty, Types.Cok)) + * sampled_ty_decl.Types.type_params + * (sampler sampled_ty) + * in *) + let sampler_ty(* _found *) = + Env.find_value + (Path.Pdot (Path.Pident (Ident.create_persistent "Test"), sampler_name)) + !Toploop.toplevel_env + (* Requires [test.cmi] to be pre-loaded *) + (* FIXME: maybe don't require the cmi and skip this check when on the + browser. + ... unless the type of the sampler might somehow depend on the types + inferred from [Code], but that should definitely be forbidden! *) + in + if true (* Ctype.moregeneral !Toploop.toplevel_env true + * (Btype.newgenty sampler_ty_found) sampler_ty_computed *) + then + (Toploop.toplevel_env := + Env.add_value (Ident.create_local sampler_name) sampler_ty + !Toploop.toplevel_env; + Toploop.setvalue sampler_name (Obj.repr f)) + else + failwith "sampler has the wrong type !" + + let sample_value ty = let { Typedtree.ctyp_type = ty; _ } = Typetexp.transl_type_scheme !Toploop.toplevel_env (Ty.obj ty) in @@ -216,9 +260,9 @@ let sample_value ty = Exp.ident (Location.mknoloc (Longident.Lident ("sample_" ^ suffix))) in let rec phrase ty = match ty.desc with | Tconstr (path, [], _) -> - sampler_id (Path.name path) + sampler_id (Path.last path) | Tconstr (path, tl, _) -> - Exp.apply (sampler_id (Path.name path)) + Exp.apply (sampler_id (Path.last path)) (List.map (fun arg -> Asttypes.Nolabel, phrase arg) tl) | Ttuple tys -> begin match tys with @@ -249,6 +293,14 @@ let sample_value ty = | exception Typetexp.Error (_loc, env, err) -> Typetexp.report_error env ppf err; failwith ("type error while defining sampler: " ^ Buffer.contents buf) + | exception Env.Error e -> + Format.kasprintf failwith "error while defining sampler: %s%a" (Buffer.contents buf) Env.report_error e + | exception Symtable.(Error (Uninitialized_global "Test")) -> + Format.kasprintf failwith "Missing sampler registration for %a" + Printtyp.type_expr ty + | exception Symtable.Error e -> + Format.kasprintf failwith "error while defining sampler: %s%a" + (Buffer.contents buf) Symtable.report_error e | exception e -> failwith ("error while defining sampler: " ^ Buffer.contents buf ^ Printexc.to_string e) @@ -266,14 +318,10 @@ let create_ref name (ty: 'a Ty.ty) (v: 'a) = let ty = Ty.repr @@ Ast_helper.Typ.constr ref_lid [Ty.obj ty] in let r = ref v in insert_in_env name ty r; - (fun () -> !r) - -let setup = lazy (Ast_mapper.register "ppx_metaquot" Ppx_metaquot.expander) + (r, ty), (fun () -> !r) let allow_introspection ~divert = - Lazy.force setup ; - let module Introspection = struct type 'a t = 'a value = @@ -339,13 +387,12 @@ let allow_introspection ~divert = res let get_printer ty = fun ppf v -> print_value ppf v ty + + let register_sampler name f = register_sampler name f let get_sampler ty = sample_value ty let parse_lid name = parse_lid name end in - insert_in_env - "Introspection" - [%ty: (module Introspection_intf.INTROSPECTION)] - (module Introspection : Introspection_intf.INTROSPECTION) + (module Introspection : Introspection_intf.INTROSPECTION) diff --git a/src/grader/introspection.mli b/src/grader/introspection.mli index 9182f9a48..1ada82917 100644 --- a/src/grader/introspection.mli +++ b/src/grader/introspection.mli @@ -17,10 +17,10 @@ val sample_value: 'a Ty.ty -> 'a val insert_in_env: string -> 'a Ty.ty -> 'a -> unit -val insert_mod_ast_in_env: var_name:string -> string -> unit -val create_ref: string -> 'a Ty.ty -> 'a -> unit -> 'a +val get_mod_ast: var_name:string -> string -> Parsetree.structure + val register_callback: string -> 'a Ty.ty -> ('a -> unit) -> unit val allow_introspection: divert:(string -> out_channel -> (string -> unit) -> (unit -> unit)) -> - unit + (module Introspection_intf.INTROSPECTION) diff --git a/src/grader/introspection_intf.mli b/src/grader/introspection_intf.mli index eac0d0e29..5a5e412e3 100644 --- a/src/grader/introspection_intf.mli +++ b/src/grader/introspection_intf.mli @@ -34,9 +34,28 @@ module type INTROSPECTION = sig val grab_stderr: unit -> unit val release_stderr: unit -> string + val register_sampler: string -> ('a -> 'b) -> unit val get_sampler: 'a Ty.ty -> (unit -> 'a) val get_printer: 'a Ty.ty -> (Format.formatter -> 'a -> unit) val parse_lid: string -> Longident.t 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 + of the grader before the tests are run. *) +module type PRE_TEST = sig + module Introspection: INTROSPECTION + + val code_ast: Parsetree.structure + val results: Learnocaml_report.t option ref + val set_progress: string -> unit + val timeout: int option +end diff --git a/src/grader/learnocaml_callback.mli b/src/grader/learnocaml_callback.mli new file mode 100644 index 000000000..db8022e5a --- /dev/null +++ b/src/grader/learnocaml_callback.mli @@ -0,0 +1 @@ +include Introspection_intf.LEARNOCAML_CALLBACK diff --git a/src/grader/mutation_test.ml b/src/grader/mutation_test.ml index ccba461ff..8e864ad61 100644 --- a/src/grader/mutation_test.ml +++ b/src/grader/mutation_test.ml @@ -1,3 +1,4 @@ +open Test_lib.Open_me open Learnocaml_report type 'a test_result = @@ -41,7 +42,7 @@ module type S = sig val passed_mutation_testing: Learnocaml_report.t -> bool end -module Make (Test_lib: Test_lib.S) : S = struct +module Make (Test_lib: module type of Test_lib) : S = struct open Test_lib let run_test_against ?(compare = (=)) f (input, expected) = diff --git a/src/grader/mutation_test.mli b/src/grader/mutation_test.mli index f01c22027..e3d0c601f 100644 --- a/src/grader/mutation_test.mli +++ b/src/grader/mutation_test.mli @@ -109,4 +109,4 @@ module type S = sig val passed_mutation_testing: Learnocaml_report.t -> bool end -module Make (_: Test_lib.S) : S +module Make (_: module type of Test_lib) : S diff --git a/src/grader/pre_test.mli b/src/grader/pre_test.mli new file mode 100644 index 000000000..4975b1a70 --- /dev/null +++ b/src/grader/pre_test.mli @@ -0,0 +1,9 @@ +(* These values are injected into the environment after the exercise and + solutions are loaded, and before the tests are loaded *) + +(* Loaded from the exercise: {[ + module Code + module Solution + ]} *) + +include Introspection_intf.PRE_TEST diff --git a/src/grader/test_lib.ml b/src/grader/test_lib.ml index b48ce0cf3..c9bb89957 100644 --- a/src/grader/test_lib.ml +++ b/src/grader/test_lib.ml @@ -6,456 +6,10 @@ * Learn-OCaml is distributed under the terms of the MIT license. See the * included LICENSE file for details. *) -module type S = sig - - val set_result : Learnocaml_report.t -> unit - - type nonrec 'a result = ('a, exn) result - - (*----------------------------------------------------------------------------*) - - module Ast_checker : sig - type 'a ast_checker = - ?on_expression: (Parsetree.expression -> Learnocaml_report.t) -> - ?on_pattern: (Parsetree.pattern -> Learnocaml_report.t) -> - ?on_structure_item: (Parsetree.structure_item -> Learnocaml_report.t) -> - ?on_external: (Parsetree.value_description -> Learnocaml_report.t) -> - ?on_include: (Parsetree.include_declaration -> Learnocaml_report.t) -> - ?on_open: (Parsetree.open_declaration -> Learnocaml_report.t) -> - ?on_module_occurence: (string -> Learnocaml_report.t) -> - ?on_variable_occurence: (string -> Learnocaml_report.t) -> - ?on_function_call: ((Parsetree.expression * (string * Parsetree.expression) list) -> Learnocaml_report.t) -> - 'a -> Learnocaml_report.t - - val ast_check_expr : Parsetree.expression ast_checker - val ast_check_structure : Parsetree.structure ast_checker - - val find_binding : Parsetree.structure -> string -> (Parsetree.expression -> Learnocaml_report.t) -> Learnocaml_report.t - - val forbid : string -> ('a -> string) -> 'a list -> ('a -> Learnocaml_report.t) - val restrict : string -> ('a -> string) -> 'a list -> ('a -> Learnocaml_report.t) - val require : string -> ('a -> string) -> 'a -> ('a -> Learnocaml_report.t) - - val forbid_expr : string -> Parsetree.expression list -> (Parsetree.expression -> Learnocaml_report.t) - val restrict_expr : string -> Parsetree.expression list -> (Parsetree.expression -> Learnocaml_report.t) - val require_expr : string -> Parsetree.expression -> (Parsetree.expression -> Learnocaml_report.t) - val forbid_syntax : string -> (_ -> Learnocaml_report.t) - val require_syntax : string -> (_ -> Learnocaml_report.t) - - val ast_sanity_check : ?modules: string list -> Parsetree.structure -> (unit -> Learnocaml_report.t) -> Learnocaml_report.t - - end - - (*----------------------------------------------------------------------------*) - - type 'a tester = - 'a Ty.ty -> 'a result -> 'a result -> Learnocaml_report.t - - type io_tester = - string -> string -> Learnocaml_report.t - - type io_postcond = - string -> Learnocaml_report.t - - exception Timeout of int - - (*----------------------------------------------------------------------------*) - - module Tester : sig - - val test : 'a tester - val test_ignore : 'a tester - val test_eq : ('a result -> 'a result -> bool) -> 'a tester - val test_eq_ok : ('a -> 'a -> bool) -> 'a tester - val test_eq_exn : (exn -> exn -> bool) -> 'a tester - val test_canon : ('a result -> 'a result) -> 'a tester - val test_canon_ok : ('a -> 'a) -> 'a tester - val test_canon_error : (exn -> exn) -> 'a tester - val test_translate : ('a -> 'b) -> 'b tester -> 'b Ty.ty -> 'a tester - - val io_test_ignore : io_tester - val io_test_equals : - ?trim: char list -> ?drop: char list -> io_tester - val io_test_lines : - ?trim: char list -> ?drop: char list -> - ?skip_empty: bool -> ?test_line: io_tester -> io_tester - val io_test_items : - ?split: char list -> ?trim: char list -> ?drop: char list -> - ?skip_empty: bool -> ?test_item: io_tester -> io_tester - - end - - (*----------------------------------------------------------------------------*) - - module Mutation : sig - - type 'arg arg_mutation_test_callbacks = - { before_reference : 'arg -> unit ; - before_user : 'arg -> unit ; - test : 'ret. ?test_result: 'ret tester -> 'ret tester } - - val arg_mutation_test_callbacks: - ?test: 'a tester -> dup: ('a -> 'a) -> blit:('a -> 'a -> unit) -> 'a Ty.ty -> - 'a arg_mutation_test_callbacks - - val array_arg_mutation_test_callbacks: - ?test: 'a array tester -> 'a array Ty.ty -> - 'a array arg_mutation_test_callbacks - - val ref_arg_mutation_test_callbacks: - ?test: 'a ref tester -> 'a ref Ty.ty -> - 'a ref arg_mutation_test_callbacks - - end - - (*----------------------------------------------------------------------------*) - - module Sampler : sig - type 'a sampler = unit -> 'a - 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 : ?min_size: int -> ?max_size: int -> ?dups: bool -> ?sorted: bool -> 'a sampler -> 'a list sampler - val sample_array : ?min_size: int -> ?max_size: int -> ?dups: bool -> ?sorted: bool -> 'a sampler -> 'a array sampler - val sample_pair : 'a sampler -> 'b sampler -> ('a * 'b) sampler - val sample_alternatively : 'a sampler list -> 'a sampler - val sample_cases : 'a list -> 'a sampler - val sample_option : 'a sampler -> 'a option sampler - - val printable_fun : string -> (_ -> _ as 'f) -> 'f - end - -(*----------------------------------------------------------------------------*) - - module Test_functions_ref_var : sig - - val test_ref : - 'a Ty.ty -> 'a ref -> 'a -> Learnocaml_report.t - - val test_variable : - 'a Ty.ty -> string -> 'a -> Learnocaml_report.t - - val test_variable_property : - 'a Ty.ty -> string -> ('a -> Learnocaml_report.t) -> Learnocaml_report.t - - val test_variable_against_solution : - 'a Ty.ty -> string -> Learnocaml_report.t - - end - - (*----------------------------------------------------------------------------*) - - module Test_functions_types : sig - val compatible_type : expected:string -> string -> Learnocaml_report.t - - val existing_type : ?score:int -> string -> bool * Learnocaml_report.t - - val abstract_type : ?allow_private:bool -> ?score:int -> string -> bool * Learnocaml_report.t - - val test_student_code : 'a Ty.ty -> ('a -> Learnocaml_report.t) -> Learnocaml_report.t - - val test_module_property : - 'a Ty.ty -> string -> ('a -> Learnocaml_report.t) -> Learnocaml_report.t - end - - (*----------------------------------------------------------------------------*) - - module Test_functions_function : sig - - val test_function_1 : - ?test: 'b tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before : ('a -> unit) -> - ?after : ('a -> ('b * string * string) -> ('b * string * string) -> Learnocaml_report.t) -> - ('a -> 'b) Ty.ty -> string -> ('a * 'b * string * string) list -> Learnocaml_report.t - - val test_function_1_against : - ?gen: int -> - ?test: 'b tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> unit) -> - ?before_user : ('a -> unit) -> - ?after : ('a -> ('b * string * string) -> ('b * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a) -> - ('a -> 'b) Ty.ty -> string -> ('a -> 'b) -> 'a list -> Learnocaml_report.t - - val test_function_1_against_solution : - ?gen: int -> - ?test: 'b tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> unit) -> - ?before_user : ('a -> unit) -> - ?after : ('a -> ('b * string * string) -> ('b * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a) -> - ('a -> 'b) Ty.ty -> string -> 'a list -> Learnocaml_report.t - - val test_function_1_against_postcond : - ?gen: int -> - ?test_stdout: io_postcond -> - ?test_stderr: io_postcond -> - ?before_reference : ('a -> unit) -> - ?before_user : ('a -> unit) -> - ?after : ('a -> ('b * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a) -> - ('a -> 'b Ty.ty -> 'b result -> Learnocaml_report.t) -> - ('a -> 'b) Ty.ty -> string -> 'a list -> Learnocaml_report.t - - (*----------------------------------------------------------------------------*) - - val test_function_2 : - ?test: 'c tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before : ('a -> 'b -> unit) -> - ?after : ('a -> 'b -> ('c * string * string) -> ('c * string * string) -> Learnocaml_report.t) -> - ('a -> 'b -> 'c) Ty.ty -> string -> ('a * 'b * 'c * string * string) list -> Learnocaml_report.t - - val test_function_2_against : - ?gen: int -> - ?test: 'c tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> 'b -> unit) -> - ?before_user : ('a -> 'b -> unit) -> - ?after : ('a -> 'b -> ('c * string * string) -> ('c * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b) -> - ('a -> 'b -> 'c) Ty.ty -> string -> ('a -> 'b -> 'c) -> ('a * 'b) list -> Learnocaml_report.t - - val test_function_2_against_solution : - ?gen: int -> - ?test: 'c tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> 'b -> unit) -> - ?before_user : ('a -> 'b -> unit) -> - ?after : ('a -> 'b -> ('c * string * string) -> ('c * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b) -> - ('a -> 'b -> 'c) Ty.ty -> string -> ('a * 'b) list -> Learnocaml_report.t - - val test_function_2_against_postcond : - ?gen: int -> - ?test_stdout: io_postcond -> - ?test_stderr: io_postcond -> - ?before_reference : ('a -> 'b -> unit) -> - ?before_user : ('a -> 'b -> unit) -> - ?after : ('a -> 'b -> ('c * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b) -> - ('a -> 'b -> 'c Ty.ty -> 'c result -> Learnocaml_report.t) -> - ('a -> 'b -> 'c) Ty.ty -> string -> ('a * 'b) list -> Learnocaml_report.t - - (*----------------------------------------------------------------------------*) - - val test_function_3 : - ?test: 'd tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before : ('a -> 'b -> 'c -> unit) -> - ?after : ('a -> 'b -> 'c -> ('d * string * string) -> ('d * string * string) -> Learnocaml_report.t) -> - ('a -> 'b -> 'c -> 'd) Ty.ty -> string -> ('a * 'b * 'c * 'd * string * string) list -> Learnocaml_report.t - - val test_function_3_against : - ?gen: int -> - ?test: 'd tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> 'b -> 'c -> unit) -> - ?before_user : ('a -> 'b -> 'c -> unit) -> - ?after : ('a -> 'b -> 'c -> ('d * string * string) -> ('d * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b * 'c) -> - ('a -> 'b -> 'c -> 'd) Ty.ty -> string -> ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) list -> Learnocaml_report.t - - val test_function_3_against_solution : - ?gen: int -> - ?test: 'd tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> 'b -> 'c -> unit) -> - ?before_user : ('a -> 'b -> 'c -> unit) -> - ?after : ('a -> 'b -> 'c -> ('d * string * string) -> ('d * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b * 'c) -> - ('a -> 'b -> 'c -> 'd) Ty.ty -> string -> ('a * 'b * 'c) list -> Learnocaml_report.t - - val test_function_3_against_postcond : - ?gen: int -> - ?test_stdout: io_postcond -> - ?test_stderr: io_postcond -> - ?before_reference : ('a -> 'b -> 'c -> unit) -> - ?before_user : ('a -> 'b -> 'c -> unit) -> - ?after : ('a -> 'b -> 'c -> ('d * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b * 'c) -> - ('a -> 'b -> 'c -> 'd Ty.ty -> 'd result -> Learnocaml_report.t) -> - ('a -> 'b -> 'c -> 'd) Ty.ty -> string -> ('a * 'b * 'c) list -> Learnocaml_report.t - - (*----------------------------------------------------------------------------*) - - val test_function_4 : - ?test: 'e tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before : ('a -> 'b -> 'c -> 'd -> unit) -> - ?after : ('a -> 'b -> 'c -> 'd -> ('e * string * string) -> ('e * string * string) -> Learnocaml_report.t) -> - ('a -> 'b -> 'c -> 'd -> 'e) Ty.ty -> string -> ('a * 'b * 'c * 'd * 'e * string * string) list -> Learnocaml_report.t - - val test_function_4_against : - ?gen: int -> - ?test: 'e tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> 'b -> 'c -> 'd -> unit) -> - ?before_user : ('a -> 'b -> 'c -> 'd -> unit) -> - ?after : ('a -> 'b -> 'c -> 'd -> ('e * string * string) -> ('e * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b * 'c * 'd) -> - ('a -> 'b -> 'c -> 'd -> 'e) Ty.ty -> string -> ('a -> 'b -> 'c -> 'd -> 'e) - -> ('a * 'b * 'c * 'd) list -> Learnocaml_report.t - - val test_function_4_against_solution : - ?gen: int -> - ?test: 'e tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : ('a -> 'b -> 'c -> 'd -> unit) -> - ?before_user : ('a -> 'b -> 'c -> 'd -> unit) -> - ?after : ('a -> 'b -> 'c -> 'd -> ('e * string * string) -> ('e * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b * 'c * 'd) -> - ('a -> 'b -> 'c -> 'd -> 'e) Ty.ty -> string -> ('a * 'b * 'c * 'd) list -> Learnocaml_report.t - - val test_function_4_against_postcond : - ?gen: int -> - ?test_stdout: io_postcond -> - ?test_stderr: io_postcond -> - ?before_reference : ('a -> 'b -> 'c -> 'd -> unit) -> - ?before_user : ('a -> 'b -> 'c -> 'd -> unit) -> - ?after : ('a -> 'b -> 'c -> 'd -> ('e * string * string) -> Learnocaml_report.t) -> - ?sampler : (unit -> 'a * 'b * 'c * 'd) -> - ('a -> 'b -> 'c -> 'd -> 'e Ty.ty -> 'e result -> Learnocaml_report.t) -> - ('a -> 'b -> 'c -> 'd -> 'e) Ty.ty -> string -> ('a * 'b * 'c * 'd) list -> Learnocaml_report.t - - end - - (*----------------------------------------------------------------------------*) - - module Test_functions_generic : sig - - val run_timeout : ?time:int -> (unit -> 'a) -> 'a - - val exec : (unit -> 'a) -> ('a * string * string) result - - val result : (unit -> 'a) -> 'a result - - (*----------------------------------------------------------------------------*) - - include (module type of Fun_ty - with type ('a, 'b, 'c) args = ('a, 'b, 'c) Fun_ty.args - and type ('a, 'b, 'c) fun_ty = ('a, 'b, 'c) Fun_ty.fun_ty) - - val ty_of_prot : - (('ar -> 'row) Ty.ty, 'ar -> 'urow, 'ret) fun_ty -> ('ar -> 'row) Ty.ty - [@@ocaml.deprecated "Use ty_of_fun_ty instead."] - - type 'a lookup = unit -> [ `Found of string * Learnocaml_report.t * 'a | `Unbound of string * Learnocaml_report.t ] - - val lookup : 'a Ty.ty -> ?display_name: string -> string -> 'a lookup - val lookup_student : 'a Ty.ty -> string -> 'a lookup - val lookup_solution : 'a Ty.ty -> string -> 'a lookup - val found : string -> 'a -> 'a lookup - val name : 'a lookup -> string - - val test_value : 'a lookup -> ('a -> Learnocaml_report.t) -> Learnocaml_report.t - - val test_function : - ?test: 'ret tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before : - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> - unit) -> - ?after : - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> - ('ret * string * string) -> - ('ret * string * string) -> - Learnocaml_report.t) -> - (('ar -> 'row) Ty.ty, 'ar -> 'urow, 'ret) fun_ty -> - ('ar -> 'row) lookup -> - (('ar -> 'row, 'ar -> 'urow, 'ret) args * (unit -> 'ret)) list -> - Learnocaml_report.t - - val test_function_against : - ?gen: int -> - ?test: 'ret tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference : - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> unit) -> - ?before_user : - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> unit) -> - ?after : - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> - ('ret * string * string) -> - ('ret * string * string) -> - Learnocaml_report.t) -> - ?sampler: - (unit -> ('ar -> 'row, 'ar -> 'urow, 'ret) args) -> - (('ar -> 'row) Ty.ty, 'ar -> 'urow, 'ret) fun_ty -> - ('ar -> 'row) lookup -> ('ar -> 'row) lookup -> - ('ar -> 'row, 'ar -> 'urow, 'ret) args list -> - Learnocaml_report.t - - val test_function_against_solution : - ?gen:int -> - ?test: 'ret tester -> - ?test_stdout: io_tester -> - ?test_stderr: io_tester -> - ?before_reference: - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> unit) -> - ?before_user: - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> unit) -> - ?after: - (('ar -> 'row, 'ar -> 'urow, 'ret) args -> - 'ret * string * string -> - 'ret * string * string -> - Learnocaml_report.item list) -> - ?sampler: - (unit -> ('ar -> 'row, 'ar -> 'urow, 'ret) args) -> - (('ar -> 'row) Ty.ty, 'ar -> 'urow, 'ret) fun_ty -> - string -> - ('ar -> 'row, 'ar -> 'urow, 'ret) args list -> - Learnocaml_report.item list - - val (==>) : 'params -> 'ret -> 'params * (unit -> 'ret) - - end - - val (@@@) : ('a -> Learnocaml_report.t) -> ('a -> Learnocaml_report.t) -> ('a -> Learnocaml_report.t) - val (@@>) : Learnocaml_report.t -> (unit -> Learnocaml_report.t) -> Learnocaml_report.t - val (@@=) : Learnocaml_report.t -> (unit -> Learnocaml_report.t) -> Learnocaml_report.t - - (**/**) - include (module type of Ast_checker) - include (module type of Tester) - include (module type of Mutation) - include (module type of Sampler) - include (module type of Test_functions_types) - include (module type of Test_functions_ref_var) - include (module type of Test_functions_function) - include (module type of Test_functions_generic) - -end - -module Make - (Params : sig - val results : Learnocaml_report.t option ref - (* val set_progress : string -> unit *) - val timeout : int option - module Introspection : Introspection_intf.INTROSPECTION - end) : S = struct +module Intro = Pre_test.Introspection let set_result report = - Params.results := Some report + Pre_test.results := Some report type nonrec 'a result = ('a, exn) result @@ -818,24 +372,24 @@ module Make (*----------------------------------------------------------------------------*) module Test_functions_types = struct - open Params + open Pre_test let compatible_type ~expected:exp got = let open Learnocaml_report in [ Message ([ Text "Checking that " ; Code got ; Text "is compatible with " ; Code exp ], Informative) ; - match Introspection.compatible_type exp ("Code." ^ got) with - | Introspection.Absent -> + match Intro.compatible_type exp ("Code." ^ got) with + | Intro.Absent -> Message ([ Text "Type not found" ], Failure) - | Introspection.Incompatible msg -> + | Intro.Incompatible msg -> Message ([ Text msg ], Failure) - | Introspection.Present () -> + | Intro.Present () -> Message ([ Text "Type found and compatible" ], Success 5) ] let existing_type ?(score = 1) name = let open Learnocaml_report in try - let lid = Longident.parse ("Code." ^ name) in + let[@alert "-deprecated"] lid = Longident.parse ("Code." ^ name) in let path, _ = Env.find_type_by_name lid !Toploop.toplevel_env in let _ = Env.find_type path !Toploop.toplevel_env in true, [ Message ( [ Text "Type" ; Code name ; Text "found" ], Success score ) ] @@ -844,7 +398,7 @@ module Make let abstract_type ?(allow_private = true) ?(score = 5) name = let open Learnocaml_report in try - let lid = Longident.parse ("Code." ^ name) in + let[@alert "-deprecated"] lid = Longident.parse ("Code." ^ name) in let path, _ = Env.find_type_by_name lid !Toploop.toplevel_env in match Env.find_type path !Toploop.toplevel_env with | { Types. type_kind = Types.Type_abstract ; Types. type_manifest = None; _ } -> @@ -857,20 +411,20 @@ module Make let test_student_code ty cb = let open Learnocaml_report in - match Introspection.get_value "Code" ty with - | Introspection.Present v -> cb v - | Introspection.Absent -> assert false - | Introspection.Incompatible msg -> + match Intro.get_value "Code" ty with + | Intro.Present v -> cb v + | Intro.Absent -> assert false + | Intro.Incompatible msg -> [ Message ([ Text "Your code doesn't match the expected signature." ; Break ; Code msg (* TODO: hide or fix locations *) ], Failure) ] let test_module_property ty name cb = let open Learnocaml_report in - match Introspection.get_value ("Code." ^ name) ty with - | Introspection.Present v -> cb v - | Introspection.Absent -> + match Intro.get_value ("Code." ^ name) ty with + | Intro.Present v -> cb v + | Intro.Absent -> [ Message ([ Text "Module" ; Code name ; Text "not found." ], Failure) ] - | Introspection.Incompatible msg -> + | Intro.Incompatible msg -> [ Message ([ Text "Module" ; Code name ; Text "doesn't match the expected signature." ; Break ; Code msg (* TODO: hide or fix locations *) ], Failure) ] @@ -888,7 +442,7 @@ module Make string -> Learnocaml_report.t let typed_printer ty ppf v = - Introspection.print_value ppf v ty + Intro.print_value ppf v ty exception Timeout of int @@ -1122,7 +676,7 @@ module Make (*----------------------------------------------------------------------------*) module Test_functions_generic = struct - open Params + open Pre_test open Tester let sigalrm_handler time = @@ -1139,23 +693,23 @@ module Make reset_sigalrm (); raise exc let run_timeout ?time v = - match time, Params.timeout with + match time, Pre_test.timeout with | Some time, _ | None, Some time -> run_timeout ~time v | None, None -> v() let exec v = - Introspection.grab_stdout () ; - Introspection.grab_stderr () ; + Intro.grab_stdout () ; + Intro.grab_stderr () ; try let res = run_timeout v in - let out = Introspection.release_stdout () in - let err = Introspection.release_stderr () in + let out = Intro.release_stdout () in + let err = Intro.release_stderr () in Ok (res, out, err) with exn -> - ignore (Introspection.release_stdout ()) ; - ignore (Introspection.release_stderr ()) ; + ignore (Intro.release_stdout ()) ; + ignore (Intro.release_stderr ()) ; Error exn let result v = match exec v with @@ -1212,7 +766,7 @@ module Make module Aux = struct let typed_printer = typed_printer - let typed_sampler = Introspection.get_sampler + let typed_sampler = Intro.get_sampler end module FunTyAux = Make(Aux) @@ -1223,16 +777,16 @@ module Make let lookup ty ?display_name name = let display_name = match display_name with None -> name | Some name -> name in let open Learnocaml_report in - let res = match Introspection.get_value name ty with - | Introspection.Present v -> + let res = match Intro.get_value name ty with + | Intro.Present v -> let msg = [ Message ([ Text "Found" ; Code display_name ; Text "with compatible type." ], Informative) ] in `Found (display_name, msg, v) - | Introspection.Absent -> + | Intro.Absent -> `Unbound (name, [ Message ([ Text "Cannot find " ; Code display_name ], Failure) ]) - | Introspection.Incompatible msg -> + | Intro.Incompatible msg -> `Unbound (name, [ Message ([ Text "Found" ; Code display_name ; Text "with unexpected type:" ; Break ; @@ -1241,16 +795,16 @@ module Make let lookup_student ty name = let open Learnocaml_report in - let res = match Introspection.get_value ("Code." ^ name) ty with - | Introspection.Present v -> + let res = match Intro.get_value ("Code." ^ name) ty with + | Intro.Present v -> let msg = [ Message ([ Text "Found" ; Code name ; Text "with compatible type." ], Informative) ] in `Found (name, msg, v) - | Introspection.Absent -> + | Intro.Absent -> `Unbound (name, [ Message ([ Text "Cannot find " ; Code name ], Failure) ]) - | Introspection.Incompatible msg -> + | Intro.Incompatible msg -> `Unbound (name, [ Message ([ Text "Found" ; Code name ; Text "with unexpected type:" ; Break ; @@ -1259,14 +813,14 @@ module Make let lookup_solution ty name = let open Learnocaml_report in - let res = match Introspection.get_value ("Solution." ^ name) ty with - | Introspection.Present v -> + let res = match Intro.get_value ("Solution." ^ name) ty with + | Intro.Present v -> `Found (name, [], v) - | Introspection.Absent -> + | Intro.Absent -> `Unbound (name, [ Message ([ Text "Looking for " ; Code name ], Informative) ; Message ([ Text "Solution not found!" ], Failure) ]) - | Introspection.Incompatible msg -> + | Intro.Incompatible msg -> `Unbound (name, [ Message ([ Text "Looking for " ; Code name ], Informative) ; Message ([ Text "Solution is wrong!" ; Break ; Code msg ], Failure) ]) in @@ -1814,7 +1368,12 @@ module Make include Test_functions_function include Test_functions_generic -end +(* end *) let () = Random.self_init () + +module Open_me = struct + module Report = Learnocaml_report + include Pre_test +end diff --git a/src/grader/test_lib.mli b/src/grader/test_lib.mli index 7d736127f..45e445205 100644 --- a/src/grader/test_lib.mli +++ b/src/grader/test_lib.mli @@ -8,7 +8,6 @@ (** Documentation for [test_lib] library. [Test_lib] module can be used to write graders for learn-ocaml. *) -module type S = sig val set_result : Learnocaml_report.t -> unit @@ -1248,12 +1247,18 @@ module type S = sig include (module type of Test_functions_ref_var) include (module type of Test_functions_function) include (module type of Test_functions_generic) +(* end *) + +(* module Make : functor + * (_ : sig + * val results : Learnocaml_report.t option ref + * val set_progress : string -> unit + * val timeout : int option + * module Introspection : Introspection_intf.INTROSPECTION + * end) -> S *) +(* module Report = Learnocaml_report + * include (module type of Pre_test) *) +module Open_me: sig + module Report = Learnocaml_report + include module type of Pre_test end - -module Make : functor - (_ : sig - val results : Learnocaml_report.t option ref - val set_progress : string -> unit - val timeout : int option - module Introspection : Introspection_intf.INTROSPECTION - end) -> S diff --git a/src/main/learnocaml_client.ml b/src/main/learnocaml_client.ml index f5ab864f4..723dc2ef6 100644 --- a/src/main/learnocaml_client.ml +++ b/src/main/learnocaml_client.ml @@ -792,13 +792,9 @@ module Grade = struct pr `Cyan "outcome" ex_outcome; if eo.verbosity >= 1 then prerr_newline (); match report with - | Error e -> - let str = - match Grading.string_of_exn e with - | Some s -> s - | None -> Printexc.to_string e - in - Printf.eprintf "[ERROR] Could not do the grading:\n%s\n" str; + | Error err -> + Printf.eprintf "[ERROR] Could not do the grading:\n%s\n" + (Grading.string_of_err err); Lwt.return 10 | Ok report -> (match eo.output_format with diff --git a/src/main/learnocaml_main.ml b/src/main/learnocaml_main.ml index 07f468717..ede893e25 100644 --- a/src/main/learnocaml_main.ml +++ b/src/main/learnocaml_main.ml @@ -111,38 +111,40 @@ module Args = struct type t = { exercises: string list; output_json: string option; + display_callback: bool; + dump_outputs: string option; + dump_reports: string option; } let grader_conf = - let apply exercises output_json = + let apply exercises output_json quiet dump_outputs dump_reports = let exercises = List.flatten exercises in - { exercises; output_json } + { exercises; output_json; display_callback = not quiet; + dump_outputs; dump_reports } in - Term.(const apply $exercises $output_json) + Term.(const apply $exercises $output_json $quiet $dump_outputs $dump_reports) let grader_cli = let apply - grade_student display_outcomes quiet display_std_outputs - dump_outputs dump_reports timeout verbose dump_dot + grade_student display_outcomes display_std_outputs + timeout verbose dump_dot = Grader_cli.grade_student := grade_student; Grader_cli.display_outcomes := display_outcomes; - Grader_cli.display_callback := not quiet; Grader_cli.display_std_outputs := display_std_outputs; - Grader_cli.dump_outputs := dump_outputs; - Grader_cli.dump_reports := dump_reports; Grader_cli.individual_timeout := timeout; Grader_cli.display_reports := verbose; Grader_cli.dump_dot := dump_dot; - Learnocaml_process_exercise_repository.dump_outputs := dump_outputs; - Learnocaml_process_exercise_repository.dump_reports := dump_reports; () in - Term.(const apply $grade_student $display_outcomes $quiet $display_std_outputs - $dump_outputs $dump_reports $timeout $verbose $dump_dot) + Term.(const apply $grade_student $display_outcomes $display_std_outputs + $timeout $verbose $dump_dot) let term = - let apply conf () = conf in + let apply conf () = + Learnocaml_process_exercise_repository.dump_outputs := conf.dump_outputs; + Learnocaml_process_exercise_repository.dump_reports := conf.dump_reports; + conf in Term.(const apply $grader_conf $grader_cli) end @@ -307,7 +309,11 @@ let main o = in Lwt.catch (fun () -> - Grader_cli.grade_from_dir ~print_result:true ex json_output + Grader_cli.grade_from_dir ~print_result:true + ~dump_outputs:o.grader.Grader.dump_outputs + ~dump_reports:o.grader.Grader.dump_reports + ~display_callback:o.grader.Grader.display_callback + ex json_output >|= function Ok () -> i | Error _ -> 1) (fun e -> Printf.ksprintf failwith diff --git a/src/ppx-metaquot/dune b/src/ppx-metaquot/dune index bb9b4fbb8..81a9bb7a5 100644 --- a/src/ppx-metaquot/dune +++ b/src/ppx-metaquot/dune @@ -24,10 +24,22 @@ (name learnocaml_ppx_metaquot) (wrapped false) (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree) - (modules Ppx_metaquot_main) + (modules Ppx_metaquot_register) (kind ppx_rewriter) ) +(executable + (name ppx_metaquot_main) + (modules ppx_metaquot_main) + (libraries learnocaml_ppx_metaquot)) + +(install + (section libexec) + (package learn-ocaml) + (files + (ppx_metaquot_main.exe as grading_ppx/learnocaml-ppx-metaquot)) +) + (library (name ty) (wrapped false) diff --git a/src/ppx-metaquot/ppx_metaquot_main.ml b/src/ppx-metaquot/ppx_metaquot_main.ml index 62a74f952..24d22a57f 100644 --- a/src/ppx-metaquot/ppx_metaquot_main.ml +++ b/src/ppx-metaquot/ppx_metaquot_main.ml @@ -1,3 +1,2 @@ let () = - Migrate_parsetree.Driver.register ~name:"ppx_metaquot" (module Migrate_parsetree.OCaml_412) - (fun _config _cookies -> Ppx_metaquot.Main.expander []) + Migrate_parsetree.Driver.run_as_ppx_rewriter ~exit_on_error:true () diff --git a/src/ppx-metaquot/ppx_metaquot_register.ml b/src/ppx-metaquot/ppx_metaquot_register.ml new file mode 100644 index 000000000..62a74f952 --- /dev/null +++ b/src/ppx-metaquot/ppx_metaquot_register.ml @@ -0,0 +1,3 @@ +let () = + Migrate_parsetree.Driver.register ~name:"ppx_metaquot" (module Migrate_parsetree.OCaml_412) + (fun _config _cookies -> Ppx_metaquot.Main.expander []) diff --git a/src/repo/dune b/src/repo/dune index a82d333a3..6ff5ce7cf 100644 --- a/src/repo/dune +++ b/src/repo/dune @@ -41,9 +41,10 @@ (name learnocaml_process_repository_lib) (wrapped false) (modules Learnocaml_process_common + Learnocaml_precompile_exercise Learnocaml_process_exercise_repository Learnocaml_process_tutorial_repository - Learnocaml_process_playground_repository) + Learnocaml_process_playground_repository) (libraries ezjsonm str lwt.unix diff --git a/src/repo/learnocaml_exercise.ml b/src/repo/learnocaml_exercise.ml index b010eaa22..9698ec69e 100644 --- a/src/repo/learnocaml_exercise.ml +++ b/src/repo/learnocaml_exercise.ml @@ -8,36 +8,67 @@ type id = string +type compiled_lib = { cma: string; js: string } + +type compiled = { + prelude_cmi: string; + prepare_cmi: string; + solution_cmi: string; + test_cmi: string; + exercise_lib: compiled_lib; (* includes prelude, prepare and solution *) + test_lib: compiled_lib; +} + type t = { id : id ; - prelude : string ; + prelude_ml : string ; template : string ; - descr : (string * string) list ; - prepare : string ; - test : string ; solution : string ; + (* absent from the json, empty except when building the exercises *) + descr : (string * string) list ; + compiled : compiled ; max_score : int ; depend : string option ; - dependencies : string list; + dependencies : string list; (* TODO: move to test.cma + list of cmi file contents *) } let encoding = let open Json_encoding in + let compiled_lib_encoding = + conv + (fun {cma; js} -> cma, js) + (fun (cma, js) -> {cma; js}) + (obj2 + (dft "cma" string "") + (dft "js" string "")) + in + let compiled_encoding = + conv + (fun {prelude_cmi; prepare_cmi; solution_cmi; test_cmi; exercise_lib; test_lib} -> + (prelude_cmi, prepare_cmi, solution_cmi, test_cmi, exercise_lib, test_lib)) + (fun (prelude_cmi, prepare_cmi, solution_cmi, test_cmi, exercise_lib, test_lib) -> + {prelude_cmi; prepare_cmi; solution_cmi; test_cmi; exercise_lib; test_lib}) + (obj6 + (req "prelude_cmi" string) + (req "prepare_cmi" string) + (req "solution_cmi" string) + (req "test_cmi" string) + (req "exercise_lib" compiled_lib_encoding) + (req "test_lib" compiled_lib_encoding)) + in conv - (fun { id ; prelude ; template ; descr ; prepare ; test ; solution ; max_score ; depend ; dependencies} -> - id, prelude, template, descr, prepare, test, solution, max_score,depend, dependencies) - (fun (id, prelude, template, descr, prepare, test, solution, max_score,depend, dependencies) -> - { id ; prelude ; template ; descr ; prepare ; test ; solution ; max_score ; depend ; dependencies}) - (obj10 + (fun { id ; prelude_ml ; template ; descr ; compiled ; max_score ; depend ; dependencies ; solution = _} -> + (id, prelude_ml, template, descr, compiled, max_score, depend, dependencies)) + (fun ((id, prelude_ml, template, descr, compiled, max_score, depend, dependencies)) -> + { id ; prelude_ml ; template ; descr ; compiled ; max_score ; depend ; dependencies; solution = ""}) + (obj8 (req "id" string) - (req "prelude" string) + (req "prelude_ml" string) (req "template" string) (req "descr" (list (tup2 string string))) - (req "prepare" string) - (req "test" string) - (req "solution" string) + (req "compiled" compiled_encoding) (req "max-score" int) - (opt "depend" (string)) + (opt "depend" string) (dft "dependencies" (list string) [])) (* let meta_from_string m = @@ -153,11 +184,11 @@ module File = struct field = (fun ex -> ex.max_score); update = (fun max_score ex -> { ex with max_score }); } - let prelude = + let prelude_ml = { key = "prelude.ml" ; ciphered = false ; decode = (fun v -> v) ; encode = (fun v -> v) ; - field = (fun ex -> ex.prelude) ; - update = (fun prelude ex -> { ex with prelude }) + field = (fun ex -> ex.prelude_ml) ; + update = (fun prelude_ml ex -> { ex with prelude_ml }) } let template = { key = "template.ml" ; ciphered = false ; @@ -165,31 +196,54 @@ module File = struct field = (fun ex -> ex.template) ; update = (fun template ex -> { ex with template }) } + let solution = + { key = "solution.ml" ; ciphered = false ; + decode = (fun v -> v) ; encode = (fun v -> v) ; + field = (fun ex -> ex.solution) ; + update = (fun solution ex -> { ex with solution }) + } let descr : (string * string) list file = { key = "descr.html" ; ciphered = false ; decode = descrs_from_string ; encode = descrs_to_string ; field = (fun ex -> ex.descr) ; update = (fun descr ex -> { ex with descr }) } - let prepare = - { key = "prepare.ml" ; ciphered = true ; - decode = (fun v -> v) ; encode = (fun v -> v) ; - field = (fun ex -> ex.prepare) ; - update = (fun prepare ex -> { ex with prepare }) - } - let test = - { key = "test.ml" ; ciphered = true ; + let compiled key get set = + { key; ciphered = true ; decode = (fun v -> v) ; encode = (fun v -> v) ; - field = (fun ex -> ex.test) ; - update = (fun test ex -> { ex with test }) - } - let solution = - { key = "solution.ml" ; ciphered = true ; - decode = (fun v -> v) ; encode = (fun v -> v) ; - field = (fun ex -> ex.solution) ; - update = (fun solution ex -> { ex with solution }) - } - + field = (fun ex -> get ex.compiled) ; + update = (fun v ex -> { ex with compiled = set v ex.compiled }) } + let prelude_cmi = + compiled "prelude.cmi" + (fun comp -> comp.prelude_cmi) + (fun prelude_cmi c -> { c with prelude_cmi }) + let prepare_cmi = + compiled "prepare.cmi" + (fun comp -> comp.prepare_cmi) + (fun prepare_cmi c -> { c with prepare_cmi }) + let solution_cmi = + compiled "solution.cmi" + (fun comp -> comp.solution_cmi) + (fun solution_cmi c -> { c with solution_cmi }) + let test_cmi = + compiled "test.cmi" + (fun comp -> comp.test_cmi) + (fun test_cmi c -> { c with test_cmi }) + let compiled_lib key get set = + compiled (key^".cma") + (fun comp -> (get comp).cma) + (fun cma c -> let l = get c in set { l with cma } c), + compiled (key^".js") + (fun comp -> (get comp).js) + (fun js c -> let l = get c in set { l with js } c) + let exercise_cma, exercise_js = + compiled_lib "exercise" + (fun comp -> comp.exercise_lib) + (fun exercise_lib c -> { c with exercise_lib }) + let test_cma, test_js = + compiled_lib "test" + (fun comp -> comp.test_lib) + (fun test_lib c -> { c with test_lib }) let depend = { key = "depend.txt" ; ciphered = false ; decode = (fun v -> Some v) ; @@ -352,12 +406,18 @@ module File = struct in join [ (* read_title () ; *) - read_file prelude ; + read_file prelude_ml ; read_file template ; - read_descrs () ; - read_file prepare ; read_file solution ; - read_file test ; + read_descrs () ; + read_file prelude_cmi ; + read_file prepare_cmi ; + read_file solution_cmi ; + read_file test_cmi ; + read_file exercise_cma ; + read_file exercise_js ; + read_file test_cma ; + read_file test_js ; read_file depend ; (* read_max_score () *) ] >>= fun () -> join (List.map read_file (dependencies (get_opt depend !ex))) >>= fun () -> @@ -408,12 +468,24 @@ module MakeReaderAnddWriter (Concur : Concur) = struct return { id = field_from_file File.id ex; (* meta = field_from_file File.meta ex; *) - prelude = field_from_file File.prelude ex ; + prelude_ml = field_from_file File.prelude_ml ex ; template = field_from_file File.template ex ; - descr = field_from_file File.descr ex ; - prepare = field_from_file File.prepare ex ; - test = field_from_file File.test ex ; solution = field_from_file File.solution ex ; + descr = field_from_file File.descr ex ; + compiled = { + prelude_cmi = field_from_file File.prelude_cmi ex; + prepare_cmi = field_from_file File.prepare_cmi ex; + solution_cmi = field_from_file File.solution_cmi ex; + test_cmi = field_from_file File.test_cmi ex; + exercise_lib = { + cma = field_from_file File.exercise_cma ex; + js = field_from_file File.exercise_js ex; + }; + test_lib = { + cma = field_from_file File.test_cma ex; + js = field_from_file File.test_js ex; + }; + }; max_score = 0 ; depend ; dependencies = @@ -450,12 +522,17 @@ module MakeReaderAnddWriter (Concur : Concur) = struct ([ write_field id ; (* write_field meta ; * write_field title ; *) - write_field prelude ; + write_field prelude_ml ; write_field template ; + (* solution not written on purpose *) write_field descr ; - write_field prepare ; - write_field solution ; - write_field test ; + write_field prelude_cmi ; + write_field prepare_cmi ; + write_field solution_cmi ; + write_field exercise_cma ; + write_field exercise_js ; + write_field test_cma ; + write_field test_js ; write_field depend ; (* write_field max_score *) ] @ (List.map write_field (dependencies (access depend ex))) ) diff --git a/src/repo/learnocaml_exercise.mli b/src/repo/learnocaml_exercise.mli index a2b1d286e..1f80480c6 100644 --- a/src/repo/learnocaml_exercise.mli +++ b/src/repo/learnocaml_exercise.mli @@ -13,6 +13,8 @@ type t type id = string +type compiled_lib = { cma: string; js: string } + (* JSON encoding of the exercise representation. Includes cipher and decipher at at encoding and decoding. *) val encoding: t Json_encoding.encoding @@ -54,20 +56,31 @@ module File : sig (** Maximum score for the exercise *) val max_score: int file - (** Returns the (private, already deciphered) [prepare.ml] *) - val prepare: string file + (** Returns the (public) [prelude.ml] *) + val prelude_ml: string file - (** Returns the (private, already deciphered) [solution.ml] *) + (** Returns the (public) [template.ml] *) + val template: string file + + (** Returns the (private) [solution.ml], only when loaded from disk (for + building the exercises). Otherwise the empty string *) val solution: string file - (** Returns the (private, already deciphered) [test.ml] *) - val test: string file + val prelude_cmi: string file - (** Returns the (public) [prelude.ml] *) - val prelude: string file + val prepare_cmi: string file - (** Returns the (public) [template.ml] *) - val template: string file + val solution_cmi: string file + + val test_cmi: string file + + val exercise_cma: string file + + val exercise_js: string file + + val test_cma: string file + + val test_js: string file (** Returns the (public) [descr.html] *) val descr: (string * string) list file diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml new file mode 100644 index 000000000..e1db9d4f8 --- /dev/null +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -0,0 +1,75 @@ +(* Compile objects from an exercise *) + +open Lwt.Infix + +(* FIXME: make these configurable *) +let grading_cmis_dir, grading_ppx_dir = + let prefix = Filename.dirname (Filename.dirname (Sys.executable_name)) in + let ( / ) = Filename.concat in + ref (prefix/"share"/"learn-ocaml"/"grading_cmis"), + ref (prefix/"lib"/"learn-ocaml"/"grading_ppx") + +let run ?dir cmd args = + Lwt_process.exec ?cwd:dir ("", Array.of_list (cmd::args)) >>= function + | Unix.WEXITED 0 -> Lwt.return_unit + | _ -> Lwt.fail_with ("Compilation failed: " ^ String.concat " " (cmd::args)) + +let is_fresh = + let mtime f = Unix.((stat f).st_mtime) in + let exe_mtime = + try mtime (Sys.executable_name) with Unix.Unix_error _ -> max_float + in + fun ?(dir=".") target srcs -> + let target = Filename.concat dir target in + let srcs = List.map (Filename.concat dir) srcs in + try + let mt = mtime target in + 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 d = Filename.concat dir in + if is_fresh ~dir target source then Lwt.return_unit else + 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 + run "ocamlc" 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" :: "--pretty" :: args in + let args = args @ [d source; "-o"; d target] in + run "js_of_ocaml" args + +let precompile ~exercise_dir = + let dir = exercise_dir in + ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"] + ~source:["prelude.ml"] ~target:"prelude.cmo" + >>= fun () -> + ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"; "Prelude"] + ~source:["prepare.ml"] ~target:"prepare.cmo" + >>= fun () -> + ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"] + ~source:["solution.ml"] ~target:"solution.cmo" + >>= fun () -> + Lwt.join [ + (ocamlc ~dir ["-a"] + ~source:["prelude.cmo"; "prepare.cmo"; "solution.cmo"] + ~target:"exercise.cma" + >>= fun () -> + jsoo ~dir [] ~source:"exercise.cma" ~target:"exercise.js"); + (ocamlc ~dir ["-c"; + "-I"; "+compiler-libs"; + "-ppx"; Filename.concat !grading_ppx_dir "learnocaml-ppx-metaquot" ] + ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"; "Test_lib.Open_me"] + ~source:["test.ml"] + ~target:"test.cmo" + >>= fun () -> + (* Todo: support for depends.txt *) + ocamlc ~dir ["-a"; (* "-linkall" *)] + ~source:["test.cmo"] + ~target:"test.cma" + >>= fun () -> + jsoo ~dir [] ~source:"test.cma" ~target:"test.js"); + ] diff --git a/src/repo/learnocaml_process_exercise_repository.ml b/src/repo/learnocaml_process_exercise_repository.ml index bfe9abc7f..7b7c63a3b 100644 --- a/src/repo/learnocaml_process_exercise_repository.ml +++ b/src/repo/learnocaml_process_exercise_repository.ml @@ -68,29 +68,22 @@ let spawn_grader ) in sleep () >>= fun () -> - Lwt_io.flush_all () >>= fun () -> - match Lwt_unix.fork () with - | 0 -> - Grader_cli.dump_outputs := dump_outputs; - Grader_cli.dump_reports := dump_reports; - Grader_cli.display_callback := false; - Lwt_main.run - (Lwt.catch (fun () -> - Grader_cli.grade ?print_result ?dirname meta exercise output_json - >|= fun r -> - print_grader_error exercise r; - match r with - | Ok () -> exit 0 - | Error _ -> exit 1) - (fun e -> - Printf.eprintf "%!Grader error: %s\n%!" (Printexc.to_string e); - exit 10)) - | pid -> - Lwt_unix.waitpid [] pid >>= fun (_pid, ret) -> + Lwt.catch (fun () -> + Grader_cli.grade + ~dump_outputs ~dump_reports ~display_callback:false + ?print_result ?dirname meta exercise output_json + >|= fun r -> + print_grader_error exercise r; incr n_processes; - match ret with - | Unix.WEXITED 0 -> Lwt.return (Ok ()) - | _ -> Lwt.return (Error (-1)) + r) + (fun e -> + incr n_processes; + Printf.eprintf "Grader error: %s\n%!" (Printexc.to_string e); + Lwt.return (Error 0)) + +let exe_mtime = + try Unix.((stat (Sys.executable_name)).st_mtime) + with Unix.Unix_error _ -> max_float let main dest_dir = let exercises_index = @@ -173,10 +166,9 @@ let main dest_dir = else from_file Meta.enc (!exercises_dir / id / "meta.json") - >>= fun meta -> - read_exercise (!exercises_dir / id) - >|= fun exercise -> - SMap.add id exercise all_exercises, + >|= fun meta -> + let exercise_dir = !exercises_dir / id in + SMap.add id exercise_dir all_exercises, (id, Some meta) :: acc) (all_exercises, []) (List.rev ids) >>= fun (all_exercises, exercises) -> @@ -195,11 +187,11 @@ let main dest_dir = let processes_arguments = List.rev @@ SMap.fold - (fun id exercise acc -> - let exercise_dir = !exercises_dir / id in + (fun id exercise_dir acc -> let json_path = dest_dir / Learnocaml_index.exercise_path id in let changed = try let { Unix.st_mtime = json_time ; _ } = Unix.stat json_path in + exe_mtime >= json_time || Sys.readdir exercise_dir |> Array.to_list |> List.map (fun f -> (Unix.stat (exercise_dir / f)).Unix.st_mtime ) |> @@ -213,7 +205,7 @@ let main dest_dir = match !dump_reports with | None -> None | Some dir -> Some (dir / id) in - (id, exercise_dir, exercise, json_path, + (id, exercise_dir, json_path, changed, dump_outputs, dump_reports) :: acc) all_exercises [] in begin @@ -222,15 +214,16 @@ let main dest_dir = Lwt_list.map_s, fun dump_outputs dump_reports ?print_result ?dirname meta exercise json_path -> - Grader_cli.dump_outputs := dump_outputs; - Grader_cli.dump_reports := dump_reports; - Grader_cli.grade ?print_result ?dirname meta exercise json_path + Grader_cli.grade + ~dump_outputs ~dump_reports ~display_callback:true + ?print_result ?dirname + meta exercise json_path >|= fun r -> print_grader_error exercise r; r else Lwt_list.map_p, spawn_grader in - listmap (fun (id, ex_dir, exercise, json_path, changed, dump_outputs,dump_reports) -> + listmap (fun (id, ex_dir, json_path, changed, dump_outputs,dump_reports) -> let dst_ex_dir = String.concat Filename.dir_sep [dest_dir; "static"; id] in Lwt_utils.mkdir_p dst_ex_dir >>= fun () -> Lwt_stream.iter_p (fun base -> @@ -242,10 +235,14 @@ let main dest_dir = (Lwt_unix.files_of_directory ex_dir) >>= fun () -> if not changed then begin Format.printf "%-24s (no changes)@." id ; - Lwt.return true + Lwt.return_true end else begin + Learnocaml_precompile_exercise.precompile ~exercise_dir:ex_dir + >>= fun () -> + read_exercise ex_dir + >>= fun exercise -> grade dump_outputs dump_reports - ~dirname:(!exercises_dir / id) (Index.find index id) exercise (Some json_path) + ~dirname:ex_dir (Index.find index id) exercise (Some json_path) >>= function | Ok () -> Format.printf "%-24s [OK]@." id ; diff --git a/src/toplevel/learnocaml_toplevel.ml b/src/toplevel/learnocaml_toplevel.ml index e006ca755..743494964 100644 --- a/src/toplevel/learnocaml_toplevel.ml +++ b/src/toplevel/learnocaml_toplevel.ml @@ -259,6 +259,38 @@ let load top ?(print_outcome = true) ?timeout ?message content = warnings ; Lwt.return result +let load_js top ?(print_outcome = true) ?message content = + let phrase = Learnocaml_toplevel_output.phrase () in + protect_execution top @@ fun () -> + begin match message with + | None -> () + | Some message -> + Learnocaml_toplevel_output.output_code ~phrase top.output + ("(* " ^ message ^ "*)") + end ; + let pp_answer = + if print_outcome then + Learnocaml_toplevel_output.output_answer ~phrase top.output + else + ignore in + Lwt.protected @@ + Learnocaml_toplevel_worker_caller.use_compiled_string + top.worker ~pp_answer content + >>= fun result -> + let warnings, result = match Toploop_results.to_report result with + | Ok (result, warnings) -> warnings, result + | Error (error, warnings) -> + Learnocaml_toplevel_output.output_error top.output error ; + warnings, false in + List.iter + (Learnocaml_toplevel_output.output_warning top.output) + warnings ; + Lwt.return result + +let load_cmi_from_string top cmi = + protect_execution top @@ fun () -> + Learnocaml_toplevel_worker_caller.load_cmi_from_string top.worker cmi + let make_timeout_popup ?(countdown = 10) ?(refill_step = 10) diff --git a/src/toplevel/learnocaml_toplevel.mli b/src/toplevel/learnocaml_toplevel.mli index 9753876b5..1588c6eee 100644 --- a/src/toplevel/learnocaml_toplevel.mli +++ b/src/toplevel/learnocaml_toplevel.mli @@ -125,6 +125,25 @@ val load: ?message: string -> string -> bool Lwt.t +(** Loads a given piece of code, without displaying its output. The code is + expected to be already compiled to js. + + @param print_outcome + Tells if answers of the toplevel are to be displayed. + @param message + Displays [(* message *)] where the code should have been echoed. + @return + Returns [Success true] whenever the code was correctly + typechecked and its evaluation did not raise an exception nor + timeouted and [false] otherwise. *) +val load_js: + t -> + ?print_outcome:bool -> + ?message: string -> + string -> bool Lwt.t + +val load_cmi_from_string: t -> string -> unit Toploop_results.toplevel_result Lwt.t + (** Parse and typecheck a given source code. *) val check: t -> string -> unit Toploop_results.toplevel_result Lwt.t diff --git a/src/toplevel/learnocaml_toplevel_worker_caller.ml b/src/toplevel/learnocaml_toplevel_worker_caller.ml index 2c5e52960..a348be112 100644 --- a/src/toplevel/learnocaml_toplevel_worker_caller.ml +++ b/src/toplevel/learnocaml_toplevel_worker_caller.ml @@ -138,11 +138,13 @@ let ty_of_host_msg : type t. t host_msg -> t msg_ty = function | Reset -> Unit | Execute _ -> Bool | Use_string _ -> Bool + | Use_compiled_string _ -> Bool | Use_mod_string _ -> Bool | Set_debug _ -> Unit | Check _ -> Unit | Set_checking_environment -> Unit | Register_callback _ -> Unit + | Load_cmi_from_string _ -> Unit (** Threads created with [post] will always be wake-uped by [onmessage] by calling [Lwt.wakeup]. They should never end with @@ -253,6 +255,13 @@ let execute worker ?pp_code ~pp_answer ~print_outcome code = close_fd worker pp_answer; Lwt.return result +let use_compiled_string worker ~pp_answer code = + let pp_answer = create_fd worker pp_answer in + post worker @@ + Use_compiled_string (pp_answer, code) >>= fun result -> + close_fd worker pp_answer; + Lwt.return result + let use_string worker ?filename ~pp_answer ~print_outcome code = let pp_answer = create_fd worker pp_answer in post worker @@ @@ -275,3 +284,7 @@ let register_callback worker name callback = let fd = create_fd worker callback in post worker (Register_callback (name, fd)) >>? fun () -> return_unit_success + +let load_cmi_from_string worker cmi = + post worker @@ + Load_cmi_from_string cmi diff --git a/src/toplevel/learnocaml_toplevel_worker_caller.mli b/src/toplevel/learnocaml_toplevel_worker_caller.mli index b8ed084dd..9cf2d3595 100644 --- a/src/toplevel/learnocaml_toplevel_worker_caller.mli +++ b/src/toplevel/learnocaml_toplevel_worker_caller.mli @@ -84,6 +84,18 @@ val execute: val set_checking_environment: t -> unit toplevel_result Lwt.t +(** Execute a given compiled code (ocaml object or jsoo-compiled version). + + @param pp_answer see {!val:execute}. + + @return as {!val:execute}. + +*) +val use_compiled_string: + t -> + pp_answer:(string -> unit) -> + string -> bool toplevel_result Lwt.t + (** Execute a given source code. The code is parsed and typechecked all at once before to start the evaluation. @@ -131,6 +143,7 @@ val register_callback : t -> string -> (string -> unit) -> unit toplevel_result environment. *) val reset: t -> ?timeout:(unit -> unit Lwt.t) -> unit -> unit Lwt.t +val load_cmi_from_string: t -> string -> unit toplevel_result Lwt.t (** Terminate the toplevel, i.e. destroy the Web Worker. It does nothing if the toplevel as been created with [async=false]. *) diff --git a/src/toplevel/learnocaml_toplevel_worker_main.ml b/src/toplevel/learnocaml_toplevel_worker_main.ml index 9d2c7f022..2850a6754 100644 --- a/src/toplevel/learnocaml_toplevel_worker_main.ml +++ b/src/toplevel/learnocaml_toplevel_worker_main.ml @@ -161,6 +161,20 @@ let handler : type a. a host_msg -> a return Lwt.t = function iter_option close_fd fd_code; close_fd fd_answer; unwrap_result result + | Use_compiled_string (fd_answer, js_code) -> + let ppf_answer = make_answer_ppf fd_answer in + if !debug then + Js_utils.debug "Worker: -> Use_js_string (%S)" js_code; + let result = + try Toploop_jsoo.use_compiled_string js_code; Toploop_ext.Ok (true, []) + with exn -> + Firebug.console##log (Js.string (Printexc.to_string exn)); + Format.fprintf ppf_answer "%s" (Printexc.to_string exn); Toploop_ext.Ok (false, []) + in + if !debug then + Js_utils.debug "Worker: <- Use_js_string (%B)" (is_success result); + close_fd fd_answer; + unwrap_result result | Use_string (filename, print_outcome, fd_answer, code) -> let ppf_answer = make_answer_ppf fd_answer in if !debug then @@ -217,17 +231,22 @@ let handler : type a. a host_msg -> a return Lwt.t = function let result = Toploop_ext.check code in Toploop.toplevel_env := saved ; unwrap_result result + | Load_cmi_from_string cmi -> + Toploop_ext.load_cmi_from_string cmi; + return_unit_success let ty_of_host_msg : type t. t host_msg -> t msg_ty = function | Init -> Unit | Reset -> Unit | Execute _ -> Bool | Use_string _ -> Bool + | Use_compiled_string _ -> Bool | Use_mod_string _ -> Bool | Set_debug _ -> Unit | Check _ -> Unit | Set_checking_environment -> Unit | Register_callback _ -> Unit + | Load_cmi_from_string _ -> Unit let () = let handler (type t) data = diff --git a/src/toplevel/learnocaml_toplevel_worker_messages.mli b/src/toplevel/learnocaml_toplevel_worker_messages.mli index 146745817..da75446aa 100644 --- a/src/toplevel/learnocaml_toplevel_worker_messages.mli +++ b/src/toplevel/learnocaml_toplevel_worker_messages.mli @@ -15,11 +15,13 @@ type _ host_msg = | Reset : unit host_msg | Execute : int option * bool * int * string -> bool host_msg | Use_string : string option * bool * int * string -> bool host_msg + | Use_compiled_string : int * string -> bool host_msg | Use_mod_string : int * bool * string * string option * string -> bool host_msg | Set_debug : bool -> unit host_msg | Register_callback : string * int -> unit host_msg | Set_checking_environment : unit host_msg | Check : string -> unit host_msg + | Load_cmi_from_string : string -> unit host_msg type _ msg_ty = | Unit : unit msg_ty diff --git a/src/toploop/dune b/src/toploop/dune index a6ff55a40..f5d088ad3 100644 --- a/src/toploop/dune +++ b/src/toploop/dune @@ -22,12 +22,13 @@ (libraries js_of_ocaml-compiler toploop) (modules Toploop_jsoo) (preprocess (pps js_of_ocaml-ppx)) + (js_of_ocaml (flags :standard --pretty)) ) (library (name toploop_unix) (wrapped false) (modes byte) - (libraries lwt.unix toploop) + (libraries toploop dynlink) (modules Toploop_unix) ) diff --git a/src/toploop/toploop_ext.ml b/src/toploop/toploop_ext.ml index 7e38a147a..9510502c8 100644 --- a/src/toploop/toploop_ext.ml +++ b/src/toploop/toploop_ext.ml @@ -239,3 +239,35 @@ let check ?(setenv = false) code = | End_of_file -> return_success () | exn -> return_exn exn +let inject_sig name sign = + Toploop.toplevel_env := + Env.add_module + (Ident.create_persistent name) + Types.Mp_present + (Types.Mty_signature sign) + !Toploop.toplevel_env + +let load_cmi_from_string cmi_str = + (* Cmi_format.input_cmi only supports reading from a channel *) + let magic_len = String.length Config.cmi_magic_number in + if String.length cmi_str < magic_len || + String.sub cmi_str 0 magic_len <> Config.cmi_magic_number then + Printf.ksprintf failwith "Bad cmi file"; + let (name, sign) = Marshal.from_string cmi_str magic_len in + (* we ignore crc and flags *) + inject_sig name sign + +let inject_global_hook: (Ident.t -> unit) ref = ref (fun _ -> ()) + +let set_inject_global_hook f = inject_global_hook := f + +let inject_global name obj = + let id = Ident.create_persistent name in + let fake_buf = Misc.LongString.create 4 in + let reloc = [Cmo_format.Reloc_setglobal id, 0] in + Symtable.patch_object fake_buf reloc; + (* we don't care about patching but this is the only entry point that allows us to register the global *) + Symtable.check_global_initialized reloc; + Symtable.update_global_table (); + Symtable.assign_global_value id obj; + !inject_global_hook id diff --git a/src/toploop/toploop_ext.mli b/src/toploop/toploop_ext.mli index 75f0c3c8b..3139d5a7d 100644 --- a/src/toploop/toploop_ext.mli +++ b/src/toploop/toploop_ext.mli @@ -91,6 +91,19 @@ val use_mod_string: ?sig_code:string -> string -> bool toplevel_result +(** Registers the given cmi files contents into the running toplevel *) +val load_cmi_from_string: + string -> unit + +(** Registers a global into the toplevel. Can be used to dynamically create + compilation units ([inject_global "Foo" (Obj.repr (module Foo))]). Does not + affect the environment (suppose a corresponding .cmi) *) +val inject_global: string -> Obj.t -> unit + +(** Register a hook to be called after inject_global on the newly registered + ident. Useful for jsoo which has additional registrations required. *) +val set_inject_global_hook: (Ident.t -> unit) -> unit + (** Helpers to embed PPX into the toplevel. *) module Ppx : sig val preprocess_structure: Parsetree.structure -> Parsetree.structure diff --git a/src/toploop/toploop_jsoo.ml b/src/toploop/toploop_jsoo.ml index 35d36f3c5..934183de2 100644 --- a/src/toploop/toploop_jsoo.ml +++ b/src/toploop/toploop_jsoo.ml @@ -128,3 +128,26 @@ let stop_channel_redirection redir = Sys_js.set_channel_flusher redir.channel append ; with Not_found -> fail () + +let use_compiled_string code = + (* jsoo supports dynload, but relies on expectations on the parent object that + are no longer valid when running from a web-worker. Thus we compile with + `jsoo --wrap-with` and apply explicitely to the global object *) + let clean_code = + let b = Buffer.create (String.length code + 2) in + let i = String.rindex code '}' in + (* jsoo >=4 adds garbage after the fun def with --wrap-with *) + Buffer.add_char b '('; + Buffer.add_substring b code 0 (i+1); + Buffer.add_char b ')'; + Buffer.contents b + in + ignore @@ + Js.Unsafe.fun_call (Js.Unsafe.eval_string clean_code) + [|Js.Unsafe.inject Js.Unsafe.global|] + +let () = Toploop_ext.set_inject_global_hook @@ fun id -> + Js_of_ocaml.Js.Unsafe.set + (Js_of_ocaml.Js.Unsafe.js_expr "jsoo_runtime.caml_global_data") + (Js_of_ocaml.Js.string (Ident.name id)) + (Symtable.get_global_value id) diff --git a/src/toploop/toploop_jsoo.mli b/src/toploop/toploop_jsoo.mli index 387de8c75..d41208ebc 100644 --- a/src/toploop/toploop_jsoo.mli +++ b/src/toploop/toploop_jsoo.mli @@ -10,6 +10,9 @@ argument*) val initialize: string list -> unit +(** Load compiled code as a string *) +val use_compiled_string: string -> unit + (** Materializes an output channel redirection. *) type redirection diff --git a/src/toploop/toploop_unix.ml b/src/toploop/toploop_unix.ml index 27f23201f..2d9805f8a 100644 --- a/src/toploop/toploop_unix.ml +++ b/src/toploop/toploop_unix.ml @@ -70,3 +70,25 @@ let stop_channel_redirection ({ target_fd ; read_fd ; backup_fd ; _ } as redirec let initialize () = Toploop.initialize_toplevel_env () + +let use_compiled_string code = + let cma = Filename.temp_file "learnocaml-file" ".cma" in + let r = + try + let oc = open_out_bin cma in + output_string oc code; + close_out oc; + Topdirs.load_file Format.std_formatter cma + with + | Symtable.Error e -> + Format.kasprintf (fun msg -> Sys.remove cma; failwith msg) + "%a" + Symtable.report_error e + | exn -> + Sys.remove cma; + raise exn + in + Sys.remove cma; + flush_all (); + if r then () + else failwith "Failed to load compiled code" diff --git a/src/toploop/toploop_unix.mli b/src/toploop/toploop_unix.mli index 7a7c0d736..0d533ad73 100644 --- a/src/toploop/toploop_unix.mli +++ b/src/toploop/toploop_unix.mli @@ -9,6 +9,9 @@ (** To be called before using any [Toploop] function. *) val initialize: unit -> unit +(** Load the given compiled code *) +val use_compiled_string: string -> unit + (** Materializes an output channel redirection. *) type redirection diff --git a/src/utils/learnocaml_partition_create.ml b/src/utils/learnocaml_partition_create.ml index daa967ca4..1611f1345 100644 --- a/src/utils/learnocaml_partition_create.ml +++ b/src/utils/learnocaml_partition_create.ml @@ -90,7 +90,7 @@ let asak_partition prof fun_name sol by_grade = (ans.Partition.bad_type @ bad_type, (i,ans.Partition.clusters) :: res) ) by_grade ([],[]) -let partition exo_name fun_name prof = +let partition _exo_name _fun_name _prof = assert false (* TODO Learnocaml_store.Exercise.get exo_name >>= fun exo -> let prelude = Learnocaml_exercise.(access File.prelude exo) in @@ -104,3 +104,4 @@ let partition exo_name fun_name prof = let by_grade = partition_by_grade fun_name lst in let bad_type,partition_by_grade = asak_partition prof fun_name solution by_grade in {not_graded; bad_type; partition_by_grade} +*) From 47d5a0614f82e313520c79739922616b99d8c868 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 1 Apr 2022 00:07:18 +0200 Subject: [PATCH 02/41] feat: Enable downloading for only the relevant artifacts (bc or js) --- src/app/learnocaml_description_main.ml | 2 +- src/app/learnocaml_exercise_main.ml | 2 +- src/app/learnocaml_student_view.ml | 2 +- src/app/server_caller.ml | 4 ++-- src/app/server_caller.mli | 2 +- src/main/learnocaml_client.ml | 2 +- src/repo/learnocaml_exercise.ml | 11 +++++++++++ src/repo/learnocaml_exercise.mli | 5 +++++ src/server/learnocaml_server.ml | 5 +++-- src/state/learnocaml_api.ml | 25 ++++++++++++++++++------- src/state/learnocaml_api.mli | 3 ++- 11 files changed, 46 insertions(+), 17 deletions(-) diff --git a/src/app/learnocaml_description_main.ml b/src/app/learnocaml_description_main.ml index e16f06b2f..2f0248bef 100644 --- a/src/app/learnocaml_description_main.ml +++ b/src/app/learnocaml_description_main.ml @@ -66,7 +66,7 @@ let () = match get_encoded_token () with | Some { arg_name = _; raw_arg = _; token } -> begin let exercise_fetch = - retrieve (Learnocaml_api.Exercise (Some token, id)) + retrieve (Learnocaml_api.Exercise (Some token, id, true)) in init_tabs (); exercise_fetch >>= fun (ex_meta, exo, _deadline) -> diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index 392e0c7cc..b210f08b1 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -119,7 +119,7 @@ let () = Js.string (id ^ " - " ^ "Learn OCaml" ^" v."^ Learnocaml_api.version); let exercise_fetch = token >>= fun token -> - retrieve (Learnocaml_api.Exercise (token, id)) + retrieve (Learnocaml_api.Exercise (token, id, true)) in let after_init top = exercise_fetch >>= fun (_meta, exo, _deadline) -> diff --git a/src/app/learnocaml_student_view.ml b/src/app/learnocaml_student_view.ml index 8e7f7ee45..ff2489e30 100644 --- a/src/app/learnocaml_student_view.ml +++ b/src/app/learnocaml_student_view.ml @@ -515,7 +515,7 @@ let () = | None -> () | Some ex_id -> Lwt.async @@ fun () -> - retrieve (Learnocaml_api.Exercise (Some teacher_token, ex_id)) + retrieve (Learnocaml_api.Exercise (Some teacher_token, ex_id, true)) >>= fun (meta, exo, _) -> clear_tabs (); let ans = SMap.find_opt ex_id save.Save.all_exercise_states in diff --git a/src/app/server_caller.ml b/src/app/server_caller.ml index 4ad49b5f4..869265136 100644 --- a/src/app/server_caller.ml +++ b/src/app/server_caller.ml @@ -114,8 +114,8 @@ let fetch_lesson_index () = let fetch_lesson id = request_exn (Learnocaml_api.Lesson id) -let fetch_exercise token id = - request_exn (Learnocaml_api.Exercise (token,id)) +let fetch_exercise token id js = + request_exn (Learnocaml_api.Exercise (token,id,js)) let fetch_tutorial_index () = request_exn (Learnocaml_api.Tutorial_index ()) diff --git a/src/app/server_caller.mli b/src/app/server_caller.mli index 10da0bc39..932344be0 100644 --- a/src/app/server_caller.mli +++ b/src/app/server_caller.mli @@ -24,7 +24,7 @@ exception Cannot_fetch of string val request_exn: 'a Learnocaml_api.request -> 'a Lwt.t val[@deprecated] fetch_exercise: - Token.t option -> Exercise.id -> (Exercise.Meta.t * Exercise.t * float option) Lwt.t + Token.t option -> Exercise.id -> bool -> (Exercise.Meta.t * Exercise.t * float option) Lwt.t val[@deprecated] fetch_lesson_index: unit -> Lesson.Index.t Lwt.t val[@deprecated] fetch_lesson : string -> Lesson.t Lwt.t diff --git a/src/main/learnocaml_client.ml b/src/main/learnocaml_client.ml index 723dc2ef6..ef03b0eaf 100644 --- a/src/main/learnocaml_client.ml +++ b/src/main/learnocaml_client.ml @@ -484,7 +484,7 @@ let fetch server_url req = | Error (`Failure s) -> Lwt.fail_with ("Server request failed: "^ s) let fetch_exercise server_url token id = - Lwt.catch (fun () -> fetch server_url (Api.Exercise (token, id))) + Lwt.catch (fun () -> fetch server_url (Api.Exercise (token, id, false))) @@ function | Not_found -> Printf.ksprintf Lwt.fail_with diff --git a/src/repo/learnocaml_exercise.ml b/src/repo/learnocaml_exercise.ml index 9698ec69e..986633647 100644 --- a/src/repo/learnocaml_exercise.ml +++ b/src/repo/learnocaml_exercise.ml @@ -456,6 +456,17 @@ let field_from_file file files = try File.(StringMap.find file.key files |> file.decode) with Not_found -> raise File.(Missing_file file.key) +let strip need_js ex = + let f {cma; js} = + if need_js then {cma= ""; js} else {cma; js = ""} + in + { ex with + compiled = + { ex.compiled with + exercise_lib = f ex.compiled.exercise_lib; + test_lib = f ex.compiled.test_lib } } + + module MakeReaderAnddWriter (Concur : Concur) = struct module FileReader = File.MakeReader(Concur) diff --git a/src/repo/learnocaml_exercise.mli b/src/repo/learnocaml_exercise.mli index 1f80480c6..177798ab0 100644 --- a/src/repo/learnocaml_exercise.mli +++ b/src/repo/learnocaml_exercise.mli @@ -110,6 +110,11 @@ val update: 'a File.file -> 'a -> t -> t ciphers it. *) val cipher: string File.file -> string -> t -> t +(** Selectively removes compiled data from an exercise. + If the first arg [js] is [true], keep only the javascript. + Otherwise, keep only the bytecode. *) +val strip: bool -> t -> t + (** Reader and decipherer *) val read: read_field:(string -> string option) -> diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 5100ba24e..bdfa6758e 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -452,17 +452,18 @@ module Request_handler = struct | Api.Exercise_index None -> lwt_fail (`Forbidden, "Forbidden") - | Api.Exercise (Some token, id) -> + | Api.Exercise (Some token, id, js) -> (Exercise.Status.is_open id token >>= function | `Open | `Deadline _ as o -> Exercise.Meta.get id >>= fun meta -> Exercise.get id >>= fun ex -> + let ex = Learnocaml_exercise.strip js ex in respond_json cache (meta, ex, match o with `Deadline t -> Some (max t 0.) | `Open -> None) | `Closed -> lwt_fail (`Forbidden, "Exercise closed")) - | Api.Exercise (None, _) -> + | Api.Exercise (None, _, _) -> lwt_fail (`Forbidden, "Forbidden") | Api.Lesson_index () -> diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 16496a9d0..5d27b8c69 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -120,7 +120,8 @@ type _ request = | Exercise_index: 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: - 'a token option * string -> (Exercise.Meta.t * Exercise.t * float option) request + 'a token option * string * bool -> + (Exercise.Meta.t * Exercise.t * float option) request | Lesson_index: unit -> (string * string) list request @@ -166,7 +167,7 @@ let supported_versions | Set_students_list (_, _) | Students_csv (_, _, _) | Exercise_index _ - | Exercise (_, _) + | Exercise (_, _, _) | Lesson_index _ | Lesson _ | Tutorial_index _ @@ -335,10 +336,12 @@ module Conversions (Json: JSON_CODEC) = struct | Exercise_index None -> get ["exercise-index.json"] - | Exercise (Some token, id) -> - get ~token ("exercises" :: String.split_on_char '/' (id^".json")) - | Exercise (None, id) -> - get ("exercises" :: String.split_on_char '/' (id^".json")) + | Exercise (Some token, id, js) -> + let ext = if js then ".js.json" else ".bc.json" in + get ~token ("exercises" :: String.split_on_char '/' (id^ext)) + | Exercise (None, id, js) -> + let ext = if js then ".js.json" else ".bc.json" in + get ("exercises" :: String.split_on_char '/' (id^ext)) | Lesson_index () -> get ["lessons.json"] @@ -463,7 +466,15 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct (match token with | Some token -> let id = Filename.chop_suffix (String.concat "/" path) ".json" in - Exercise (Some token, id) |> k + let id_js = match Filename.chop_suffix_opt ~suffix:".bc" id with + | Some id -> Some (id, false) + | None -> match Filename.chop_suffix_opt ~suffix:".js" id with + | Some id -> Some (id, true) + | None -> None + in + (match id_js with + | Some (id, js) -> Exercise (Some token, id, js) |> k + | None -> Invalid_request "Missing bc/js extension" |> k) | None -> Invalid_request "Missing token" |> k) | Some "" -> Static ["exercise.html"] |> k diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index 86f0ca385..e2c53758b 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -109,7 +109,8 @@ type _ request = | Exercise_index: 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: - 'a token option * string -> (Exercise.Meta.t * Exercise.t * float option) request + 'a token option * string * bool -> + (Exercise.Meta.t * Exercise.t * float option) request | Lesson_index: unit -> (string * string) list request From 2792faf8f49b7b874ae9a854ccafb2c4a2922383 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 1 Apr 2022 12:36:38 +0200 Subject: [PATCH 03/41] refactor: Get rid of the pseudo-cipher Finally :) This should give a nice economy of bandwidth since the unciphered compilation artifacts will compress much better. --- src/grader/grader_cli.ml | 2 +- src/repo/dune | 2 +- src/repo/learnocaml_exercise.ml | 100 +++++++----------- src/repo/learnocaml_exercise.mli | 11 +- src/repo/learnocaml_precompile_exercise.ml | 2 +- .../learnocaml_process_exercise_repository.ml | 2 +- src/utils/dune | 8 -- src/utils/learnocaml_xor.ml | 45 -------- src/utils/learnocaml_xor.mli | 12 --- 9 files changed, 45 insertions(+), 139 deletions(-) delete mode 100644 src/utils/learnocaml_xor.ml delete mode 100644 src/utils/learnocaml_xor.mli diff --git a/src/grader/grader_cli.ml b/src/grader/grader_cli.ml index 7654ac230..5e4edfe6a 100644 --- a/src/grader/grader_cli.ml +++ b/src/grader/grader_cli.ml @@ -27,7 +27,7 @@ let read_exercise exercise_dir = in Learnocaml_exercise.read_lwt ~read_field ~id:(Filename.basename exercise_dir) - ~decipher:false () + () let remove_trailing_slash s = let len = String.length s in diff --git a/src/repo/dune b/src/repo/dune index 6ff5ce7cf..2ffa050af 100644 --- a/src/repo/dune +++ b/src/repo/dune @@ -4,7 +4,7 @@ (modules Learnocaml_index Learnocaml_exercise) (libraries ocplib-json-typed - learnocaml_xor + base64 omd lwt ezjsonm) diff --git a/src/repo/learnocaml_exercise.ml b/src/repo/learnocaml_exercise.ml index 986633647..aa502ad98 100644 --- a/src/repo/learnocaml_exercise.ml +++ b/src/repo/learnocaml_exercise.ml @@ -34,12 +34,19 @@ type t = let encoding = let open Json_encoding in + let b64 = + (* TODO: try to use the native implementation on browsers ? *) + conv + (fun s -> Base64.encode_string s) + (fun b -> Result.get_ok (Base64.decode b)) + string + in let compiled_lib_encoding = conv (fun {cma; js} -> cma, js) (fun (cma, js) -> {cma; js}) (obj2 - (dft "cma" string "") + (dft "cma" b64 "") (dft "js" string "")) in let compiled_encoding = @@ -49,10 +56,10 @@ let encoding = (fun (prelude_cmi, prepare_cmi, solution_cmi, test_cmi, exercise_lib, test_lib) -> {prelude_cmi; prepare_cmi; solution_cmi; test_cmi; exercise_lib; test_lib}) (obj6 - (req "prelude_cmi" string) - (req "prepare_cmi" string) - (req "solution_cmi" string) - (req "test_cmi" string) + (req "prelude_cmi" b64) + (req "prepare_cmi" b64) + (req "solution_cmi" b64) + (req "test_cmi" b64) (req "exercise_lib" compiled_lib_encoding) (req "test_lib" compiled_lib_encoding)) in @@ -116,7 +123,6 @@ module File = struct type 'a file = { key : string ; - ciphered : bool ; decode : string -> 'a ; encode : 'a -> string ; field : t -> 'a ; @@ -125,15 +131,10 @@ module File = struct exception Missing_file of string - let get { key ; ciphered ; decode ; _ } ex = + let get { key ; decode ; _ } ex = try let raw = StringMap.find key ex in - if ciphered then - let prefix = - Digest.string (StringMap.find "id" ex ^ "_" ^ key) in - decode (Learnocaml_xor.decode ~prefix raw) - else - decode raw + decode raw with Not_found -> raise (Missing_file ("get " ^ key)) let get_opt file ex = @@ -144,18 +145,13 @@ module File = struct let has { key ; _ } ex = StringMap.mem key ex - let set { key ; ciphered ; encode ; _ } raw ex = - if ciphered then - let prefix = - Digest.string (StringMap.find "id" ex ^ "_" ^ key) in - StringMap.add key (Learnocaml_xor.encode ~prefix (encode raw)) ex - else - StringMap.add key (encode raw) ex + let set { key ; encode ; _ } raw ex = + StringMap.add key (encode raw) ex let key file = file.key let id = - { key = "id" ; ciphered = false ; + { key = "id" ; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> ex.id) ; update = (fun id ex -> { ex with id }) @@ -179,37 +175,37 @@ module File = struct * } *) let max_score = let key = "max_score.txt" in - { key ; ciphered = false ; + { key ; decode = (fun v -> int_of_string v) ; encode = (fun v -> string_of_int v) ; field = (fun ex -> ex.max_score); update = (fun max_score ex -> { ex with max_score }); } let prelude_ml = - { key = "prelude.ml" ; ciphered = false ; + { key = "prelude.ml" ; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> ex.prelude_ml) ; update = (fun prelude_ml ex -> { ex with prelude_ml }) } let template = - { key = "template.ml" ; ciphered = false ; + { key = "template.ml" ; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> ex.template) ; update = (fun template ex -> { ex with template }) } let solution = - { key = "solution.ml" ; ciphered = false ; + { key = "solution.ml" ; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> ex.solution) ; update = (fun solution ex -> { ex with solution }) } let descr : (string * string) list file = - { key = "descr.html" ; ciphered = false ; + { key = "descr.html" ; decode = descrs_from_string ; encode = descrs_to_string ; field = (fun ex -> ex.descr) ; update = (fun descr ex -> { ex with descr }) } let compiled key get set = - { key; ciphered = true ; + { key; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> get ex.compiled) ; update = (fun v ex -> { ex with compiled = set v ex.compiled }) } @@ -245,7 +241,7 @@ module File = struct (fun comp -> comp.test_lib) (fun test_lib c -> { c with test_lib }) let depend = - { key = "depend.txt" ; ciphered = false ; + { key = "depend.txt" ; decode = (fun v -> Some v) ; encode = (function | None -> "" (* no `depend` ~ empty `depend` *) @@ -273,7 +269,7 @@ module File = struct let filenames = parse_dependencies txt in List.mapi (fun pos filename -> - { key = filename ; ciphered = true ; + { key = filename ; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> List.nth ex.dependencies pos) ; update = (fun v ex -> @@ -283,7 +279,7 @@ module File = struct filenames module MakeReader (Concur : Concur) = struct - let read ~read_field ?id: ex_id ?(decipher = true) () = + let read ~read_field ?id: ex_id () = let open Concur in let ex = ref StringMap.empty in read_field id.key >>= fun pr_id -> @@ -302,18 +298,11 @@ module File = struct * return (meta_from_string meta_json) * end >>= fun meta_json -> * ex := set meta meta_json !ex; *) - let read_file ({ key ; ciphered ; decode ; _ } as field) = + let read_file ({ key ; decode ; _ } as field) = read_field key >>= function | Some raw -> - let deciphered = - if ciphered && decipher then - let prefix = - Digest.string (ex_id ^ "_" ^ key) in - Learnocaml_xor.decode ~prefix raw - else - raw in (* decode / encode now to catch malformed fields earlier *) - ex := set field (decode deciphered) !ex ; + ex := set field (decode raw) !ex ; return () | None -> return () in (* let read_title () = @@ -433,24 +422,14 @@ let access f ex = let decipher f ex = let open File in let raw = f.field ex in - if f.ciphered then - let prefix = - Digest.string (ex.id ^ "_" ^ f.key) in - f.decode (Learnocaml_xor.decode ~prefix raw) - else - f.decode raw + f.decode raw let update f v ex = f.File.update v ex let cipher f v ex = let open File in - if f.ciphered then - let prefix = - Digest.string (ex.id ^ "_" ^ f.key) in - f.update (Learnocaml_xor.encode ~prefix (f.encode v)) ex - else - f.update (f.encode v) ex + f.update (f.encode v) ex let field_from_file file files = try File.(StringMap.find file.key files |> file.decode) @@ -471,9 +450,9 @@ module MakeReaderAnddWriter (Concur : Concur) = struct module FileReader = File.MakeReader(Concur) - let read ~read_field ?id ?decipher () = + let read ~read_field ?id () = let open Concur in - FileReader.read ~read_field ?id ?decipher () >>= fun ex -> + FileReader.read ~read_field ?id () >>= fun ex -> try let depend = File.get_opt File.depend ex in return @@ -507,25 +486,18 @@ module MakeReaderAnddWriter (Concur : Concur) = struct ^ File.(key depend) ^ ", but not found" in raise (File.Missing_file msg') in - List.map field_from_dependency (File.dependencies depend) + List.map field_from_dependency (File.dependencies depend) } with File.Missing_file _ as e -> fail e - let write ~write_field ex ?(cipher = true) acc = + let write ~write_field ex acc = let open Concur in let open File in let acc = ref acc in - let ex_id = ex.id in - let write_field { key ; ciphered ; encode ; field ; _ } = + let write_field { key ; encode ; field ; _ } = try let raw = field ex |> encode in - let ciphered = if ciphered && (not cipher) then - let prefix = - Digest.string (ex_id ^ "_" ^ key) in - Learnocaml_xor.decode ~prefix raw - else - raw in - write_field key ciphered !acc >>= fun nacc -> + write_field key raw !acc >>= fun nacc -> acc := nacc ; return () with Not_found -> Concur.return () in diff --git a/src/repo/learnocaml_exercise.mli b/src/repo/learnocaml_exercise.mli index 177798ab0..b29419a32 100644 --- a/src/repo/learnocaml_exercise.mli +++ b/src/repo/learnocaml_exercise.mli @@ -15,8 +15,7 @@ type id = string type compiled_lib = { cma: string; js: string } -(* JSON encoding of the exercise representation. Includes cipher and decipher at - at encoding and decoding. *) +(* JSON encoding of the exercise representation. *) val encoding: t Json_encoding.encoding (** Intermediate representation of files, resulting of reading the exercise directory *) @@ -118,25 +117,25 @@ val strip: bool -> t -> t (** Reader and decipherer *) val read: read_field:(string -> string option) -> - ?id:string -> ?decipher:bool -> unit -> + ?id:string -> unit -> t (** Writer and cipherer, ['a] can be [unit] *) val write: write_field:(string -> string -> 'a -> 'a) -> - t -> ?cipher:bool -> 'a -> + t -> 'a -> 'a (** Reader and decipherer with {!Lwt} *) val read_lwt: read_field:(string -> string option Lwt.t) -> - ?id:string -> ?decipher:bool -> unit -> + ?id:string -> unit -> t Lwt.t (** Writer and cipherer with {!Lwt}, ['a] can be [unit] *) val write_lwt: write_field:(string -> string -> 'a -> 'a Lwt.t) -> - t -> ?cipher:bool -> 'a -> + t -> 'a -> 'a Lwt.t (** JSON serializer, with {!id} file included *) diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index e1db9d4f8..54eb09639 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -38,7 +38,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" :: "--pretty" :: args in + let args = "--wrap-with=dynload" :: args in let args = args @ [d source; "-o"; d target] in run "js_of_ocaml" args diff --git a/src/repo/learnocaml_process_exercise_repository.ml b/src/repo/learnocaml_process_exercise_repository.ml index 7b7c63a3b..94d069cce 100644 --- a/src/repo/learnocaml_process_exercise_repository.ml +++ b/src/repo/learnocaml_process_exercise_repository.ml @@ -25,7 +25,7 @@ let read_exercise exercise_dir = in Learnocaml_exercise.read_lwt ~read_field ~id:(Filename.basename exercise_dir) - ~decipher:false () + () let exercises_dir = ref "./exercises" diff --git a/src/utils/dune b/src/utils/dune index cb9f0f4dc..afefe93c6 100644 --- a/src/utils/dune +++ b/src/utils/dune @@ -33,14 +33,6 @@ (modules Lwt_utils) ) -(library - (name learnocaml_xor) - (wrapped false) - (flags :standard -warn-error A-4-42-44-45-48) - (libraries base64) - (modules Learnocaml_xor) - ) - (library (name sha) (wrapped false) diff --git a/src/utils/learnocaml_xor.ml b/src/utils/learnocaml_xor.ml deleted file mode 100644 index 6f94d5fe0..000000000 --- a/src/utils/learnocaml_xor.ml +++ /dev/null @@ -1,45 +0,0 @@ -(* This file is part of Learn-OCaml. - * - * Copyright (C) 2019 OCaml Software Foundation. - * Copyright (C) 2015-2018 OCamlPro. - * - * Learn-OCaml is distributed under the terms of the MIT license. See the - * included LICENSE file for details. *) - -let alphabet = - Bytes.of_string - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" - -let () = - Bytes.set alphabet 26 '+'; - Bytes.set alphabet 37 '/'; - for i = 0 to 25 do - Bytes.set alphabet i (Char.chr @@ 65 + i); - Bytes.set alphabet (i+38) (Char.chr @@ 97 + 25 - i) - done; - for i = 0 to 9 do - Bytes.set alphabet (i+27) (Char.chr @@ 48 + i) - done - -let xor_key = - "Caml1999I0150\153\200\232\027\154a\029u@\251\127SX\141\140\157\ - \219\195\000\228\020\180_CR\202\130\129\127\2491\130\011\183\ - \158b\022\"qB0\166+\169\212_\205\164 D\210Qn\181o\225\147q\156\ - \028u6\248b\177\002\164`\187\250\221\240o6\156\240\020\027\243o\ - \017h\218\208\168\164f\161+5\137\132ml\169\235\174\212\029" - -let xor ?prefix str = - let xor_key = - match prefix with - | None -> xor_key - | Some prefix -> prefix ^ xor_key in - let str' = Bytes.create (String.length str) in - for i = 0 to String.length str - 1 do - let c = Char.code xor_key.[i mod (String.length xor_key)] in - Bytes.set str' (i) (Char.chr (c lxor (Char.code (String.get str i)))) - done; - Bytes.to_string str' - -let alphabet = Base64.make_alphabet (Bytes.to_string alphabet) -let decode ?prefix str = xor ?prefix @@ (Base64.decode ~alphabet str |> Result.get_ok) -let encode ?prefix str = Base64.encode ~alphabet @@ xor ?prefix str |> Result.get_ok diff --git a/src/utils/learnocaml_xor.mli b/src/utils/learnocaml_xor.mli deleted file mode 100644 index d104a495b..000000000 --- a/src/utils/learnocaml_xor.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* This file is part of Learn-OCaml. - * - * Copyright (C) 2019 OCaml Software Foundation. - * Copyright (C) 2015-2018 OCamlPro. - * - * Learn-OCaml is distributed under the terms of the MIT license. See the - * included LICENSE file for details. *) - -(* This is trivial and dummy "encryption" for the tests and the solutions. *) - -val encode: ?prefix:string -> string -> string -val decode: ?prefix:string -> string -> string From 87ee902e1c60fd3d5b6fcb40e68b563062b70662 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 1 Apr 2022 12:45:52 +0200 Subject: [PATCH 04/41] fix: Fix a small race condition in builder --- src/utils/lwt_utils.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index df972c6e3..6565ed85c 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -9,16 +9,18 @@ open Lwt.Infix let rec mkdir_p ?(perm=0o755) dir = - Lwt_unix.file_exists dir >>= function - | true -> + if Sys.file_exists dir then if Sys.is_directory dir then Lwt.return () else Lwt.fail_with (Printf.sprintf "Can't create dir: file %s is in the way" dir) - | false -> - mkdir_p (Filename.dirname dir) >>= fun () -> - Lwt_unix.mkdir dir perm + else + if Sys.file_exists (Filename.dirname dir) then + Lwt.return (Unix.mkdir dir perm) + else + mkdir_p ~perm (Filename.dirname dir) >>= fun () -> + mkdir_p ~perm dir let copy_file src dst = Lwt.catch (fun () -> From eaad14cfe1d693081c43277c71dca8a74bd5a5a7 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 1 Apr 2022 14:15:37 +0200 Subject: [PATCH 05/41] perf: Make `learn-ocaml build` parallel by default (now that it's fixed) --- src/main/learnocaml_main.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/learnocaml_main.ml b/src/main/learnocaml_main.ml index ede893e25..f004166e0 100644 --- a/src/main/learnocaml_main.ml +++ b/src/main/learnocaml_main.ml @@ -194,7 +194,7 @@ module Args = struct the entire repository. Can be repeated." let jobs = - value & opt int 1 & info ["jobs";"j"] ~docv:"INT" ~doc: + value & opt int 8 & info ["jobs";"j"] ~docv:"INT" ~doc: "Number of building jobs to run in parallel" type t = { From 787840bda9701ae932ce5f9d56c5929dbb889e17 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 6 Apr 2022 09:41:21 +0200 Subject: [PATCH 06/41] feat: Include Prelude/Prepare and shadow them instead of just `open`. This restores the toplevel output on values defined in Prelude, and forbids access to the interface of Prepare (which were two small regressions with pre-compilation). --- src/app/learnocaml_exercise_main.ml | 10 +++++++--- src/grader/grading.ml | 12 +++++++++--- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index b210f08b1..318b78e80 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -129,13 +129,17 @@ let () = Learnocaml_toplevel.load_cmi_from_string top Learnocaml_exercise.(decipher File.prepare_cmi exo) >>= fun _ -> Learnocaml_toplevel.load_js ~print_outcome:false top - ~message: [%i"loading the prelude..."] exercise_js >>= fun r -> if not r then Lwt.fail_with [%i"error in prelude"] else - Learnocaml_toplevel.load top "open! Prelude ;;" >>= fun r -> + Learnocaml_toplevel.load top "include Prelude ;;" + ~message: [%i"loading the prelude..."] >>= fun r -> if not r then Lwt.fail_with [%i"error in prelude"] else - Learnocaml_toplevel.load top "open! Prepare ;;" >>= fun r -> + Learnocaml_toplevel.load ~print_outcome:false top "module Prelude = struct end;;" >>= fun r -> + if not r then Lwt.fail_with [%i"error in prelude"] else + Learnocaml_toplevel.load ~print_outcome:false top "include Prepare ;;" >>= fun r -> + if not r then Lwt.fail_with [%i"error in prelude"] else + Learnocaml_toplevel.load ~print_outcome:false top "module Prepare = struct end;;" >>= fun r -> if not r then Lwt.fail_with [%i"error in prelude"] else (* TODO: maybe remove Prelude, Prepare modules from the env ? *) Learnocaml_toplevel.set_checking_environment top >>= fun () -> diff --git a/src/grader/grading.ml b/src/grader/grading.ml index 606ec544c..480d4ec8a 100644 --- a/src/grader/grading.ml +++ b/src/grader/grading.ml @@ -115,10 +115,16 @@ let get_grade }; handle_error (internal_error [%i"while preparing the tests"]) @@ - Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Prelude|}; + Toploop_ext.use_string ~print_outcome ~ppf_answer + {|include Prelude|}; handle_error (internal_error [%i"while preparing the tests"]) @@ - Toploop_ext.use_string ~print_outcome:false ~ppf_answer {|open! Prepare|}; - + Toploop_ext.use_string ~print_outcome:false ~ppf_answer + {|module Prelude = struct end|}; + handle_error (internal_error [%i"while preparing the tests"]) @@ + Toploop_ext.use_string ~print_outcome:false ~ppf_answer + {|include Prepare|}; + Toploop_ext.use_string ~print_outcome:false ~ppf_answer + {|module Prepare = struct end|}; set_progress [%i"Loading your code."] ; handle_error user_code_error @@ From a97f81367bcce970e6474f39d3f5940df77cb880 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 6 Apr 2022 15:46:01 +0200 Subject: [PATCH 07/41] fix: Properly type samplers --- src/grader/introspection.ml | 108 +++++++++++++++++++++++------------- 1 file changed, 68 insertions(+), 40 deletions(-) diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index 2869c3dc6..6bb1280c3 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -206,52 +206,80 @@ let print_value ppf v ty = Format.fprintf ppf "@]" end + +(* for a type [('a, 'b) foo] => [register_sampler "foo" f] where [f] must have + type ['a sampler -> 'b sampler -> ('a, 'b) foo sampler]. + - find the sampler's type from its name and the cmi + - lookup type [foo] + - build the expected sampler type from the type params of [foo] + - match with the sampler type +*) let register_sampler name f = - let sampler_name = "sample_" ^ name in - (* FIXME TODO: type-check the specified samplers ! *) - (* let sampled_ty_path, sampled_ty_decl = - * Env.find_type_by_name (Longident.Lident name) !Toploop.toplevel_env - * in - * let sampled_ty = - * match sampled_ty_decl.Types.type_manifest with - * | Some ty -> ty - * | None -> failwith "Type is not public for sampling" - * in - * let sampler_ty_computed = - * (\* The given sampler must be a function with one argument for every type param *\) - * let sampler ty = (\* ['a sampler] == [unit -> 'a] *\) - * Types.Tarrow (Asttypes.Nolabel, Predef.type_unit, ty, Types.Cok) - * in - * List.fold_right (fun typaram ty -> - * Types.Tarrow (Asttypes.Nolabel, Btype.newgenty (sampler typaram), Btype.newgenty ty, Types.Cok)) - * sampled_ty_decl.Types.type_params - * (sampler sampled_ty) - * in *) - let sampler_ty(* _found *) = - Env.find_value - (Path.Pdot (Path.Pident (Ident.create_persistent "Test"), sampler_name)) - !Toploop.toplevel_env - (* Requires [test.cmi] to be pre-loaded *) - (* FIXME: maybe don't require the cmi and skip this check when on the - browser. - ... unless the type of the sampler might somehow depend on the types - inferred from [Code], but that should definitely be forbidden! *) + let open Types in + let gen_sampler_type = + Path.Pdot + (Path.Pident (Ident.create_persistent "Test_lib"), + "sampler") in - if true (* Ctype.moregeneral !Toploop.toplevel_env true - * (Btype.newgenty sampler_ty_found) sampler_ty_computed *) - then - (Toploop.toplevel_env := - Env.add_value (Ident.create_local sampler_name) sampler_ty - !Toploop.toplevel_env; - Toploop.setvalue sampler_name (Obj.repr f)) - else - failwith "sampler has the wrong type !" - + let lookup_env = !Toploop.toplevel_env in + let sampler_name = "sample_" ^ name in + match + let sampler_path = + Path.Pdot (Path.Pident (Ident.create_persistent "Test"), + sampler_name) + 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 + with + | exception Not_found -> + Format.ksprintf failwith "Bad sampler registration (function %s not found).@." + sampler_name + | _sampler_path, sampler_desc -> + match + Env.find_type_by_name (Longident.Lident name) lookup_env + with + | exception Not_found -> + Format.eprintf "Warning: unrecognised sampler definition (type %s not found).@." + name + | sampled_ty_path, sampled_ty_decl -> + let sampler_ty_expected = + Ctype.begin_def(); + let ty_args = + List.map (fun _ -> Ctype.newvar ()) sampled_ty_decl.type_params + in + let ty_target = + Ctype.newty (Tconstr (sampled_ty_path, ty_args, ref Mnil)) + in + let fn_args = + List.map (fun ty -> Ctype.newconstr gen_sampler_type [ty]) ty_args + in + let sampler_ty = + List.fold_right (fun fn_arg ty -> + Ctype.newty (Tarrow (Asttypes.Nolabel, fn_arg, ty, Cunknown))) + fn_args (Ctype.newconstr gen_sampler_type [ty_target]) + in + Ctype.end_def (); + Ctype.generalize sampler_ty; + sampler_ty + in + (try + Ctype.unify lookup_env + sampler_ty_expected + (Ctype.instance sampler_desc.val_type) + with Ctype.Unify _ -> + Format.ksprintf failwith "%s has a wrong type for a sampling function.@." + sampler_name); + Toploop.toplevel_env := + Env.add_value (Ident.create_local sampler_name) sampler_desc + !Toploop.toplevel_env; + Toploop.setvalue sampler_name (Obj.repr f) let sample_value ty = let { Typedtree.ctyp_type = ty; _ } = Typetexp.transl_type_scheme !Toploop.toplevel_env (Ty.obj ty) in - let lid = Format.asprintf "sample_%04X" (Random.int 0xFFFF) in + let lid = Format.asprintf "sample_%06X" (Random.int 0xFFFFFF) in let phrase = let open Asttypes in let open Types in From 7422ca439fb450af6dab362ccc95e094f4297b41 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 7 Apr 2022 10:42:50 +0200 Subject: [PATCH 08/41] fix: Avoid double-printing of internal grader errors --- src/grader/grader_cli.ml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/grader/grader_cli.ml b/src/grader/grader_cli.ml index 5e4edfe6a..cb45ab55e 100644 --- a/src/grader/grader_cli.ml +++ b/src/grader/grader_cli.ml @@ -60,6 +60,19 @@ let grade ?(print_result=false) ?dirname >>= fun (result, stdout_contents, stderr_contents, outcomes) -> flush stderr; match result with + | Error (Grading.Internal_error _ as err) -> + let dump_error ppf = + Format.fprintf ppf "%s@." (Grading.string_of_err err) + in + begin match dump_outputs with + | None -> () + | Some prefix -> + let oc = open_out (prefix ^ ".error") in + dump_error (Format.formatter_of_out_channel oc) ; + close_out oc + end ; + dump_error Format.err_formatter ; + Lwt.return (Error (-1)) | Error err -> let dump_error ppf = Format.fprintf ppf "%s@." (Grading.string_of_err err); From e63359e38760ee052b62d6ccf3e46ad1db46e988 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 7 Apr 2022 11:32:07 +0200 Subject: [PATCH 09/41] perf: Dump the cmis for grading only once --- src/grader/grading_cli.ml | 41 ++++++++++++++++++--------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/src/grader/grading_cli.ml b/src/grader/grading_cli.ml index 5a2875b57..2615dd0e8 100644 --- a/src/grader/grading_cli.ml +++ b/src/grader/grading_cli.ml @@ -18,30 +18,33 @@ and remove dir name = let file = Filename.concat dir name in if Sys.is_directory file then remove_dir file else Lwt_unix.unlink file -let with_temp_dir f = - let rec get_dir () = - let d = - Filename.concat - (Filename.get_temp_dir_name ()) - (Printf.sprintf "grader_%06X" (Random.int 0xFFFFFF)) - in - Lwt.catch (fun () -> Lwt_unix.mkdir d 0o700 >>= fun () -> Lwt.return d) - @@ function - | Unix.Unix_error(Unix.EEXIST, _, _) -> get_dir () - | e -> raise e +let rec mk_temp_dir () = + let d = + Filename.concat + (Filename.get_temp_dir_name ()) + (Printf.sprintf "grader_%06X" (Random.int 0xFFFFFF)) in - get_dir () >>= fun dir -> - Lwt.catch - (fun () -> f dir >>= fun res -> remove_dir dir >>= fun () -> Lwt.return res) - (fun e -> remove_dir dir >>= fun () -> Lwt.fail e) + Lwt.catch (fun () -> Lwt_unix.mkdir d 0o700 >>= fun () -> Lwt.return d) + @@ function + | Unix.Unix_error(Unix.EEXIST, _, _) -> mk_temp_dir () + | e -> Lwt.fail e (* The answer of the grader will be returned marshalled through a pipe: type it explicitely and avoid any exceptions inside. *) type grader_answer = (Learnocaml_report.t, Grading.error) Stdlib.result * string * string * string +let cmis_dir = lazy begin + mk_temp_dir () >>= fun cmis_dir -> + let module ResDump = OCamlResFormats.Files (OCamlResSubFormats.Raw) in + ResDump.output { OCamlResFormats.base_output_dir = cmis_dir } + Embedded_cmis.root; + Lwt_main.at_exit (fun () -> remove_dir cmis_dir); + Lwt.return cmis_dir +end + let get_grade ?callback ?timeout ?dirname exo solution = - with_temp_dir @@ fun cmis_dir -> + Lazy.force cmis_dir >>= fun cmis_dir -> Lwt_io.flush_all () >>= fun () -> flush_all (); let in_fd, out_fd = Unix.pipe ~cloexec:true () in @@ -51,12 +54,6 @@ let get_grade ?callback ?timeout ?dirname exo solution = Unix.close in_fd; let oc = Unix.out_channel_of_descr out_fd in let (ret: grader_answer) = - let module ResDump = - OCamlResFormats.Files (OCamlResSubFormats.Raw) in - let dump_cmis = - ResDump.output { OCamlResFormats.base_output_dir = cmis_dir } in - dump_cmis Embedded_cmis.root ; - (* dump_cmis Embedded_grading_cmis.root ; *) Load_path.init [ cmis_dir ] ; Toploop_unix.initialize () ; let divert name chan cb = From c61a4d06715180069e9c6625f9c9559af476054d Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 8 Apr 2022 15:48:35 +0200 Subject: [PATCH 10/41] fix: Fix segfault on graders using samplers returning newly defined exceptions (or extensible variant cases) --- src/grader/introspection.ml | 40 ++++++++++++++++++++++++++++--- src/grader/introspection_intf.mli | 4 ++++ src/grader/test_lib.ml | 2 +- 3 files changed, 42 insertions(+), 4 deletions(-) diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index 6bb1280c3..44225b71e 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -167,6 +167,39 @@ 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]. *) +let base_print_value, install_printer = + let 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) + in + let print_value env obj ppf ty = + !Oprint.out_value ppf @@ + Printer.outval_of_value 300 100 (fun _ _ _ -> None) env obj ty + in + let install_printer pr = Printer.install_printer pr in + print_value, install_printer + let print_value ppf v ty = let { Typedtree.ctyp_type = ty; _ } = Typetexp.transl_type_scheme !Toploop.toplevel_env (Ty.obj ty) in @@ -192,17 +225,17 @@ let print_value ppf v ty = done) (fun () -> ()) in begin try - Toploop.print_value !Toploop.toplevel_env (Obj.repr v) tmp_ppf ty ; + base_print_value !Toploop.toplevel_env (Obj.repr v) tmp_ppf ty ; Format.pp_print_flush tmp_ppf () with Exit -> () end ; match !state with `Start | `Decided false | `Undecided -> false | `Decided true -> true in if needs_parentheses then begin Format.fprintf ppf "@[(" ; - Toploop.print_value !Toploop.toplevel_env (Obj.repr v) ppf ty ; + base_print_value !Toploop.toplevel_env (Obj.repr v) ppf ty ; Format.fprintf ppf ")@]" end else begin Format.fprintf ppf "@[" ; - Toploop.print_value !Toploop.toplevel_env (Obj.repr v) ppf ty ; + base_print_value !Toploop.toplevel_env (Obj.repr v) ppf ty ; Format.fprintf ppf "@]" end @@ -414,6 +447,7 @@ let allow_introspection ~divert = stderr_cb := bad_stderr_cb ; res + let install_printer pr = install_printer pr let get_printer ty = fun ppf v -> print_value ppf v ty let register_sampler name f = register_sampler name f diff --git a/src/grader/introspection_intf.mli b/src/grader/introspection_intf.mli index 5a5e412e3..51858a8e4 100644 --- a/src/grader/introspection_intf.mli +++ b/src/grader/introspection_intf.mli @@ -36,6 +36,10 @@ module type INTROSPECTION = sig val register_sampler: string -> ('a -> 'b) -> unit val get_sampler: 'a Ty.ty -> (unit -> 'a) + + val install_printer: + Path.t -> Types.type_expr -> (Format.formatter -> Obj.t -> unit) -> unit + val get_printer: 'a Ty.ty -> (Format.formatter -> 'a -> unit) val parse_lid: string -> Longident.t diff --git a/src/grader/test_lib.ml b/src/grader/test_lib.ml index c9bb89957..c93ee58f0 100644 --- a/src/grader/test_lib.ml +++ b/src/grader/test_lib.ml @@ -1351,7 +1351,7 @@ module Intro = Pre_test.Introspection let () = let path = Path.Pident (Ident.create_local "fun_printer") in let ty = Typetexp.transl_type_scheme !Toploop.toplevel_env (Ty.obj [%ty: _ -> _ ]) in - Toploop.install_printer path ty.Typedtree.ctyp_type fun_printer + Intro.install_printer path ty.Typedtree.ctyp_type fun_printer end let (@@@) f g = fun x -> f x @ g x From 7825a6b6d15b213b1297d7878e8fb36057ec7b81 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 8 Apr 2022 16:34:52 +0200 Subject: [PATCH 11/41] fix: Be more precise on the definition and lookup of samplers --- src/grader/grading.ml | 2 -- src/grader/introspection.ml | 23 ++++++++++++++++++----- src/grader/introspection_intf.mli | 3 +++ src/grader/test_lib.ml | 15 +++++++++++++++ src/grader/test_lib.mli | 15 +++++++++++++++ 5 files changed, 51 insertions(+), 7 deletions(-) diff --git a/src/grader/grading.ml b/src/grader/grading.ml index 480d4ec8a..6f9b70111 100644 --- a/src/grader/grading.ml +++ b/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 diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index 44225b71e..db26060c0 100644 --- a/src/grader/introspection.ml +++ b/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 = diff --git a/src/grader/introspection_intf.mli b/src/grader/introspection_intf.mli index 51858a8e4..cd3e5a0db 100644 --- a/src/grader/introspection_intf.mli +++ b/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) diff --git a/src/grader/test_lib.ml b/src/grader/test_lib.ml index c93ee58f0..f9051a190 100644 --- a/src/grader/test_lib.ml +++ b/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 () diff --git a/src/grader/test_lib.mli b/src/grader/test_lib.mli index 45e445205..071dabe67 100644 --- a/src/grader/test_lib.mli +++ b/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. *) From 46631d8e62385d934012ae16d756ce6f4bee4139 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 8 Apr 2022 17:11:56 +0200 Subject: [PATCH 12/41] build: Make `make testrun` parallel (now that it works!) --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 0afbb6028..3b220a658 100644 --- a/Makefile +++ b/Makefile @@ -70,7 +70,7 @@ REPO ?= demo-repository testrun: build install rm -rf www/css - learn-ocaml build --repo $(REPO) -j1 + learn-ocaml build --repo $(REPO) rm -rf www/css ln -s ../static/css www LEARNOCAML_SERVER_NOCACHE=1 learn-ocaml serve From 3cd75f5fbf580ab7ec388ef36976a0b32ca118ce Mon Sep 17 00:00:00 2001 From: Hernouf Mohamed Date: Sun, 3 Apr 2022 21:47:33 +0200 Subject: [PATCH 13/41] 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. --- .gitignore | 5 ++ src/grader/grading_cli.mli | 2 +- src/ppx-metaquot/dune | 8 +++- src/ppx-metaquot/ppx_metaquot_register.ml | 3 +- src/ppx-metaquot/recorder.ml | 56 ++++++++++++++++++++++ src/repo/learnocaml_precompile_exercise.ml | 2 +- src/toploop/toploop_unix.mli | 2 +- 7 files changed, 73 insertions(+), 5 deletions(-) create mode 100644 src/ppx-metaquot/recorder.ml diff --git a/.gitignore b/.gitignore index ad564485a..b18739c8c 100644 --- a/.gitignore +++ b/.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 diff --git a/src/grader/grading_cli.mli b/src/grader/grading_cli.mli index 61d9cdcba..e41425308 100644 --- a/src/grader/grading_cli.mli +++ b/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) -> diff --git a/src/ppx-metaquot/dune b/src/ppx-metaquot/dune index 81a9bb7a5..90421c4d0 100644 --- a/src/ppx-metaquot/dune +++ b/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) ) diff --git a/src/ppx-metaquot/ppx_metaquot_register.ml b/src/ppx-metaquot/ppx_metaquot_register.ml index 62a74f952..3ec201163 100644 --- a/src/ppx-metaquot/ppx_metaquot_register.ml +++ b/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 diff --git a/src/ppx-metaquot/recorder.ml b/src/ppx-metaquot/recorder.ml new file mode 100644 index 000000000..0264b13e3 --- /dev/null +++ b/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 diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index 54eb09639..a0688bcb3 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/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" diff --git a/src/toploop/toploop_unix.mli b/src/toploop/toploop_unix.mli index 0d533ad73..c460ab732 100644 --- a/src/toploop/toploop_unix.mli +++ b/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 From f0e8346450a826a9955a71b69aa4504865d2d56a Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 12 Apr 2022 13:20:38 +0200 Subject: [PATCH 14/41] feat: Restore compatibility with static deployment Previous patch on byte/js selection broke static servers. This restores the compatible API by using GET args to filter the answer (on a static server, no filtering will be done but that just means a little more bandwidth usage). --- src/state/learnocaml_api.ml | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 5d27b8c69..09175ce53 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -279,10 +279,10 @@ module Conversions (Json: JSON_CODEC) = struct let to_http_request : type resp. resp request -> http_request = - let get ?token path = { + let get ?token ?(args=[]) path = { meth = `GET; path; - args = match token with None -> [] | Some t -> ["token", Token.to_string t]; + args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ args; } in let post ~token path body = { meth = `POST body; @@ -337,11 +337,12 @@ module Conversions (Json: JSON_CODEC) = struct get ["exercise-index.json"] | Exercise (Some token, id, js) -> - let ext = if js then ".js.json" else ".bc.json" in - get ~token ("exercises" :: String.split_on_char '/' (id^ext)) + get ~token + ("exercises" :: String.split_on_char '/' (id^".json")) + ~args:["mode", if js then "js" else "byte"] | Exercise (None, id, js) -> - let ext = if js then ".js.json" else ".bc.json" in - get ("exercises" :: String.split_on_char '/' (id^ext)) + get ("exercises" :: String.split_on_char '/' (id^".json")) + ~args:["mode", if js then "js" else "byte"] | Lesson_index () -> get ["lessons.json"] @@ -466,15 +467,8 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct (match token with | Some token -> let id = Filename.chop_suffix (String.concat "/" path) ".json" in - let id_js = match Filename.chop_suffix_opt ~suffix:".bc" id with - | Some id -> Some (id, false) - | None -> match Filename.chop_suffix_opt ~suffix:".js" id with - | Some id -> Some (id, true) - | None -> None - in - (match id_js with - | Some (id, js) -> Exercise (Some token, id, js) |> k - | None -> Invalid_request "Missing bc/js extension" |> k) + let js = List.assoc_opt "mode" request.args = Some "js" in + Exercise (Some token, id, js) |> k | None -> Invalid_request "Missing token" |> k) | Some "" -> Static ["exercise.html"] |> k From 99e913d847c54e021669c7068ca991ae24de89f2 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 13 Apr 2022 10:09:00 +0200 Subject: [PATCH 15/41] 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. --- src/ppx-metaquot/dune | 16 +++--- src/ppx-metaquot/ppx_autoregister.ml | 60 +++++++++++++++++++++++ src/ppx-metaquot/ppx_autoregister.mli | 8 +++ src/ppx-metaquot/ppx_metaquot_grader.ml | 16 ++++++ src/ppx-metaquot/ppx_metaquot_register.ml | 4 -- src/ppx-metaquot/recorder.ml | 56 --------------------- 6 files changed, 92 insertions(+), 68 deletions(-) create mode 100644 src/ppx-metaquot/ppx_autoregister.ml create mode 100644 src/ppx-metaquot/ppx_autoregister.mli create mode 100644 src/ppx-metaquot/ppx_metaquot_grader.ml delete mode 100644 src/ppx-metaquot/ppx_metaquot_register.ml delete mode 100644 src/ppx-metaquot/recorder.ml 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 From d22a78822b007e92f576288713dfa5ed6be2b1de Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 15 Apr 2022 10:50:41 +0200 Subject: [PATCH 16/41] feat: Add support for a `test_libs.txt` file in exercises It just contains the names of the ocamlfind libraries to link in. --- src/repo/learnocaml_precompile_exercise.ml | 34 ++++++++++++++++++---- 1 file changed, 29 insertions(+), 5 deletions(-) diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index a0688bcb3..b98f1ee21 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -42,8 +42,32 @@ let jsoo ?(dir=Sys.getcwd ()) ~source ~target args = let args = args @ [d source; "-o"; d target] in run "js_of_ocaml" args +let read_lines fopen = + try + let ic = fopen () in + let lines = ref [] in + try while true do lines := input_line ic :: !lines done; [] + with End_of_file -> + close_in ic; + List.rev !lines + with Sys_error _ -> [] + let precompile ~exercise_dir = let dir = exercise_dir in + let grader_libs = + read_lines (fun () -> open_in (Filename.concat dir "test_libs.txt")) in + let grader_flags = + List.fold_right (fun lib flags -> + let libflags = + read_lines (fun () -> + Printf.ksprintf Unix.open_process_in + "ocamlfind query %s -predicates byte -format \"-I&%%d&%%a\"" lib) + |> List.map (String.split_on_char '&') + |> List.flatten + in + List.append libflags flags) + grader_libs [] + in ocamlc ~dir ["-c"] ~opn:["Learnocaml_callback"] ~source:["prelude.ml"] ~target:"prelude.cmo" >>= fun () -> @@ -59,15 +83,15 @@ 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_ppx_dir "learnocaml-ppx-metaquot"] + (ocamlc ~dir (["-c"; + "-I"; "+compiler-libs"; + "-ppx"; Filename.concat !grading_ppx_dir "learnocaml-ppx-grader"] + @ grader_flags) ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"; "Test_lib.Open_me"] ~source:["test.ml"] ~target:"test.cmo" >>= fun () -> - (* Todo: support for depends.txt *) - ocamlc ~dir ["-a"; (* "-linkall" *)] + ocamlc ~dir ["-a"] ~source:["test.cmo"] ~target:"test.cma" >>= fun () -> From e7686163f9b23acc6140cabd406f2999f228fb50 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 21 Apr 2022 19:16:34 +0200 Subject: [PATCH 17/41] feat: Preprocessing and typing of samplers and printers --- src/grader/dune | 66 +++++------- src/grader/introspection.ml | 138 +++++++++++++++++++----- src/grader/introspection_intf.mli | 13 ++- src/grader/mutation_test.ml | 37 ++----- src/grader/mutation_test.mli | 16 +-- src/grader/test_lib.ml | 26 +++-- src/ppx-metaquot/ppx_autoregister.ml | 36 +++++-- src/ppx-metaquot/ppx_autoregister.mli | 2 +- src/ppx-metaquot/ppx_metaquot_grader.ml | 32 +++++- src/toplevel/dune | 9 ++ 10 files changed, 237 insertions(+), 138 deletions(-) diff --git a/src/grader/dune b/src/grader/dune index d9a219e8c..82a70bbb2 100644 --- a/src/grader/dune +++ b/src/grader/dune @@ -7,12 +7,6 @@ (libraries ocplib-json-typed ocplib_i18n) ) -(rule - (targets learnocaml_report.odoc) - (deps .learnocaml_report.objs/byte/learnocaml_report.cmti) - (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) -) - ;; needs to be a separate lib because the module is shared between evaluator ;; parts (Grading) and dynamic parts (Test_lib) (library @@ -22,28 +16,16 @@ (modules_without_implementation introspection_intf) (libraries learnocaml_report ty)) -;; dynamic part, on which Prelude/Prepare/Test_lib etc. depend -(library - (name learnocaml_callback) - (wrapped false) - (modules learnocaml_callback) - (modules_without_implementation learnocaml_callback) - ;; hack: learnocaml_callback actually does have an implementation, but it is inserted - ;; into the toplevel later on, through registered callbacks. Defining this lib - ;; ensures the compilation of `learnocaml_callback.cmi` - (libraries compiler-libs learnocaml_report introspection_intf)) - ;; dynamic part, on which Test_lib depends (library (name pre_test) (wrapped false) - (modules pre_test) - (modules_without_implementation pre_test) - ;; hack: pre_test actually does have an implementation, but it is dynamically - ;; generated and injected in the environment during grading. We are interested - ;; in pre_test.cmi to compile test_lib.cmo, then test_lib.cmo should only be - ;; loaded in the specific grading toplevel env. - (libraries compiler-libs learnocaml_report introspection_intf)) + (modules learnocaml_callback learnocaml_internal pre_test) + (modules_without_implementation learnocaml_callback learnocaml_internal pre_test) + (libraries compiler-libs + learnocaml_report + learnocaml_internal_intf + introspection_intf)) ;; dynamic (but pre-compiled) part (library @@ -59,10 +41,7 @@ learnocaml_report learnocaml_repository introspection_intf - ;; dynamic dependencies - learnocaml_callback - pre_test - ) + pre_test) (modules Test_lib) (preprocess (pps learnocaml_ppx_metaquot)) ) @@ -71,18 +50,18 @@ (deps testing_dyn.cma) (action (run js_of_ocaml %{deps} --wrap-with dynload --pretty))) -(rule - (targets test_lib.odoc) - (deps .testing_dyn.objs/byte/test_lib.cmti) - (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) -) +;; (rule +;; (targets test_lib.odoc) +;; (deps .testing_dyn.objs/byte/test_lib.cmti) +;; (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) +;; ) -(rule - (alias doc) - (action (progn (run mkdir -p doc) - (run odoc html %{dep:learnocaml_report.odoc} -o %{workspace_root}/_doc/_html) - (run odoc html %{dep:test_lib.odoc} -o %{workspace_root}/_doc/_html))) -) +;; (rule +;; (alias doc) +;; (action (progn (run mkdir -p doc) +;; (run odoc html %{dep:learnocaml_report.odoc} -o %{workspace_root}/_doc/_html) +;; (run odoc html %{dep:test_lib.odoc} -o %{workspace_root}/_doc/_html))) +;; ) @@ -178,7 +157,8 @@ (rule (targets embedded_grading_lib.ml) (deps - .learnocaml_callback.objs/byte/learnocaml_callback.cmi + .pre_test.objs/byte/learnocaml_callback.cmi + .pre_test.objs/byte/learnocaml_internal.cmi ;; .pre_test.objs/byte/pre_test.cmi -- only test_lib should be needed .testing_dyn.objs/byte/test_lib.cmi testing_dyn.cma @@ -188,16 +168,19 @@ ) ;; cmis that are needed to precompile the graders for exercises +;; FIXME: now we install the libs through dune, so use that ?? (install (section share) (package learn-ocaml) (files (../ppx-metaquot/.ty.objs/byte/ty.cmi as grading_cmis/ty.cmi) (../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi as grading_cmis/fun_ty.cmi) +;; (.exercise_init.objs/byte/exercise_init.cmi as grading_cmis/exercise_init.cmi) (.introspection_intf.objs/byte/introspection_intf.cmi as grading_cmis/introspection_intf.cmi) + (.pre_test.objs/byte/learnocaml_internal.cmi as grading_cmis/learnocaml_internal.cmi) (.pre_test.objs/byte/pre_test.cmi as grading_cmis/pre_test.cmi) (.learnocaml_report.objs/byte/learnocaml_report.cmi as grading_cmis/learnocaml_report.cmi) - (.learnocaml_callback.objs/byte/learnocaml_callback.cmi as grading_cmis/learnocaml_callback.cmi) + (.pre_test.objs/byte/learnocaml_callback.cmi as grading_cmis/learnocaml_callback.cmi) ;;FIXME separate lib?? (.testing_dyn.objs/byte/test_lib.cmi as grading_cmis/test_lib.cmi)) ) @@ -210,6 +193,7 @@ (libraries learnocaml_ppx_metaquot ocplib-ocamlres.runtime toploop + learnocaml_internal_intf introspection_intf embedded_cmis ocplib_i18n diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index db26060c0..a33defd85 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -172,33 +172,114 @@ let get_value lid ty = Note: re-instanciating [Genprintval.Make] means we lose any previously defined printers through [Topdirs.dir_install_printer]. *) -let base_print_value, install_printer = - let 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) - in - let print_value env obj ppf ty = - !Oprint.out_value ppf @@ - Printer.outval_of_value 300 100 (fun _ _ _ -> None) env obj ty +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 install_printer pr = Printer.install_printer pr in - print_value, install_printer + 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 + Ctype.end_def (); + (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@ @[%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.generalize printer_ty_expected; + let ty_path = + match ty_target.desc with + | Tconstr (path, args, _) + when Ctype.all_distinct_vars env args -> Format.kasprintf failwith "XXX %a // %a // %a" Printtyp.path ty_path Printtyp.path path Printtyp.type_expr ty_target + | Tconstr (path, args, _) -> Format.kasprintf failwith "XXX %a // %a // %a" Printtyp.path ty_path Printtyp.path path Printtyp.type_expr ty_target + | _ -> ty_path + in + let rec build v = function + | [] -> + Genprintval.Zero + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) + | _ :: args -> + Genprintval.Succ + (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) + in + Printer.install_generic_printer' + Path.(Pdot (Pident modident, "print_"^tyname)) + ty_path + (build (Obj.repr pr) ty_args) let print_value ppf v ty = let { Typedtree.ctyp_type = ty; _ } = @@ -247,7 +328,7 @@ let print_value ppf v ty = - build the expected sampler type from the type params of [foo] - match with the sampler type *) -let register_sampler name f = +let register_sampler _modname _id name f = let open Types in let gen_sampler_type = Path.Pdot @@ -460,7 +541,8 @@ let allow_introspection ~divert = stderr_cb := bad_stderr_cb ; res - let install_printer pr = install_printer pr + let install_printer_internal pr = install_printer pr + let install_printer path ty pr = 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 diff --git a/src/grader/introspection_intf.mli b/src/grader/introspection_intf.mli index cd3e5a0db..df35e7247 100644 --- a/src/grader/introspection_intf.mli +++ b/src/grader/introspection_intf.mli @@ -34,10 +34,6 @@ 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) val install_printer: @@ -47,6 +43,15 @@ module type INTROSPECTION = sig val parse_lid: string -> Longident.t + (**/**) + (** Only for use by learnocaml's ppx *) + (* 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 -> 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 diff --git a/src/grader/mutation_test.ml b/src/grader/mutation_test.ml index 8e864ad61..55d11b266 100644 --- a/src/grader/mutation_test.ml +++ b/src/grader/mutation_test.ml @@ -13,36 +13,8 @@ let uncurry3 f = fun (x, y, z) -> f x y z let uncurry4 f = fun (x, y, z, w) -> f x y z w let map_third f = fun (x, y, z) -> (x, y, f z) -module type S = sig - val run_test_against_mutant: - ?compare: ('b -> 'b -> bool) -> - ('a -> 'b) -> ('a * 'b) -> bool - val test_unit_tests_1: - ?test_student_soln: bool -> - ?test: ('b -> 'b -> bool) -> - ('a -> 'b) Ty.ty -> string -> ('a -> 'b) mutant_info list -> Learnocaml_report.t - val test_unit_tests_2: - ?test_student_soln: bool -> - ?test: ('c -> 'c -> bool) -> - ('a -> 'b -> 'c) Ty.ty -> string -> ('a -> 'b -> 'c) mutant_info list -> Learnocaml_report.t - val test_unit_tests_3: - ?test_student_soln: bool -> - ?test: ('d -> 'd -> bool) -> - ('a -> 'b -> 'c -> 'd) Ty.ty - -> string - -> ('a -> 'b -> 'c -> 'd) mutant_info list - -> Learnocaml_report.t - val test_unit_tests_4: - ?test_student_soln: bool -> - ?test: ('e -> 'e -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e) Ty.ty - -> string - -> ('a -> 'b -> 'c -> 'd -> 'e) mutant_info list - -> Learnocaml_report.t - val passed_mutation_testing: Learnocaml_report.t -> bool -end - -module Make (Test_lib: module type of Test_lib) : S = struct +(* module Make (Test_lib: module type of Test_lib) : S = struct *) +module M = struct open Test_lib let run_test_against ?(compare = (=)) f (input, expected) = @@ -320,3 +292,8 @@ module Make (Test_lib: module type of Test_lib) : S = struct test_ty printer out_printer name soln stud muts end + +include M + +(* for backwards-compatibility *) +module Make (_: module type of Test_lib) = M diff --git a/src/grader/mutation_test.mli b/src/grader/mutation_test.mli index e3d0c601f..1505e00d7 100644 --- a/src/grader/mutation_test.mli +++ b/src/grader/mutation_test.mli @@ -32,15 +32,6 @@ type 'a mutant_info = string * int * 'a For testing a function called [foo], the student's tests should be in a variable called [foo_tests]. - This module needs to be instantiated with an instance of - [Test_lib], which is available to the grader code: - - {[ - module M = Mutation_test.Make (Test_lib) - - M.test_unit_tests_1 ... - ]} - A grading function is defined for each arity function from one to four: @@ -58,7 +49,7 @@ type 'a mutant_info = string * int * 'a expected and actual outputs, and defaults to structural equality ([(=)]). *) -module type S = sig +module M: sig (** Run a test (a pair of input and expected output) on a mutant function. @@ -109,4 +100,7 @@ module type S = sig val passed_mutation_testing: Learnocaml_report.t -> bool end -module Make (_: module type of Test_lib) : S +include M + +(** For backwards compatibility *) +module Make (_: module type of Test_lib) = M diff --git a/src/grader/test_lib.ml b/src/grader/test_lib.ml index f9051a190..3df7f4198 100644 --- a/src/grader/test_lib.ml +++ b/src/grader/test_lib.ml @@ -1326,10 +1326,16 @@ module Intro = Pre_test.Introspection if sorted then Array.sort compare arr ; arr + let sample_list sample () = + (* version without parameters for ppx_autoregister *) + Array.to_list (sample_array sample ()) + let sample_list ?min_size ?max_size ?dups ?sorted sample () = Array.to_list (sample_array ?min_size ?max_size ?dups ?sorted sample ()) - let sample_pair sample1 sample2 () = + type ('a, 'b) pair = 'a * 'b + let sample_pair: 'a sampler -> 'b sampler -> ('a, 'b) pair sampler = + fun sample1 sample2 () -> (sample1 (), sample2 ()) let printable_funs = ref [] @@ -1355,18 +1361,18 @@ module Intro = Pre_test.Introspection 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 () = Intro.register_sampler "Test_lib" "sample_bool" "bool" sample_bool + let () = Intro.register_sampler "Test_lib" "sample_int" "int" sample_int + let () = Intro.register_sampler "Test_lib" "sample_float" "float" sample_float + let () = Intro.register_sampler "Test_lib" "sample_char" "char" sample_char + let () = Intro.register_sampler "Test_lib" "sample_string" "string" sample_string + let () = Intro.register_sampler "Test_lib" "sample_option" "option" sample_option let sample_array sample () = sample_array sample () - let () = Intro.register_sampler "array" sample_array + let () = Intro.register_sampler "Test_lib" "sample_array" "array" sample_array let sample_list sample () = sample_list sample () - let () = Intro.register_sampler "list" sample_list + let () = Intro.register_sampler "Test_lib" "sample_list" "list" sample_list type ('a, 'b) pair = 'a * 'b - let () = Intro.register_sampler "pair" sample_pair + let () = Intro.register_sampler "Test_lib" "sample_pair" "pair" sample_pair end let (@@@) f g = fun x -> f x @ g x diff --git a/src/ppx-metaquot/ppx_autoregister.ml b/src/ppx-metaquot/ppx_autoregister.ml index 21b67b33f..54599dc9e 100644 --- a/src/ppx-metaquot/ppx_autoregister.ml +++ b/src/ppx-metaquot/ppx_autoregister.ml @@ -2,7 +2,7 @@ open Ppxlib module type ARG = sig val val_prefix: string - val inject_def: string -> string loc -> expression + val inject_def: string -> string -> string loc -> expression end module Make (Arg: ARG) = struct @@ -35,24 +35,40 @@ module Ast_builder = Ast_builder.Make (struct let loc = Location.none end) +let gen_expr (name, e) = + let id = + (* Create a fresh id that will be exported in the interface, so that looking + up the register function type in the cmi can't be tricked by later + redefinitions with a different type *) + Printf.sprintf "learnocaml_autoregister_%s_%06X" + name (Random.int 0xFFFFFF) + in + ({txt=id; loc=e.loc}, e), Arg.inject_def id name e + 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 ids, exprs = List.split (List.map gen_expr defs) in + let val_registration = esequence exprs in let register_toplevel = - [ value_binding ~pat:punit ~expr:val_registration ] + List.map (fun (id, e) -> + value_binding + ~pat:(Ast_builder.ppat_var id) + ~expr:(Ast_builder.pexp_ident + {txt=Longident.Lident e.txt; loc=e.loc})) + ids + @ [ 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) + 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 diff --git a/src/ppx-metaquot/ppx_autoregister.mli b/src/ppx-metaquot/ppx_autoregister.mli index 69dd05be6..d5ef60f11 100644 --- a/src/ppx-metaquot/ppx_autoregister.mli +++ b/src/ppx-metaquot/ppx_autoregister.mli @@ -1,6 +1,6 @@ module type ARG = sig val val_prefix: string - val inject_def: string -> string Ppxlib.loc -> Ppxlib.expression + val inject_def: string -> string -> string Ppxlib.loc -> Ppxlib.expression end module Make (_: ARG): sig diff --git a/src/ppx-metaquot/ppx_metaquot_grader.ml b/src/ppx-metaquot/ppx_metaquot_grader.ml index 3c7dbfc0b..f1473fb1e 100644 --- a/src/ppx-metaquot/ppx_metaquot_grader.ml +++ b/src/ppx-metaquot/ppx_metaquot_grader.ml @@ -1,16 +1,42 @@ + +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 name var = + 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 name - ; Nolabel, evar ~loc var.txt] + [ 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 []); + Ppxlib.Driver.register_transformation "print_recorder" ~impl:Printer_recorder.expand; Ppxlib.Driver.register_transformation "sample_recorder" ~impl:Sampler_recorder.expand diff --git a/src/toplevel/dune b/src/toplevel/dune index 337f82112..d25756a0e 100644 --- a/src/toplevel/dune +++ b/src/toplevel/dune @@ -8,6 +8,14 @@ toploop_results) ) +(library + (name learnocaml_internal_intf) + (public_name learn-ocaml.learnocaml_internal_intf) + (wrapped false) + (modules learnocaml_internal_intf) + (modules_without_implementation learnocaml_internal_intf) +) + (executable (name learnocaml_toplevel_worker_main) (modes (byte js)) @@ -20,6 +28,7 @@ toploop_results ocplib-ocamlres.runtime embedded_cmis + learnocaml_internal_intf learnocaml_toplevel_worker_messages) (modules Learnocaml_toplevel_worker_main) (preprocess (pps js_of_ocaml-ppx)) From 3fc41caf632ede074476d760b892ebd61b790b9e Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 19 Apr 2022 11:00:19 +0200 Subject: [PATCH 18/41] feat: Provide lib to compile grader helper libraries and facility to link them during the `build` step. NOTE: the helper library is going to be included in every exercise. A lighter approach could be to keep loading it separately, e.g. after loading the cma/js file from a directory holding static content on the server (and removing the `.cma` from the compilation line in `precompile_exercise.ml`). This will probably fit well once we include such a mechanism for loading custom libraries as the prelude to exercises, the main difference being that the latter will also need the `cmi` files. --- META.learn-ocaml.template | 6 ++++++ src/grader/dune | 21 ++++++++++----------- src/grader/learnocaml_internal.mli | 4 ++++ src/repo/learnocaml_precompile_exercise.ml | 4 ++-- src/toplevel/dune | 1 - src/toplevel/learnocaml_internal_intf.mli | 4 ++++ 6 files changed, 26 insertions(+), 14 deletions(-) create mode 100644 META.learn-ocaml.template create mode 100644 src/grader/learnocaml_internal.mli create mode 100644 src/toplevel/learnocaml_internal_intf.mli diff --git a/META.learn-ocaml.template b/META.learn-ocaml.template new file mode 100644 index 000000000..a19c0e2cd --- /dev/null +++ b/META.learn-ocaml.template @@ -0,0 +1,6 @@ +package "test_lib" ( + directory = "test_lib" + version = "0.13.2" + description = "Learn-ocaml dependencies for automatic graders" + requires = "compiler-libs" +) diff --git a/src/grader/dune b/src/grader/dune index 82a70bbb2..d2bd5d104 100644 --- a/src/grader/dune +++ b/src/grader/dune @@ -168,20 +168,19 @@ ) ;; cmis that are needed to precompile the graders for exercises -;; FIXME: now we install the libs through dune, so use that ?? (install - (section share) + (section lib) (package learn-ocaml) (files - (../ppx-metaquot/.ty.objs/byte/ty.cmi as grading_cmis/ty.cmi) - (../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi as grading_cmis/fun_ty.cmi) -;; (.exercise_init.objs/byte/exercise_init.cmi as grading_cmis/exercise_init.cmi) - (.introspection_intf.objs/byte/introspection_intf.cmi as grading_cmis/introspection_intf.cmi) - (.pre_test.objs/byte/learnocaml_internal.cmi as grading_cmis/learnocaml_internal.cmi) - (.pre_test.objs/byte/pre_test.cmi as grading_cmis/pre_test.cmi) - (.learnocaml_report.objs/byte/learnocaml_report.cmi as grading_cmis/learnocaml_report.cmi) - (.pre_test.objs/byte/learnocaml_callback.cmi as grading_cmis/learnocaml_callback.cmi) ;;FIXME separate lib?? - (.testing_dyn.objs/byte/test_lib.cmi as grading_cmis/test_lib.cmi)) + (../ppx-metaquot/.ty.objs/byte/ty.cmi as test_lib/ty.cmi) + (../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi as test_lib/fun_ty.cmi) +;; (.exercise_init.objs/byte/exercise_init.cmi as test_lib/exercise_init.cmi) + (.introspection_intf.objs/byte/introspection_intf.cmi as test_lib/introspection_intf.cmi) + (.pre_test.objs/byte/learnocaml_internal.cmi as test_lib/learnocaml_internal.cmi) + (.pre_test.objs/byte/pre_test.cmi as test_lib/pre_test.cmi) + (.learnocaml_report.objs/byte/learnocaml_report.cmi as test_lib/learnocaml_report.cmi) + (.pre_test.objs/byte/learnocaml_callback.cmi as test_lib/learnocaml_callback.cmi) ;;FIXME separate lib?? + (.testing_dyn.objs/byte/test_lib.cmi as test_lib/test_lib.cmi)) ) diff --git a/src/grader/learnocaml_internal.mli b/src/grader/learnocaml_internal.mli new file mode 100644 index 000000000..3471067bb --- /dev/null +++ b/src/grader/learnocaml_internal.mli @@ -0,0 +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 diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index b98f1ee21..4fad60bca 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -6,7 +6,7 @@ open Lwt.Infix let grading_cmis_dir, grading_ppx_dir = let prefix = Filename.dirname (Filename.dirname (Sys.executable_name)) in let ( / ) = Filename.concat in - ref (prefix/"share"/"learn-ocaml"/"grading_cmis"), + ref (prefix/"lib"/"learn-ocaml"/"test_lib"), ref (prefix/"lib"/"learn-ocaml"/"grading_ppx") let run ?dir cmd args = @@ -91,7 +91,7 @@ let precompile ~exercise_dir = ~source:["test.ml"] ~target:"test.cmo" >>= fun () -> - ocamlc ~dir ["-a"] + ocamlc ~dir (["-a"] @ grader_flags) ~source:["test.cmo"] ~target:"test.cma" >>= fun () -> diff --git a/src/toplevel/dune b/src/toplevel/dune index d25756a0e..b0ce0edb6 100644 --- a/src/toplevel/dune +++ b/src/toplevel/dune @@ -10,7 +10,6 @@ (library (name learnocaml_internal_intf) - (public_name learn-ocaml.learnocaml_internal_intf) (wrapped false) (modules learnocaml_internal_intf) (modules_without_implementation learnocaml_internal_intf) diff --git a/src/toplevel/learnocaml_internal_intf.mli b/src/toplevel/learnocaml_internal_intf.mli new file mode 100644 index 000000000..21b77d5d4 --- /dev/null +++ b/src/toplevel/learnocaml_internal_intf.mli @@ -0,0 +1,4 @@ +(* (hidden) interface of the module that will be pre-loaded in the toplevel *) +module type S = sig + val register_printer: string -> ('a -> 'b) -> unit +end From 7d2752392ec7bf74a21d1604e2f35a221377e3f1 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 20 Apr 2022 12:16:44 +0200 Subject: [PATCH 19/41] fix: Fix printer registration in the grader --- src/grader/introspection.ml | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index a33defd85..7936a9234 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -54,7 +54,7 @@ let insert_in_env (type t) name (ty : t Ty.ty) (value : t) = match ty.ctyp_desc with | Ttyp_package { pack_type; _ } -> Env.add_module - (Ident.create_local name) + (Ident.create_persistent name) Types.Mp_present pack_type !Toploop.toplevel_env @@ -235,7 +235,6 @@ let install_printer modname id tyname pr = ty_args (gen_printer_type ty_target) in - Ctype.end_def (); (try Ctype.unify env printer_ty_expected @@ -260,26 +259,33 @@ let install_printer modname id tyname pr = args) ty_args tyname); + Ctype.end_def (); Ctype.generalize printer_ty_expected; - let ty_path = - match ty_target.desc with - | Tconstr (path, args, _) - when Ctype.all_distinct_vars env args -> Format.kasprintf failwith "XXX %a // %a // %a" Printtyp.path ty_path Printtyp.path path Printtyp.type_expr ty_target - | Tconstr (path, args, _) -> Format.kasprintf failwith "XXX %a // %a // %a" Printtyp.path ty_path Printtyp.path path Printtyp.type_expr ty_target - | _ -> ty_path - in - let rec build v = function + 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 ((Obj.obj v : _ -> Obj.t) fn) args) + (fun fn -> build_generic ((Obj.obj v : _ -> Obj.t) fn) args) in - Printer.install_generic_printer' - Path.(Pdot (Pident modident, "print_"^tyname)) - ty_path - (build (Obj.repr pr) ty_args) + 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) + let print_value ppf v ty = let { Typedtree.ctyp_type = ty; _ } = From c43290947491dc3e1de76a5df3581531971332aa Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 20 Apr 2022 17:35:29 +0200 Subject: [PATCH 20/41] fix: Do some cleanup & Fix `mutation_testing` test lib Now, an optional library that demonstrates the use of grader libraries. --- META.learn-ocaml.template | 1 + demo-repository/exercises/demo/test_libs.txt | 1 + src/grader-plugins/dune | 16 ++++++++++ .../mutation_test.ml | 0 .../mutation_test.mli | 4 +-- src/grader/dune | 25 +++------------- src/grader/test_lib/dune | 30 +++++++++++++++++++ src/ppx-metaquot/dune | 19 ++++-------- .../{ppx_metaquot_grader.ml => grader_ppx.ml} | 0 src/ppx-metaquot/grader_ppx_main.ml | 2 ++ src/ppx-metaquot/ppx_metaquot_main.ml | 2 -- src/repo/learnocaml_precompile_exercise.ml | 7 ++--- 12 files changed, 65 insertions(+), 42 deletions(-) create mode 100644 demo-repository/exercises/demo/test_libs.txt create mode 100644 src/grader-plugins/dune rename src/{grader => grader-plugins}/mutation_test.ml (100%) rename src/{grader => grader-plugins}/mutation_test.mli (97%) create mode 100644 src/grader/test_lib/dune rename src/ppx-metaquot/{ppx_metaquot_grader.ml => grader_ppx.ml} (100%) create mode 100644 src/ppx-metaquot/grader_ppx_main.ml delete mode 100644 src/ppx-metaquot/ppx_metaquot_main.ml diff --git a/META.learn-ocaml.template b/META.learn-ocaml.template index a19c0e2cd..73be50fbb 100644 --- a/META.learn-ocaml.template +++ b/META.learn-ocaml.template @@ -4,3 +4,4 @@ package "test_lib" ( description = "Learn-ocaml dependencies for automatic graders" requires = "compiler-libs" ) +# DUNE_GEN diff --git a/demo-repository/exercises/demo/test_libs.txt b/demo-repository/exercises/demo/test_libs.txt new file mode 100644 index 000000000..6a71efd37 --- /dev/null +++ b/demo-repository/exercises/demo/test_libs.txt @@ -0,0 +1 @@ +learn-ocaml.mutation_testing diff --git a/src/grader-plugins/dune b/src/grader-plugins/dune new file mode 100644 index 000000000..9e64a39e3 --- /dev/null +++ b/src/grader-plugins/dune @@ -0,0 +1,16 @@ +(library + (name mutation_testing) + (public_name learn-ocaml.mutation_testing) + (wrapped false) + (modes byte) + (libraries compiler-libs) + ;; The following lines are specific for compiling from within learn-ocaml. + ;; When writing grader-helper libs, use instead: + ;; (libraries learn-ocaml.test_lib) + ;; (preprocess (action (run %{libexec:learn-ocaml.test_lib:grader-ppx} %{input-file}))) + (flags (:standard -I src/grader/test_lib -open Test_lib.Open_me)) + (modules mutation_test) + (preprocess (pps grader_ppx)) + (preprocessor_deps (alias ../grader/test_lib/test_lib_cmis)) + ;; this is not a preprocessor deps, but dune does not allow other kinds of deps... +) diff --git a/src/grader/mutation_test.ml b/src/grader-plugins/mutation_test.ml similarity index 100% rename from src/grader/mutation_test.ml rename to src/grader-plugins/mutation_test.ml diff --git a/src/grader/mutation_test.mli b/src/grader-plugins/mutation_test.mli similarity index 97% rename from src/grader/mutation_test.mli rename to src/grader-plugins/mutation_test.mli index 1505e00d7..f87bde703 100644 --- a/src/grader/mutation_test.mli +++ b/src/grader-plugins/mutation_test.mli @@ -100,7 +100,7 @@ module M: sig val passed_mutation_testing: Learnocaml_report.t -> bool end -include M +include module type of M (** For backwards compatibility *) -module Make (_: module type of Test_lib) = M +module Make (_: module type of Test_lib): module type of M diff --git a/src/grader/dune b/src/grader/dune index d2bd5d104..a2a597ddf 100644 --- a/src/grader/dune +++ b/src/grader/dune @@ -35,15 +35,15 @@ (library_flags :standard -linkall) (libraries ty toploop - learnocaml_ppx_metaquot learnocaml_ppx_metaquot_lib + grader_ppx ocplib-json-typed learnocaml_report learnocaml_repository introspection_intf pre_test) (modules Test_lib) - (preprocess (pps learnocaml_ppx_metaquot)) + (preprocess (pps grader_ppx)) ) (rule (target testing_dyn.js) @@ -167,29 +167,12 @@ (run ocp-ocamlres -format ocamlres %{deps}))) ) -;; cmis that are needed to precompile the graders for exercises -(install - (section lib) - (package learn-ocaml) - (files - (../ppx-metaquot/.ty.objs/byte/ty.cmi as test_lib/ty.cmi) - (../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi as test_lib/fun_ty.cmi) -;; (.exercise_init.objs/byte/exercise_init.cmi as test_lib/exercise_init.cmi) - (.introspection_intf.objs/byte/introspection_intf.cmi as test_lib/introspection_intf.cmi) - (.pre_test.objs/byte/learnocaml_internal.cmi as test_lib/learnocaml_internal.cmi) - (.pre_test.objs/byte/pre_test.cmi as test_lib/pre_test.cmi) - (.learnocaml_report.objs/byte/learnocaml_report.cmi as test_lib/learnocaml_report.cmi) - (.pre_test.objs/byte/learnocaml_callback.cmi as test_lib/learnocaml_callback.cmi) ;;FIXME separate lib?? - (.testing_dyn.objs/byte/test_lib.cmi as test_lib/test_lib.cmi)) -) - - (library (name grading) (wrapped false) (modes byte) (library_flags :standard -linkall) - (libraries learnocaml_ppx_metaquot + (libraries grader_ppx ocplib-ocamlres.runtime toploop learnocaml_internal_intf @@ -201,7 +184,7 @@ (modules Introspection Embedded_grading_lib Grading) - (preprocess (per_module ((pps ppx_ocplib_i18n learnocaml_ppx_metaquot) Grading))) + (preprocess (per_module ((pps ppx_ocplib_i18n grader_ppx) Grading))) ) diff --git a/src/grader/test_lib/dune b/src/grader/test_lib/dune new file mode 100644 index 000000000..ef6511b32 --- /dev/null +++ b/src/grader/test_lib/dune @@ -0,0 +1,30 @@ +;; cmis that are needed to precompile the graders for exercises + +(rule + (alias test_lib_cmis) + (action (progn + (copy %{dep:../../ppx-metaquot/.ty.objs/byte/ty.cmi} ty.cmi) + (copy %{dep:../../ppx-metaquot/.fun_ty.objs/byte/fun_ty.cmi} fun_ty.cmi) + ;; (copy %{dep:../.exercise_init.objs/byte/exercise_init.cmi} exercise_init.cmi) + (copy %{dep:../.introspection_intf.objs/byte/introspection_intf.cmi} introspection_intf.cmi) + (copy %{dep:../.pre_test.objs/byte/learnocaml_internal.cmi} learnocaml_internal.cmi) + (copy %{dep:../.pre_test.objs/byte/pre_test.cmi} pre_test.cmi) + (copy %{dep:../.learnocaml_report.objs/byte/learnocaml_report.cmi} learnocaml_report.cmi) + (copy %{dep:../.pre_test.objs/byte/learnocaml_callback.cmi} learnocaml_callback.cmi) + (copy %{dep:../.testing_dyn.objs/byte/test_lib.cmi} test_lib.cmi))) +) + +(install + (section lib) + (package learn-ocaml) + (files + (ty.cmi as test_lib/ty.cmi) + (fun_ty.cmi as test_lib/fun_ty.cmi) + ;; (exercise_init.cmi as test_lib/exercise_init.cmi) + (introspection_intf.cmi as test_lib/introspection_intf.cmi) + (learnocaml_internal.cmi as test_lib/learnocaml_internal.cmi) + (pre_test.cmi as test_lib/pre_test.cmi) + (learnocaml_report.cmi as test_lib/learnocaml_report.cmi) + (learnocaml_callback.cmi as test_lib/learnocaml_callback.cmi) + (test_lib.cmi as test_lib/test_lib.cmi)) +) diff --git a/src/ppx-metaquot/dune b/src/ppx-metaquot/dune index 6253671a5..9a9f026a6 100644 --- a/src/ppx-metaquot/dune +++ b/src/ppx-metaquot/dune @@ -20,30 +20,23 @@ (libraries ppx_tools compiler-libs) ) -;; (library -;; (name learnocaml_recorder) -;; (wrapped false) -;; (modules Recorder) -;; (libraries ppxlib)) - (library - (name learnocaml_ppx_metaquot) + (name grader_ppx) (wrapped false) (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree ppxlib) - (modules Ppx_autoregister Ppx_metaquot_grader) + (modules Ppx_autoregister Grader_ppx) (kind ppx_rewriter) ) (executable - (name ppx_metaquot_main) - (modules ppx_metaquot_main) - (libraries learnocaml_ppx_metaquot)) + (name grader_ppx_main) + (modules grader_ppx_main) + (libraries grader_ppx)) (install (section libexec) (package learn-ocaml) - (files - (ppx_metaquot_main.exe as grading_ppx/learnocaml-ppx-grader)) + (files (grader_ppx_main.exe as test_lib/grader-ppx)) ) (library diff --git a/src/ppx-metaquot/ppx_metaquot_grader.ml b/src/ppx-metaquot/grader_ppx.ml similarity index 100% rename from src/ppx-metaquot/ppx_metaquot_grader.ml rename to src/ppx-metaquot/grader_ppx.ml diff --git a/src/ppx-metaquot/grader_ppx_main.ml b/src/ppx-metaquot/grader_ppx_main.ml new file mode 100644 index 000000000..1d4ed0de6 --- /dev/null +++ b/src/ppx-metaquot/grader_ppx_main.ml @@ -0,0 +1,2 @@ +let () = + Migrate_parsetree.Driver.run_main ~exit_on_error:true () diff --git a/src/ppx-metaquot/ppx_metaquot_main.ml b/src/ppx-metaquot/ppx_metaquot_main.ml deleted file mode 100644 index 24d22a57f..000000000 --- a/src/ppx-metaquot/ppx_metaquot_main.ml +++ /dev/null @@ -1,2 +0,0 @@ -let () = - Migrate_parsetree.Driver.run_as_ppx_rewriter ~exit_on_error:true () diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index 4fad60bca..3b508d515 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -3,11 +3,10 @@ open Lwt.Infix (* FIXME: make these configurable *) -let grading_cmis_dir, grading_ppx_dir = +let grading_cmis_dir = let prefix = Filename.dirname (Filename.dirname (Sys.executable_name)) in let ( / ) = Filename.concat in - ref (prefix/"lib"/"learn-ocaml"/"test_lib"), - ref (prefix/"lib"/"learn-ocaml"/"grading_ppx") + ref (prefix/"lib"/"learn-ocaml"/"test_lib") let run ?dir cmd args = Lwt_process.exec ?cwd:dir ("", Array.of_list (cmd::args)) >>= function @@ -85,7 +84,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-grader"] + "-ppx"; Filename.concat !grading_cmis_dir "grader-ppx --as-ppx"] @ grader_flags) ~opn:["Learnocaml_callback"; "Prelude"; "Prepare"; "Test_lib.Open_me"] ~source:["test.ml"] From 264db4c0436f581c5fc68f222305e8f8770fd674 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 21 Apr 2022 10:55:30 +0200 Subject: [PATCH 21/41] refactor: Generalize sampler typing sync'ing with printer handling and the newer ppx that has the module name. --- src/grader/dune | 28 +++++---- src/grader/introspection.ml | 111 ++++++++++++++++++------------------ src/grader/test_lib.ml | 18 +++--- 3 files changed, 81 insertions(+), 76 deletions(-) diff --git a/src/grader/dune b/src/grader/dune index a2a597ddf..36c91555a 100644 --- a/src/grader/dune +++ b/src/grader/dune @@ -7,6 +7,12 @@ (libraries ocplib-json-typed ocplib_i18n) ) +(rule + (targets learnocaml_report.odoc) + (deps .learnocaml_report.objs/byte/learnocaml_report.cmti) + (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) +) + ;; needs to be a separate lib because the module is shared between evaluator ;; parts (Grading) and dynamic parts (Test_lib) (library @@ -50,18 +56,18 @@ (deps testing_dyn.cma) (action (run js_of_ocaml %{deps} --wrap-with dynload --pretty))) -;; (rule -;; (targets test_lib.odoc) -;; (deps .testing_dyn.objs/byte/test_lib.cmti) -;; (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) -;; ) +(rule + (targets test_lib.odoc) + (deps .testing_dyn.objs/byte/test_lib.cmti) + (action (run odoc compile --package learn-ocaml %{deps} -o %{targets})) +) -;; (rule -;; (alias doc) -;; (action (progn (run mkdir -p doc) -;; (run odoc html %{dep:learnocaml_report.odoc} -o %{workspace_root}/_doc/_html) -;; (run odoc html %{dep:test_lib.odoc} -o %{workspace_root}/_doc/_html))) -;; ) +(rule + (alias doc) + (action (progn (run mkdir -p doc) + (run odoc html %{dep:learnocaml_report.odoc} -o %{workspace_root}/_doc/_html) + (run odoc html %{dep:test_lib.odoc} -o %{workspace_root}/_doc/_html))) +) diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index 7936a9234..f4356d9b0 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -334,80 +334,79 @@ let print_value ppf v ty = - build the expected sampler type from the type params of [foo] - match with the sampler type *) -let register_sampler _modname _id name f = +let register_sampler modname id tyname f = let open Types in + let inmodpath id = + match String.split_on_char '.' modname with + | md::r -> + List.fold_left (fun acc id -> Path.Pdot (acc, id)) + (Path.Pident (Ident.create_persistent md)) (r @ [id]) + | [] -> + Path.Pident (Ident.create_local id) + in + let sampler_path = inmodpath id in + let env = !Toploop.toplevel_env in let gen_sampler_type = Path.Pdot (Path.Pident (Ident.create_persistent "Test_lib"), "sampler") in - let lookup_env = !Toploop.toplevel_env in - let sampler_name = "sample_" ^ name in + let ty_path1 = inmodpath tyname in match - let sampler_path = - Path.Pdot (Path.Pident (Ident.create_persistent "Test"), - sampler_name) - in - try sampler_path, Env.find_value sampler_path lookup_env - with Not_found -> - 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 -> - match - 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 + Env.find_value sampler_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.eprintf - "Warning: unrecognised sampler definition (type %s not found).@." - name - | sampled_ty_path, sampled_ty_decl -> + "Warning: ignored bad sampler registration %s.sample_%s. The type and \ + sampler must be found in the cmi file (no mli file allowed)@." + modname tyname + | sampler_desc, (sampled_ty_path, sampled_ty_decl) -> + Ctype.begin_def(); + let ty_args = + List.map (fun _ -> Ctype.newvar ()) sampled_ty_decl.type_params + in + let ty_target = + Ctype.newty (Tconstr (sampled_ty_path, ty_args, ref Mnil)) + in + let fn_args = + List.map (fun ty -> Ctype.newconstr gen_sampler_type [ty]) ty_args + in let sampler_ty_expected = - Ctype.begin_def(); - let ty_args = - List.map (fun _ -> Ctype.newvar ()) sampled_ty_decl.type_params - in - let ty_target = - Ctype.newty (Tconstr (sampled_ty_path, ty_args, ref Mnil)) - in - let fn_args = - List.map (fun ty -> Ctype.newconstr gen_sampler_type [ty]) ty_args - in - let sampler_ty = - List.fold_right (fun fn_arg ty -> - Ctype.newty (Tarrow (Asttypes.Nolabel, fn_arg, ty, Cunknown))) - fn_args (Ctype.newconstr gen_sampler_type [ty_target]) - in - Ctype.end_def (); - Ctype.generalize sampler_ty; - sampler_ty + List.fold_right (fun fn_arg ty -> + Ctype.newty (Tarrow (Asttypes.Nolabel, fn_arg, ty, Cunknown))) + fn_args (Ctype.newconstr gen_sampler_type [ty_target]) in (try - Ctype.unify lookup_env + Ctype.unify env sampler_ty_expected (Ctype.instance sampler_desc.val_type) with Ctype.Unify _ -> - Format.ksprintf failwith "%s has a wrong type for a sampling function.@." - sampler_name); + Format.kasprintf failwith + "Mismatching type for sampling function %s.sample_%s.@;\ + The type must be@ @[%aunit -> %a%s@]@." + modname tyname + (Format.pp_print_list + (fun ppf -> Format.fprintf ppf "(unit -> %a) ->@ " (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 (); + let def_name = "sample_" ^ tyname in Toploop.toplevel_env := - Env.add_value (Ident.create_local sampler_name) sampler_desc + Env.add_value (Ident.create_local def_name) sampler_desc !Toploop.toplevel_env; - Toploop.setvalue sampler_name (Obj.repr f) + Toploop.setvalue def_name (Obj.repr f) let sample_value ty = let { Typedtree.ctyp_type = ty; _ } = diff --git a/src/grader/test_lib.ml b/src/grader/test_lib.ml index 3df7f4198..0144f9a14 100644 --- a/src/grader/test_lib.ml +++ b/src/grader/test_lib.ml @@ -1361,18 +1361,18 @@ module Intro = Pre_test.Introspection end module Sampler_reg = struct include Sampler - let () = Intro.register_sampler "Test_lib" "sample_bool" "bool" sample_bool - let () = Intro.register_sampler "Test_lib" "sample_int" "int" sample_int - let () = Intro.register_sampler "Test_lib" "sample_float" "float" sample_float - let () = Intro.register_sampler "Test_lib" "sample_char" "char" sample_char - let () = Intro.register_sampler "Test_lib" "sample_string" "string" sample_string - let () = Intro.register_sampler "Test_lib" "sample_option" "option" sample_option + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_bool" "bool" sample_bool + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_int" "int" sample_int + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_float" "float" sample_float + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_char" "char" sample_char + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_string" "string" sample_string + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_option" "option" sample_option let sample_array sample () = sample_array sample () - let () = Intro.register_sampler "Test_lib" "sample_array" "array" sample_array + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_array" "array" sample_array let sample_list sample () = sample_list sample () - let () = Intro.register_sampler "Test_lib" "sample_list" "list" sample_list + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_list" "list" sample_list type ('a, 'b) pair = 'a * 'b - let () = Intro.register_sampler "Test_lib" "sample_pair" "pair" sample_pair + let () = Intro.register_sampler "Test_lib.Sampler_reg" "sample_pair" "pair" sample_pair end let (@@@) f g = fun x -> f x @ g x From 1ec3af6ebec857f79f440706779190541636ce68 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 21 Apr 2022 18:55:47 +0200 Subject: [PATCH 22/41] fix: Allow printer registration in prepare/prelude & Fix print callbacks' usage --- src/grader/grading.ml | 17 +- src/grader/introspection.ml | 122 +-------------- src/grader/introspection_intf.mli | 9 -- src/grader/learnocaml_callback.mli | 2 +- src/grader/learnocaml_internal.mli | 2 +- src/ppx-metaquot/dune | 26 +++- src/ppx-metaquot/exercise_ppx.ml | 2 + src/ppx-metaquot/exercise_ppx_main.ml | 2 + src/ppx-metaquot/grader_ppx.ml | 37 ----- src/ppx-metaquot/ppx_autoregister.ml | 8 + src/ppx-metaquot/ppx_autoregister.mli | 4 + src/ppx-metaquot/printer_recorder.ml | 13 ++ src/ppx-metaquot/printer_recorder.mli | 1 + src/ppx-metaquot/sampler_recorder.ml | 13 ++ src/ppx-metaquot/sampler_recorder.mli | 1 + src/repo/learnocaml_precompile_exercise.ml | 19 ++- src/toplevel/learnocaml_internal_intf.mli | 13 +- .../learnocaml_toplevel_worker_main.ml | 33 ++++ src/toploop/toploop_ext.ml | 146 ++++++++++++++++++ src/toploop/toploop_ext.mli | 9 ++ src/toploop/toploop_jsoo.ml | 3 +- src/toploop/toploop_unix.ml | 1 + 22 files changed, 297 insertions(+), 186 deletions(-) create mode 100644 src/ppx-metaquot/exercise_ppx.ml create mode 100644 src/ppx-metaquot/exercise_ppx_main.ml create mode 100644 src/ppx-metaquot/printer_recorder.ml create mode 100644 src/ppx-metaquot/printer_recorder.mli create mode 100644 src/ppx-metaquot/sampler_recorder.ml create mode 100644 src/ppx-metaquot/sampler_recorder.mli diff --git a/src/grader/grading.ml b/src/grader/grading.ml index 6f9b70111..9a13b16b9 100644 --- a/src/grader/grading.ml +++ b/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|}; diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index f4356d9b0..77243110a 100644 --- a/src/grader/introspection.ml +++ b/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@ @[%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 diff --git a/src/grader/introspection_intf.mli b/src/grader/introspection_intf.mli index df35e7247..4e1ad128b 100644 --- a/src/grader/introspection_intf.mli +++ b/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 diff --git a/src/grader/learnocaml_callback.mli b/src/grader/learnocaml_callback.mli index db8022e5a..a1d9d8c8a 100644 --- a/src/grader/learnocaml_callback.mli +++ b/src/grader/learnocaml_callback.mli @@ -1 +1 @@ -include Introspection_intf.LEARNOCAML_CALLBACK +include Learnocaml_internal_intf.CALLBACKS diff --git a/src/grader/learnocaml_internal.mli b/src/grader/learnocaml_internal.mli index 3471067bb..763c33897 100644 --- a/src/grader/learnocaml_internal.mli +++ b/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 diff --git a/src/ppx-metaquot/dune b/src/ppx-metaquot/dune index 9a9f026a6..94de62ada 100644 --- a/src/ppx-metaquot/dune +++ b/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 diff --git a/src/ppx-metaquot/exercise_ppx.ml b/src/ppx-metaquot/exercise_ppx.ml new file mode 100644 index 000000000..b5a8bab72 --- /dev/null +++ b/src/ppx-metaquot/exercise_ppx.ml @@ -0,0 +1,2 @@ +let () = + Ppxlib.Driver.register_transformation "print_recorder" ~impl:Printer_recorder.expand diff --git a/src/ppx-metaquot/exercise_ppx_main.ml b/src/ppx-metaquot/exercise_ppx_main.ml new file mode 100644 index 000000000..1d4ed0de6 --- /dev/null +++ b/src/ppx-metaquot/exercise_ppx_main.ml @@ -0,0 +1,2 @@ +let () = + Migrate_parsetree.Driver.run_main ~exit_on_error:true () diff --git a/src/ppx-metaquot/grader_ppx.ml b/src/ppx-metaquot/grader_ppx.ml index f1473fb1e..fdf803e18 100644 --- a/src/ppx-metaquot/grader_ppx.ml +++ b/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 []); diff --git a/src/ppx-metaquot/ppx_autoregister.ml b/src/ppx-metaquot/ppx_autoregister.ml index 54599dc9e..35ca269fb 100644 --- a/src/ppx-metaquot/ppx_autoregister.ml +++ b/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 diff --git a/src/ppx-metaquot/ppx_autoregister.mli b/src/ppx-metaquot/ppx_autoregister.mli index d5ef60f11..3420ec662 100644 --- a/src/ppx-metaquot/ppx_autoregister.mli +++ b/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 diff --git a/src/ppx-metaquot/printer_recorder.ml b/src/ppx-metaquot/printer_recorder.ml new file mode 100644 index 000000000..4c4f7c53b --- /dev/null +++ b/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) diff --git a/src/ppx-metaquot/printer_recorder.mli b/src/ppx-metaquot/printer_recorder.mli new file mode 100644 index 000000000..268a2effb --- /dev/null +++ b/src/ppx-metaquot/printer_recorder.mli @@ -0,0 +1 @@ +val expand: Ppxlib.structure -> Ppxlib.structure diff --git a/src/ppx-metaquot/sampler_recorder.ml b/src/ppx-metaquot/sampler_recorder.ml new file mode 100644 index 000000000..55bfbac87 --- /dev/null +++ b/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) diff --git a/src/ppx-metaquot/sampler_recorder.mli b/src/ppx-metaquot/sampler_recorder.mli new file mode 100644 index 000000000..268a2effb --- /dev/null +++ b/src/ppx-metaquot/sampler_recorder.mli @@ -0,0 +1 @@ +val expand: Ppxlib.structure -> Ppxlib.structure diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index 3b508d515..03a690d60 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/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" diff --git a/src/toplevel/learnocaml_internal_intf.mli b/src/toplevel/learnocaml_internal_intf.mli index 21b77d5d4..48d55724e 100644 --- a/src/toplevel/learnocaml_internal_intf.mli +++ b/src/toplevel/learnocaml_internal_intf.mli @@ -1,4 +1,13 @@ +(** Interface of the module that gets automatically injected in the environment + before the Prelude is loaded. *) +module type CALLBACKS = sig + val print_html: string -> unit + val print_svg: string -> unit +end + + (* (hidden) interface of the module that will be pre-loaded in the toplevel *) -module type S = sig - val register_printer: string -> ('a -> 'b) -> unit +module type INTERNAL = sig + val install_printer: string -> string -> string -> ('a -> 'b) -> unit + exception Undefined end diff --git a/src/toplevel/learnocaml_toplevel_worker_main.ml b/src/toplevel/learnocaml_toplevel_worker_main.ml index 2850a6754..45ed8e3d3 100644 --- a/src/toplevel/learnocaml_toplevel_worker_main.ml +++ b/src/toplevel/learnocaml_toplevel_worker_main.ml @@ -129,6 +129,15 @@ let make_answer_ppf fd_answer = (fun str -> check_first_call () ; orig_print_string str) (fun () -> check_first_call () ; orig_flush ()) +(* For callbacks that are part of Learnocaml_internal_intf.CALLBACKS and + expected to be registered in advance *) +let print_html_callback = ref (fun _ -> ()) +let print_svg_callback = ref (fun _ -> ()) +let pre_registered_callbacks = [ + "print_html", print_html_callback; + "print_svg", print_svg_callback; +] + (** Code compilation and execution *) (* TODO protect execution with a mutex! *) @@ -224,6 +233,9 @@ let handler : type a. a host_msg -> a return Lwt.t = function val_loc = Location.none } !Toploop.toplevel_env ; Toploop.setvalue name (Obj.repr callback) ; + (match List.assoc_opt name pre_registered_callbacks with + | Some cbr -> cbr := callback + | None -> ()); return_unit_success | Check code -> let saved = !Toploop.toplevel_env in @@ -286,3 +298,24 @@ let () = "debug_worker" (Toploop.Directive_bool (fun b -> debug := b)); Worker.set_onmessage (fun s -> Lwt.async (fun () -> handler s)) + +(* Register some dynamic modules that are expected by compiled artifacts loaded + into the exercises. These have no cmi (hence are invisible to non-compiled + code) and are lightweight, so they should not affect the non-exercise + toplevels *) + +let () = + let module Learnocaml_callback: Learnocaml_internal_intf.CALLBACKS = struct + let print_html s = !print_html_callback s + let print_svg s = !print_svg_callback s + end in + Toploop_ext.inject_global "Learnocaml_callback" + (Obj.repr (module Learnocaml_callback: Learnocaml_internal_intf.CALLBACKS)) + +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)) diff --git a/src/toploop/toploop_ext.ml b/src/toploop/toploop_ext.ml index 9510502c8..0ef95a6dd 100644 --- a/src/toploop/toploop_ext.ml +++ b/src/toploop/toploop_ext.ml @@ -271,3 +271,149 @@ let inject_global name obj = Symtable.update_global_table (); Symtable.assign_global_value id obj; !inject_global_hook id + + +(** Printing *) + +(* Replacement for [Toploop.print_value] that doesn't segfault on yet + unregistered extension constructors (needed for printing types defined in + test.ml from within test.ml). *) +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 pending_installed_printers = ref [] + +(** 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 inmodpath id = + match String.split_on_char '.' modname with + | md::r -> + List.fold_left (fun acc id -> Path.Pdot (acc, id)) + (Path.Pident (Ident.create_persistent md)) (r @ [id]) + | [] -> + Path.Pident (Ident.create_local id) + in + let printer_path = inmodpath 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 = inmodpath 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.printf + "Warning: bad printer definition %s.print_%s. The type and printer \ + must be found in the cmi file (no mli file allowed).@." + 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.printf + "Warning: mismatching type for print function %s.print_%s.@;\ + The type must be@ @[%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 = inmodpath ("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 + (* Register for our custom 'Printer' as used by the graders *) + let () = + 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.printf + "Warning: 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) + in + (* Register for the toplevel built-in printer (the API doesn't allow us to + override it). Attempting to use the printer registered this way before + the module is fully loaded would risk crashes (e.g. on extensible + variants) *) + let rec path_to_longident = function + | Path.Pdot (p, s) -> Longident.Ldot (path_to_longident p, s) + | Path.Pident i -> Longident.Lident (Ident.name i) + | Path.Papply _ -> assert false + in + pending_installed_printers := + path_to_longident printer_path :: !pending_installed_printers + +let register_pending_printers () = + List.iter (Topdirs.dir_install_printer Format.std_formatter) + (List.rev !pending_installed_printers); + pending_installed_printers := [] diff --git a/src/toploop/toploop_ext.mli b/src/toploop/toploop_ext.mli index 3139d5a7d..0591b56a6 100644 --- a/src/toploop/toploop_ext.mli +++ b/src/toploop/toploop_ext.mli @@ -110,3 +110,12 @@ module Ppx : sig val preprocess_signature: Parsetree.signature -> Parsetree.signature val preprocess_phrase: Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase end + +module Printer : Genprintval.S with type t = Obj.t + +(** Used by our ppx *) +val install_printer: string -> string -> string -> ('a -> 'b) -> unit + +(** Hook to be called after loading units so that the registered printers are + present also in the toplevel's built-in printer. *) +val register_pending_printers: unit -> unit diff --git a/src/toploop/toploop_jsoo.ml b/src/toploop/toploop_jsoo.ml index 934183de2..ac11af40f 100644 --- a/src/toploop/toploop_jsoo.ml +++ b/src/toploop/toploop_jsoo.ml @@ -144,7 +144,8 @@ let use_compiled_string code = in ignore @@ Js.Unsafe.fun_call (Js.Unsafe.eval_string clean_code) - [|Js.Unsafe.inject Js.Unsafe.global|] + [|Js.Unsafe.inject Js.Unsafe.global|]; + Toploop_ext.register_pending_printers () let () = Toploop_ext.set_inject_global_hook @@ fun id -> Js_of_ocaml.Js.Unsafe.set diff --git a/src/toploop/toploop_unix.ml b/src/toploop/toploop_unix.ml index 2d9805f8a..7fc8b7592 100644 --- a/src/toploop/toploop_unix.ml +++ b/src/toploop/toploop_unix.ml @@ -89,6 +89,7 @@ let use_compiled_string code = raise exn in Sys.remove cma; + Toploop_ext.register_pending_printers (); flush_all (); if r then () else failwith "Failed to load compiled code" From 54851dd368e1c8a5635a2a193751aec1e46f1d97 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 10:25:08 +0200 Subject: [PATCH 23/41] refactor: Disable debug flags --- src/grader/dune | 2 +- src/repo/learnocaml_precompile_exercise.ml | 2 +- src/toploop/dune | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/grader/dune b/src/grader/dune index 36c91555a..c181c614a 100644 --- a/src/grader/dune +++ b/src/grader/dune @@ -54,7 +54,7 @@ (rule (target testing_dyn.js) (deps testing_dyn.cma) - (action (run js_of_ocaml %{deps} --wrap-with dynload --pretty))) + (action (run js_of_ocaml %{deps} --wrap-with dynload))) (rule (targets test_lib.odoc) diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index 03a690d60..59c0a3ca9 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -42,7 +42,7 @@ let ocamlc ?(dir=Sys.getcwd ()) ?(opn=[]) ?(ppx=[]) ~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" :: "--pretty" :: args in + let args = "--wrap-with=dynload" :: args in let args = args @ [d source; "-o"; d target] in run "js_of_ocaml" args diff --git a/src/toploop/dune b/src/toploop/dune index f5d088ad3..913cca06d 100644 --- a/src/toploop/dune +++ b/src/toploop/dune @@ -22,7 +22,6 @@ (libraries js_of_ocaml-compiler toploop) (modules Toploop_jsoo) (preprocess (pps js_of_ocaml-ppx)) - (js_of_ocaml (flags :standard --pretty)) ) (library From f028b75b09676120669ea6f4b9e0beff686c9302 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 10:32:41 +0200 Subject: [PATCH 24/41] docs: Update French translation --- translations/fr.po | 129 ++++++++++++++++++--------------------------- 1 file changed, 50 insertions(+), 79 deletions(-) diff --git a/translations/fr.po b/translations/fr.po index 201aad75a..9b7e4fd89 100644 --- a/translations/fr.po +++ b/translations/fr.po @@ -1,5 +1,5 @@ # LEARN-OCAML FRENCH TRANSLATION -# Copyright (C) 2019 OCaml Software Foundation. +# Copyright (C) 2019-2023 OCaml Software Foundation. # Copyright (C) 2018 OCamlPro # Louis Gesbert , 2018. # @@ -206,7 +206,7 @@ msgstr "Statistiques" #: File "src/app/learnocaml_common.ml", line 836, characters 37-48 #: "src/app/learnocaml_index_main.ml", 843, 29-40 #: "src/app/learnocaml_teacher_tab.ml", 375, 21-32 -#: "src/app/learnocaml_exercise_main.ml", 204, 23-34 +#: "src/app/learnocaml_exercise_main.ml", 213, 23-34 msgid "Exercises" msgstr "Exercices" @@ -338,55 +338,55 @@ msgstr "Métadonnées" msgid "The toplevel has been cleared.\n" msgstr "Le toplevel a été nettoyé.\n" -#: File "src/toplevel/learnocaml_toplevel.ml", line 271, characters 36-49 +#: File "src/toplevel/learnocaml_toplevel.ml", line 303, characters 36-49 msgid "%d seconds!" msgstr "%d secondes !" -#: File "src/toplevel/learnocaml_toplevel.ml", line 274, characters 20-30 +#: File "src/toplevel/learnocaml_toplevel.ml", line 306, characters 20-30 msgid "Kill it!" msgstr "Le terminer !" -#: File "src/toplevel/learnocaml_toplevel.ml", line 284, characters 24-40 +#: File "src/toplevel/learnocaml_toplevel.ml", line 316, characters 24-40 msgid "Infinite loop?" msgstr "Boucle infinie ?" -#: File "src/toplevel/learnocaml_toplevel.ml", line 286, characters 23-66 +#: File "src/toplevel/learnocaml_toplevel.ml", line 318, characters 23-66 msgid "The toplevel has not been responding for " msgstr "Le toplevel ne répond plus depuis " -#: File "src/toplevel/learnocaml_toplevel.ml", line 288, characters 23-34 292, +#: File "src/toplevel/learnocaml_toplevel.ml", line 320, characters 23-34 324, msgid " seconds." msgstr " secondes." -#: File "src/toplevel/learnocaml_toplevel.ml", line 290, characters 23-46 +#: File "src/toplevel/learnocaml_toplevel.ml", line 322, characters 23-46 msgid "It will be killed in " msgstr "Il sera terminé dans " -#: File "src/toplevel/learnocaml_toplevel.ml", line 321, characters 20-34 +#: File "src/toplevel/learnocaml_toplevel.ml", line 353, characters 20-34 msgid "Show anyway!" msgstr "Afficher quand même !" -#: File "src/toplevel/learnocaml_toplevel.ml", line 323, characters 20-34 +#: File "src/toplevel/learnocaml_toplevel.ml", line 355, characters 20-34 msgid "Hide output!" msgstr "Masquer la sortie !" -#: File "src/toplevel/learnocaml_toplevel.ml", line 332, characters 24-41 +#: File "src/toplevel/learnocaml_toplevel.ml", line 364, characters 24-41 msgid "Flooded output!" msgstr "La sortie déborde !" -#: File "src/toplevel/learnocaml_toplevel.ml", line 335, characters 30-69 +#: File "src/toplevel/learnocaml_toplevel.ml", line 367, characters 30-69 msgid "Your code is flooding the %s channel." msgstr "Votre code submerge le canal %s." -#: File "src/toplevel/learnocaml_toplevel.ml", line 337, characters 23-48 +#: File "src/toplevel/learnocaml_toplevel.ml", line 369, characters 23-48 msgid "It has already printed " msgstr "Il a déjà affiché " -#: File "src/toplevel/learnocaml_toplevel.ml", line 339, characters 23-32 +#: File "src/toplevel/learnocaml_toplevel.ml", line 371, characters 23-32 msgid " bytes." msgstr " octets." -#: File "src/toplevel/learnocaml_toplevel.ml", line 375, characters 44-80 +#: File "src/toplevel/learnocaml_toplevel.ml", line 407, characters 44-80 msgid "" "\n" "Interrupted output channel %s.\n" @@ -394,7 +394,7 @@ msgstr "" "\n" "Canal de sortie %s interrompu.\n" -#: File "src/toplevel/learnocaml_toplevel.ml", lines 407-412, characters 5-39 +#: File "src/toplevel/learnocaml_toplevel.ml", lines 439-444, characters 5-39 msgid "" "Printf.printf \"Welcome to OCaml %s\\n%!\" (Sys.ocaml_version);\n" "print_endline \" - type your OCaml phrase in the box below and press [Enter]\";\n" @@ -408,7 +408,7 @@ msgstr "" "print_endline \" - utilisez [Ctrl-\\xe2\\x86\\x91] pour retrouver votre entrée précédente\";\n" "print_endline \" - utilisez [Ctrl-\\xe2\\x86\\x91] / [Ctrl-\\xe2\\x86\\x93] pour naviguer dans l'historique\";;" -#: File "src/toplevel/learnocaml_toplevel.ml", line 518, characters 11-43 +#: File "src/toplevel/learnocaml_toplevel.ml", line 550, characters 11-43 msgid "The toplevel has been reset.\n" msgstr "Le toplevel a été redémarré.\n" @@ -968,7 +968,7 @@ msgstr "" "%a\n" "%!" -#: File "src/grader/grading.ml", line 22, characters 28-59 +#: File "src/grader/grading.ml", line 22, characters 26-57 msgid "" "Error in user code:\n" "\n" @@ -980,47 +980,28 @@ msgstr "" "%a\n" "%!" -#: File "src/grader/grading.ml", line 96, characters 38-65 106, 131, 139, 143, -msgid "while preparing the tests" -msgstr "lors de la préparation des tests" - -#: File "src/grader/grading.ml", line 100, characters 22-44 -msgid "Loading the prelude." -msgstr "Chargement du prélude." +#: File "src/grader/grading.ml", line 25, characters 9-32 +msgid "The grader is invalid" +msgstr "Le moteur de notation est invalide" -#: File "src/grader/grading.ml", line 101, characters 38-65 -msgid "while loading the prelude" -msgstr "lors du chargement du prélude" - -#: File "src/grader/grading.ml", line 105, characters 22-55 +#: File "src/grader/grading.ml", line 115, characters 22-55 msgid "Preparing the test environment." msgstr "Préparation de l'environnement de test." -#: File "src/grader/grading.ml", line 110, characters 22-42 +#: File "src/grader/grading.ml", line 119, characters 38-65 125, 128, 131, 134, +#: 168, 175, 181, +msgid "while preparing the tests" +msgstr "lors de la préparation des tests" + +#: File "src/grader/grading.ml", line 138, characters 22-42 msgid "Loading your code." msgstr "Chargement du code utilisateur." -#: File "src/grader/grading.ml", line 115, characters 22-45 -msgid "Loading the solution." -msgstr "Chargement de la solution." - -#: File "src/grader/grading.ml", line 116, characters 38-66 -msgid "while loading the solution" -msgstr "lors du chargement de la solution" - -#: File "src/grader/grading.ml", line 120, characters 22-54 +#: File "src/grader/grading.ml", line 145, characters 22-54 msgid "Preparing to launch the tests." msgstr "Préparation du lancement des tests." -#: File "src/grader/grading.ml", line 146, characters 22-49 -msgid "Launching the test bench." -msgstr "Lancement du banc de test." - -#: File "src/grader/grading.ml", line 175, characters 45-78 -msgid "while loading user dependencies" -msgstr "lors du chargement des dépendances" - -#: File "src/grader/grading.ml", line 191, characters 38-67 +#: File "src/grader/grading.ml", line 183, characters 38-67 msgid "while testing your solution" msgstr "lors du test de la solution utilisateur" @@ -1048,46 +1029,46 @@ msgstr "TEMPS ÉCOULÉ" msgid "The deadline for this exercise has expired. Any changes you make from now on will remain local only." msgstr "La date limite de rendu de cet exercice est passée. Vos changements ne seront plus sauvegardés sur le serveur." -#: File "src/app/learnocaml_exercise_main.ml", line 130, characters 25-49 -#: "src/app/learnocaml_playground_main.ml", 47, 19-43 -msgid "loading the prelude..." -msgstr "Chargement du prélude..." - -#: File "src/app/learnocaml_exercise_main.ml", line 135, characters 41-59 -#: "src/app/learnocaml_playground_main.ml", 50, 31-49 +#: File "src/app/learnocaml_exercise_main.ml", line 134, characters 36-54 137, +#: 35-53 139, 141, 143, "src/app/learnocaml_playground_main.ml", 50, 31-49 msgid "error in prelude" msgstr "erreur dans le prélude" -#: File "src/app/learnocaml_exercise_main.ml", line 216, characters 28-37 +#: File "src/app/learnocaml_exercise_main.ml", line 136, characters 19-43 +#: "src/app/learnocaml_playground_main.ml", 47, +msgid "loading the prelude..." +msgstr "Chargement du prélude..." + +#: File "src/app/learnocaml_exercise_main.ml", line 224, characters 28-37 #: "src/app/learnocaml_playground_main.ml", 84, msgid "Compile" msgstr "Compiler" -#: File "src/app/learnocaml_exercise_main.ml", line 220, characters 25-33 +#: File "src/app/learnocaml_exercise_main.ml", line 228, characters 29-37 msgid "Grade!" msgstr "Noter!" -#: File "src/app/learnocaml_exercise_main.ml", line 224, characters 48-55 +#: File "src/app/learnocaml_exercise_main.ml", line 232, characters 48-55 msgid "abort" msgstr "abandonner" -#: File "src/app/learnocaml_exercise_main.ml", lines 228-229, characters 35-65 +#: File "src/app/learnocaml_exercise_main.ml", lines 236-237, characters 35-65 msgid "Grading is taking a lot of time, maybe your code is looping? " msgstr "La notation prend du temps, peut-être une boucle infinie dans votre code ? " -#: File "src/app/learnocaml_exercise_main.ml", line 235, characters 35-57 +#: File "src/app/learnocaml_exercise_main.ml", line 243, characters 35-57 msgid "Launching the grader" msgstr "Lancement de la notation" -#: File "src/app/learnocaml_exercise_main.ml", line 258, characters 60-86 +#: File "src/app/learnocaml_exercise_main.ml", line 266, characters 60-86 msgid "Grading aborted by user." msgstr "Notation annulée par l'utilisateur." -#: File "src/app/learnocaml_exercise_main.ml", line 280, characters 38-59 +#: File "src/app/learnocaml_exercise_main.ml", line 288, characters 38-59 msgid "Error in your code." msgstr "Erreur dans le code." -#: File "src/app/learnocaml_exercise_main.ml", line 281, characters 27-85 +#: File "src/app/learnocaml_exercise_main.ml", line 289, characters 27-85 msgid "Cannot start the grader if your code does not typecheck." msgstr "La notation ne peut être lancée si le code ne compile pas." @@ -1172,7 +1153,7 @@ msgstr "Aucun rapport" msgid "Status of student: " msgstr "Suivi étudiant: " -#: File "src/grader/grader_jsoo_worker.ml", line 57, characters 34-67 +#: File "src/grader/grader_jsoo_worker.ml", line 65, characters 34-67 msgid "" "Error in your solution:\n" "%a\n" @@ -1182,7 +1163,7 @@ msgstr "" "%a\n" "%!" -#: File "src/grader/grader_jsoo_worker.ml", line 60, characters 34-68 +#: File "src/grader/grader_jsoo_worker.ml", line 68, characters 34-68 msgid "" "Error in the exercise %s\n" "%a\n" @@ -1192,7 +1173,7 @@ msgstr "" "%a\n" "%!" -#: File "src/grader/grader_jsoo_worker.ml", line 64, characters 17-71 +#: File "src/grader/grader_jsoo_worker.ml", line 72, characters 17-71 msgid "" "Internal error:\n" "The grader did not return a report." @@ -1200,10 +1181,8 @@ msgstr "" "Erreur interne:\n" "Le moteur de notation n'a pas retourné de rapport." -#: File "src/grader/grader_jsoo_worker.ml", line 66, characters 17-38 -msgid "Unexpected error:\n" -msgstr "Erreur inattendue:\n" - +#~ msgid "Unexpected error:\n" +#~ msgstr "Erreur inattendue:\n" #~ msgid "By prerequisites" #~ msgstr "Par prérequis" @@ -1222,14 +1201,6 @@ msgstr "Erreur inattendue:\n" #~ msgid "Download student data as CSV" #~ msgstr "Exporter les données étudiants en CSV" -#~ msgid "Fetch from server" -#~ msgstr "Télécharger du serveur" - -#~ msgid "Ignore & keep editing" -#~ msgstr "Ignorer & continuer d'éditer" - -#~ msgid "Fetch from server & overwrite" -#~ msgstr "Télécharger du serveur & écraser" #~ msgid "A more recent answer exists on the server. Do you want to fetch the new version?" #~ msgstr "Une version plus récente de cette réponse existe sur le serveur. Voulez-vous télécharger la nouvelle version ?" From 915514524c501317d79c6e40ee8a948f6a3e5af1 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 11:58:30 +0200 Subject: [PATCH 25/41] docs!: Remove doc tutorial on `depend.txt` (it will need rewriting) --- docs/howto-write-exercises.md | 6 - docs/tutorials/step-8.md | 199 ---------------------------------- docs/tutorials/step-9.md | 3 - 3 files changed, 208 deletions(-) delete mode 100644 docs/tutorials/step-8.md delete mode 100644 docs/tutorials/step-9.md diff --git a/docs/howto-write-exercises.md b/docs/howto-write-exercises.md index a61200a85..1ccc42435 100644 --- a/docs/howto-write-exercises.md +++ b/docs/howto-write-exercises.md @@ -65,9 +65,3 @@ get the files for the second step, and so on and so forth. [Step 6 : Grading functions for variables](tutorials/step-6.md) [Step 7 : Modifying the comparison functions (testers) with the optional arguments [~test], [~test_stdout], [~test_stderr]](tutorials/step-7.md) - -[Step 8 : Reusing the grader code](tutorials/step-8.md) - -- Separating the grader code - -[Step 9 : Introspection of students code](tutorials/step-9.md) diff --git a/docs/tutorials/step-8.md b/docs/tutorials/step-8.md deleted file mode 100644 index 1b26ab136..000000000 --- a/docs/tutorials/step-8.md +++ /dev/null @@ -1,199 +0,0 @@ -# Step 8: Reusing the grader code - -This step explains how to separate the grader code, and eventually reuse it in -other exercises. - -During the grading, the file **test.ml** is evaluated in an environment that -contains notably: -- **prelude.ml** and **prepare.ml** ; -- the student code isolated in a module `Code` ; -- **solution.ml** in a module `Solution` ; -- the grading modules **Introspection**, **Report** and **Test_lib**. - -### Separating the grader code - -It is possible to extend this environment by declaring some other user-defined -modules in an optional file **depend.txt**, located in the exercise directory. - -Each declaration in **depend.txt** is a single line containing the relative path -of an *.ml* or *.mli* file. The order of the *.ml* declarations specifies the -order in which each module is loaded in the grading environment. - -By default each dependency *foo.ml* is isolated in a module *Foo*, which can be -constrained by the content of an optional signature file *foo.mli*. Furthermore, -an annotation `[@@@included]` can be used at the beginning of a file *foo.ml* to -denote that all the bindings of *foo.ml* are evaluated in the toplevel -environment (and not in a module *Foo*). - -Dependencies that are not defined at the root of the exercise repository are -ignored by the build system: therefore, if you modify them, do not forget to -refresh the timestamp of `test.ml` (using `touch` for instance). - -### A complete example - -Let's write an exercise dedicated to *Peano numbers*. Here is the structure of -the exercise: - -``` -. -├── exercises -│ ├── index.json -│ └── lib -│ │ ├── check.ml -│ │ └── check.mli -│ ├── peano -│ │ ├── depend.txt -│ │ ├── descr.md -│ │ ├── meta.json -│ │ ├── prelude.ml -│ │ ├── prepare.ml -│ │ ├── solution.ml -│ │ ├── template.ml -│ │ ├── test.ml -│ │ └── tests -│ │ ├── samples.ml -│ │ ├── add.ml -│ │ └── odd_even.ml -│ ├── an-other-exercise -│ │ ├── depend.txt -│ │ │ ... -``` - -The exercise **peano** follows the classical format : **prelude.ml**, -**prepare.ml**, **solution.ml**, **template.ml** and **test.ml**. -It also includes several dependencies (**check.ml**, **samples.ml**, **add.ml** -and **odd_even.ml**) which are declared as follows in **depend.txt**: - -```txt -../lib/check.mli -../lib/check.ml # a comment - -tests/samples.ml -tests/add.ml -tests/odd_even.ml -``` - -Here is in details the source code of the exercise : - -- **descr.md**: - > * implement the function `add : peano -> peano -> peano` ; - > * implement the functions `odd : peano -> bool` and `even : peano -> bool`. - -- **prelude.ml**: - ```ocaml - type peano = Z | S of peano - ``` - -- **solution.ml**: - ```ocaml - let rec add n = function - | Z -> n - | S m -> S (add n m) - - let rec odd = function - | Z -> false - | S n -> even n - and even = function - | Z -> true - | S n -> odd n - ``` - -- **test.ml**: - ```ocaml - let () = - Check.safe_set_result [ Add.test ; Odd_even.test ] - ``` - -Note that **test.ml** is very compact because it simply combines functions -defined in separated files. - -- **../lib/check.ml**: - ```ocaml - open Test_lib - open Report - - let safe_set_result tests = - set_result @@ - ast_sanity_check code_ast @@ fun () -> - List.mapi (fun i test -> - Section ([ Text ("Question " ^ string_of_int i ^ ":") ], - test ())) tests - ``` - -- **../lib/check.mli**: - ```ocaml - val safe_set_result : (unit -> Report.t) list -> unit - ``` - -- **tests/add.ml**: - ```ocaml - let test () = - Test_lib.test_function_2_against_solution - [%ty : peano -> peano -> peano ] "add" - [ (Z, Z) ; (S(Z), S(S(Z))) ] - ``` - -- **tests/odd_even.ml**: - ```ocaml - let test () = - Test_lib.test_function_1_against_solution - [%ty : peano -> bool ] "odd" - [ Z ; S(Z) ; S(S(Z)) ] - @ - Test_lib.test_function_1_against_solution - [%ty : peano -> bool ] "even" - [ Z ; S(Z) ; S(S(Z)) ] - ``` - -Remember that **Test_lib** internally requires a user-defined sampler -`sample_peano : unit -> peano` to generate value of type `peano`. This sampler -has to be present in the toplevel environment -- and not in a module -- in order -to be found by the introspection primitives during grading. Therefore, -we define this sampler in a file starting with the annotation `[@@@included]`. - -- **tests/samples.ml**: - ```ocaml - [@@@included] - - let sample_peano () = - let rec aux = function - | 0 -> Z - | n -> S (aux (n-1)) - in aux (Random.int 42) - ``` - -Finally, the content of **test.ml** will be evaluated in the following -environment: - -```ocaml -val print_html : 'a -> 'b - -type peano = Z | S of peano - -module Code : sig - val add : peano -> peano -> peano - val odd : peano -> bool - val even : peano -> bool -end - -module Solution : sig - val add : peano -> peano -> peano - val odd : peano -> bool - val even : peano -> bool -end - -module Test_lib : Test_lib.S - -module Report = Learnocaml_report - -module Check : sig val check_all : (unit -> Report.t) list -> unit end - -val sample_peano : unit -> peano - -module Add : sig val test : unit -> Report.t end - -module Odd_even : sig val test : unit -> Report.t end -``` - -In the end, this feature can provide an increased comfort for writing large -automated graders and for reusing them in other exercises. diff --git a/docs/tutorials/step-9.md b/docs/tutorials/step-9.md deleted file mode 100644 index 2c51e3db0..000000000 --- a/docs/tutorials/step-9.md +++ /dev/null @@ -1,3 +0,0 @@ -# Step 9: Introspection of students code - -This document explains how to do an introspection of students code. From 2c89d9e0935cfce90031502c85cfb6ffa7ca000e Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 11:59:21 +0200 Subject: [PATCH 26/41] docs: Update doc for pre-compiled exercises + `test_libs.txt` --- docs/exercises_format.md | 30 ++++++++++++++++ docs/exercises_tests.md | 34 +++++++++++++++---- ...-setup-exercise-development-environment.md | 4 +-- docs/tutorials/step-0.md | 5 ++- 4 files changed, 62 insertions(+), 11 deletions(-) diff --git a/docs/exercises_format.md b/docs/exercises_format.md index 4eded44e3..ca01cab5e 100644 --- a/docs/exercises_format.md +++ b/docs/exercises_format.md @@ -54,6 +54,30 @@ An exercise is described by a directory containing at most the following files: - solution.ml - test.ml - max_score.txt +- test_libs.txt + +> Note: as of learn-ocaml 1.0, the `.ml` files get compiled into the exercise. +> It is therefore not possible to use directives like `#install_printer`. +> However, you can still define your own printers in a way similar to defining +> custom `sample_` functions: +> +> ```ocaml +> (* Custom printer for a pre-defined type *) +> let print_float ppf x = Format.fprintf ppf "%.2f" x +> +> (* Name the alias to define a printer for a specific instanciation of a +> generic type *) +> type int_list = int list +> let print_int_list ppf l = ... +> +> (* Define a generic printer for a generic type *) +> let print_result ppok pperr ppf = function +> | Ok ok -> Format.fprintf ppf "OK(%a)" ppok ok +> | Error err -> Format.fprintf ppf "ERR(%a)" pperr err +> ``` +> +> Printers defined in `prelude.ml` or `prepare.ml` affect the toplevel and the +> grader. Printers defined in `test.ml`, obviously, affect only the grader. ### meta.json @@ -130,6 +154,12 @@ code, which will be described and detailed in another section. Maximum score that is possible to get for this exercise, even if the grader grades more. Overridden by the field `max_score`, if present in `meta.json`. +### test_libs.txt + +List of additional libraries (one per line) to be used by the grader. The +libraries will be looked up using `ocamlfind`, available to `test.ml` during its +compilation, and bundled in the exercise grader. + # Metadata When building the corpus and extracting the metadatas of all exercises, the diff --git a/docs/exercises_tests.md b/docs/exercises_tests.md index 0ea7c8337..69e6afa19 100644 --- a/docs/exercises_tests.md +++ b/docs/exercises_tests.md @@ -20,23 +20,23 @@ A classic `test.ml` file is as follows: open Test_lib open Report -let exercise_1 = .. +let exercise_1 () = .. -let exercise_2 = .. +let exercise_2 () = .. -let exercise_3 = .. +let exercise_3 () = .. let () = set_result @@ ast_sanity_check code_ast @@ fun () -> - [ exercise_1 ; exercise_2 ; exercise_3 ] + [ exercise_1 (); exercise_2 (); exercise_3 () ] ``` -The values `exercise_x` are values of type `Learnocaml_report.report`, which is +The return values of `exercise_x` are of type `Learnocaml_report.report`, which is a representation of the report given by the grader. In this example, each of -these values are referring to a specific question from the exercise. Their +these values is referring to a specific question from the exercise. Their content is detailed in the next section. These reports are then given to the function `ast_sanity_check`, which ensures that some modules are never used (`Obj`, `Marshall`, all the modules from `compiler-libs` or the library that @@ -46,7 +46,7 @@ allows introspection), and also excludes some syntactic features of the language # Writing tests and reports -The format of reports can be found in `src/state/learnocaml_report.ml`. A report +The format of reports can be found in `src/grader/learnocaml_report.ml`. A report describes the result of what should be outputted and interpreted by the grader. It can be classified into sections for lisibility, and return many kind of messages: @@ -252,3 +252,23 @@ forbidden or required. The two functions `ast_check_expr` and pattern-matching on some specific patterns into the code. The function `find_binding` look for a toplevel value and apply a given function on its syntax tree. + +### Using helper libraries for testing + +Using a `test_libs.txt` file, it is possible to include libraries that define +helpers for grading. + +The file should contain the ocamlfind names of the libraries, one per line. + +Example of such libs include +[mutation_testing](https://github.com/ocaml-sf/learn-ocaml/blob/master/src/grader-plugins/mutation_test.ml) +(from McGill University, included in this repository), or +[easy-check](https://github.com/lsylvestre/easy-check) from University Paris 6. + +See `src/grader-plugins/dune` to get how to build such libraries. Like +`test.ml`, they can access the `Introspection` and `Test_lib` interfaces. They +cannot, at the time of writing, define new samplers or printers, but if you need +that feature and are ready to contribute, all that is missing is the inclusion +of their `cmi` files in the grading-toplevel environment (these features rely +on dynamic typing, and the `cma` library doesn't include the required typing +information). diff --git a/docs/howto-setup-exercise-development-environment.md b/docs/howto-setup-exercise-development-environment.md index d591abf8a..6893a8ddd 100644 --- a/docs/howto-setup-exercise-development-environment.md +++ b/docs/howto-setup-exercise-development-environment.md @@ -12,7 +12,6 @@ GNU/Linux and MacOS X are supported. > use: > > docker version # If this fails, find out how to run Docker, first -> docker login > docker run --rm \ > -v $REPOSITORY:/repository:ro \ > -v learn-ocaml-sync:/sync \ @@ -63,7 +62,6 @@ ready: ``` opam switch create . --deps-only --locked -opam install opam-installer eval $(opam env) ``` @@ -74,7 +72,7 @@ your current opam switch, without creating a dedicated one.) Second, compile and install the platform: ``` -make && make opaminstall +make && make install ``` At this point, you should get a working `learn-ocaml` program in diff --git a/docs/tutorials/step-0.md b/docs/tutorials/step-0.md index a56304157..4fbeabb6f 100644 --- a/docs/tutorials/step-0.md +++ b/docs/tutorials/step-0.md @@ -13,7 +13,8 @@ specific shape, illustrated by the following ascii art: │   │   ├── prepare.ml │   │   ├── solution.ml │   │   ├── template.ml -│   │   └── test.ml +│   │   ├── test.ml +│   │   └── test_libs.txt │   ├── exercise2 │   │   ├── ... │   ├── index.json @@ -68,6 +69,8 @@ The complete format specification for exercise description is given in - `test.ml` is the grader code. + - `test_libs.txt` optionally lists grader-helper libraries used by `test.ml` + - `lessons` and `tutorials` are ignored in this tutorial. ## Do it yourself! From 32ad13e1915239af563f88fa673b73649d685f28 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 12:05:33 +0200 Subject: [PATCH 27/41] fix: Fix dune dependency glitch on recompilation of `mutation_test` --- src/grader-plugins/dune | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/grader-plugins/dune b/src/grader-plugins/dune index 9e64a39e3..a0b860d55 100644 --- a/src/grader-plugins/dune +++ b/src/grader-plugins/dune @@ -11,6 +11,7 @@ (flags (:standard -I src/grader/test_lib -open Test_lib.Open_me)) (modules mutation_test) (preprocess (pps grader_ppx)) - (preprocessor_deps (alias ../grader/test_lib/test_lib_cmis)) - ;; this is not a preprocessor deps, but dune does not allow other kinds of deps... + (preprocessor_deps (file ../grader/grading.cma) + (alias ../grader/test_lib/test_lib_cmis)) + ;; these are not a preprocessor deps, but dune does not allow other kinds of deps... ) From 466e80ca8e5ea1ab99590d4795f7913188dd0333 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 13:50:25 +0200 Subject: [PATCH 28/41] fix(docker): Include jsoo in Dockerfile, which is now needed --- Dockerfile | 8 ++++++++ Makefile | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 4b1c13d5d..fa4b0341c 100644 --- a/Dockerfile +++ b/Dockerfile @@ -66,6 +66,14 @@ ARG opam_switch="/home/opam/.opam/4.12" COPY --from=compilation /home/opam/install-prefix /usr COPY --from=compilation "$opam_switch/bin"/ocaml* "$opam_switch/bin/" COPY --from=compilation "$opam_switch/lib/ocaml" "$opam_switch/lib/ocaml/" +COPY --from=compilation "$opam_switch/bin/js_of_ocaml" "$opam_switch/bin/" +COPY --from=compilation "$opam_switch/lib/js_of_ocaml" "$opam_switch/lib/js_of_ocaml" + +# Fixes for ocamlfind +COPY --from=compilation "$opam_switch/lib/findlib.conf" "$opam_switch/lib/" +COPY --from=compilation "$opam_switch/lib/stdlib" "$opam_switch/lib/stdlib" +ENV PATH="${opam_switch}/bin:${PATH}" +ENV OCAMLPATH="/usr/lib" ENTRYPOINT ["dumb-init","/usr/bin/learn-ocaml","--sync-dir=/sync","--repo=/repository"] CMD ["build","serve"] diff --git a/Makefile b/Makefile index 3b220a658..6d0c8c87a 100644 --- a/Makefile +++ b/Makefile @@ -82,7 +82,7 @@ docker-images: Dockerfile learn-ocaml.opam @docker build -t learn-ocaml-compilation --target compilation docker @docker build -t learn-ocaml --target program docker @docker build -t learn-ocaml-client --target client docker - @echo "Use with 'docker run --rm -v \$$PWD/sync:/sync -v \$$PWD:/repository -p PORT:8080 learn-ocaml -- ARGS'" + @echo "Use with 'docker run --rm -v learn-ocaml-sync:/sync -v \$$PWD:/repository -p PORT:8080 learn-ocaml -- ARGS'" VERSION = $(shell opam show ./learn-ocaml.opam -f version) From fa2cd23babafcea0ff7a2d685993a838af65eada Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 14:48:57 +0200 Subject: [PATCH 29/41] fix(ci): Fix permission issues `learn-ocaml build` now requires write access to the repository since it writes compilation artefacts in-place. --- .github/workflows/build-and-test.yml | 2 ++ tests/runtests.sh | 1 + 2 files changed, 3 insertions(+) diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml index 9fb851071..33670b387 100644 --- a/.github/workflows/build-and-test.yml +++ b/.github/workflows/build-and-test.yml @@ -21,6 +21,8 @@ jobs: uses: actions/checkout@v3 - name: Build Docker images run: "make docker-images" + - name: Fix permissions + run: "chmod -R a+wX demo-repository" - name: Run learn-ocaml build on demo-repository run: "docker run --rm -v $(pwd)/demo-repository:/repository learn-ocaml -- build" - name: Clone learn-ocaml-corpus inside tests/corpuses diff --git a/tests/runtests.sh b/tests/runtests.sh index c1f06b506..e8c2e0ca5 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -67,6 +67,7 @@ wait_for_it () { run_server () { SYNC="$srcdir"/"$dir"/sync REPO="$srcdir"/"$dir"/repo + chmod -R a+w "$REPO" mkdir "$SYNC" 2>/dev/null chmod o+w "$SYNC" From 5b4e0abaf1c16c1f1964014ab0b4feecc6bcdef8 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 22 Apr 2022 18:55:58 +0200 Subject: [PATCH 30/41] docs: Add/Update copyright headers --- src/ace-lib/ace.ml | 2 +- src/ace-lib/ocaml_mode.ml | 2 +- src/app/learnocaml_common.ml | 2 +- src/app/learnocaml_description_main.ml | 7 +++++++ src/app/learnocaml_exercise_main.ml | 2 +- src/app/learnocaml_index_main.ml | 2 +- src/app/learnocaml_local_storage.ml | 2 +- src/app/learnocaml_partition_view.ml | 2 +- src/app/learnocaml_playground_main.ml | 2 +- src/app/learnocaml_student_view.ml | 2 +- src/app/learnocaml_teacher_tab.ml | 2 +- src/app/server_caller.ml | 2 +- src/grader-plugins/mutation_test.ml | 7 +++++++ src/grader/grader_cli.ml | 2 +- src/grader/grader_jsoo_messages.ml | 2 +- src/grader/grader_jsoo_worker.ml | 2 +- src/grader/grading.ml | 2 +- src/grader/grading_cli.ml | 2 +- src/grader/grading_jsoo.ml | 2 +- src/grader/introspection.ml | 2 +- src/grader/introspection.mli | 2 +- src/grader/introspection_intf.mli | 2 +- src/grader/learnocaml_callback.mli | 7 +++++++ src/grader/learnocaml_internal.mli | 7 +++++++ src/grader/learnocaml_report.ml | 2 +- src/grader/pre_test.mli | 7 +++++++ src/grader/test_lib.ml | 2 +- src/grader/test_lib.mli | 2 +- src/main/learnocaml_client.ml | 2 +- src/main/learnocaml_main.ml | 2 +- src/main/learnocaml_server_args.ml | 4 ++-- src/main/learnocaml_server_main.ml | 2 +- src/ppx-metaquot/exercise_ppx.ml | 7 +++++++ src/ppx-metaquot/exercise_ppx_main.ml | 7 +++++++ src/ppx-metaquot/fun_ty.ml | 2 +- src/ppx-metaquot/grader_ppx.ml | 7 +++++++ src/ppx-metaquot/grader_ppx_main.ml | 7 +++++++ src/ppx-metaquot/ppx_autoregister.ml | 7 +++++++ src/ppx-metaquot/ppx_autoregister.mli | 7 +++++++ src/ppx-metaquot/printer_recorder.ml | 7 +++++++ src/ppx-metaquot/printer_recorder.mli | 7 +++++++ src/ppx-metaquot/sampler_recorder.ml | 7 +++++++ src/ppx-metaquot/sampler_recorder.mli | 7 +++++++ src/ppx-metaquot/ty.ml | 2 +- src/repo/learnocaml_exercise.ml | 2 +- src/repo/learnocaml_exercise.mli | 2 +- src/repo/learnocaml_index.ml | 2 +- src/repo/learnocaml_lesson.ml | 2 +- src/repo/learnocaml_precompile_exercise.ml | 7 +++++++ src/repo/learnocaml_process_exercise_repository.ml | 2 +- src/repo/learnocaml_process_playground_repository.ml | 2 +- src/repo/learnocaml_process_tutorial_repository.ml | 2 +- src/repo/learnocaml_tutorial.ml | 2 +- src/repo/learnocaml_tutorial_checker_main.ml | 2 +- src/repo/learnocaml_tutorial_parser.ml | 2 +- src/repo/learnocaml_tutorial_reader_main.ml | 2 +- src/server/learnocaml_server.ml | 2 +- src/state/learnocaml_api.ml | 2 +- src/state/learnocaml_api.mli | 2 +- src/state/learnocaml_data.ml | 2 +- src/state/learnocaml_store.ml | 2 +- src/toplevel/learnocaml_internal_intf.mli | 7 +++++++ src/toplevel/learnocaml_toplevel.ml | 2 +- src/toplevel/learnocaml_toplevel.mli | 2 +- src/toplevel/learnocaml_toplevel_history.ml | 2 +- src/toplevel/learnocaml_toplevel_input.ml | 2 +- src/toplevel/learnocaml_toplevel_output.ml | 2 +- src/toplevel/learnocaml_toplevel_pp.ml | 2 +- src/toplevel/learnocaml_toplevel_worker_caller.ml | 2 +- src/toplevel/learnocaml_toplevel_worker_caller.mli | 2 +- src/toplevel/learnocaml_toplevel_worker_main.ml | 2 +- src/toplevel/learnocaml_toplevel_worker_messages.mli | 2 +- src/toploop/toploop_ext.ml | 2 +- src/toploop/toploop_ext.mli | 2 +- src/toploop/toploop_jsoo.ml | 2 +- src/toploop/toploop_jsoo.mli | 2 +- src/toploop/toploop_results.ml | 2 +- src/toploop/toploop_unix.ml | 2 +- src/toploop/toploop_unix.mli | 2 +- src/utils/learnocaml_partition_create.ml | 2 +- src/utils/lwt_request.ml | 2 +- src/utils/lwt_utils.ml | 2 +- 82 files changed, 185 insertions(+), 66 deletions(-) diff --git a/src/ace-lib/ace.ml b/src/ace-lib/ace.ml index 00da23396..d971e475a 100644 --- a/src/ace-lib/ace.ml +++ b/src/ace-lib/ace.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019-2022 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/ace-lib/ocaml_mode.ml b/src/ace-lib/ocaml_mode.ml index b3cca0fda..a2b962d65 100644 --- a/src/ace-lib/ocaml_mode.ml +++ b/src/ace-lib/ocaml_mode.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_common.ml b/src/app/learnocaml_common.ml index e36fcac4b..a5a12d2d6 100644 --- a/src/app/learnocaml_common.ml +++ b/src/app/learnocaml_common.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019-2022 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_description_main.ml b/src/app/learnocaml_description_main.ml index 2f0248bef..e215555be 100644 --- a/src/app/learnocaml_description_main.ml +++ b/src/app/learnocaml_description_main.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + open Js_of_ocaml open Js_of_ocaml_tyxml open Js_utils diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index 318b78e80..0ac7d113d 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019-2022 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_index_main.ml b/src/app/learnocaml_index_main.ml index 883e65574..893626e64 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019-2022 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_local_storage.ml b/src/app/learnocaml_local_storage.ml index 26522633c..c77aa6db7 100644 --- a/src/app/learnocaml_local_storage.ml +++ b/src/app/learnocaml_local_storage.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019-2022 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_partition_view.ml b/src/app/learnocaml_partition_view.ml index d1571a151..a3e77ce99 100644 --- a/src/app/learnocaml_partition_view.ml +++ b/src/app/learnocaml_partition_view.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_playground_main.ml b/src/app/learnocaml_playground_main.ml index d0b11074d..f1e4e5792 100644 --- a/src/app/learnocaml_playground_main.ml +++ b/src/app/learnocaml_playground_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_student_view.ml b/src/app/learnocaml_student_view.ml index ff2489e30..7dbef0e28 100644 --- a/src/app/learnocaml_student_view.ml +++ b/src/app/learnocaml_student_view.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/learnocaml_teacher_tab.ml b/src/app/learnocaml_teacher_tab.ml index b9bc2e5d5..c615e0b10 100644 --- a/src/app/learnocaml_teacher_tab.ml +++ b/src/app/learnocaml_teacher_tab.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/app/server_caller.ml b/src/app/server_caller.ml index 869265136..9cb7a873a 100644 --- a/src/app/server_caller.ml +++ b/src/app/server_caller.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader-plugins/mutation_test.ml b/src/grader-plugins/mutation_test.ml index 55d11b266..f03b83a7a 100644 --- a/src/grader-plugins/mutation_test.ml +++ b/src/grader-plugins/mutation_test.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + open Test_lib.Open_me open Learnocaml_report diff --git a/src/grader/grader_cli.ml b/src/grader/grader_cli.ml index cb45ab55e..c3da7277c 100644 --- a/src/grader/grader_cli.ml +++ b/src/grader/grader_cli.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/grader_jsoo_messages.ml b/src/grader/grader_jsoo_messages.ml index 8a38f204c..a80b19a5d 100644 --- a/src/grader/grader_jsoo_messages.ml +++ b/src/grader/grader_jsoo_messages.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/grader_jsoo_worker.ml b/src/grader/grader_jsoo_worker.ml index 1fd379fea..0ad89a0a8 100644 --- a/src/grader/grader_jsoo_worker.ml +++ b/src/grader/grader_jsoo_worker.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/grading.ml b/src/grader/grading.ml index 9a13b16b9..ba7cdd998 100644 --- a/src/grader/grading.ml +++ b/src/grader/grading.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/grading_cli.ml b/src/grader/grading_cli.ml index 2615dd0e8..929d84fae 100644 --- a/src/grader/grading_cli.ml +++ b/src/grader/grading_cli.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/grading_jsoo.ml b/src/grader/grading_jsoo.ml index bc574212c..11afbfa1f 100644 --- a/src/grader/grading_jsoo.ml +++ b/src/grader/grading_jsoo.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/introspection.ml b/src/grader/introspection.ml index 77243110a..0873c84ca 100644 --- a/src/grader/introspection.ml +++ b/src/grader/introspection.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/introspection.mli b/src/grader/introspection.mli index 1ada82917..fdc06bc4d 100644 --- a/src/grader/introspection.mli +++ b/src/grader/introspection.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/introspection_intf.mli b/src/grader/introspection_intf.mli index 4e1ad128b..c65207957 100644 --- a/src/grader/introspection_intf.mli +++ b/src/grader/introspection_intf.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/learnocaml_callback.mli b/src/grader/learnocaml_callback.mli index a1d9d8c8a..125a95dce 100644 --- a/src/grader/learnocaml_callback.mli +++ b/src/grader/learnocaml_callback.mli @@ -1 +1,8 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + include Learnocaml_internal_intf.CALLBACKS diff --git a/src/grader/learnocaml_internal.mli b/src/grader/learnocaml_internal.mli index 763c33897..c572a3ac7 100644 --- a/src/grader/learnocaml_internal.mli +++ b/src/grader/learnocaml_internal.mli @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + (* 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 *) diff --git a/src/grader/learnocaml_report.ml b/src/grader/learnocaml_report.ml index 51a5600ed..424aac602 100644 --- a/src/grader/learnocaml_report.ml +++ b/src/grader/learnocaml_report.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/pre_test.mli b/src/grader/pre_test.mli index 4975b1a70..38aef9b83 100644 --- a/src/grader/pre_test.mli +++ b/src/grader/pre_test.mli @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + (* These values are injected into the environment after the exercise and solutions are loaded, and before the tests are loaded *) diff --git a/src/grader/test_lib.ml b/src/grader/test_lib.ml index 0144f9a14..0691c796e 100644 --- a/src/grader/test_lib.ml +++ b/src/grader/test_lib.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/grader/test_lib.mli b/src/grader/test_lib.mli index 071dabe67..d6c14543d 100644 --- a/src/grader/test_lib.mli +++ b/src/grader/test_lib.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/main/learnocaml_client.ml b/src/main/learnocaml_client.ml index ef03b0eaf..cb1cb8dbc 100644 --- a/src/main/learnocaml_client.ml +++ b/src/main/learnocaml_client.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/main/learnocaml_main.ml b/src/main/learnocaml_main.ml index f004166e0..4bc49bad4 100644 --- a/src/main/learnocaml_main.ml +++ b/src/main/learnocaml_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/main/learnocaml_server_args.ml b/src/main/learnocaml_server_args.ml index 8b3c10784..f089df0ae 100644 --- a/src/main/learnocaml_server_args.ml +++ b/src/main/learnocaml_server_args.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the @@ -79,4 +79,4 @@ module Args (SN : Section_name) = struct calling the native server from learn-ocaml main *) Term.(const apply $ app_dir $ sync_dir $ base_url $ port $ cert) -end \ No newline at end of file +end diff --git a/src/main/learnocaml_server_main.ml b/src/main/learnocaml_server_main.ml index aad5b1199..00fccac88 100644 --- a/src/main/learnocaml_server_main.ml +++ b/src/main/learnocaml_server_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/ppx-metaquot/exercise_ppx.ml b/src/ppx-metaquot/exercise_ppx.ml index b5a8bab72..02714053b 100644 --- a/src/ppx-metaquot/exercise_ppx.ml +++ b/src/ppx-metaquot/exercise_ppx.ml @@ -1,2 +1,9 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + let () = Ppxlib.Driver.register_transformation "print_recorder" ~impl:Printer_recorder.expand diff --git a/src/ppx-metaquot/exercise_ppx_main.ml b/src/ppx-metaquot/exercise_ppx_main.ml index 1d4ed0de6..729261994 100644 --- a/src/ppx-metaquot/exercise_ppx_main.ml +++ b/src/ppx-metaquot/exercise_ppx_main.ml @@ -1,2 +1,9 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + let () = Migrate_parsetree.Driver.run_main ~exit_on_error:true () diff --git a/src/ppx-metaquot/fun_ty.ml b/src/ppx-metaquot/fun_ty.ml index 2d41330d5..0b8e31910 100644 --- a/src/ppx-metaquot/fun_ty.ml +++ b/src/ppx-metaquot/fun_ty.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/ppx-metaquot/grader_ppx.ml b/src/ppx-metaquot/grader_ppx.ml index fdf803e18..15e936df0 100644 --- a/src/ppx-metaquot/grader_ppx.ml +++ b/src/ppx-metaquot/grader_ppx.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + let () = Migrate_parsetree.Driver.register ~name:"ppx_metaquot" (module Migrate_parsetree.OCaml_412) (fun _config _cookies -> Ppx_metaquot.Main.expander []); diff --git a/src/ppx-metaquot/grader_ppx_main.ml b/src/ppx-metaquot/grader_ppx_main.ml index 1d4ed0de6..729261994 100644 --- a/src/ppx-metaquot/grader_ppx_main.ml +++ b/src/ppx-metaquot/grader_ppx_main.ml @@ -1,2 +1,9 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + let () = Migrate_parsetree.Driver.run_main ~exit_on_error:true () diff --git a/src/ppx-metaquot/ppx_autoregister.ml b/src/ppx-metaquot/ppx_autoregister.ml index 35ca269fb..d38ae9cfd 100644 --- a/src/ppx-metaquot/ppx_autoregister.ml +++ b/src/ppx-metaquot/ppx_autoregister.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + open Ppxlib module type ARG = sig diff --git a/src/ppx-metaquot/ppx_autoregister.mli b/src/ppx-metaquot/ppx_autoregister.mli index 3420ec662..f100b2ef4 100644 --- a/src/ppx-metaquot/ppx_autoregister.mli +++ b/src/ppx-metaquot/ppx_autoregister.mli @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + module type ARG = sig val val_prefix: string val inject_def: string -> string -> string Ppxlib.loc -> Ppxlib.expression diff --git a/src/ppx-metaquot/printer_recorder.ml b/src/ppx-metaquot/printer_recorder.ml index 4c4f7c53b..8e81c0abf 100644 --- a/src/ppx-metaquot/printer_recorder.ml +++ b/src/ppx-metaquot/printer_recorder.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + include Ppx_autoregister.Make(struct let val_prefix = "print" let inject_def id name var = diff --git a/src/ppx-metaquot/printer_recorder.mli b/src/ppx-metaquot/printer_recorder.mli index 268a2effb..5b00dfcc1 100644 --- a/src/ppx-metaquot/printer_recorder.mli +++ b/src/ppx-metaquot/printer_recorder.mli @@ -1 +1,8 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + val expand: Ppxlib.structure -> Ppxlib.structure diff --git a/src/ppx-metaquot/sampler_recorder.ml b/src/ppx-metaquot/sampler_recorder.ml index 55bfbac87..3520f1d13 100644 --- a/src/ppx-metaquot/sampler_recorder.ml +++ b/src/ppx-metaquot/sampler_recorder.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + include Ppx_autoregister.Make(struct let val_prefix = "sample" let inject_def id name var = diff --git a/src/ppx-metaquot/sampler_recorder.mli b/src/ppx-metaquot/sampler_recorder.mli index 268a2effb..5b00dfcc1 100644 --- a/src/ppx-metaquot/sampler_recorder.mli +++ b/src/ppx-metaquot/sampler_recorder.mli @@ -1 +1,8 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + val expand: Ppxlib.structure -> Ppxlib.structure diff --git a/src/ppx-metaquot/ty.ml b/src/ppx-metaquot/ty.ml index 12beae6b7..444dc1940 100644 --- a/src/ppx-metaquot/ty.ml +++ b/src/ppx-metaquot/ty.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_exercise.ml b/src/repo/learnocaml_exercise.ml index aa502ad98..714992c0a 100644 --- a/src/repo/learnocaml_exercise.ml +++ b/src/repo/learnocaml_exercise.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_exercise.mli b/src/repo/learnocaml_exercise.mli index b29419a32..bc2f6db01 100644 --- a/src/repo/learnocaml_exercise.mli +++ b/src/repo/learnocaml_exercise.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_index.ml b/src/repo/learnocaml_index.ml index 50e3e8c2b..ec7571d3e 100644 --- a/src/repo/learnocaml_index.ml +++ b/src/repo/learnocaml_index.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_lesson.ml b/src/repo/learnocaml_lesson.ml index 4403ab2b2..b35fd09e5 100644 --- a/src/repo/learnocaml_lesson.ml +++ b/src/repo/learnocaml_lesson.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index 59c0a3ca9..ab34c46fd 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022-2023 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + (* Compile objects from an exercise *) open Lwt.Infix diff --git a/src/repo/learnocaml_process_exercise_repository.ml b/src/repo/learnocaml_process_exercise_repository.ml index 94d069cce..4b346f7a9 100644 --- a/src/repo/learnocaml_process_exercise_repository.ml +++ b/src/repo/learnocaml_process_exercise_repository.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_process_playground_repository.ml b/src/repo/learnocaml_process_playground_repository.ml index 8b3a54769..e9900d5e8 100644 --- a/src/repo/learnocaml_process_playground_repository.ml +++ b/src/repo/learnocaml_process_playground_repository.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_process_tutorial_repository.ml b/src/repo/learnocaml_process_tutorial_repository.ml index fa7da5903..f1484de87 100644 --- a/src/repo/learnocaml_process_tutorial_repository.ml +++ b/src/repo/learnocaml_process_tutorial_repository.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_tutorial.ml b/src/repo/learnocaml_tutorial.ml index 1eae8e88e..fe8888b07 100644 --- a/src/repo/learnocaml_tutorial.ml +++ b/src/repo/learnocaml_tutorial.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_tutorial_checker_main.ml b/src/repo/learnocaml_tutorial_checker_main.ml index 08fb83e18..7f1c2225b 100644 --- a/src/repo/learnocaml_tutorial_checker_main.ml +++ b/src/repo/learnocaml_tutorial_checker_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_tutorial_parser.ml b/src/repo/learnocaml_tutorial_parser.ml index b3bb52e38..15c5aae56 100644 --- a/src/repo/learnocaml_tutorial_parser.ml +++ b/src/repo/learnocaml_tutorial_parser.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/repo/learnocaml_tutorial_reader_main.ml b/src/repo/learnocaml_tutorial_reader_main.ml index 5a0a034ad..571729f7c 100644 --- a/src/repo/learnocaml_tutorial_reader_main.ml +++ b/src/repo/learnocaml_tutorial_reader_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index bdfa6758e..af1fdd830 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 09175ce53..655b7f0f9 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index e2c53758b..984a3277a 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml index 0b73156a7..211ee9928 100644 --- a/src/state/learnocaml_data.ml +++ b/src/state/learnocaml_data.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index 3d10c0f2e..04bd5d51e 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_internal_intf.mli b/src/toplevel/learnocaml_internal_intf.mli index 48d55724e..57a57c853 100644 --- a/src/toplevel/learnocaml_internal_intf.mli +++ b/src/toplevel/learnocaml_internal_intf.mli @@ -1,3 +1,10 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2022 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + (** Interface of the module that gets automatically injected in the environment before the Prelude is loaded. *) module type CALLBACKS = sig diff --git a/src/toplevel/learnocaml_toplevel.ml b/src/toplevel/learnocaml_toplevel.ml index 743494964..09edec96d 100644 --- a/src/toplevel/learnocaml_toplevel.ml +++ b/src/toplevel/learnocaml_toplevel.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel.mli b/src/toplevel/learnocaml_toplevel.mli index 1588c6eee..e6fb2901a 100644 --- a/src/toplevel/learnocaml_toplevel.mli +++ b/src/toplevel/learnocaml_toplevel.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_history.ml b/src/toplevel/learnocaml_toplevel_history.ml index 6465b7317..2c5bbbb11 100644 --- a/src/toplevel/learnocaml_toplevel_history.ml +++ b/src/toplevel/learnocaml_toplevel_history.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_input.ml b/src/toplevel/learnocaml_toplevel_input.ml index 0fb67163d..e8cb419f3 100644 --- a/src/toplevel/learnocaml_toplevel_input.ml +++ b/src/toplevel/learnocaml_toplevel_input.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_output.ml b/src/toplevel/learnocaml_toplevel_output.ml index b2a529c45..346195d13 100644 --- a/src/toplevel/learnocaml_toplevel_output.ml +++ b/src/toplevel/learnocaml_toplevel_output.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_pp.ml b/src/toplevel/learnocaml_toplevel_pp.ml index b312366fa..491b37fa8 100644 --- a/src/toplevel/learnocaml_toplevel_pp.ml +++ b/src/toplevel/learnocaml_toplevel_pp.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_worker_caller.ml b/src/toplevel/learnocaml_toplevel_worker_caller.ml index a348be112..de3de6460 100644 --- a/src/toplevel/learnocaml_toplevel_worker_caller.ml +++ b/src/toplevel/learnocaml_toplevel_worker_caller.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_worker_caller.mli b/src/toplevel/learnocaml_toplevel_worker_caller.mli index 9cf2d3595..8de5bfe2a 100644 --- a/src/toplevel/learnocaml_toplevel_worker_caller.mli +++ b/src/toplevel/learnocaml_toplevel_worker_caller.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_worker_main.ml b/src/toplevel/learnocaml_toplevel_worker_main.ml index 45ed8e3d3..0b15b1566 100644 --- a/src/toplevel/learnocaml_toplevel_worker_main.ml +++ b/src/toplevel/learnocaml_toplevel_worker_main.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toplevel/learnocaml_toplevel_worker_messages.mli b/src/toplevel/learnocaml_toplevel_worker_messages.mli index da75446aa..686eb40f2 100644 --- a/src/toplevel/learnocaml_toplevel_worker_messages.mli +++ b/src/toplevel/learnocaml_toplevel_worker_messages.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_ext.ml b/src/toploop/toploop_ext.ml index 0ef95a6dd..577c1d9d0 100644 --- a/src/toploop/toploop_ext.ml +++ b/src/toploop/toploop_ext.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_ext.mli b/src/toploop/toploop_ext.mli index 0591b56a6..be386ffc3 100644 --- a/src/toploop/toploop_ext.mli +++ b/src/toploop/toploop_ext.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_jsoo.ml b/src/toploop/toploop_jsoo.ml index ac11af40f..9a2e6c89b 100644 --- a/src/toploop/toploop_jsoo.ml +++ b/src/toploop/toploop_jsoo.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_jsoo.mli b/src/toploop/toploop_jsoo.mli index d41208ebc..2da1ff8a5 100644 --- a/src/toploop/toploop_jsoo.mli +++ b/src/toploop/toploop_jsoo.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_results.ml b/src/toploop/toploop_results.ml index cda6be8b5..819d6aa20 100644 --- a/src/toploop/toploop_results.ml +++ b/src/toploop/toploop_results.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_unix.ml b/src/toploop/toploop_unix.ml index 7fc8b7592..bcf58eb5e 100644 --- a/src/toploop/toploop_unix.ml +++ b/src/toploop/toploop_unix.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/toploop/toploop_unix.mli b/src/toploop/toploop_unix.mli index c460ab732..9828b6bed 100644 --- a/src/toploop/toploop_unix.mli +++ b/src/toploop/toploop_unix.mli @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/utils/learnocaml_partition_create.ml b/src/utils/learnocaml_partition_create.ml index 1611f1345..880fd872a 100644 --- a/src/utils/learnocaml_partition_create.ml +++ b/src/utils/learnocaml_partition_create.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/utils/lwt_request.ml b/src/utils/lwt_request.ml index 8c2eab8b5..a5413889a 100644 --- a/src/utils/lwt_request.ml +++ b/src/utils/lwt_request.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 6565ed85c..51ddabb91 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -1,6 +1,6 @@ (* This file is part of Learn-OCaml. * - * Copyright (C) 2019 OCaml Software Foundation. + * Copyright (C) 2019-2023 OCaml Software Foundation. * Copyright (C) 2015-2018 OCamlPro. * * Learn-OCaml is distributed under the terms of the MIT license. See the From 365cbb719a5048a6f422278fc986f822ad17770b Mon Sep 17 00:00:00 2001 From: Yann Regis-Gianas Date: Wed, 27 Jul 2022 16:58:31 +0200 Subject: [PATCH 31/41] fix: Expose `prepare.ml` file Signed-off-by: Yann Regis-Gianas --- src/repo/learnocaml_exercise.ml | 53 +++++++++++++++++++------------- src/repo/learnocaml_exercise.mli | 5 ++- 2 files changed, 36 insertions(+), 22 deletions(-) diff --git a/src/repo/learnocaml_exercise.ml b/src/repo/learnocaml_exercise.ml index 714992c0a..6b53b8e56 100644 --- a/src/repo/learnocaml_exercise.ml +++ b/src/repo/learnocaml_exercise.ml @@ -22,6 +22,8 @@ type compiled = { type t = { id : id ; prelude_ml : string ; + prepare_ml : string ; + (* absent from the json, empty except when building the exercises *) template : string ; solution : string ; (* absent from the json, empty except when building the exercises *) @@ -64,10 +66,10 @@ let encoding = (req "test_lib" compiled_lib_encoding)) in conv - (fun { id ; prelude_ml ; template ; descr ; compiled ; max_score ; depend ; dependencies ; solution = _} -> + (fun { id ; prelude_ml ; prepare_ml = _; template ; descr ; compiled ; max_score ; depend ; dependencies ; solution = _} -> (id, prelude_ml, template, descr, compiled, max_score, depend, dependencies)) (fun ((id, prelude_ml, template, descr, compiled, max_score, depend, dependencies)) -> - { id ; prelude_ml ; template ; descr ; compiled ; max_score ; depend ; dependencies; solution = ""}) + { id ; prelude_ml ; prepare_ml = ""; template ; descr ; compiled ; max_score ; depend ; dependencies; solution = ""}) (obj8 (req "id" string) (req "prelude_ml" string) @@ -81,7 +83,7 @@ let encoding = (* let meta_from_string m = * Ezjsonm.from_string m * |> Json_encoding.destruct Learnocaml_meta.encoding - * + * * let meta_to_string m = * Json_encoding.construct Learnocaml_meta.encoding m * |> (function @@ -138,9 +140,9 @@ module File = struct with Not_found -> raise (Missing_file ("get " ^ key)) let get_opt file ex = - try (* a missing file here is necessarily [file] *) - get file ex - with Missing_file _ -> None + try (* a missing file here is necessarily [file] *) + get file ex + with Missing_file _ -> None let has { key ; _ } ex = StringMap.mem key ex @@ -186,6 +188,12 @@ module File = struct field = (fun ex -> ex.prelude_ml) ; update = (fun prelude_ml ex -> { ex with prelude_ml }) } + let prepare_ml = + { key = "prepare.ml" ; + decode = (fun v -> v) ; encode = (fun v -> v) ; + field = (fun ex -> ex.prepare_ml) ; + update = (fun prepare_ml ex -> { ex with prepare_ml }) + } let template = { key = "template.ml" ; decode = (fun v -> v) ; encode = (fun v -> v) ; @@ -242,8 +250,8 @@ module File = struct (fun test_lib c -> { c with test_lib }) let depend = { key = "depend.txt" ; - decode = (fun v -> Some v) ; - encode = (function + decode = (fun v -> Some v) ; + encode = (function | None -> "" (* no `depend` ~ empty `depend` *) | Some txt -> txt) ; field = (fun ex -> ex.depend) ; @@ -252,7 +260,7 @@ module File = struct (* [parse_dependencies txt] extracts dependencies from the string [txt]. Dependencies are file names separated by at least one line break. - [txt] may contain comments starting with characters ';' or '#' + [txt] may contain comments starting with characters ';' or '#' and ending by a line break. *) let parse_dependencies txt = let remove_comment ~start:c line = @@ -267,17 +275,17 @@ module File = struct | None -> [] | Some txt -> let filenames = parse_dependencies txt in - List.mapi + List.mapi (fun pos filename -> { key = filename ; decode = (fun v -> v) ; encode = (fun v -> v) ; field = (fun ex -> List.nth ex.dependencies pos) ; - update = (fun v ex -> - let dependencies = + update = (fun v ex -> + let dependencies = List.mapi (fun i v' -> if i = pos then v else v') ex.dependencies in { ex with dependencies }) }) filenames - + module MakeReader (Concur : Concur) = struct let read ~read_field ?id: ex_id () = let open Concur in @@ -396,6 +404,7 @@ module File = struct join [ (* read_title () ; *) read_file prelude_ml ; + read_file prepare_ml ; read_file template ; read_file solution ; read_descrs () ; @@ -447,7 +456,7 @@ let strip need_js ex = module MakeReaderAnddWriter (Concur : Concur) = struct - + module FileReader = File.MakeReader(Concur) let read ~read_field ?id () = @@ -459,6 +468,7 @@ module MakeReaderAnddWriter (Concur : Concur) = struct { id = field_from_file File.id ex; (* meta = field_from_file File.meta ex; *) prelude_ml = field_from_file File.prelude_ml ex ; + prepare_ml = field_from_file File.prepare_ml ex ; template = field_from_file File.template ex ; solution = field_from_file File.solution ex ; descr = field_from_file File.descr ex ; @@ -478,14 +488,14 @@ module MakeReaderAnddWriter (Concur : Concur) = struct }; max_score = 0 ; depend ; - dependencies = + dependencies = let field_from_dependency file = try field_from_file file ex - with File.Missing_file msg - -> let msg' = msg ^ ": dependency declared in " + with File.Missing_file msg + -> let msg' = msg ^ ": dependency declared in " ^ File.(key depend) ^ ", but not found" in - raise (File.Missing_file msg') - in + raise (File.Missing_file msg') + in List.map field_from_dependency (File.dependencies depend) } with File.Missing_file _ as e -> fail e @@ -505,7 +515,8 @@ module MakeReaderAnddWriter (Concur : Concur) = struct ([ write_field id ; (* write_field meta ; * write_field title ; *) - write_field prelude_ml ; + write_field prelude_ml ; + (* prepare not written on purpose *) write_field template ; (* solution not written on purpose *) write_field descr ; @@ -517,7 +528,7 @@ module MakeReaderAnddWriter (Concur : Concur) = struct write_field test_cma ; write_field test_js ; write_field depend ; - (* write_field max_score *) ] + (* write_field max_score *) ] @ (List.map write_field (dependencies (access depend ex))) ) >>= fun () -> return !acc diff --git a/src/repo/learnocaml_exercise.mli b/src/repo/learnocaml_exercise.mli index bc2f6db01..1b188774a 100644 --- a/src/repo/learnocaml_exercise.mli +++ b/src/repo/learnocaml_exercise.mli @@ -58,6 +58,9 @@ module File : sig (** Returns the (public) [prelude.ml] *) val prelude_ml: string file + (** Returns the (private) [prepare.ml] *) + val prepare_ml: string file + (** Returns the (public) [template.ml] *) val template: string file @@ -87,7 +90,7 @@ module File : sig (** Returns the (public) depend file *) val depend: string option file - (** [dependencies txt] create the (private, already deciphered) dependencies + (** [dependencies txt] create the (private, already deciphered) dependencies declared in [txt] *) val dependencies: string option -> string file list end From 57ca10b0a40157e6b97d974c76c9963a1e00a0aa Mon Sep 17 00:00:00 2001 From: Yann Regis-Gianas Date: Wed, 27 Jul 2022 17:00:51 +0200 Subject: [PATCH 32/41] fix(partition-view): Reactivate the feature Signed-off-by: Yann Regis-Gianas --- src/utils/learnocaml_partition_create.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/utils/learnocaml_partition_create.ml b/src/utils/learnocaml_partition_create.ml index 880fd872a..315c5caac 100644 --- a/src/utils/learnocaml_partition_create.ml +++ b/src/utils/learnocaml_partition_create.ml @@ -90,11 +90,11 @@ let asak_partition prof fun_name sol by_grade = (ans.Partition.bad_type @ bad_type, (i,ans.Partition.clusters) :: res) ) by_grade ([],[]) -let partition _exo_name _fun_name _prof = assert false (* TODO +let partition exo_name fun_name prof = Learnocaml_store.Exercise.get exo_name >>= fun exo -> - let prelude = Learnocaml_exercise.(access File.prelude exo) in - let prepare = Learnocaml_exercise.(decipher File.prepare exo) in + let prelude = Learnocaml_exercise.(access File.prelude_ml exo) in + let prepare = Learnocaml_exercise.(decipher File.prepare_ml exo) in let prelude = prelude ^ "\n" ^ prepare in let solution = Learnocaml_exercise.(decipher File.solution exo) in let solution = prelude ^ "\n" ^ solution in @@ -104,4 +104,3 @@ let partition _exo_name _fun_name _prof = assert false (* TODO let by_grade = partition_by_grade fun_name lst in let bad_type,partition_by_grade = asak_partition prof fun_name solution by_grade in {not_graded; bad_type; partition_by_grade} -*) From ee57ac18dc7d395108defaa38079affb13f6ccaf Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 26 Oct 2023 16:22:47 +0200 Subject: [PATCH 33/41] fix(CLI): Report JSON parse error origin and locations --- src/repo/learnocaml_process_common.ml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/repo/learnocaml_process_common.ml b/src/repo/learnocaml_process_common.ml index a6acf5a65..2d733d226 100644 --- a/src/repo/learnocaml_process_common.ml +++ b/src/repo/learnocaml_process_common.ml @@ -15,5 +15,17 @@ let to_file encoding fn value = let from_file encoding fn = Lwt_io.(with_file ~mode: Input) fn @@ fun chan -> Lwt_io.read chan >>= fun str -> - let json = Ezjsonm.from_string str in + let json = + match Ezjsonm.from_string_result str with + | Ok json -> json + | Error err -> + let loc = match Ezjsonm.read_error_location err with + | None -> fn + | Some ((li, col), _) -> + Printf.sprintf "%s, line %d, column %d" fn li col + in + Printf.ksprintf failwith + "Parse error in %s:\n %s" loc + (Ezjsonm.read_error_description err); + in Lwt.return (Json_encoding.destruct encoding json) From cb417d186a32b2b0d11aea4228c264642b64bf34 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 26 Oct 2023 17:06:15 +0200 Subject: [PATCH 34/41] strengthening(grader): Add a safeguard against grading workers going haywire An uncaught exception could get caught upper on the stack, and lead the worker to start running pending lwt stuff that belong to the master.. Also attempt to fix "too many open files" error with many workers --- src/grader/grading_cli.ml | 39 +++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/src/grader/grading_cli.ml b/src/grader/grading_cli.ml index 929d84fae..a8822498a 100644 --- a/src/grader/grading_cli.ml +++ b/src/grader/grading_cli.ml @@ -52,23 +52,29 @@ let get_grade ?callback ?timeout ?dirname exo solution = | 0 -> (* /!\ there must be strictly no Lwt calls in the child *) Unix.close in_fd; - let oc = Unix.out_channel_of_descr out_fd in - let (ret: grader_answer) = - Load_path.init [ cmis_dir ] ; - Toploop_unix.initialize () ; - let divert name chan cb = - let redirection = Toploop_unix.redirect_channel name chan cb in - fun () -> Toploop_unix.stop_channel_redirection redirection in - let load_code compiled_code = - try - Toploop_unix.use_compiled_string compiled_code.Learnocaml_exercise.cma; - Toploop_ext.Ok (true, []) - with _ -> Toploop_ext.Ok (false, []) - in - Grading.get_grade ?callback ?timeout ?dirname ~divert ~load_code - exo solution + let () = + try + let oc = Unix.out_channel_of_descr out_fd in + let (ret: grader_answer) = + Load_path.init [ cmis_dir ] ; + Toploop_unix.initialize () ; + let divert name chan cb = + let redirection = Toploop_unix.redirect_channel name chan cb in + fun () -> Toploop_unix.stop_channel_redirection redirection in + let load_code compiled_code = + try + Toploop_unix.use_compiled_string + compiled_code.Learnocaml_exercise.cma; + Toploop_ext.Ok (true, []) + with _ -> Toploop_ext.Ok (false, []) + in + Grading.get_grade ?callback ?timeout ?dirname ~divert ~load_code + exo solution + in + output_value oc ret + with e -> + Format.eprintf "Subprocess failed with: %s\n%!" (Printexc.to_string e) in - output_value oc ret; flush_all (); Unix._exit 0 | child_pid -> @@ -79,6 +85,7 @@ let get_grade ?callback ?timeout ?dirname exo solution = (function End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) >>= fun (ans: grader_answer option) -> Lwt_unix.waitpid [] child_pid >>= fun (_pid, stat) -> + Lwt_io.close ic >>= fun () -> match ans, stat with | _, Unix.WSIGNALED n -> Printf.ksprintf Lwt.fail_with "Grading sub-process was killed (%d)" n From ead187e387d5794d3f16bb420a77e643b95f4b5a Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 26 Oct 2023 19:05:55 +0200 Subject: [PATCH 35/41] fix(grader): allow exercises to use vg, gg since the libraries are already available --- src/repo/learnocaml_precompile_exercise.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/repo/learnocaml_precompile_exercise.ml b/src/repo/learnocaml_precompile_exercise.ml index ab34c46fd..4358ea647 100644 --- a/src/repo/learnocaml_precompile_exercise.ml +++ b/src/repo/learnocaml_precompile_exercise.ml @@ -15,6 +15,11 @@ let grading_cmis_dir = let ( / ) = Filename.concat in ref (prefix/"lib"/"learn-ocaml"/"test_lib") +let extra_cmis_dirs = + let prefix = Filename.dirname (Filename.dirname (Sys.executable_name)) in + let ( / ) = Filename.concat in + ref [prefix/"lib"/"vg"; prefix/"lib"/"gg"] + let run ?dir cmd args = Lwt_process.exec ?cwd:dir ("", Array.of_list (cmd::args)) >>= function | Unix.WEXITED 0 -> Lwt.return_unit @@ -42,6 +47,9 @@ let ocamlc ?(dir=Sys.getcwd ()) ?(opn=[]) ?(ppx=[]) ~source ~target args = ppx args in let args = "-I" :: dir :: "-I" :: !grading_cmis_dir :: args in + let args = + List.flatten (List.map (fun d -> ["-I"; d]) !extra_cmis_dirs) @ 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 run "ocamlc" args From 942edc2fb1b30336f45caf9027d18f2bd5221ea9 Mon Sep 17 00:00:00 2001 From: Alexandre Moine Date: Mon, 11 Sep 2023 21:10:04 +0200 Subject: [PATCH 36/41] fix(teacher_tab): use newer asak compatible with precompilation asak 0.4 is now released on opam --- learn-ocaml-client.opam | 2 +- learn-ocaml.opam | 2 +- src/utils/learnocaml_partition_create.ml | 16 +++++++++++++--- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/learn-ocaml-client.opam b/learn-ocaml-client.opam index 4e67d4605..2ee63112e 100644 --- a/learn-ocaml-client.opam +++ b/learn-ocaml-client.opam @@ -18,7 +18,7 @@ homepage: "https://github.com/ocaml-sf/learn-ocaml" bug-reports: "https://github.com/ocaml-sf/learn-ocaml/issues" dev-repo: "git+https://github.com/ocaml-sf/learn-ocaml" depends: [ - "asak" {< "0.4"} + "asak" {>= "0.4"} "base64" "base" {>= "v0.9.4"} "cmdliner" {>= "1.1.0"} diff --git a/learn-ocaml.opam b/learn-ocaml.opam index c43a9a695..01d9d8041 100644 --- a/learn-ocaml.opam +++ b/learn-ocaml.opam @@ -18,7 +18,7 @@ homepage: "https://github.com/ocaml-sf/learn-ocaml" bug-reports: "https://github.com/ocaml-sf/learn-ocaml/issues" dev-repo: "git+https://github.com/ocaml-sf/learn-ocaml" depends: [ - "asak" {< "0.4"} + "asak" { >= "0.4"} "base64" "base" {>= "v0.9.4"} "cmdliner" {>= "1.1.0"} diff --git a/src/utils/learnocaml_partition_create.ml b/src/utils/learnocaml_partition_create.ml index 315c5caac..453e79a21 100644 --- a/src/utils/learnocaml_partition_create.ml +++ b/src/utils/learnocaml_partition_create.ml @@ -90,17 +90,27 @@ let asak_partition prof fun_name sol by_grade = (ans.Partition.bad_type @ bad_type, (i,ans.Partition.clusters) :: res) ) by_grade ([],[]) +let read_cmi_from_file cmi_str = + (* Cmi_format.input_cmi only supports reading from a channel *) + let magic_len = String.length Config.cmi_magic_number in + if String.length cmi_str < magic_len || + String.sub cmi_str 0 magic_len <> Config.cmi_magic_number then + Printf.ksprintf failwith "Bad cmi file"; + (* we ignore crc and flags *) + (Marshal.from_string cmi_str magic_len : (string*Types.signature_item list)) + let partition exo_name fun_name prof = Learnocaml_store.Exercise.get exo_name >>= fun exo -> let prelude = Learnocaml_exercise.(access File.prelude_ml exo) in let prepare = Learnocaml_exercise.(decipher File.prepare_ml exo) in let prelude = prelude ^ "\n" ^ prepare in - let solution = Learnocaml_exercise.(decipher File.solution exo) in - let solution = prelude ^ "\n" ^ solution in + let (_,solution) = + read_cmi_from_file (Learnocaml_exercise.(decipher File.solution_cmi exo)) in + let sol_typ = Asak.Partition.find_value_type_from_signature fun_name solution in get_all_saves exo_name prelude >|= fun saves -> let not_graded,lst = partition_was_graded saves in let by_grade = partition_by_grade fun_name lst in - let bad_type,partition_by_grade = asak_partition prof fun_name solution by_grade in + let bad_type,partition_by_grade = asak_partition prof fun_name sol_typ by_grade in {not_graded; bad_type; partition_by_grade} From f572990b4a25363da2b907f08b1f5aa0065273f4 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 26 Oct 2023 20:59:02 +0200 Subject: [PATCH 37/41] doc: update index.md --- docs/index.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/docs/index.md b/docs/index.md index 312a281aa..652928f29 100644 --- a/docs/index.md +++ b/docs/index.md @@ -53,7 +53,7 @@ The Inconsolata font is released under the Open Font License. See [http://www.levien.com/type/myfonts/inconsolata.html](http://www.levien.com/type/myfonts/inconsolata.html). The Biolinum font is licensed under the GNU General Public License with -a the 'Font-Exception'. +a 'Font-Exception'. See [http://www.linuxlibertine.org](http://www.linuxlibertine.org). The public instance of Learn OCaml uses the Fontin font instead of @@ -78,9 +78,9 @@ It was written by OCamlPro from 2015 to 2018. The current main contributors are Érik Martin-Dorel, Yann Régis-Gianas, and Louis Gesbert. -The initial authors were Benjamin Canou, Çağdaş Bozman, and Grégoire Henry. +The initial authors were Benjamin Canou, Çağdaş Bozman, Grégoire Henry, and Louis Gesbert. -It builds on the previous experience of Try OCaml, by Çağdaş Bozman, and Fabrice Le Fessant. +It builds on the previous experience of Try OCaml, by Çağdaş Bozman and Fabrice Le Fessant. We heavily use js_of_ocaml, so thanks to the Ocsigen team. From f1abb7d48e00e19edd3d922a043d309767b4c339 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 26 Oct 2023 21:21:20 +0200 Subject: [PATCH 38/41] fix(build): update lockfiles --- learn-ocaml-client.opam.locked | 66 ++++++++++++------------ learn-ocaml.opam.locked | 92 +++++++++++++++++----------------- 2 files changed, 78 insertions(+), 80 deletions(-) diff --git a/learn-ocaml-client.opam.locked b/learn-ocaml-client.opam.locked index 725f5ffb6..536f861b1 100644 --- a/learn-ocaml-client.opam.locked +++ b/learn-ocaml-client.opam.locked @@ -22,18 +22,17 @@ homepage: "https://github.com/ocaml-sf/learn-ocaml" bug-reports: "https://github.com/ocaml-sf/learn-ocaml/issues" depends: [ "angstrom" {= "0.15.0"} - "asak" {= "0.3"} + "asak" {= "0.4"} "astring" {= "0.8.5"} - "base" {= "v0.14.1"} + "base" {= "v0.14.3"} "base-bigarray" {= "base"} "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} "base64" {= "3.5.0"} - "bigarray-compat" {= "1.0.0"} + "bigarray-compat" {= "1.1.0"} "bigstringaf" {= "0.8.0"} - "biniou" {= "1.2.1"} - "cmdliner" {= "1.1.1"} + "cmdliner" {= "1.1.0"} "cohttp" {= "4.0.0"} "cohttp-lwt" {= "4.0.0"} "cohttp-lwt-unix" {= "4.0.0"} @@ -42,51 +41,50 @@ depends: [ "conduit-lwt-unix" {= "1.3.0"} "conf-libssl" {= "3"} "conf-pkg-config" {= "2"} - "cppo" {= "1.6.7"} + "cppo" {= "1.6.8"} "csexp" {= "1.5.1"} - "cstruct" {= "5.0.0"} - "digestif" {= "1.0.0"} - "dune" {= "2.9.0"} - "dune-configurator" {= "2.9.0"} - "easy-format" {= "1.3.2"} - "eqaf" {= "0.7"} - "ezjsonm" {= "1.1.0"} + "cstruct" {= "5.2.0"} + "digestif" {= "1.1.0"} + "dune" {= "2.9.3"} + "dune-configurator" {= "2.9.3"} + "eqaf" {= "0.8"} + "ezjsonm" {= "1.3.0"} "fieldslib" {= "v0.14.0"} - "fmt" {= "0.8.9"} + "fmt" {= "0.9.0"} "gg" {= "0.9.3"} "hex" {= "1.4.0"} "ipaddr" {= "2.9.0"} "jane-street-headers" {= "v0.14.0"} - "js_of_ocaml" {= "3.9.0"} - "js_of_ocaml-compiler" {= "3.9.1"} - "js_of_ocaml-ppx" {= "3.9.0"} + "js_of_ocaml" {= "4.0.0"} + "js_of_ocaml-compiler" {= "4.0.0"} + "js_of_ocaml-ppx" {= "4.0.0"} "jsonm" {= "1.0.1"} "jst-config" {= "v0.14.1"} "logs" {= "0.7.0"} - "lwt" {= "5.4.1"} + "lwt" {= "5.5.0"} "lwt_ssl" {= "1.1.3"} - "magic-mime" {= "1.1.3"} - "menhir" {= "20210419"} - "menhirLib" {= "20210419"} - "menhirSdk" {= "20210419"} + "magic-mime" {= "1.2.0"} + "menhir" {= "20220210"} + "menhirLib" {= "20220210"} + "menhirSdk" {= "20220210"} "mmap" {= "1.1.0"} "num" {= "1.4"} "ocaml" {= "4.12.1"} - "ocaml-compiler-libs" {= "v0.12.3"} + "ocaml-compiler-libs" {= "v0.12.4"} "ocaml-config" {= "2"} "ocaml-migrate-parsetree" {= "1.8.0"} "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} - "ocamlbuild" {= "0.14.0"} - "ocamlfind" {= "1.9.1"} + "ocamlbuild" {= "0.14.1"} + "ocamlfind" {= "1.9.3"} "ocp-indent-nlfork" {= "1.5.4"} "ocp-ocamlres" {= "0.4"} - "ocplib-endian" {= "1.1"} + "ocplib-endian" {= "1.2"} "ocplib-json-typed" {= "0.7.1"} "octavius" {= "1.2.2"} "omd" {= "1.3.1"} - "parsexp" {= "v0.14.1"} - "pprint" {= "20200410"} + "parsexp" {= "v0.14.2"} + "pprint" {= "20220103"} "ppx_assert" {= "v0.14.0"} "ppx_base" {= "v0.14.0"} "ppx_cold" {= "v0.14.0"} @@ -101,11 +99,11 @@ depends: [ "ppx_js_style" {= "v0.14.1"} "ppx_optcomp" {= "v0.14.0"} "ppx_sexp_conv" {= "v0.14.1"} - "ppx_tools" {= "6.3"} + "ppx_tools" {= "6.4"} "ppxlib" {= "0.15.0"} - "re" {= "1.9.0"} + "re" {= "1.10.3"} "result" {= "1.5"} - "seq" {= "0.2.2"} + "seq" {= "base"} "sexplib" {= "v0.14.0"} "sexplib0" {= "v0.14.0"} "ssl" {= "0.5.12"} @@ -113,13 +111,13 @@ depends: [ "stdlib-shims" {= "0.3.0"} "stringext" {= "1.6.0"} "time_now" {= "v0.14.0"} - "topkg" {= "1.0.3"} + "topkg" {= "1.0.5"} "uchar" {= "0.0.2"} "uri" {= "4.2.0"} "uri-sexp" {= "4.2.0"} - "uutf" {= "1.0.2"} + "uutf" {= "1.0.3"} "vg" {= "0.9.4"} - "yojson" {= "1.7.0"} + "yojson" {= "2.1.0"} ] build: ["dune" "build" "@install" "-p" name "-j" jobs] dev-repo: "git+https://github.com/ocaml-sf/learn-ocaml" diff --git a/learn-ocaml.opam.locked b/learn-ocaml.opam.locked index 5f05b1be7..6fb43cd0d 100644 --- a/learn-ocaml.opam.locked +++ b/learn-ocaml.opam.locked @@ -19,89 +19,89 @@ bug-reports: "https://github.com/ocaml-sf/learn-ocaml/issues" dev-repo: "git+https://github.com/ocaml-sf/learn-ocaml" depends: [ "angstrom" {= "0.15.0"} - "asak" {= "0.3"} + "asak" {= "0.4"} "astring" {= "0.8.5"} - "base" {= "v0.14.1"} + "base" {= "v0.14.3"} "base-bigarray" {= "base"} "base-bytes" {= "base"} "base-threads" {= "base"} "base-unix" {= "base"} "base64" {= "3.5.0"} - "bigarray-compat" {= "1.0.0"} + "bigarray-compat" {= "1.1.0"} "bigstringaf" {= "0.8.0"} - "biniou" {= "1.2.1"} - "checkseum" {= "0.3.1"} - "cmdliner" {= "1.1.1"} + "checkseum" {= "0.3.2"} + "cmdliner" {= "1.1.0"} "cohttp" {= "4.0.0"} "cohttp-lwt" {= "4.0.0"} "cohttp-lwt-unix" {= "4.0.0"} "conduit" {= "1.3.0"} "conduit-lwt" {= "1.3.0"} "conduit-lwt-unix" {= "1.3.0"} - "conf-git" {= "1.0"} + "conf-git" {= "1.1"} "conf-libssl" {= "3"} "conf-pkg-config" {= "2"} - "conf-which" {= "1"} - "cppo" {= "1.6.7"} + "cppo" {= "1.6.8"} "csexp" {= "1.5.1"} - "cstruct" {= "5.0.0"} + "cstruct" {= "5.2.0"} "decompress" {= "0.8.1"} - "digestif" {= "1.0.0"} - "dune" {= "2.9.0"} - "dune-configurator" {= "2.9.0"} + "digestif" {= "1.1.0"} + "dune" {= "2.9.3"} + "dune-configurator" {= "2.9.3"} "easy-format" {= "1.3.2"} - "eqaf" {= "0.7"} - "ezjsonm" {= "1.1.0"} - "fmt" {= "0.8.9"} + "eqaf" {= "0.8"} + "ezjsonm" {= "1.3.0"} + "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} "gg" {= "0.9.3"} "hex" {= "1.4.0"} "ipaddr" {= "2.9.0"} "jane-street-headers" {= "v0.14.0"} - "js_of_ocaml" {= "3.9.0"} - "js_of_ocaml-compiler" {= "3.9.1"} - "js_of_ocaml-lwt" {= "3.9.0"} - "js_of_ocaml-ppx" {= "3.9.0"} - "js_of_ocaml-toplevel" {= "3.9.0"} - "js_of_ocaml-tyxml" {= "3.9.0"} + "js_of_ocaml" {= "4.0.0"} + "js_of_ocaml-compiler" {= "4.0.0"} + "js_of_ocaml-lwt" {= "4.0.0"} + "js_of_ocaml-ppx" {= "4.0.0"} + "js_of_ocaml-toplevel" {= "4.0.0"} + "js_of_ocaml-tyxml" {= "4.0.0"} "jsonm" {= "1.0.1"} "jst-config" {= "v0.14.1"} "logs" {= "0.7.0"} - "lwt" {= "5.4.1"} - "lwt_react" {= "1.1.4"} + "lwt" {= "5.5.0"} + "lwt_log" {= "1.1.1"} + "lwt_react" {= "1.1.5"} "lwt_ssl" {= "1.1.3"} - "magic-mime" {= "1.1.3"} - "markup" {= "0.8.2"} + "magic-mime" {= "1.2.0"} + "markup" {= "1.0.2"} "markup-lwt" {= "0.5.0"} - "menhir" {= "20210419"} - "menhirLib" {= "20210419"} - "menhirSdk" {= "20210419"} + "menhir" {= "20220210"} + "menhirLib" {= "20220210"} + "menhirSdk" {= "20220210"} "mmap" {= "1.1.0"} "num" {= "1.4"} "ocaml" {= "4.12.1"} - "ocaml-compiler-libs" {= "v0.12.3"} + "ocaml-compiler-libs" {= "v0.12.4"} "ocaml-config" {= "2"} "ocaml-migrate-parsetree" {= "1.8.0"} "ocaml-options-vanilla" {= "1"} "ocaml-syntax-shims" {= "1.0.0"} - "ocamlbuild" {= "0.14.0"} - "ocamlfind" {= "1.9.1"} + "ocamlbuild" {= "0.14.1"} + "ocamlfind" {= "1.9.3"} "ocp-indent-nlfork" {= "1.5.4"} "ocp-ocamlres" {= "0.4"} - "ocplib-endian" {= "1.1"} + "ocplib-endian" {= "1.2"} "ocplib-json-typed" {= "0.7.1"} "ocplib-json-typed-browser" {= "0.7.1"} "octavius" {= "1.2.2"} - "odoc" {= "1.5.3"} + "odoc" {= "2.1.0"} + "odoc-parser" {= "1.0.0"} "omd" {= "1.3.1"} "optint" {= "0.1.0"} - "parsexp" {= "v0.14.1"} - "pprint" {= "20200410"} + "parsexp" {= "v0.14.2"} + "pprint" {= "20220103"} "ppx_assert" {= "v0.14.0"} "ppx_base" {= "v0.14.0"} "ppx_cold" {= "v0.14.0"} "ppx_compare" {= "v0.14.0"} - "ppx_cstruct" {= "5.0.0"} + "ppx_cstruct" {= "5.2.0"} "ppx_derivers" {= "1.2.1"} "ppx_enumerate" {= "v0.14.0"} "ppx_expect" {= "v0.14.0"} @@ -111,14 +111,14 @@ depends: [ "ppx_js_style" {= "v0.14.1"} "ppx_optcomp" {= "v0.14.0"} "ppx_sexp_conv" {= "v0.14.1"} - "ppx_tools" {= "6.3"} + "ppx_tools" {= "6.4"} "ppx_tools_versioned" {= "5.4.0"} "ppxlib" {= "0.15.0"} - "re" {= "1.9.0"} - "react" {= "1.2.1"} - "reactiveData" {= "0.2.1"} + "re" {= "1.10.3"} + "react" {= "1.2.2"} + "reactiveData" {= "0.2.2"} "result" {= "1.5"} - "seq" {= "0.2.2"} + "seq" {= "base"} "sexplib" {= "v0.14.0"} "sexplib0" {= "v0.14.0"} "ssl" {= "0.5.12"} @@ -126,14 +126,14 @@ depends: [ "stdlib-shims" {= "0.3.0"} "stringext" {= "1.6.0"} "time_now" {= "v0.14.0"} - "topkg" {= "1.0.3"} - "tyxml" {= "4.4.0"} + "topkg" {= "1.0.5"} + "tyxml" {= "4.5.0"} "uchar" {= "0.0.2"} "uri" {= "4.2.0"} "uri-sexp" {= "4.2.0"} - "uutf" {= "1.0.2"} + "uutf" {= "1.0.3"} "vg" {= "0.9.4"} - "yojson" {= "1.7.0"} + "yojson" {= "2.1.0"} ] build: [ [make "static"] From b94f05368a02038e5efb978976d8f7e20154fcc6 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 26 Oct 2023 23:42:49 +0200 Subject: [PATCH 39/41] fix(CI): attempt to fix running the docker image on the corpus --- .github/workflows/build-and-test.yml | 4 ++-- tests/runtests.sh | 13 +++++++------ 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml index 33670b387..5bf4684a0 100644 --- a/.github/workflows/build-and-test.yml +++ b/.github/workflows/build-and-test.yml @@ -26,9 +26,9 @@ jobs: - name: Run learn-ocaml build on demo-repository run: "docker run --rm -v $(pwd)/demo-repository:/repository learn-ocaml -- build" - name: Clone learn-ocaml-corpus inside tests/corpuses - run: "mkdir tests/corpuses && cd tests/corpuses && git clone --depth=1 https://github.com/ocaml-sf/learn-ocaml-corpus.git && cd ../.." + run: "git clone --depth=1 https://github.com/ocaml-sf/learn-ocaml-corpus.git tests/corpuses/learn-ocaml-corpus" - name: Run tests - run: "cd tests && bash -c ./runtests.sh" + run: "tests/runtests.sh" client_using_other_server: name: Build learn-ocaml-client and run quick tests diff --git a/tests/runtests.sh b/tests/runtests.sh index e8c2e0ca5..2905f3704 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -69,15 +69,14 @@ run_server () { REPO="$srcdir"/"$dir"/repo chmod -R a+w "$REPO" - mkdir "$SYNC" 2>/dev/null + mkdir -p "$SYNC" 2>/dev/null chmod o+w "$SYNC" # Run the server in background - SERVERID=$(set -x; docker run --entrypoint '' -d -p 8080:8080 \ + SERVERID=$(set -x; docker run -d -p 8080:8080 \ -v "$srcdir/$dir":/home/learn-ocaml/actual \ -v "$SYNC":/sync -v "$REPO":/repository \ - learn-ocaml /bin/sh -c \ - "learn-ocaml --sync-dir=/sync --repo=/repository build serve") + learn-ocaml) # Wait for the server to be initialized if ! wait_for_it "http://localhost:8080/version" "$build_timeout" sleep 1s || @@ -233,9 +232,11 @@ while IFS= read -r corpus; do echo "---> Testing corpus $corpus:" - if ! ( set -x; docker run --entrypoint '' \ + chmod -R a+w "$corpus" + + if ! ( set -x; docker run --rm \ -v "$(realpath "$corpus"):/repository" \ - learn-ocaml /bin/sh -c "learn-ocaml --repo=/repository build" ); then + learn-ocaml build ); then red "Failed to build $corpus" exit 1 fi From 91a418eeadf3be73e716a83ae16153332d7d19e7 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 27 Oct 2023 12:04:16 +0200 Subject: [PATCH 40/41] fix(CI): disable compat tests with 0.12, 0.13 It's not expected that we remain compatible with versions that required exposing `solution.ml`. --- .github/workflows/build-and-test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml index 5bf4684a0..22fc75081 100644 --- a/.github/workflows/build-and-test.yml +++ b/.github/workflows/build-and-test.yml @@ -38,8 +38,8 @@ jobs: fail-fast: false matrix: server_image: - - 'ocamlsf/learn-ocaml:0.12' - - 'ocamlsf/learn-ocaml:0.13.0' + # - 'ocamlsf/learn-ocaml:0.12' + # - 'ocamlsf/learn-ocaml:0.13.0' - 'learn-ocaml' # use learn-ocaml image built from master env: USE_CLIENT_IMAGE: 'true' From 6ce797f818766047c85d543188767fb4d3609352 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 31 Oct 2023 18:07:52 +0100 Subject: [PATCH 41/41] fix(docker): install more libs in server image these are required for compiling certain exercises --- Dockerfile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Dockerfile b/Dockerfile index fa4b0341c..126d0b2c1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -68,12 +68,16 @@ COPY --from=compilation "$opam_switch/bin"/ocaml* "$opam_switch/bin/" COPY --from=compilation "$opam_switch/lib/ocaml" "$opam_switch/lib/ocaml/" COPY --from=compilation "$opam_switch/bin/js_of_ocaml" "$opam_switch/bin/" COPY --from=compilation "$opam_switch/lib/js_of_ocaml" "$opam_switch/lib/js_of_ocaml" +COPY --from=compilation "$opam_switch/lib/vg" "$opam_switch/lib/vg" +COPY --from=compilation "$opam_switch/lib/gg" "$opam_switch/lib/gg" # Fixes for ocamlfind COPY --from=compilation "$opam_switch/lib/findlib.conf" "$opam_switch/lib/" COPY --from=compilation "$opam_switch/lib/stdlib" "$opam_switch/lib/stdlib" ENV PATH="${opam_switch}/bin:${PATH}" ENV OCAMLPATH="/usr/lib" +RUN ln -sf "$opam_switch/lib/vg" "/usr/lib" +RUN ln -sf "$opam_switch/lib/gg" "/usr/lib" ENTRYPOINT ["dumb-init","/usr/bin/learn-ocaml","--sync-dir=/sync","--repo=/repository"] CMD ["build","serve"]