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/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 7397b0360..ae9d47ae8 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.3) +(lang dune 2.4) (name learn-ocaml) (version 0.13.2) (allow_approximate_merlin) diff --git a/src/app/learnocaml_description_main.ml b/src/app/learnocaml_description_main.ml index 6484d9f2a..2f0248bef 100644 --- a/src/app/learnocaml_description_main.ml +++ b/src/app/learnocaml_description_main.ml @@ -66,12 +66,12 @@ 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) -> (* 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 bea8bde16..b79785020 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -119,20 +119,25 @@ 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) -> - 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 = @@ -188,7 +193,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/app/learnocaml_student_view.ml b/src/app/learnocaml_student_view.ml index c7b3d1303..d3d052abc 100644 --- a/src/app/learnocaml_student_view.ml +++ b/src/app/learnocaml_student_view.ml @@ -484,7 +484,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 3631e90df..ecad7d944 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 ee9473af4..9ca000d98 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/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 709f1a641..2514a42d4 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 @@ -30,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 @@ -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 e66095ef7..27456e845 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 2ed208d97..8e053f961 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 83b6a1283..dd27df549 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 a918a6544..4b3c27dbc 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 6b3af3cb5..a085c7f49 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 227f3ac94..193366d44 100644 --- a/src/grader/grading_cli.mli +++ b/src/grader/grading_cli.mli @@ -7,11 +7,11 @@ * 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) -> ?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/introspection.ml b/src/grader/introspection.ml index 2bd4c0eaf..b3c485a10 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,8 +95,7 @@ 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 @@ -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 842fc9d9a..622041674 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 b1afabf59..1f49ab69a 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 7b60cf890..fb4ae48fb 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 1e6690eec..b97331618 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 0895d9bee..1165d6bdc 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 @@ -1246,12 +1245,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 5953eb7f3..36ff9293a 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 @@ -778,13 +778,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 cca1be85e..ee2167d65 100644 --- a/src/main/learnocaml_main.ml +++ b/src/main/learnocaml_main.ml @@ -109,38 +109,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 @@ -190,7 +192,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 = { @@ -297,7 +299,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..90421c4d0 100644 --- a/src/ppx-metaquot/dune +++ b/src/ppx-metaquot/dune @@ -20,14 +20,32 @@ (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) - (modules Ppx_metaquot_main) + (libraries learnocaml_ppx_metaquot_lib ty fun_ty ocaml-migrate-parsetree learnocaml_recorder) + (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..3ec201163 --- /dev/null +++ b/src/ppx-metaquot/ppx_metaquot_register.ml @@ -0,0 +1,4 @@ +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 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/dune b/src/repo/dune index a82d333a3..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) @@ -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 74f329e2a..2ed4f3750 100644 --- a/src/repo/learnocaml_exercise.ml +++ b/src/repo/learnocaml_exercise.ml @@ -8,36 +8,74 @@ 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 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" b64 "") + (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" 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 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 = @@ -85,7 +123,6 @@ module File = struct type 'a file = { key : string ; - ciphered : bool ; decode : string -> 'a ; encode : 'a -> string ; field : t -> 'a ; @@ -94,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 = @@ -113,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 }) @@ -148,50 +175,73 @@ 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 = - { key = "prelude.ml" ; ciphered = false ; + let prelude_ml = + { key = "prelude.ml" ; 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 ; + { 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" ; + 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 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 ; - 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 ; + let compiled key get set = + { key; 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 ; + { key = "depend.txt" ; decode = (fun v -> Some v) ; encode = (function | None -> "" (* no `depend` ~ empty `depend` *) @@ -219,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 -> @@ -229,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 -> @@ -248,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 () = @@ -352,12 +395,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 () -> @@ -373,47 +422,60 @@ 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) 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) - 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 { 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 = @@ -424,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 @@ -450,12 +505,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 1bb8809a7..939f22c8c 100644 --- a/src/repo/learnocaml_exercise.mli +++ b/src/repo/learnocaml_exercise.mli @@ -13,8 +13,9 @@ type t type id = string -(* JSON encoding of the exercise representation. Includes cipher and decipher at - at encoding and decoding. *) +type compiled_lib = { cma: string; js: string } + +(* JSON encoding of the exercise representation. *) val encoding: t Json_encoding.encoding (** Intermediate representation of files, resulting of reading the exercise directory *) @@ -54,20 +55,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 @@ -97,28 +109,33 @@ 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) -> - ?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 new file mode 100644 index 000000000..a0688bcb3 --- /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" :: 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 df2cbb627..8d3783211 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" @@ -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/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 2b2c00f88..7822358e1 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -449,17 +449,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 f07866c25..b2d411cbc 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 _ @@ -334,10 +335,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"] @@ -461,7 +464,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 0b77c8c08..e6d2f639b 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 diff --git a/src/toplevel/learnocaml_toplevel.ml b/src/toplevel/learnocaml_toplevel.ml index 1c6e872a1..b2dc5a5de 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 4e91cdccb..ecec7d4ae 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 c33554edd..f88bef837 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 a9f5e9c0b..b09149401 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 50497ce3b..496af7374 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 1906d2520..1ede1b150 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 3d318ca5e..10d946bb3 100644 --- a/src/toploop/toploop_ext.ml +++ b/src/toploop/toploop_ext.ml @@ -239,3 +239,34 @@ 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.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 9dc185353..c7a6eeaf0 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 e299a48f7..4ce95c5e5 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 43dd927b6..b32242064 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 c5168b2e7..37d33c41c 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 88fb2a428..85cd5b4b7 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 @@ -30,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 diff --git a/src/utils/dune b/src/utils/dune index 51b8db206..06a804123 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_partition_create.ml b/src/utils/learnocaml_partition_create.ml index 8358c4922..cfcb50696 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} +*) diff --git a/src/utils/learnocaml_xor.ml b/src/utils/learnocaml_xor.ml deleted file mode 100644 index e34464d52..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) 2016-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 57606cfe7..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) 2016-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 diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 0fe27a22c..d40171377 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 () ->