uTop_main: Handle `input-multi` commands.

src/lib/uTop_main.ml

@@ -72,12 +72,25 @@ let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, inde
    | The read-line class                                             |
    +-----------------------------------------------------------------+ *)
 
-let parse_and_check parse input eos_is_error =
+let parse_input_multi input =
   let buf = Buffer.create 32 in
   let result =
     UTop.collect_formatters buf [Format.err_formatter]
       (fun () ->
-         match parse input eos_is_error with
+         match !UTop.parse_use_file input false with
+           | UTop.Error (locs, msg) ->
+               UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
+           | UTop.Value phrases ->
+               (UTop.Value phrases))
+  in
+  (result, Buffer.contents buf)
+
+let parse_and_check input eos_is_error =
+  let buf = Buffer.create 32 in
+  let result =
+    UTop.collect_formatters buf [Format.err_formatter]
+      (fun () ->
+         match !UTop.parse_toplevel_phrase input eos_is_error with
            | UTop.Error (locs, msg) ->
                UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
            | UTop.Value phrase ->
@@ -113,7 +126,7 @@ class read_phrase ~term = object(self)
         (* Toploop does that: *)
         Location.reset ();
         try
-          let result = parse_and_check !UTop.parse_toplevel_phrase input false in
+          let result = parse_and_check input false in
           return_value <- Some result;
           LTerm_history.add UTop.history input;
           return result
@@ -731,18 +744,12 @@ module Emacs(M : sig end) = struct
     in
     loop true
 
-  let process_input add_to_history eos_is_error =
+  let process_checked_phrase phrase = begin
-    let input = read_data () in
-    let result, warnings = parse_and_check !UTop.parse_toplevel_phrase input eos_is_error in
-    match result with
-      | UTop.Value phrase -> begin
-          send "accept" "";
-          List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
-          if add_to_history then LTerm_history.add UTop.history input;
     (* Rewrite toplevel expressions. *)
     let phrase = rewrite phrase in
     try
-            ignore (Toploop.execute_phrase true Format.std_formatter phrase)
+      ignore (Toploop.execute_phrase true Format.std_formatter phrase);
+      true
     with exn ->
       (* The only possible errors are directive errors. *)
       let msg = UTop.get_message Errors.report_error exn in
@@ -754,14 +761,64 @@ module Emacs(M : sig end) = struct
         with Not_found ->
           msg
       in
-            List.iter (send "stderr") (split_at ~trim:true '\n' msg)
+      List.iter (send "stderr") (split_at ~trim:true '\n' msg);
+      false
   end
+
+  let process_input add_to_history eos_is_error =
+    let input = read_data () in
+    let result, warnings = parse_and_check input eos_is_error in
+    match result with
+      | UTop.Value phrase ->
+          send "accept" "";
+          List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
+          if add_to_history then LTerm_history.add UTop.history input;
+          ignore (process_checked_phrase phrase)
       | UTop.Error (locs, msg) ->
           send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
           List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
           if add_to_history then LTerm_history.add UTop.history input;
           List.iter (send "stderr") (split_at ~trim:true '\n' msg)
 
+  let send_error locs msg warnings =
+    send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
+    match warnings with
+      | Some warnings -> List.iter (send "stderr") (split_at ~trim:true '\n' warnings)
+      | None -> ();
+    List.iter (send "stderr") (split_at ~trim:true '\n' msg)
+
+  let process_input_multi () =
+    let input = read_data () in
+    let result, warnings = parse_input_multi input in
+    let typecheck = function phrase ->
+      match UTop.check_phrase phrase with 
+        | None -> None
+        | Some (locs, msg) -> Some (convert_locs input locs, msg)  (* FIXME *)
+    in
+    match result with
+      | UTop.Value phrases ->
+          send "accept" "";
+          List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
+          let rec loop = function
+            | (phrase::more_phrases) -> begin
+              match typecheck phrase with
+                | Some (locs, msg) ->
+                  send_error locs msg None
+                | None ->
+                  let success = process_checked_phrase phrase in
+                  if success then
+                    loop phrases
+                  else
+                    ()
+              end
+            | [] ->
+              ()
+          in
+          loop phrases
+          (* FIXME: send "end" ""? *)
+      | UTop.Error (locs, msg) ->
+        send_error locs msg (Some warnings)
+
   let rec loop () =
     (* Reset completion. *)
     UTop_complete.reset ();
@@ -797,6 +854,19 @@ module Emacs(M : sig end) = struct
             loop_commands history_prev history_next
           else
             loop ()
+      | Some ("input-multi", arg) ->
+          let continue =
+            try
+              process_input_multi ();
+              false
+            with UTop.Need_more ->
+              send "continue" "";
+              true
+          in
+          if continue then
+            loop_commands history_prev history_next
+          else
+            loop ()
       | Some ("complete", _) ->
           let input = read_data () in
           let start, words =