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

Add UTop.end_and_accept_current_phrase 

Closes #131
This commit is contained in:
Jeremie Dimino 2015-05-12 16:46:24 +01:00
parent 90ffbe737a
commit 92fafe1f48
3 changed files with 82 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
src/lib/uTop.cppo.ml
View File

@ -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,
LTerm_read_line.doc_of_action action)
name_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,
LTerm_read_line.doc_of_action action)
name_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))

14
src/lib/uTop.mli
View File

@ -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

57
src/lib/uTop_main.cppo.ml
View File

@ -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 ->
x
| None ->
assert false
| Some x ->
x
| None -> assert false
method exec = function
| LTerm_read_line.Accept :: actions when !UTop.smart_accept && S.value self#mode = LTerm_read_line.Edition -> begin
Zed_macro.add self#macro LTerm_read_line.Accept;
(* Try to parse the input. *)
| action :: actions when S.value self#mode = LTerm_read_line.Edition &&
is_accept action -> begin
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, _), _) ->
(* Highlight error locations. *)
List.iter
(fun (start, stop) ->
for i = start to stop - 1 do
let ch, style = styled.(i) in
styled.(i) <- (ch, { style with LTerm_style.underline = Some true })
done)
locs
| _ ->
()
| Some (UTop.Error (locs, _), _) ->
(* Highlight error locations. *)
List.iter
(fun (start, stop) ->
for i = start to stop - 1 do
let ch, style = styled.(i) in
styled.(i) <- (ch, { style with LTerm_style.underline = Some true })
done)
locs
| _ ->
()
end;
(styled, position)