Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

#3959, #7202: in script mode, handle directive errors #10476

Merged
merged 6 commits into from
Jul 8, 2021
Merged

#3959, #7202: in script mode, handle directive errors #10476

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
8ac50b2
script mode: handle directive errors
Octachron Jun 25, 2021
63d0292
scripting mode: better interface and test
Octachron Jun 28, 2021
d3956e0
remove fail
Octachron Jun 30, 2021
519b6ca
review: better name
Octachron Jul 7, 2021
4819e28
Fix test
Octachron Jul 7, 2021
01019e5
update changes
Octachron Jul 8, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
2 changes: 2 additions & 0 deletions .depend
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6549,6 +6549,7 @@ toplevel/native/topeval.cmi : \
toplevel/native/topmain.cmo : \
toplevel/toploop.cmi \
toplevel/native/topeval.cmi \
toplevel/topdirs.cmi \
toplevel/topcommon.cmi \
utils/misc.cmi \
driver/main_args.cmi \
Expand All @@ -6560,6 +6561,7 @@ toplevel/native/topmain.cmo : \
toplevel/native/topmain.cmx : \
toplevel/toploop.cmx \
toplevel/native/topeval.cmx \
toplevel/topdirs.cmx \
toplevel/topcommon.cmx \
utils/misc.cmx \
driver/main_args.cmx \
Expand Down
4 changes: 4 additions & 0 deletions Changes
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,10 @@ Working version

### Tools:

- #3959, #7202: ocaml, directive errors (`#use "";;`) in script mode use stderr
and exit with an error
(Florian Angeletti, review by ??)
gasche marked this conversation as resolved.
Show resolved Hide resolved

### Manual and documentation:

### Compiler user-interface and warnings:
Expand Down
6 changes: 5 additions & 1 deletion toplevel/byte/topmain.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -178,7 +178,11 @@ let input_argument name =
in
Compenv.readenv ppf Before_link;
Compmisc.read_clflags_from_env ();
if prepare ppf && Toploop.run_script ppf name newargs
if prepare ppf && (
let exit x = raise (Compenv.Exit_with_status x) in
Topdirs.set_error_handler { exit; ppf };
Toploop.run_script ppf name newargs
Copy link
Member

@gasche gasche Jun 25, 2021 •
edited

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This logic is not reentrant, in the sense that the error handler remains set after the script has run. I would expect that you reset it to its previous value after running the script. (Doing this with your API is surprisingly tricky; if you exposed a ref directly you could use Misc.protect_refs, or you could expose with_error_handler using it internally.)

What happens if I use #use "a.ml";; from an interactive toplevel, which succeeds correctly, and then I run another directive that fails?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This code path isn't hit if you're in an interactive toplevel, I think?

Copy link
Member Author

@Octachron Octachron Jun 28, 2021 •
edited

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Indeed, in scripting mode, we never go back to interactive mode. In fact, we are only running the first script given as argument.

)
then raise (Compenv.Exit_with_status 0)
else raise (Compenv.Exit_with_status 2)
end
Expand Down
6 changes: 5 additions & 1 deletion toplevel/native/topmain.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -69,7 +69,11 @@ let input_argument name =
(Array.length !argv - !Arg.current)
in
Compmisc.read_clflags_from_env ();
if prepare ppf && Toploop.run_script ppf name newargs
if prepare ppf && (
let exit x = raise (Compenv.Exit_with_status x) in
Topdirs.set_error_handler { exit; ppf };
Toploop.run_script ppf name newargs
)
then raise (Compenv.Exit_with_status 0)
else raise (Compenv.Exit_with_status 2)
end
Expand Down
74 changes: 46 additions & 28 deletions toplevel/topdirs.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -21,8 +21,19 @@ open Longident
open Types
open Toploop

(* The standard output formatter *)
let std_out = std_formatter
(* The error formatter for directives
In the toplevel, we print directly on stdout.
*)

type error_handler =
{
exit: int -> unit;
ppf: Format.formatter
}

let error_handler = ref { exit = ignore; ppf = std_formatter }
let set_error_handler eh = error_handler := eh
let exit_failure = 125

