use the new history system

Ignore-this: 3a1d9830d09215b8c34ac97ee79fd97d

darcs-hash:20120212190432-c41ad-865dd5a514e2a3175f6c5412f54567fb7861638c

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

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

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
+  try_lwt
-  history := h;
+    LTerm_history.load UTop.history fn
-  return ()
+  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 <options> <object-files> [script-file [arguments]]\noptions are:"
+let app_name = Filename.basename Sys.executable_name
+let usage = Printf.sprintf "Usage: %s <options> <object-files> [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

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, _, _) ->
+  with
-    return ()
+    | 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 =