stashing rebased (by chrismamo1)

This commit is contained in:
chrismamo1 2016-06-25 14:48:55 -05:00 committed by Jérémie Dimino
parent f5ee983845
commit 6b8c78de58
3 changed files with 59 additions and 4 deletions

View File

@ -27,6 +27,11 @@ let history = LTerm_history.create []
let history_file_name = ref (Some (Filename.concat LTerm_resources.home ".utop-history")) let history_file_name = ref (Some (Filename.concat LTerm_resources.home ".utop-history"))
let history_file_max_size = ref None let history_file_max_size = ref None
let history_file_max_entries = ref None let history_file_max_entries = ref None
let stashable_session_history =
(LTerm_history.create
~max_size:max_int
~max_entries:max_int
[])
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Hooks | | Hooks |
@ -537,6 +542,7 @@ utop defines the following directives:
#help : list all directives #help : list all directives
#utop_bindings : list all the current key bindings #utop_bindings : list all the current key bindings
#utop_macro : display the currently recorded macro #utop_macro : display the currently recorded macro
#utop_stash : store all the valid commands from your current session in a file
#topfind_log : display messages recorded from findlib since the beginning of the session #topfind_log : display messages recorded from findlib since the beginning of the session
#topfind_verbose : enable/disable topfind verbosity #topfind_verbose : enable/disable topfind verbosity
@ -629,6 +635,34 @@ let () =
(Toploop.Directive_none (Toploop.Directive_none
(fun () -> print_endline (Sys.getcwd ()))) (fun () -> print_endline (Sys.getcwd ())))
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))
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Camlp4 | | Camlp4 |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)

View File

@ -210,6 +210,15 @@ val history_file_max_entries : int option ref
default) the maximum number of entries if [history] will be default) the maximum number of entries if [history] will be
used. *) 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. *)
(** {6 Console specific configuration} *) (** {6 Console specific configuration} *)
type profile = Dark | Light type profile = Dark | Light

View File

@ -111,7 +111,8 @@ let parse_and_check input eos_is_error =
UTop.Value (Parsetree.Ptop_def pstr) UTop.Value (Parsetree.Ptop_def pstr)
with Pparse.Error error -> with Pparse.Error error ->
Pparse.report_error Format.str_formatter error; Pparse.report_error Format.str_formatter error;
UTop.Error ([], Format.flush_str_formatter ()) let err_string = Format.flush_str_formatter () in
UTop.Error ([], err_string)
end end
#endif #endif
| _ -> input | _ -> input
@ -121,7 +122,8 @@ let parse_and_check input eos_is_error =
(fun () -> (fun () ->
match preprocess (!UTop.parse_toplevel_phrase input eos_is_error) with match preprocess (!UTop.parse_toplevel_phrase input eos_is_error) with
| UTop.Error (locs, msg) -> | UTop.Error (locs, msg) ->
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n") let msg = "Error: " ^ msg in
UTop.Error (convert_locs input locs, msg ^ "\n")
| UTop.Value phrase -> | UTop.Value phrase ->
match UTop.check_phrase phrase with match UTop.check_phrase phrase with
| None -> | None ->
@ -189,6 +191,15 @@ class read_phrase ~term = object(self)
let result = parse_and_check input eos_is_error in let result = parse_and_check input eos_is_error in
return_value <- Some result; return_value <- Some result;
LTerm_history.add UTop.history input; 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);
return result return result
with UTop.Need_more -> with UTop.Need_more ->
(* Input not finished, continue. *) (* Input not finished, continue. *)
@ -649,13 +660,12 @@ let rec loop term =
match result with match result with
| UTop.Value phrase -> | UTop.Value phrase ->
return (Some phrase) return (Some phrase)
| UTop.Error (_, msg) -> | UTop.Error (locs, msg) ->
print_error term msg >>= fun () -> print_error term msg >>= fun () ->
return None) return None)
(fun () -> LTerm.flush term) (fun () -> LTerm.flush term)
) )
in in
match phrase_opt with match phrase_opt with
| Some phrase -> | Some phrase ->
(* Rewrite toplevel expressions. *) (* Rewrite toplevel expressions. *)
@ -680,6 +690,8 @@ let rec loop term =
(* Get the string printed. *) (* Get the string printed. *)
Format.pp_print_flush pp (); Format.pp_print_flush pp ();
let string = Buffer.contents buffer in let string = Buffer.contents buffer in
let string' = "(* " ^ (String.trim string) ^ " *)\n" in
let _ = LTerm_history.add UTop.stashable_session_history string' in
match phrase with match phrase with
| Parsetree.Ptop_def _ -> | Parsetree.Ptop_def _ ->
(* The string is an output phrase, colorize it. *) (* The string is an output phrase, colorize it. *)