(* Directive sections (used in #help) *)
let section_general = "General"
Expand Down Expand Up @@ -122,18 +133,24 @@ let _ = add_directive "cd" (Directive_string dir_cd)
doc = "Change the current working directory.";
}

let dir_load ppf name = ignore (Topeval.load_file false ppf name)

let _ = add_directive "load" (Directive_string (dir_load std_out))
let with_error f x = f !error_handler x
let boolean_exit {exit; _ } b = if b then exit 0 else exit exit_failure

let dir_load h name =
boolean_exit h (Topeval.load_file false h.ppf name)

let _ = add_directive "load" (Directive_string (with_error dir_load))
{
section = section_run;
doc = "Load in memory a bytecode object, produced by ocamlc.";
}

let dir_load_rec ppf name = ignore (Topeval.load_file true ppf name)
let dir_load_rec h name =
boolean_exit h (Topeval.load_file true h.ppf name)

let _ = add_directive "load_rec"
(Directive_string (dir_load_rec std_out))
(Directive_string (with_error dir_load_rec))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Note: there is something subtly wrong with the fact that directives take a single formatter, on which they only print errors. This is the property that you use in this refactoring, but it does not hold for all directives, which is why your PR needs special treatment of #help and #show. (What is the expected behavior of #show_val fubar;; in non-interactive mode?)

I think that there would be various ways to improve on this:

  1. We could pass two different formatters to our directives, an output formatter and an error formatter.
  2. We could make the code simpler, instead of more complex, by changing the directive_fun types to add oppf:Format.formatter -> eppf:Format.formatter ->, and let Toploop pass the formatters.
  3. Alternatively, the directives could be in charge of deciding which formatter to use, and call error_formatter () directly. (But this makes it harder to redirect directive output to a completely different place.)

I'm not so fond of (3). (2) sounds nice, but it may have unpleasant backward-compatibility implications for utop and down. It may be that the best compromise is to remain "subtly wrong" and not change the interface at all, as this PR is doing, but this is worth a discussion.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I tend to agree that morally directives should take both an error and output formatters as argument, and the current set of directives accidentally only use one of them.

(What is the expected behavior of #show_val fubar;; in non-interactive mode?)

I would expect the result of show to be print on stdout as part of the script result.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

In this example, fubar is missing from the environment, I wondered if it should be counted as a directive failure or not. (Currently it is not, I guess?)

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Currently, it is not. And keeping it that way seems somewhat sensible (if certainly a bit arbitrary): sucesses or failures of #show do not alter the state of the script. Or looking from another perspective, a failure to find an identifier is still a valid answer to the user's query "show me some information about fubar".

{
section = section_run;
doc = "As #load, but loads dependencies recursively.";
Expand All @@ -143,26 +160,27 @@ let load_file = Topeval.load_file false

(* Load commands from a file *)

let dir_use ppf name =
ignore (Toploop.use_input ppf (Toploop.File name))
let dir_use_output ppf name = ignore(Toploop.use_output ppf name)
let dir_mod_use ppf name =
ignore (Toploop.mod_use_input ppf (Toploop.File name))
let dir_use h name =
boolean_exit h (Toploop.use_input h.ppf (Toploop.File name))
let dir_use_output h name = boolean_exit h (Toploop.use_output h.ppf name)
let dir_mod_use h name =
boolean_exit h (Toploop.mod_use_input h.ppf (Toploop.File name))

let _ = add_directive "use" (Directive_string (dir_use std_out))
let _ = add_directive "use" (Directive_string (with_error dir_use))
{
section = section_run;
doc = "Read, compile and execute source phrases from the given file.";
}

let _ = add_directive "use_output" (Directive_string (dir_use_output std_out))
let _ = add_directive "use_output"
(Directive_string (with_error dir_use_output))
{
section = section_run;
doc = "Execute a command and read, compile and execute source phrases \
from its output.";
}

let _ = add_directive "mod_use" (Directive_string (dir_mod_use std_out))
let _ = add_directive "mod_use" (Directive_string (with_error dir_mod_use))
{
section = section_run;
doc = "Usage is identical to #use but #mod_use \
Expand Down Expand Up @@ -278,10 +296,10 @@ let find_printer_type ppf lid =
fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
raise Exit

let dir_install_printer ppf lid =
let dir_install_printer h lid =
try
let ((ty_arg, ty), path, is_old_style) =
find_printer_type ppf lid in
find_printer_type h.ppf lid in
let v = eval_value_path !toplevel_env path in
match ty with
| None ->
Expand All @@ -306,33 +324,33 @@ let dir_install_printer ppf lid =
install_generic_printer' path ty_path (build v ty_args)
with Exit -> ()

let dir_remove_printer ppf lid =
let dir_remove_printer h lid =
try
let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
let (_ty_arg, path, _is_old_style) = find_printer_type h.ppf lid in
begin try
remove_printer path
with Not_found ->
fprintf ppf "No printer named %a.@." Printtyp.longident lid
fprintf h.ppf "No printer named %a.@." Printtyp.longident lid
end
with Exit -> ()

let _ = add_directive "install_printer"
(Directive_ident (dir_install_printer std_out))
(Directive_ident (with_error dir_install_printer))
{
section = section_print;
doc = "Registers a printer for values of a certain type.";
}

let _ = add_directive "remove_printer"
(Directive_ident (dir_remove_printer std_out))
(Directive_ident (with_error dir_remove_printer))
{
section = section_print;
doc = "Remove the named function from the table of toplevel printers.";
}

let parse_warnings ppf iserr s =
let parse_warnings h iserr s =
try Option.iter Location.(prerr_alert none) @@ Warnings.parse_options iserr s
with Arg.Bad err -> fprintf ppf "%s.@." err
with Arg.Bad err -> fprintf h.ppf "%s.@." err; h.exit exit_failure

(* Typing information *)

Expand Down Expand Up @@ -383,7 +401,7 @@ let reg_show_prim name to_sig doc =
all_show_funs := to_sig :: !all_show_funs;
add_directive
name
(Directive_ident (show_prim to_sig std_out))
(Directive_ident (show_prim to_sig std_formatter))
{
section = section_env;
doc;
Expand Down Expand Up @@ -584,7 +602,7 @@ let show env loc id lid =
if sg = [] then raise Not_found else sg

let () =
add_directive "show" (Directive_ident (show_prim show std_out))
add_directive "show" (Directive_ident (show_prim show std_formatter))
{
section = section_env;
doc = "Print the signatures of components \
Expand Down Expand Up @@ -639,14 +657,14 @@ let _ = add_directive "ppx"
}

let _ = add_directive "warnings"
(Directive_string (parse_warnings std_out false))
(Directive_string (fun s -> parse_warnings !error_handler false s))
{
section = section_options;
doc = "Enable or disable warnings according to the argument.";
}

let _ = add_directive "warn_error"
(Directive_string (parse_warnings std_out true))
(Directive_string (fun s -> parse_warnings !error_handler true s))
{
section = section_options;
doc = "Treat as errors the warnings enabled by the argument.";
Expand Down Expand Up @@ -716,7 +734,7 @@ let print_directives ppf () =
List.iter (print_section ppf) (directive_sections ())

let _ = add_directive "help"
(Directive_none (print_directives std_out))
(Directive_none (print_directives std_formatter))
{
section = section_general;
doc = "Prints a list of all available directives, with \
Expand Down
20 changes: 12 additions & 8 deletions toplevel/topdirs.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,18 +14,22 @@
(**************************************************************************)

(* The toplevel directives. *)

open Format
type error_handler =
{
exit: int -> unit;
ppf: Format.formatter
}
val set_error_handler: error_handler -> unit

val dir_quit : unit -> unit
val dir_directory : string -> unit
val dir_remove_directory : string -> unit
val dir_cd : string -> unit
val dir_load : formatter -> string -> unit
val dir_use : formatter -> string -> unit
val dir_use_output : formatter -> string -> unit
val dir_install_printer : formatter -> Longident.t -> unit
val dir_remove_printer : formatter -> Longident.t -> unit
val dir_load : error_handler -> string -> unit
val dir_use : error_handler -> string -> unit
val dir_use_output : error_handler -> string -> unit
val dir_install_printer : error_handler -> Longident.t -> unit
val dir_remove_printer : error_handler -> Longident.t -> unit

(* These are now injected from [Topeval], for the bytecode toplevel only:
val dir_trace : formatter -> Longident.t -> unit
Expand All @@ -48,4 +52,4 @@ type 'a printer_type_new = Format.formatter -> 'a -> unit
type 'a printer_type_old = 'a -> unit

(* Here for backwards compatibility, use [Toploop.load_file]. *)
val[@deprecated] load_file : formatter -> string -> bool
val[@deprecated] load_file : Format.formatter -> string -> bool