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

Merge pull request #353 from kit-ty-kate/413 

Add support for OCaml 4.13
This commit is contained in:
Rudi Grinberg 2021-05-25 14:00:59 -07:00 committed by GitHub
parent 711c24661c 9fe8b5d838
commit 480c9f7a88
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 91 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
src/lib/uTop.ml
View File

@ -17,6 +17,13 @@ open LTerm_style
let (>>=) = Lwt.(>>=)
let toploop_get_directive name =
#if OCAML_VERSION >= (4, 13, 0)
Toploop.get_directive name
#else
try Some (Hashtbl.find Toploop.directive_table name) with Not_found -> None
#endif
module String_set = Set.Make(String)
let version = "%%VERSION%%"
@ -491,38 +498,49 @@ let prompt = ref default_prompt
let edit_mode= ref LTerm_editor.Default
let default_info = {
Toploop.section = "UTop";
doc = ""; (* TODO: have some kind of documentation *)
}
let () =
Hashtbl.add Toploop.directive_table "utop_prompt_simple"
Toploop.add_directive "utop_prompt_simple"
(Toploop.Directive_none
(fun () ->
prompt := S.map (Printf.ksprintf LTerm_text.of_utf8 "utop [%d]: ") count));
prompt := S.map (Printf.ksprintf LTerm_text.of_utf8 "utop [%d]: ") count))
default_info;
Hashtbl.add Toploop.directive_table "utop_prompt_dummy"
Toploop.add_directive "utop_prompt_dummy"
(Toploop.Directive_none
(fun () ->
prompt := S.const (LTerm_text.of_utf8 "# ")));
prompt := S.const (LTerm_text.of_utf8 "# ")))
default_info;
Hashtbl.add Toploop.directive_table "utop_prompt_fancy_light"
Toploop.add_directive "utop_prompt_fancy_light"
(Toploop.Directive_none
(fun () ->
set_profile Light;
prompt := default_prompt));
prompt := default_prompt))
default_info;
Hashtbl.add Toploop.directive_table "utop_prompt_fancy_dark"
Toploop.add_directive "utop_prompt_fancy_dark"
(Toploop.Directive_none
(fun () ->
set_profile Dark;
prompt := default_prompt));
prompt := default_prompt))
default_info;
Hashtbl.add Toploop.directive_table "edit_mode_default"
Toploop.add_directive "edit_mode_default"
(Toploop.Directive_none
(fun () ->
edit_mode:= LTerm_editor.Default));
edit_mode:= LTerm_editor.Default))
default_info;
Hashtbl.add Toploop.directive_table "edit_mode_vi"
Toploop.add_directive "edit_mode_vi"
(Toploop.Directive_none
(fun () ->
edit_mode:= LTerm_editor.Vi))
default_info
(* +-----------------------------------------------------------------+
| Help |
@ -544,7 +562,7 @@ let doc_of_action action =
LTerm_read_line.doc_of_action action
let () =
Hashtbl.add Toploop.directive_table "utop_help"
Toploop.add_directive "utop_help"
(Toploop.Directive_none
(fun () ->
print_endline "If you can't see the prompt properly try: #utop_prompt_simple
@ -559,9 +577,10 @@ utop defines the following directives:
#topfind_log : display messages recorded from findlib since the beginning of the session
#topfind_verbose : enable/disable topfind verbosity
For a complete description of utop, look at the utop(1) manual page."));
For a complete description of utop, look at the utop(1) manual page."))
default_info;
Hashtbl.add Toploop.directive_table "utop_bindings"
Toploop.add_directive "utop_bindings"
(Toploop.Directive_none
(fun () ->
let make_lines keys actions acc =
@ -630,9 +649,10 @@ For a complete description of utop, look at the utop(1) manual page."));
output_string stdout (Buffer.contents buf)
in
List.iter format_line table;
flush stdout));
flush stdout))
default_info;
Hashtbl.add Toploop.directive_table "utop_macro"
Toploop.add_directive "utop_macro"
(Toploop.Directive_none
(fun () ->
let macro = Zed_macro.contents LTerm_read_line.macro in
@ -642,11 +662,13 @@ For a complete description of utop, look at the utop(1) manual page."));
output_char stdout '\n')
macro;
flush stdout))
default_info
let () =
Hashtbl.add Toploop.directive_table "pwd"
Toploop.add_directive "pwd"
(Toploop.Directive_none
(fun () -> print_endline (Sys.getcwd ())))
default_info
let make_stash_directive entry_formatter fname =
if get_ui () = Emacs then
@ -682,7 +704,7 @@ let () =
Printf.sprintf "(* %s *)" out
end
in
Hashtbl.add Toploop.directive_table "utop_stash" (Toploop.Directive_string fn)
Toploop.add_directive "utop_stash" (Toploop.Directive_string fn) default_info
let () =
let fn = make_stash_directive begin function
@ -692,7 +714,7 @@ let () =
out
end
in
Hashtbl.add Toploop.directive_table "utop_save" (Toploop.Directive_string fn)
Toploop.add_directive "utop_save" (Toploop.Directive_string fn) default_info
(* +-----------------------------------------------------------------+
| Findlib stuff |
@ -724,19 +746,19 @@ let () =
if S.value topfind_verbose then real_log str
let () =
Hashtbl.add
Toploop.directive_table
Toploop.add_directive
"topfind_log"
(Toploop.Directive_none
(fun () ->
List.iter (fun str -> print_string str; print_char '\n')
(S.value topfind_log);
flush stdout));
flush stdout))
default_info;
Hashtbl.add
Toploop.directive_table
Toploop.add_directive
"topfind_verbose"
(Toploop.Directive_bool set_topfind_verbose)
default_info
let split_words str =
let len = String.length str in
@ -771,11 +793,11 @@ let require packages =
handle_findlib_error exn
let () =
Hashtbl.add
Toploop.directive_table
Toploop.add_directive
"require"
(Toploop.Directive_string
(fun str -> require (split_words str)))
default_info
(* +-----------------------------------------------------------------+
| Backports |
@ -806,11 +828,11 @@ let use_output command =
let () =
let name = "use_output" in
if not (Hashtbl.mem Toploop.directive_table name) then
Hashtbl.add
Toploop.directive_table
if toploop_get_directive name = None then
Toploop.add_directive
name
(Toploop.Directive_string use_output)
default_info
(* +-----------------------------------------------------------------+
| Initialization |

35
src/lib/uTop_complete.ml
View File

@ -22,6 +22,20 @@ let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.
| Utils |
+-----------------------------------------------------------------+ *)
let toploop_get_directive name =
#if OCAML_VERSION >= (4, 13, 0)
Toploop.get_directive name
#else
try Some (Hashtbl.find Toploop.directive_table name) with Not_found -> None
#endif
let toploop_all_directive_names () =
#if OCAML_VERSION >= (4, 13, 0)
Toploop.all_directive_names ()
#else
Hashtbl.fold (fun dir _ acc -> dir::acc) Toploop.directive_table []
#endif
(* Transform a non-empty list of strings into a long-identifier. *)
let longident_of_list = function
| [] ->
@ -254,17 +268,18 @@ let parse_label tokens =
let list_directives phrase_terminator =
String_map.bindings
(Hashtbl.fold
(fun dir kind map ->
(List.fold_left
(fun map dir ->
let suffix =
match kind with
| Toploop.Directive_none _ -> phrase_terminator
| Toploop.Directive_string _ -> " \""
| Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _ -> " "
match toploop_get_directive dir with
| Some (Toploop.Directive_none _) -> phrase_terminator
| Some (Toploop.Directive_string _) -> " \""
| Some (Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _) -> " "
| None -> assert false
in
String_map.add dir suffix map)
Toploop.directive_table
String_map.empty)
String_map.empty
(toploop_all_directive_names ()))
(* +-----------------------------------------------------------------+
| File listing |
@ -1045,7 +1060,7 @@ let complete ~phrase_terminator ~input =
(* Generic completion on directives. *)
| [(Symbol "#", _); ((Lident dir | Uident dir), _); (Blanks, { idx2 = stop })] ->
(stop,
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
match toploop_get_directive dir with
| Some (Toploop.Directive_none _) -> [(phrase_terminator, "")]
| Some (Toploop.Directive_string _) -> [(" \"", "")]
| Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)]
@ -1053,7 +1068,7 @@ let complete ~phrase_terminator ~input =
| Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names ()))
| None -> [])
| (Symbol "#", _) :: ((Lident dir | Uident dir), _) :: tokens -> begin
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
match toploop_get_directive dir with
| Some (Toploop.Directive_none _) ->
(0, [])
| Some (Toploop.Directive_string _) ->

