From 5d1167e7e2fec406d723541cfdc7a96b871ce37e Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 8 Jul 2022 09:45:33 +0100 Subject: [PATCH 1/7] Report exits from the toplevel correctly Previously, you just got: ocaml-mdx-test: internal error, uncaught exception: Compenv.Exit_with_status(125) --- lib/top/mdx_top.ml | 7 +++++-- test/bin/mdx-test/expect/compenv-exit/test-case.md | 5 +++++ .../expect/compenv-exit/test-case.md.expected | 7 +++++++ test/bin/mdx-test/expect/dune.inc | 12 ++++++++++++ 4 files changed, 29 insertions(+), 2 deletions(-) create mode 100644 test/bin/mdx-test/expect/compenv-exit/test-case.md create mode 100644 test/bin/mdx-test/expect/compenv-exit/test-case.md.expected diff --git a/lib/top/mdx_top.ml b/lib/top/mdx_top.ml index 6be8193cf..aa4cc5f9c 100644 --- a/lib/top/mdx_top.ml +++ b/lib/top/mdx_top.ml @@ -337,7 +337,7 @@ type t = { let toplevel_exec_phrase t ppf p = match Phrase.result p with | Error exn -> raise exn - | Ok phrase -> + | Ok phrase -> ( Warnings.reset_fatal (); let mapper = Lexbuf.position_mapper (Phrase.start p) in let phrase = @@ -356,7 +356,10 @@ let toplevel_exec_phrase t ppf p = if !Clflags.dump_parsetree then Printast.top_phrase ppf phrase; if !Clflags.dump_source then Pprintast.top_phrase ppf phrase; Env.reset_cache_toplevel (); - Toploop.execute_phrase t.verbose ppf phrase + try Toploop.execute_phrase t.verbose ppf phrase + with Compenv.Exit_with_status code -> + Format.fprintf ppf "[%d]@." code; + false) type var_and_value = V : 'a ref * 'a -> var_and_value diff --git a/test/bin/mdx-test/expect/compenv-exit/test-case.md b/test/bin/mdx-test/expect/compenv-exit/test-case.md new file mode 100644 index 000000000..5deda90ae --- /dev/null +++ b/test/bin/mdx-test/expect/compenv-exit/test-case.md @@ -0,0 +1,5 @@ +Exits from the toplevel are reported correctly: + +```ocaml +# #use "idontexist.ml";; +``` diff --git a/test/bin/mdx-test/expect/compenv-exit/test-case.md.expected b/test/bin/mdx-test/expect/compenv-exit/test-case.md.expected new file mode 100644 index 000000000..2023ad5bd --- /dev/null +++ b/test/bin/mdx-test/expect/compenv-exit/test-case.md.expected @@ -0,0 +1,7 @@ +Exits from the toplevel are reported correctly: + +```ocaml +# #use "idontexist.ml";; +Cannot find file idontexist.ml. +[125] +``` diff --git a/test/bin/mdx-test/expect/dune.inc b/test/bin/mdx-test/expect/dune.inc index 86b4c33b4..54b10eeba 100644 --- a/test/bin/mdx-test/expect/dune.inc +++ b/test/bin/mdx-test/expect/dune.inc @@ -35,6 +35,18 @@ (alias runtest) (action (diff code/test-case.md code.actual))) +(rule + (target compenv-exit.actual) + (deps (package mdx) (source_tree compenv-exit)) + (action + (with-stdout-to %{target} + (chdir compenv-exit + (run ocaml-mdx test --output - test-case.md))))) + +(rule + (alias runtest) + (action (diff compenv-exit/test-case.md.expected compenv-exit.actual))) + (rule (target cram.actual) (deps (package mdx) (source_tree cram)) From df4e3cc4bc7b13bccd6296239a30453e97ba5221 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Wed, 13 Jul 2022 15:59:07 +0200 Subject: [PATCH 2/7] Fix compilation with older versions of OCaml --- lib/top/compat_top.ml | 12 ++++++++++++ lib/top/compat_top.mli | 5 +++++ lib/top/mdx_top.ml | 6 +++--- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/lib/top/compat_top.ml b/lib/top/compat_top.ml index 361873c00..403f55f33 100644 --- a/lib/top/compat_top.ml +++ b/lib/top/compat_top.ml @@ -167,3 +167,15 @@ let ctype_get_desc ty = #else (Ctype.repr ty).Types.desc #endif + +exception Exit_with_status of int + +let execute_phrase print_outcome ppf phr = +#if OCAML_VERSION >= (4, 12, 0) + match Toploop.execute_phrase print_outcome ppf phr with + | v -> v + | exception Compenv.Exit_with_status status -> + raise (Exit_with_status status) +#else + Toploop.execute_phrase print_outcome ppf phr +#endif diff --git a/lib/top/compat_top.mli b/lib/top/compat_top.mli index 8420212c1..d382bc29e 100644 --- a/lib/top/compat_top.mli +++ b/lib/top/compat_top.mli @@ -59,3 +59,8 @@ val ctype_is_equal : val ctype_expand_head_and_get_desc : Env.t -> Types.type_expr -> Types.type_desc val ctype_get_desc : Types.type_expr -> Types.type_desc + +exception Exit_with_status of int + +val execute_phrase : + bool -> Format.formatter -> Parsetree.toplevel_phrase -> bool diff --git a/lib/top/mdx_top.ml b/lib/top/mdx_top.ml index aa4cc5f9c..f8aed525e 100644 --- a/lib/top/mdx_top.ml +++ b/lib/top/mdx_top.ml @@ -305,7 +305,7 @@ module Rewrite = struct let preload verbose ppf = let require pkg = let p = top_directive_require pkg in - let _ = Toploop.execute_phrase verbose ppf p in + let _ = execute_phrase verbose ppf p in () in match active_rewriters () with @@ -356,8 +356,8 @@ let toplevel_exec_phrase t ppf p = if !Clflags.dump_parsetree then Printast.top_phrase ppf phrase; if !Clflags.dump_source then Pprintast.top_phrase ppf phrase; Env.reset_cache_toplevel (); - try Toploop.execute_phrase t.verbose ppf phrase - with Compenv.Exit_with_status code -> + try execute_phrase t.verbose ppf phrase + with Exit_with_status code -> Format.fprintf ppf "[%d]@." code; false) From 19095a94fc405acec7148401d599a4377f655c16 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 14 Jul 2022 10:36:30 +0200 Subject: [PATCH 3/7] Patch and redirect available directives They have to be redirected because by default they write to stdout, but we capture stderr (and in 4.14 they write to stderr). Unfortunately, just overwriting them in the directives Hashtbl does not work, since the ordering of additions is somewhat undefined so they might be overwritten. A safer way is to create new directives and rewrite those to be evaluated to them. Also, `"use"` is a builtin directive, not from findlib so needs to be excluded to get the error message printed. --- lib/top/compat_top.ml | 33 +++++++++++++++++++++++++++++++++ lib/top/compat_top.mli | 3 +++ lib/top/mdx_top.ml | 8 +++++++- 3 files changed, 43 insertions(+), 1 deletion(-) diff --git a/lib/top/compat_top.ml b/lib/top/compat_top.ml index 403f55f33..dcc6452c5 100644 --- a/lib/top/compat_top.ml +++ b/lib/top/compat_top.ml @@ -179,3 +179,36 @@ let execute_phrase print_outcome ppf phr = #else Toploop.execute_phrase print_outcome ppf phr #endif + +#if OCAML_VERSION < (4, 14, 0) +let std_err = Format.err_formatter + +let patch_directive name directive = + let patched_name = Format.asprintf "mdx_%s" name in + let directive_info = Toploop.{ section = "MDX PATCHED"; doc = "Patched by MDX" } in + Toploop.add_directive patched_name directive directive_info; + patched_name + +let mdx_load = patch_directive "load" (Directive_string (Topdirs.dir_load std_err)) +let mdx_use = patch_directive "use" (Directive_string (Topdirs.dir_use std_err)) +let mdx_use_output = patch_directive "use_output" (Directive_string (Topdirs.dir_use_output std_err)) +let mdx_install_printer = patch_directive "install_printer" (Directive_ident (Topdirs.dir_install_printer std_err)) +let mdx_remove_printer = patch_directive "remove_printer" (Directive_ident (Topdirs.dir_remove_printer std_err)) +let mdx_trace = patch_directive "trace" (Directive_ident (Topdirs.dir_trace std_err)) +let mdx_untrace = patch_directive "untrace" (Directive_ident (Topdirs.dir_untrace std_err)) +let mdx_untrace_all = patch_directive "untrace_all" (Directive_none (Topdirs.dir_untrace_all std_err)) +#endif + +let redirect_directive directive = + match directive with +#if OCAML_VERSION < (4, 14, 0) + | "load" -> mdx_load + | "use" -> mdx_use + | "use_output" -> mdx_use_output + | "install_printer" -> mdx_install_printer + | "remove_printer" -> mdx_remove_printer + | "trace" -> mdx_trace + | "untrace" -> mdx_untrace + | "untrace_all" -> mdx_untrace_all +#endif + | v -> v diff --git a/lib/top/compat_top.mli b/lib/top/compat_top.mli index d382bc29e..be90d84c0 100644 --- a/lib/top/compat_top.mli +++ b/lib/top/compat_top.mli @@ -64,3 +64,6 @@ exception Exit_with_status of int val execute_phrase : bool -> Format.formatter -> Parsetree.toplevel_phrase -> bool + +(* If the directive has to be intercepted, this function will return the new name of the directive *) +val redirect_directive : string -> string diff --git a/lib/top/mdx_top.ml b/lib/top/mdx_top.ml index f8aed525e..6c71d673b 100644 --- a/lib/top/mdx_top.ml +++ b/lib/top/mdx_top.ml @@ -161,7 +161,7 @@ module Phrase = struct let is_findlib_directive = let findlib_directive = function - | "require" | "use" | "camlp4o" | "camlp4r" | "thread" -> true + | "require" | "camlp4o" | "camlp4r" | "thread" -> true | _ -> false in function @@ -290,6 +290,12 @@ module Rewrite = struct in Btype.backtrack snap; Ptop_def pstr) + | Ptop_dir pdir -> + let pdir_name = pdir.pdir_name in + let pdir_name = + { pdir_name with txt = Compat_top.redirect_directive pdir_name.txt } + in + Ptop_dir { pdir with pdir_name } | _ -> phrase (** [top_directive require "pkg"] builds the AST for [#require "pkg"] *) From cfedb20ecf4b6fc4d8a176c99abb92b759a4447a Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 14 Jul 2022 10:55:58 +0200 Subject: [PATCH 4/7] Fix redirection for older and newer versions `use_output` was added in 4.11, whereas the `use_trace` was removed in 4.13. --- lib/top/compat_top.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/lib/top/compat_top.ml b/lib/top/compat_top.ml index dcc6452c5..d1c78c8ca 100644 --- a/lib/top/compat_top.ml +++ b/lib/top/compat_top.ml @@ -191,9 +191,15 @@ let patch_directive name directive = let mdx_load = patch_directive "load" (Directive_string (Topdirs.dir_load std_err)) let mdx_use = patch_directive "use" (Directive_string (Topdirs.dir_use std_err)) -let mdx_use_output = patch_directive "use_output" (Directive_string (Topdirs.dir_use_output std_err)) let mdx_install_printer = patch_directive "install_printer" (Directive_ident (Topdirs.dir_install_printer std_err)) let mdx_remove_printer = patch_directive "remove_printer" (Directive_ident (Topdirs.dir_remove_printer std_err)) +#endif + +#if OCAML_VERSION > (4, 11, 0) && OCAML_VERSION < (4, 14, 0) +let mdx_use_output = patch_directive "use_output" (Directive_string (Topdirs.dir_use_output std_err)) +#endif + +#if OCAML_VERSION < (4, 13, 0) let mdx_trace = patch_directive "trace" (Directive_ident (Topdirs.dir_trace std_err)) let mdx_untrace = patch_directive "untrace" (Directive_ident (Topdirs.dir_untrace std_err)) let mdx_untrace_all = patch_directive "untrace_all" (Directive_none (Topdirs.dir_untrace_all std_err)) @@ -204,9 +210,13 @@ let redirect_directive directive = #if OCAML_VERSION < (4, 14, 0) | "load" -> mdx_load | "use" -> mdx_use - | "use_output" -> mdx_use_output | "install_printer" -> mdx_install_printer | "remove_printer" -> mdx_remove_printer +#endif +#if OCAML_VERSION > (4, 11, 0) && OCAML_VERSION < (4, 14, 0) + | "use_output" -> mdx_use_output +#endif +#if OCAML_VERSION < (4, 13, 0) | "trace" -> mdx_trace | "untrace" -> mdx_untrace | "untrace_all" -> mdx_untrace_all From 6fd673cc531ce5b6d0e9622a1379159a43eab8f2 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 14 Jul 2022 11:51:54 +0200 Subject: [PATCH 5/7] Redefine the directives to throw an error on failure The stdlib pre-4.14 defines them to be `ignore`d but they can be made to throw the error like in 4.14. At least some of them, for which the underlying functions are exposed in the interface. --- lib/top/compat_top.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/lib/top/compat_top.ml b/lib/top/compat_top.ml index d1c78c8ca..9eb200b35 100644 --- a/lib/top/compat_top.ml +++ b/lib/top/compat_top.ml @@ -170,6 +170,7 @@ let ctype_get_desc ty = exception Exit_with_status of int + let execute_phrase print_outcome ppf phr = #if OCAML_VERSION >= (4, 12, 0) match Toploop.execute_phrase print_outcome ppf phr with @@ -189,14 +190,30 @@ let patch_directive name directive = Toploop.add_directive patched_name directive directive_info; patched_name +(* port of Topdirs.action_on_suberror *) +let action_on_suberror b = + if not b && not !Sys.interactive then + raise (Exit_with_status 125) + +(* [load] cannot be patched to return errors because the underlying code is not exposed: + It would require [Topdirs.load_file] with the first argument to be [false] but the exposed + version hardcodes it to [true]. + *) let mdx_load = patch_directive "load" (Directive_string (Topdirs.dir_load std_err)) -let mdx_use = patch_directive "use" (Directive_string (Topdirs.dir_use std_err)) + +let dir_use ppf name = + action_on_suberror (Toploop.use_file ppf name) + +let mdx_use = patch_directive "use" (Directive_string (dir_use std_err)) let mdx_install_printer = patch_directive "install_printer" (Directive_ident (Topdirs.dir_install_printer std_err)) let mdx_remove_printer = patch_directive "remove_printer" (Directive_ident (Topdirs.dir_remove_printer std_err)) #endif #if OCAML_VERSION > (4, 11, 0) && OCAML_VERSION < (4, 14, 0) -let mdx_use_output = patch_directive "use_output" (Directive_string (Topdirs.dir_use_output std_err)) + +let dir_use_output ppf name = action_on_suberror (Toploop.use_output ppf name) + +let mdx_use_output = patch_directive "use_output" (Directive_string (dir_use_output std_err)) #endif #if OCAML_VERSION < (4, 13, 0) From c520c0a8dae7b12962972b48526b93303686515f Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 14 Jul 2022 11:59:29 +0200 Subject: [PATCH 6/7] Add support for `load_rec` and patch `load` conditionally OCaml 4.13 introduces a few deprecations that we need to work around. --- lib/top/compat_top.ml | 39 ++++++++++++++++++++++++++++++++------- 1 file changed, 32 insertions(+), 7 deletions(-) diff --git a/lib/top/compat_top.ml b/lib/top/compat_top.ml index 9eb200b35..3934c95f9 100644 --- a/lib/top/compat_top.ml +++ b/lib/top/compat_top.ml @@ -195,23 +195,19 @@ let action_on_suberror b = if not b && not !Sys.interactive then raise (Exit_with_status 125) -(* [load] cannot be patched to return errors because the underlying code is not exposed: - It would require [Topdirs.load_file] with the first argument to be [false] but the exposed - version hardcodes it to [true]. - *) -let mdx_load = patch_directive "load" (Directive_string (Topdirs.dir_load std_err)) - let dir_use ppf name = action_on_suberror (Toploop.use_file ppf name) let mdx_use = patch_directive "use" (Directive_string (dir_use std_err)) + let mdx_install_printer = patch_directive "install_printer" (Directive_ident (Topdirs.dir_install_printer std_err)) let mdx_remove_printer = patch_directive "remove_printer" (Directive_ident (Topdirs.dir_remove_printer std_err)) #endif #if OCAML_VERSION > (4, 11, 0) && OCAML_VERSION < (4, 14, 0) -let dir_use_output ppf name = action_on_suberror (Toploop.use_output ppf name) +let dir_use_output ppf name = + action_on_suberror (Toploop.use_output ppf name) let mdx_use_output = patch_directive "use_output" (Directive_string (dir_use_output std_err)) #endif @@ -222,10 +218,39 @@ let mdx_untrace = patch_directive "untrace" (Directive_ident (Topdirs.dir_untrac let mdx_untrace_all = patch_directive "untrace_all" (Directive_none (Topdirs.dir_untrace_all std_err)) #endif +#if OCAML_VERSION < (4, 13, 0) +(* [load] cannot be patched to return errors because the underlying code is not exposed: + It would require [Topdirs.load_file] with the first argument to be [false] but the exposed + version hardcodes it to [true]. + *) +let mdx_load = patch_directive "load" (Directive_string (Topdirs.dir_load std_err)) + +(* On the other hand, [load_rec] can be patched because the curried [true] is the only + difference between these directives *) +let dir_load_rec ppf name = + action_on_suberror (Topdirs.load_file ppf name) + +let mdx_load_rec = patch_directive "load_rec" (Directive_string (dir_load_rec std_err)) + +#elif OCAML_VERSION > (4, 13, 0) && OCAML_VERSION < (4, 14, 0) +(* OCaml 4.13 exposes [Topeval.load_file] which allows us to patch [#load] too *) +let dir_load ppf name = + action_on_suberror (Topeval.load_file false ppf name) + +let mdx_load = patch_directive "load" (Directive_string (dir_load std_err)) + +(* This uses [Topeval.load_file] because [Topdirs.load_file] is deprecated on 4.13 *) +let dir_load_rec ppf name = + action_on_suberror (Topeval.load_file true ppf name) + +let mdx_load_rec = patch_directive "load_rec" (Directive_string (dir_load_rec std_err)) +#endif + let redirect_directive directive = match directive with #if OCAML_VERSION < (4, 14, 0) | "load" -> mdx_load + | "load_rec" -> mdx_load_rec | "use" -> mdx_use | "install_printer" -> mdx_install_printer | "remove_printer" -> mdx_remove_printer From d78356662ad245b63158d25580eafe5bd5f508b5 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 14 Jul 2022 15:47:50 +0200 Subject: [PATCH 7/7] Add changelog entry --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 3403b2bc7..1e0557fb0 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -9,6 +9,8 @@ #### Fixed - Fixed compatibility with Cmdliner 1.1.0 (#371, @Leonidas-from-XIV) +- Report errors and exit codes of toplevel directives (#382, @talex5, + @Leonidas-from-XIV) #### Removed