haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #8 from benkard/input-multi 

Add multi-phrase input
This commit is contained in:
Jérémie Dimino 2013-04-14 09:51:44 -07:00
parent 2e0026da7c c9e89f0079
commit 725c6b0327
6 changed files with 161 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/camlp4/uTop_camlp4.ml
View File

@ -45,7 +45,7 @@ let convert_camlp4_toplevel_phrase ast =
let loc, msg = get_camlp4_error_message exn in
UTop.Error ([loc], msg)
let parse_toplevel_phrase_camlp4 str eos_is_error =
let parse_camlp4 syntax str eos_is_error =
(* Execute delayed actions now. *)
Register.iter_and_take_callbacks (fun (_, f) -> f ());
let eof = ref false in
@ -61,12 +61,7 @@ let parse_toplevel_phrase_camlp4 str eos_is_error =
Some str.[i])
in
let token_stream = Gram.filter (Gram.lex (Loc.mk UTop.input_name) char_stream) in
match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with
| Some ast ->
let ast = AstFilters.fold_topphrase_filters (fun t filter -> filter t) ast in
UTop.Value ast
| None ->
raise UTop.Need_more
UTop.Value (Gram.parse_tokens_after_filter syntax token_stream)
with exn ->
if !eof && not eos_is_error then
raise UTop.Need_more
@ -74,15 +69,42 @@ let parse_toplevel_phrase_camlp4 str eos_is_error =
let loc, msg = get_camlp4_error_message exn in
UTop.Error ([loc], msg)
let parse_toplevel_phrase_camlp4 str eos_is_error =
match parse_camlp4 Syntax.top_phrase str eos_is_error with
| UTop.Value None ->
raise UTop.Need_more
| UTop.Value (Some ast) ->
UTop.Value (AstFilters.fold_topphrase_filters (fun t filter -> filter t) ast)
| UTop.Error (locs, msg) ->
UTop.Error (locs, msg)
let parse_toplevel_phrase str eos_is_error =
match parse_toplevel_phrase_camlp4 str eos_is_error with
| UTop.Value ast ->
convert_camlp4_toplevel_phrase ast
| UTop.Error (locs, msg) ->
UTop.Error (locs, msg)
let parse_use_file str eos_is_error =
match parse_camlp4 Syntax.use_file str eos_is_error with
| UTop.Value ([], _) ->
raise UTop.Need_more
| UTop.Value (asts, _) ->
let rec loop phrases = function
| [] -> UTop.Value (List.rev phrases)
| (ast::more_asts) ->
match convert_camlp4_toplevel_phrase
(AstFilters.fold_topphrase_filters (fun t filter -> filter t) ast)
with
| UTop.Value y -> loop (y::phrases) more_asts
| UTop.Error (_,_) as e -> e
in loop [] asts
| UTop.Error (locs, msg) ->
UTop.Error (locs, msg)
let () =
UTop.parse_toplevel_phrase := parse_toplevel_phrase;
UTop.parse_use_file := parse_use_file;
(* Force camlp4 to display its welcome message. *)
try
ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string ""))

2
src/camlp4/uTop_camlp4.mli
View File

@ -12,7 +12,7 @@ val parse_toplevel_phrase : string -> bool -> Parsetree.toplevel_phrase UTop.res
val parse_toplevel_phrase_camlp4 : string -> bool -> Camlp4.PreCast.Ast.str_item UTop.result
(** Camlp4 toplevel phrase parser. Same as {!parse_toplevel_phrase}
but the result is not converted to an OCaml ast. *)
but the result is not converted to an OCaml ast. *)
val convert_camlp4_toplevel_phrase : Camlp4.PreCast.Ast.str_item -> Parsetree.toplevel_phrase UTop.result
(** Converts a camlp4 toplevel phrase into a standard OCaml toplevel

8
src/lib/uTop.ml
View File

@ -209,12 +209,12 @@ let mkloc loc =
(loc.Location.loc_start.Lexing.pos_cnum,
loc.Location.loc_end.Lexing.pos_cnum)
let parse_toplevel_phrase_default str eos_is_error =
let parse_default parse str eos_is_error =
let eof = ref false in
let lexbuf = lexbuf_of_string eof str in
try
(* Try to parse the phrase. *)
let phrase = Parse.toplevel_phrase lexbuf in
let phrase = parse lexbuf in
Value phrase
with
| _ when !eof && not eos_is_error ->
@ -240,8 +240,12 @@ let parse_toplevel_phrase_default str eos_is_error =
| exn ->
Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn)
let parse_toplevel_phrase_default = parse_default Parse.toplevel_phrase
let parse_toplevel_phrase = ref parse_toplevel_phrase_default
let parse_use_file_default = parse_default Parse.use_file
let parse_use_file = ref parse_use_file_default
(* +-----------------------------------------------------------------+
| Safety checking |
+-----------------------------------------------------------------+ *)

