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

@@ -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 =
+let stashable_session_history = UTop_history.create ()
-  (LTerm_history.create
-    ~max_size:max_int
-    ~max_entries:max_int
-    [])
 
 (* +-----------------------------------------------------------------+
    | 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"
+  let fn = make_stash_directive begin function
-    (Toploop.Directive_string
+  | UTop_history.Input i ->
-      (fun fname ->
+    i
-        let _ :: entries = LTerm_history.contents stashable_session_history in
+  | Output out | Error out | Bad_input out | Warnings out ->
-        (* getting and then reversing the entries instead of using
+    Printf.sprintf "(* %s *)" out
-           [LTerm_history.save] because the latter escapes newline characters *)
+  end
-        let () =
+  in
-          Printf.printf
+  Hashtbl.add Toploop.directive_table "utop_stash" (Toploop.Directive_string fn)
-            "Stashing %d entries in %s... "
+
-            (List.length entries / 2) (* because half are comments *)
+let () =
-            fname
+  let fn = make_stash_directive begin function
-        in
+  | UTop_history.Input i | Bad_input i ->
-        let entries = List.rev entries in
+    Printf.sprintf "# %s" i
-        try
+  | Output out | Error out | Warnings out ->
-          let oc = open_out fname in
+    out
-          try
+  end
-            List.iter
+  in
-              (fun e ->
+  Hashtbl.add Toploop.directive_table "utop_save_session" (Toploop.Directive_string fn)
-                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                                                          |

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
+val stashable_session_history : UTop_history.t
-  (** A history consisting only of expressions successfully evaluated
+  (** A history consisting of inputs and resulting values or errors of the
-      during the current session. Because stashing is supposed to
+      current session. Because stashing is supposed to produce a valid OCaml
-      produce a valid OCaml file which will behave roughly the same as
+      file which will behave roughly the same as the console, it is best if
-      the console, it is best if this history never gets truncated, so
+      this history never gets truncated. While this will certainly lead to a
-      its maximum size is set at [max_int]. While this will certainly
+      slight memory leaking problem, UTop sessions are rarely long enough to
-      lead to a slight memory leaking problem, UTop sessions are
+      make it a serious issue. *)
-      rarely long enough to make it a serious issue. *)
 
 (** {6 Console specific configuration} *)
 

src/lib/uTop_history.ml

@@ -0,0 +1,70 @@
+(*
+ * uTop_history.ml
+ * -----------------
+ * Copyright : (c) 2017, Fabian Hemmer <copy@copy.sh>
+ * 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

src/lib/uTop_history.mli

@@ -0,0 +1,40 @@
+(*
+ * uTop_history.mli
+ * -------
+ * Copyright : (c) 2017, Fabian Hemmer <copy@copy.sh>
+ * 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 *)

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(
+          let out, warnings = result in
-            match result with
+          begin
-            | UTop.Value _, _ ->
+            match out with
-                LTerm_history.add UTop.stashable_session_history input
+            | UTop.Value _ ->
-            | (UTop.Error (_, msg)), _ ->
+              UTop_history.add_input UTop.stashable_session_history input;
-                let input = "(* " ^ (String.trim input) ^ " *)" in
+              UTop_history.add_warnings UTop.stashable_session_history warnings;
-                LTerm_history.add UTop.stashable_session_history input;
+            | (UTop.Error (_, msg)) ->
-                let stash_msg = "(* " ^ (String.trim msg) ^ " *)\n" in
+              UTop_history.add_bad_input UTop.stashable_session_history input;
-                LTerm_history.add UTop.stashable_session_history stash_msg);
+              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
+           UTop_history.add_output UTop.stashable_session_history string;
-           let _ = LTerm_history.add UTop.stashable_session_history string' in
            match phrase with
              | Parsetree.Ptop_def _ ->
                  (* The string is an output phrase, colorize it. *)