stashing rebased (by chrismamo1)

src/lib/uTop.ml

@@ -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_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
+    [])
 
 (* +-----------------------------------------------------------------+
    | Hooks                                                           |
@@ -537,6 +542,7 @@ utop defines the following directives:
 #help            : list all 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
 #topfind_log     : display messages recorded from findlib since the beginning of the session
 #topfind_verbose : enable/disable topfind verbosity
 
@@ -629,6 +635,34 @@ let () =
     (Toploop.Directive_none
        (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                                                          |
    +-----------------------------------------------------------------+ *)

src/lib/uTop.mli

@@ -210,6 +210,15 @@ 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. *)
+
 (** {6 Console specific configuration} *)
 
 type profile = Dark | Light

src/lib/uTop_main.ml

@@ -111,7 +111,8 @@ let parse_and_check input eos_is_error =
           UTop.Value (Parsetree.Ptop_def pstr)
         with Pparse.Error 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
 #endif
     | _ -> input
@@ -121,7 +122,8 @@ let parse_and_check input eos_is_error =
       (fun () ->
          match preprocess (!UTop.parse_toplevel_phrase input eos_is_error) with
            | 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 ->
                match UTop.check_phrase phrase with
                  | None ->
@@ -189,6 +191,15 @@ 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);
           return result
         with UTop.Need_more ->
           (* Input not finished, continue. *)
@@ -649,13 +660,12 @@ let rec loop term =
           match result with
             | UTop.Value phrase ->
                 return (Some phrase)
-            | UTop.Error (_, msg) ->
+            | UTop.Error (locs, msg) ->
                 print_error term msg >>= fun () ->
                 return None)
         (fun () -> LTerm.flush term)
     )
   in
-
   match phrase_opt with
     | Some phrase ->
         (* Rewrite toplevel expressions. *)
@@ -680,6 +690,8 @@ 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
            match phrase with
              | Parsetree.Ptop_def _ ->
                  (* The string is an output phrase, colorize it. *)