13
src/lib/uTop.mli
View File

@ -208,6 +208,13 @@ 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
(** The default parser for toplevel regions. It uses the standard
ocaml parser. *)
val parse_toplevel_phrase : (string -> bool -> Parsetree.toplevel_phrase result) ref
(** [parse_toplevel_phrase] is the function used to parse a phrase
typed in the toplevel.
@ -225,7 +232,11 @@ val parse_toplevel_phrase : (string -> bool -> Parsetree.toplevel_phrase result)
Except for {!Need_more}, the function must not raise any
exception. *)
val parse_toplevel_phrase_default : string -> bool -> Parsetree.toplevel_phrase result
val parse_toplevel_phrase_default : string -> bool -> Parsetree.toplevel_phrase result
(** The default parser for toplevel phrases. It uses the standard
ocaml parser. *)
val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result
(** The default parser. It uses the standard ocaml parser. *)
val input_name : string

104
src/lib/uTop_main.ml
View File

@ -72,6 +72,19 @@ let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, inde
| The read-line class |
+-----------------------------------------------------------------+ *)
let parse_input_multi input =
let buf = Buffer.create 32 in
let result =
UTop.collect_formatters buf [Format.err_formatter]
(fun () ->
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 =
@ -731,37 +744,79 @@ module Emacs(M : sig end) = struct
in
loop true
let process_checked_phrase phrase =
(* Rewrite toplevel expressions. *)
let phrase = rewrite phrase in
try
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
(* Skip the dumb location. *)
let msg =
try
let idx = String.index msg '\n' + 1 in
String.sub msg idx (String.length msg - idx)
with Not_found ->
msg
in
List.iter (send "stderr") (split_at ~trim:true '\n' msg);
false
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 -> begin
| 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;
(* Rewrite toplevel expressions. *)
let phrase = rewrite phrase in
try
ignore (Toploop.execute_phrase true Format.std_formatter phrase)
with exn ->
(* The only possible errors are directive errors. *)
let msg = UTop.get_message Errors.report_error exn in
(* Skip the dumb location. *)
let msg =
try
let idx = String.index msg '\n' + 1 in
String.sub msg idx (String.length msg - idx)
with Not_found ->
msg
in
List.iter (send "stderr") (split_at ~trim:true '\n' msg)
end
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 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 more_phrases
else
()
end
| [] ->
()
in
loop phrases
| UTop.Error (locs, msg) ->
send_error locs msg (Some warnings)
let rec loop () =
(* Reset completion. *)
UTop_complete.reset ();
@ -797,6 +852,19 @@ module Emacs(M : sig end) = struct
loop_commands history_prev history_next
else
loop ()
| Some ("input-multi", _) ->
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 =

38
src/top/utop.el
View File

@ -151,6 +151,9 @@ This hook is only run if exiting actually kills the buffer."
(defvar utop-prompt-max 0
"The point at the end of the current prompt.")
(defvar utop-input-prompt-max 0
"The point at the end of the last input prompt.")
(defvar utop-output ""
"The output of the utop sub-process not yet processed.")
@ -179,6 +182,9 @@ before the end of prompt.")
(defvar utop-initial-command nil
"Initial phrase to evaluate.")
(defvar utop-initial-mode nil
"Mode to evaluate utop-initial-command in (nil or :multi).")
(defvar utop-phrase-terminator ";;"
"The OCaml phrase terminator.")
@ -319,6 +325,7 @@ it is started."
(defun utop-send-data (cmd)
"Send current input to utop"
(let ((lines (split-string (buffer-substring-no-properties utop-prompt-max (point-max)) "\n")))
(setq utop-input-prompt-max utop-prompt-max)
;; Send all lines to utop
(utop-send-string cmd)
(while lines
@ -537,7 +544,8 @@ it is started."
(goto-char (point-max))
(insert utop-initial-command)
(setq utop-initial-command nil)
(utop-eval-input nil t nil))))
(utop-eval-input nil t nil utop-initial-mode)
(setq utop-initial-mode nil))))
;; Input has been accepted
((string= command "accept")
;; Add a newline character at the end of the buffer
@ -550,7 +558,9 @@ it is started."
(while offsets
(let ((a (string-to-number (car offsets)))
(b (string-to-number (cadr offsets))))
(add-text-properties (+ utop-prompt-max a) (+ utop-prompt-max b) '(face utop-error))
(add-text-properties (min (point-max) (+ utop-input-prompt-max a))
(min (point-max) (+ utop-input-prompt-max b))
'(face utop-error))
(setq offsets (cdr (cdr offsets))))))
;; Make everything read-only
(add-text-properties (point-min) (point-max) utop-non-editable-properties)
@ -633,7 +643,7 @@ it is started."
;; | Sending data to the utop sub-process |
;; +-----------------------------------------------------------------+
(defun utop-eval-input (&optional allow-incomplete auto-end add-to-history)
(defun utop-eval-input (&optional allow-incomplete auto-end add-to-history input-multi)
"Send the current input to the utop process and let ocaml
evaluate it.
@ -666,6 +676,8 @@ If ADD-TO-HISTORY is t then the input will be added to history."
(utop-set-state 'wait)
(utop-send-data
(cond
((eq input-multi :multi)
"input-multi:\n")
((and allow-incomplete (not auto-end) add-to-history)
"input:allow-incomplete,add-to-history\n")
(add-to-history
@ -771,21 +783,22 @@ when byte-compiling."
;; Put it in utop mode
(with-current-buffer buf (utop-mode)))))))
(defun utop-eval-string (string)
(defun utop-eval-string (string &optional mode)
(with-current-buffer utop-buffer-name
(cond
((eq utop-state 'edit)
;; Insert it at the end of the utop buffer
(goto-char (point-max))
(insert string)
;; Send input to utop now, telling it to automatically add the
;; Send input to utop now, telling it to automatically add the
;; phrase terminator
(utop-eval-input nil t nil))
(utop-eval-input nil t nil mode))
((eq utop-state 'wait)
;; utop is starting, save the initial command to send
(setq utop-initial-command string)))))
(setq utop-initial-command string)
(setq utop-initial-mode mode)))))
(defun utop-eval (start end)
(defun utop-eval (start end &optional mode)
"Eval the given region in utop."
;; From tuareg
(unless (eq major-mode 'caml-mode)
@ -801,13 +814,13 @@ when byte-compiling."
(utop-choose-call "skip-to-end-of-phrase")
(setq end (point))
(buffer-substring-no-properties start end))))
(utop-eval-string text)))
(utop-eval-string text mode)))
(defun utop-eval-region (start end)
"Eval the current region in utop."
(interactive "r")
(utop-prepare-for-eval)
(utop-eval start end))
(utop-eval start end :multi))
(defun utop-eval-phrase ()
"Eval the surrounding Caml phrase (or block) in utop."
@ -825,7 +838,7 @@ when byte-compiling."
"Send the buffer to utop."
(interactive)
(utop-prepare-for-eval)
(utop-eval (point-min) (point-max)))
(utop-eval (point-min) (point-max) :multi))
(defun utop-edit-complete ()
"Completion in a caml/tuareg/typerex."
@ -1108,6 +1121,7 @@ defaults to 0."
;; Reset variables
(setq utop-prompt-min (point-max))
(setq utop-prompt-max (point-max))
(setq utop-input-prompt-max (point-max))
(setq utop-output "")
(setq utop-command-number 0)
(setq utop-completion nil)
@ -1143,6 +1157,7 @@ defaults to 0."
(make-local-variable 'utop-process)
(make-local-variable 'utop-prompt-min)
(make-local-variable 'utop-prompt-max)
(make-local-variable 'utop-input-prompt-max)
(make-local-variable 'utop-last-prompt)
(make-local-variable 'utop-output)
(make-local-variable 'utop-command-number)
@ -1150,6 +1165,7 @@ defaults to 0."
(make-local-variable 'utop-state)
(make-local-variable 'utop-complete-buffer)
(make-local-variable 'utop-initial-command)
(make-local-variable 'utop-initial-mode)
(make-local-variable 'utop-phrase-terminator)
(make-local-variable 'utop-pending-position)
(make-local-variable 'utop-pending-entry)