19
src/lib/uTop_main.ml
View File

@ -1337,9 +1337,15 @@ let typeof sid =
let str = Buffer.contents buf in
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
let default_info = {
Toploop.section = "UTop";
doc = ""; (* TODO: have some kind of documentation *)
}
let () =
Hashtbl.add Toploop.directive_table "typeof"
Toploop.add_directive "typeof"
(Toploop.Directive_string typeof)
default_info
(* +-----------------------------------------------------------------+
| Entry point |
@ -1355,7 +1361,12 @@ let prepare () =
List.for_all
(function
| `Packages l -> UTop.require l; true
| `Object fn -> Topdirs.load_file Format.err_formatter fn)
| `Object fn ->
#if OCAML_VERSION >= (4, 13, 0)
Toploop.load_file Format.err_formatter fn)
#else
Topdirs.load_file Format.err_formatter fn)
#endif
(List.rev !preload)
in
if ok then !Toploop.toplevel_startup_hook ();
@ -1442,7 +1453,7 @@ let args = Arg.align [
#endif
"-version", Arg.Unit print_version, " Print version and exit";
"-vnum", Arg.Unit print_version_num, " Print version number and exit";
"-w", Arg.String (Warnings.parse_options false),
"-w", Arg.String (fun opt -> ignore (Warnings.parse_options false opt)),
Printf.sprintf
"<list> Enable or disable warnings according to <list>:\n\
\ +<spec> enable warnings in <spec>\n\
@ -1453,7 +1464,7 @@ let args = Arg.align [
\ <num1>..<num2> a range of consecutive warning numbers\n\
\ <letter> a predefined set\n\
\ default setting is %S" Warnings.defaults_w;
"-warn-error", Arg.String (Warnings.parse_options true),
"-warn-error", Arg.String (fun opt -> ignore (Warnings.parse_options true opt)),
Printf.sprintf
"<list> Enable or disable error status for warnings according to <list>\n\
\ See option -w for the syntax of <list>.\n\