Add UTop.end_and_accept_current_phrase

Closes #131

src/lib/uTop.cppo.ml

@@ -76,6 +76,10 @@ let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true
 let auto_run_async, get_auto_run_async, set_auto_run_async = make_variable true
 let topfind_verbose, get_topfind_verbose, set_topfind_verbose = make_variable false
 
+(* Ugly hack until the action system of lambda-term is improved *)
+let end_and_accept_current_phrase : LTerm_read_line.action =
+  Edit (Custom (fun () -> assert false))
+
 (* +-----------------------------------------------------------------+
    | Keywords                                                        |
    +-----------------------------------------------------------------+ *)
@@ -499,6 +503,18 @@ let () =
 module Bindings = Zed_input.Make (LTerm_key)
 module Keys_map = Map.Make (struct type t = LTerm_key.t list let compare = compare end)
 
+let name_of_action action =
+  if action == end_and_accept_current_phrase then
+    "end-and-accept-current-phrase"
+  else
+    LTerm_read_line.name_of_action action
+
+let doc_of_action action =
+  if action == end_and_accept_current_phrase then
+    "end the current phrase with the phrase terminator (;;) and evaluate it"
+  else
+    LTerm_read_line.doc_of_action action
+
 let () =
   Hashtbl.add Toploop.directive_table "utop_help"
     (Toploop.Directive_none
@@ -533,20 +549,29 @@ For a complete description of utop, look at the utop(1) manual page."));
                           loop
                             actions
                             (("",
-                              LTerm_read_line.name_of_action action,
+                              name_of_action action,
-                              LTerm_read_line.doc_of_action action)
+                              doc_of_action action)
                              :: acc)
                   in
                   loop
                     actions
                     ((String.concat " " (List.map LTerm_key.to_string_compact keys),
-                      LTerm_read_line.name_of_action action,
+                      name_of_action action,
-                      LTerm_read_line.doc_of_action action)
+                      doc_of_action action)
                      :: acc)
           in
-          let bindings = Bindings.fold (fun key actions map -> Keys_map.add key (List.map (fun action -> (LTerm_read_line.Edit action)) actions) map) !LTerm_edit.bindings Keys_map.empty in
+          let bindings =
+            Bindings.fold
+              (fun key actions map ->
+                 Keys_map.add key
+                   (List.map (fun action -> (LTerm_read_line.Edit action)) actions) map)
+              !LTerm_edit.bindings Keys_map.empty
+          in
           let bindings = Bindings.fold Keys_map.add !LTerm_read_line.bindings bindings in
-          let table = List.rev (Keys_map.fold (fun keys action acc -> make_lines keys action acc) bindings []) in
+          let table =
+            List.rev (Keys_map.fold (fun keys action acc -> make_lines keys action acc)
+                        bindings [])
+          in
           let size_key, size_name, size_doc =
             List.fold_left
               (fun (size_key, size_name, size_doc) (key, name, doc) ->
@@ -582,7 +607,7 @@ For a complete description of utop, look at the utop(1) manual page."));
           let macro = Zed_macro.contents LTerm_read_line.macro in
           List.iter
             (fun action ->
-               output_string stdout (LTerm_read_line.name_of_action action);
+               output_string stdout (name_of_action action);
                output_char stdout '\n')
             macro;
           flush stdout))

src/lib/uTop.mli

@@ -154,6 +154,19 @@ val get_auto_run_async : unit -> bool
 val set_auto_run_async : bool -> unit
   (** Modifies {!auto_run_async}. *)
 
+val end_and_accept_current_phrase : LTerm_read_line.action
+ (** Action that add the phrase terminator at the end of the current phrase
+     and accepts it. For instance to avoid typing [;;], add this to your
+     ~/.ocamlinit:
+
+     {[
+       #require "lambda-term";;
+       LTerm_read_line.bind
+         [ { control = false; meta = false; shift = false; code = Enter } ]
+         [ UTop.end_and_accept_current_phrase ]
+     ]}
+ *)
+
 (** {6 History} *)
 
 val history : LTerm_history.t
@@ -234,7 +247,6 @@ type 'a result =
 exception Need_more
   (** Exception raised by a parser when it need more data. *)
 
-(*val parse_use_file : (string -> bool -> ((Camlp4.PreCast.Syntax.Ast.str_item list * Camlp4.PreCast.Syntax.Loc.t option) Camlp4.PreCast.Syntax.Gram.Entry.t) result) ref*)
 val parse_use_file : (string -> bool -> Parsetree.toplevel_phrase list result) ref
 
 val parse_use_file_default : string -> bool -> Parsetree.toplevel_phrase list result

src/lib/uTop_main.cppo.ml

@@ -125,6 +125,17 @@ let parse_and_check input eos_is_error =
   in
   (result, Buffer.contents buf)
 
+let add_terminator s =
+  let terminator = UTop.get_phrase_terminator () in
+  if Zed_utf8.ends_with s terminator then
+    s
+  else
+    s ^ terminator
+
+let is_accept : LTerm_read_line.action -> bool = function
+  | Accept -> true
+  | action -> action == UTop.end_and_accept_current_phrase
+
 (* Read a phrase. If the result is a value, it is guaranteed to by a
    valid phrase (i.e. typable and compilable). It also returns
    warnings printed parsing. *)
@@ -136,20 +147,26 @@ class read_phrase ~term = object(self)
 
   method eval =
     match return_value with
-      | Some x ->
+    | Some x ->
-          x
+      x
-      | None ->
+    | None -> assert false
-          assert false
 
   method exec = function
-    | LTerm_read_line.Accept :: actions when !UTop.smart_accept && S.value self#mode = LTerm_read_line.Edition -> begin
+    | action :: actions when S.value self#mode = LTerm_read_line.Edition &&
-        Zed_macro.add self#macro LTerm_read_line.Accept;
+                             is_accept action  -> begin
-        (* Try to parse the input. *)
+        Zed_macro.add self#macro action;
         let input = Zed_rope.to_string (Zed_edit.text self#edit) in
+        let input =
+          if action == UTop.end_and_accept_current_phrase then
+            add_terminator input
+          else
+            input
+        in
         (* Toploop does that: *)
         Location.reset ();
+        let eos_is_error = not !UTop.smart_accept in
         try
-          let result = parse_and_check input false in
+          let result = parse_and_check input eos_is_error in
           return_value <- Some result;
           LTerm_history.add UTop.history input;
           return result
@@ -159,7 +176,7 @@ class read_phrase ~term = object(self)
           self#exec actions
       end
     | actions ->
-        super_term#exec actions
+      super_term#exec actions
 
   method stylise last =
     let styled, position = super#stylise last in
@@ -178,17 +195,17 @@ class read_phrase ~term = object(self)
       LTerm_text.stylise_parenthesis styled position styles.style_paren
     else begin
       match return_value with
-        | Some (UTop.Error (locs, _), _) ->
+      | Some (UTop.Error (locs, _), _) ->
-            (* Highlight error locations. *)
+        (* Highlight error locations. *)
-            List.iter
+        List.iter
-              (fun (start, stop) ->
+          (fun (start, stop) ->
-                 for i = start to stop - 1 do
+             for i = start to stop - 1 do
-                   let ch, style = styled.(i) in
+               let ch, style = styled.(i) in
-                   styled.(i) <- (ch, { style with LTerm_style.underline = Some true })
+               styled.(i) <- (ch, { style with LTerm_style.underline = Some true })
-                 done)
+             done)
-              locs
+          locs
-        | _ ->
+      | _ ->
-            ()
+        ()
     end;
 
     (styled, position)