Portable toplevel exit

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
 

lib/top/compat_top.ml

@@ -167,3 +167,100 @@ 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
+
+#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
+
+(* port of Topdirs.action_on_suberror *)
+let action_on_suberror b =
+  if not b && not !Sys.interactive then
+    raise (Exit_with_status 125)
+
+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 mdx_use_output = patch_directive "use_output" (Directive_string (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))
+#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
+#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
+#endif
+  | v -> v

lib/top/compat_top.mli

@@ -59,3 +59,11 @@ 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
+
+(* If the directive has to be intercepted, this function will return the new name of the directive *)
+val redirect_directive : string -> string

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"] *)
@@ -305,7 +311,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
@@ -337,7 +343,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 +362,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 execute_phrase t.verbose ppf phrase
+      with Exit_with_status code ->
+        Format.fprintf ppf "[%d]@." code;
+        false)
 
 type var_and_value = V : 'a ref * 'a -> var_and_value
 

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";;
+```

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]
+```

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))