diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index e6026a2..1aed247 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -17,6 +17,8 @@ module String_set = Set.Make(String) let version = UTop_version.version +let history = LTerm_history.create [] + (* +-----------------------------------------------------------------+ | Hooks | +-----------------------------------------------------------------+ *) diff --git a/src/lib/uTop.mli b/src/lib/uTop.mli index 1ae6cd9..455177f 100644 --- a/src/lib/uTop.mli +++ b/src/lib/uTop.mli @@ -14,6 +14,19 @@ open React val version : string (** Version of utop. *) +val history : LTerm_history.t + (** The history used by utop. You can configure limits using the + [LTerm_history] module. + + For example if you want to limit the history to 1000 line, add + these lines to your ~/.ocamlinit file: + + {[ + #require "lambda-term";; + LTerm_history.set_max_entries UTop.history 1000;; + ]} + *) + val count : int React.signal (** The number of commands already executed. *) diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index d44f485..ab3ea15 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -22,16 +22,15 @@ module String_set = Set.Make(String) | History | +-----------------------------------------------------------------+ *) -let history = ref [] - let init_history () = - let hist_name = Filename.concat LTerm_resources.home ".utop-history" in + let fn = Filename.concat LTerm_resources.home ".utop-history" in (* Save history on exit. *) - Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history); + Lwt_main.at_exit (fun () -> LTerm_history.save UTop.history ~append:true fn); (* Load history. *) - lwt h = LTerm_read_line.load_history hist_name in - history := h; - return () + try_lwt + LTerm_history.load UTop.history fn + with Unix.Unix_error (error, func, arg) -> + Lwt_log.error_f "cannot load history from %S: %s: %s" fn func (Unix.error_message error) (* +-----------------------------------------------------------------+ | offset --> index | @@ -72,7 +71,7 @@ let parse_and_check input eos_is_error = (* Read a phrase. If the result is a value, it is guaranteed to by a valid phrase (i.e. typable and compilable). *) class read_phrase ~term = object(self) - inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.engine ~history:!history () as super + inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.engine ~history:(LTerm_history.contents UTop.history) () as super inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.term term as super_term val mutable return_value = None @@ -94,7 +93,7 @@ class read_phrase ~term = object(self) try let result = parse_and_check input false in return_value <- Some result; - history := LTerm_read_line.add_entry input !history; + LTerm_history.add UTop.history input; return result with UTop.Need_more -> (* Input not finished, continue. *) @@ -619,7 +618,8 @@ let args = Arg.align [ "-emacs", Arg.Set emacs_mode, " Run in emacs mode"; ] -let usage = "Usage: utop [script-file [arguments]]\noptions are:" +let app_name = Filename.basename Sys.executable_name +let usage = Printf.sprintf "Usage: %s [script-file [arguments]]\noptions are:" app_name let common_init () = (* Initializes toplevel environment. *) @@ -643,7 +643,13 @@ let common_init () = if Sys.file_exists fn then ignore (Toploop.use_silently Format.err_formatter fn) -let main () = +let load_inputrc () = + try_lwt + LTerm_inputrc.load () + with Unix.Unix_error (error, func, arg) -> + Lwt_log.error_f "cannot key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error) + +let main_aux () = Arg.parse args file_argument usage; if not (prepare ()) then exit 2; if !emacs_mode then begin @@ -661,7 +667,7 @@ let main () = (* Install our out phrase printer. *) Toploop.print_out_phrase := print_out_phrase term !Toploop.print_out_phrase; (* Load user data. *) - Lwt_main.run (join [init_history (); UTop_styles.load (); LTerm_inputrc.load ()]); + Lwt_main.run (join [init_history (); UTop_styles.load (); load_inputrc ()]); (* Display a welcome message. *) Lwt_main.run (welcome term); (* Common initialization. *) @@ -683,3 +689,18 @@ let main () = end; (* Don't let the standard toplevel run... *) exit 0 + +let main () = + try + main_aux () + with exn -> + (match exn with + | Unix.Unix_error (error, func, "") -> + Printf.eprintf "%s: %s: %s\n" app_name func (Unix.error_message error) + | Unix.Unix_error (error, func, arg) -> + Printf.eprintf "%s: %s(%S): %s\n" app_name func arg (Unix.error_message error) + | exn -> + Printf.eprintf "Fatal error: exception %s\n" (Printexc.to_string exn)); + Printexc.print_backtrace stderr; + flush stderr; + exit 2 diff --git a/src/lib/uTop_styles.ml b/src/lib/uTop_styles.ml index 07fbdc4..6b18ee6 100644 --- a/src/lib/uTop_styles.ml +++ b/src/lib/uTop_styles.ml @@ -55,8 +55,9 @@ let styles = { } let load () = + let fn = Filename.concat LTerm_resources.home ".utoprc" in try_lwt - lwt res = LTerm_resources.load (Filename.concat LTerm_resources.home ".utoprc") in + lwt res = LTerm_resources.load fn in styles.style_keyword <- LTerm_resources.get_style "keyword" res; styles.style_symbol <- LTerm_resources.get_style "symbol" res; styles.style_ident <- LTerm_resources.get_style "identifier" res; @@ -84,8 +85,11 @@ let load () = | str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str))); UTop_private.error_style := styles.style_error; return () - with Unix.Unix_error(Unix.ENOENT, _, _) -> - return () + with + | Unix.Unix_error(Unix.ENOENT, _, _) -> + return () + | Unix.Unix_error (error, func, arg) -> + Lwt_log.error_f "cannot load styles from %S: %s: %s" fn func (Unix.error_message error) let stylise stylise tokens = let rec loop tokens =