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
commit 480c9f7a88
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 91 additions and 43 deletions

View File

@ -17,6 +17,13 @@ open LTerm_style
let (>>=) = Lwt.(>>=) 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) module String_set = Set.Make(String)
let version = "%%VERSION%%" let version = "%%VERSION%%"
@ -491,38 +498,49 @@ let prompt = ref default_prompt
let edit_mode= ref LTerm_editor.Default let edit_mode= ref LTerm_editor.Default
let default_info = {
Toploop.section = "UTop";
doc = ""; (* TODO: have some kind of documentation *)
}
let () = let () =
Hashtbl.add Toploop.directive_table "utop_prompt_simple" Toploop.add_directive "utop_prompt_simple"
(Toploop.Directive_none (Toploop.Directive_none
(fun () -> (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 (Toploop.Directive_none
(fun () -> (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 (Toploop.Directive_none
(fun () -> (fun () ->
set_profile Light; 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 (Toploop.Directive_none
(fun () -> (fun () ->
set_profile Dark; 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 (Toploop.Directive_none
(fun () -> (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 (Toploop.Directive_none
(fun () -> (fun () ->
edit_mode:= LTerm_editor.Vi)) edit_mode:= LTerm_editor.Vi))
default_info
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Help | | Help |
@ -544,7 +562,7 @@ let doc_of_action action =
LTerm_read_line.doc_of_action action LTerm_read_line.doc_of_action action
let () = let () =
Hashtbl.add Toploop.directive_table "utop_help" Toploop.add_directive "utop_help"
(Toploop.Directive_none (Toploop.Directive_none
(fun () -> (fun () ->
print_endline "If you can't see the prompt properly try: #utop_prompt_simple 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_log : display messages recorded from findlib since the beginning of the session
#topfind_verbose : enable/disable topfind verbosity #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 (Toploop.Directive_none
(fun () -> (fun () ->
let make_lines keys actions acc = 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) output_string stdout (Buffer.contents buf)
in in
List.iter format_line table; 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 (Toploop.Directive_none
(fun () -> (fun () ->
let macro = Zed_macro.contents LTerm_read_line.macro in 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') output_char stdout '\n')
macro; macro;
flush stdout)) flush stdout))
default_info
let () = let () =
Hashtbl.add Toploop.directive_table "pwd" Toploop.add_directive "pwd"
(Toploop.Directive_none (Toploop.Directive_none
(fun () -> print_endline (Sys.getcwd ()))) (fun () -> print_endline (Sys.getcwd ())))
default_info
let make_stash_directive entry_formatter fname = let make_stash_directive entry_formatter fname =
if get_ui () = Emacs then if get_ui () = Emacs then
@ -682,7 +704,7 @@ let () =
Printf.sprintf "(* %s *)" out Printf.sprintf "(* %s *)" out
end end
in 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 () =
let fn = make_stash_directive begin function let fn = make_stash_directive begin function
@ -692,7 +714,7 @@ let () =
out out
end end
in 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 | | Findlib stuff |
@ -724,19 +746,19 @@ let () =
if S.value topfind_verbose then real_log str if S.value topfind_verbose then real_log str
let () = let () =
Hashtbl.add Toploop.add_directive
Toploop.directive_table
"topfind_log" "topfind_log"
(Toploop.Directive_none (Toploop.Directive_none
(fun () -> (fun () ->
List.iter (fun str -> print_string str; print_char '\n') List.iter (fun str -> print_string str; print_char '\n')
(S.value topfind_log); (S.value topfind_log);
flush stdout)); flush stdout))
default_info;
Hashtbl.add Toploop.add_directive
Toploop.directive_table
"topfind_verbose" "topfind_verbose"
(Toploop.Directive_bool set_topfind_verbose) (Toploop.Directive_bool set_topfind_verbose)
default_info
let split_words str = let split_words str =
let len = String.length str in let len = String.length str in
@ -771,11 +793,11 @@ let require packages =
handle_findlib_error exn handle_findlib_error exn
let () = let () =
Hashtbl.add Toploop.add_directive
Toploop.directive_table
"require" "require"
(Toploop.Directive_string (Toploop.Directive_string
(fun str -> require (split_words str))) (fun str -> require (split_words str)))
default_info
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Backports | | Backports |
@ -806,11 +828,11 @@ let use_output command =
let () = let () =
let name = "use_output" in let name = "use_output" in
if not (Hashtbl.mem Toploop.directive_table name) then if toploop_get_directive name = None then
Hashtbl.add Toploop.add_directive
Toploop.directive_table
name name
(Toploop.Directive_string use_output) (Toploop.Directive_string use_output)
default_info
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Initialization | | Initialization |

View File

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

View File

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