From 466194415593b30abe1c0879d9c220cbac908898 Mon Sep 17 00:00:00 2001 From: Fabian Date: Mon, 10 Apr 2017 16:49:05 -0500 Subject: [PATCH] Add #utop_stash and #utop_save - Strip colour terminal escapes from errors - Store inputs and outputs seperately in UTop_history - Add #utop_save, which prints inputs and outputs similar to a simple prompt --- src/lib/uTop.ml | 77 ++++++++++++++++++++++++---------------- src/lib/uTop.mli | 15 ++++---- src/lib/uTop_history.ml | 70 ++++++++++++++++++++++++++++++++++++ src/lib/uTop_history.mli | 40 +++++++++++++++++++++ src/lib/uTop_main.ml | 23 ++++++------ 5 files changed, 175 insertions(+), 50 deletions(-) create mode 100644 src/lib/uTop_history.ml create mode 100644 src/lib/uTop_history.mli diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index 8e3d1f8..843bab7 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -27,11 +27,7 @@ let history = LTerm_history.create [] let history_file_name = ref (Some (Filename.concat LTerm_resources.home ".utop-history")) let history_file_max_size = ref None let history_file_max_entries = ref None -let stashable_session_history = - (LTerm_history.create - ~max_size:max_int - ~max_entries:max_int - []) +let stashable_session_history = UTop_history.create () (* +-----------------------------------------------------------------+ | Hooks | @@ -543,6 +539,7 @@ utop defines the following directives: #utop_bindings : list all the current key bindings #utop_macro : display the currently recorded macro #utop_stash : store all the valid commands from your current session in a file +#utop_save : store the current session with a simple prompt in a file #topfind_log : display messages recorded from findlib since the beginning of the session #topfind_verbose : enable/disable topfind verbosity @@ -635,33 +632,51 @@ let () = (Toploop.Directive_none (fun () -> print_endline (Sys.getcwd ()))) +let make_stash_directive entry_formatter fname = + if get_ui () = Emacs then + print_endline "Stashing is currently not supported in Emacs" + else + let entries = UTop_history.contents stashable_session_history in + (* remove the stash directive from its output *) + let entries = match entries with [] -> [] | _ :: e -> e in + let entries = List.rev entries in + Printf.printf "Stashing %d entries in %s ... " (List.length entries) fname; + try + let oc = open_out fname in + try + List.iter + (fun e -> + let line = entry_formatter e in + output_string oc line; + output_char oc '\n') + entries; + close_out oc; + Printf.printf "Done.\n"; + with exn -> + close_out oc; + raise exn + with exn -> + Printf.printf "Error with file %s: %s\n" fname @@ Printexc.to_string exn + let () = - Hashtbl.add Toploop.directive_table "utop_stash" - (Toploop.Directive_string - (fun fname -> - let _ :: entries = LTerm_history.contents stashable_session_history in - (* getting and then reversing the entries instead of using - [LTerm_history.save] because the latter escapes newline characters *) - let () = - Printf.printf - "Stashing %d entries in %s... " - (List.length entries / 2) (* because half are comments *) - fname - in - let entries = List.rev entries in - try - let oc = open_out fname in - try - List.iter - (fun e -> - output_string oc (e ^ "\n")) - entries; - close_out oc; - Printf.printf "Done.\n"; - with exn -> - close_out oc; - Printf.printf "Done.\n"; - with exn -> Printf.printf "Error with file %s.\n" fname)) + let fn = make_stash_directive begin function + | UTop_history.Input i -> + i + | Output out | Error out | Bad_input out | Warnings out -> + Printf.sprintf "(* %s *)" out + end + in + Hashtbl.add Toploop.directive_table "utop_stash" (Toploop.Directive_string fn) + +let () = + let fn = make_stash_directive begin function + | UTop_history.Input i | Bad_input i -> + Printf.sprintf "# %s" i + | Output out | Error out | Warnings out -> + out + end + in + Hashtbl.add Toploop.directive_table "utop_save_session" (Toploop.Directive_string fn) (* +-----------------------------------------------------------------+ | Camlp4 | diff --git a/src/lib/uTop.mli b/src/lib/uTop.mli index 3e7f5cd..1dd33b0 100644 --- a/src/lib/uTop.mli +++ b/src/lib/uTop.mli @@ -210,14 +210,13 @@ val history_file_max_entries : int option ref default) the maximum number of entries if [history] will be used. *) -val stashable_session_history : LTerm_history.t - (** A history consisting only of expressions successfully evaluated - during the current session. Because stashing is supposed to - produce a valid OCaml file which will behave roughly the same as - the console, it is best if this history never gets truncated, so - its maximum size is set at [max_int]. While this will certainly - lead to a slight memory leaking problem, UTop sessions are - rarely long enough to make it a serious issue. *) +val stashable_session_history : UTop_history.t + (** A history consisting of inputs and resulting values or errors of the + current session. Because stashing is supposed to produce a valid OCaml + file which will behave roughly the same as the console, it is best if + this history never gets truncated. While this will certainly lead to a + slight memory leaking problem, UTop sessions are rarely long enough to + make it a serious issue. *) (** {6 Console specific configuration} *) diff --git a/src/lib/uTop_history.ml b/src/lib/uTop_history.ml new file mode 100644 index 0000000..8b1eba2 --- /dev/null +++ b/src/lib/uTop_history.ml @@ -0,0 +1,70 @@ +(* + * uTop_history.ml + * ----------------- + * Copyright : (c) 2017, Fabian Hemmer + * Licence : BSD3 + * + * This file is a part of utop. + *) + +type entry = + | Input of string + | Output of string + | Error of string + | Warnings of string + | Bad_input of string +and t = entry list ref + +let create () : t = + ref [] + +let contents (t : t) = + !t + +let strip_colors s = + let len = String.length s in + let find_escape offset = + try + let i = String.index_from s offset '\027' in + if i = len - 1 || s.[i + 1] <> '[' then + None + else + Some i + with + | Not_found -> None + in + let rec find_color_escapes offset = + match find_escape offset with + | None -> [offset, len] + | Some esc_offset -> + try + let i = String.index_from s esc_offset 'm' in + (offset, esc_offset) :: find_color_escapes (i + 1) + with + | Not_found -> [offset, len] + in + find_color_escapes 0 + |> List.map (fun (i, j) -> String.sub s i (j - i)) + |> String.concat "" + +let add history v = + history := v :: !history + +let add_input history input = + add history @@ Input (String.trim input) + +let add_output history output = + let output = String.trim output in + if output <> "" then (* directives produce empty output *) + add history @@ Output output + +let add_error history error = + add history @@ Error (strip_colors @@ String.trim error) + +let add_bad_input history input = + add history @@ Bad_input (String.trim input) + +let add_warnings history warnings = + let warnings = String.trim warnings in + if warnings <> "" then + add history @@ Warnings warnings diff --git a/src/lib/uTop_history.mli b/src/lib/uTop_history.mli new file mode 100644 index 0000000..f4638a9 --- /dev/null +++ b/src/lib/uTop_history.mli @@ -0,0 +1,40 @@ +(* + * uTop_history.mli + * ------- + * Copyright : (c) 2017, Fabian Hemmer + * Licence : BSD3 + * + * This file is a part of utop. + *) + + +(** Type of a history entry *) +type entry = + | Input of string + | Output of string + | Error of string + | Warnings of string + | Bad_input of string + +type t + +val create : unit -> t + (** Create a new, empty history *) + +val contents : t -> entry list + (** Get the contents of the given history *) + +val add_input : t -> string -> unit + (** Add an input *) + +val add_output : t -> string -> unit + (** Add an output *) + +val add_error : t -> string -> unit + (** Add an error *) + +val add_warnings : t -> string -> unit + (** Add a warning *) + +val add_bad_input : t -> string -> unit + (** Add an input that resulted in an error *) diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index 0ebb0c9..a85ea61 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -191,15 +191,17 @@ class read_phrase ~term = object(self) let result = parse_and_check input eos_is_error in return_value <- Some result; LTerm_history.add UTop.history input; - ignore( - match result with - | UTop.Value _, _ -> - LTerm_history.add UTop.stashable_session_history input - | (UTop.Error (_, msg)), _ -> - let input = "(* " ^ (String.trim input) ^ " *)" in - LTerm_history.add UTop.stashable_session_history input; - let stash_msg = "(* " ^ (String.trim msg) ^ " *)\n" in - LTerm_history.add UTop.stashable_session_history stash_msg); + let out, warnings = result in + begin + match out with + | UTop.Value _ -> + UTop_history.add_input UTop.stashable_session_history input; + UTop_history.add_warnings UTop.stashable_session_history warnings; + | (UTop.Error (_, msg)) -> + UTop_history.add_bad_input UTop.stashable_session_history input; + UTop_history.add_warnings UTop.stashable_session_history warnings; + UTop_history.add_error UTop.stashable_session_history msg; + end; return result with UTop.Need_more -> (* Input not finished, continue. *) @@ -690,8 +692,7 @@ let rec loop term = (* Get the string printed. *) Format.pp_print_flush pp (); let string = Buffer.contents buffer in - let string' = "(* " ^ (String.trim string) ^ " *)\n" in - let _ = LTerm_history.add UTop.stashable_session_history string' in + UTop_history.add_output UTop.stashable_session_history string; match phrase with | Parsetree.Ptop_def _ -> (* The string is an output phrase, colorize it. *)