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

Add support for OCaml 4.13

src/lib/uTop.ml

@@ -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.add_directive
-    Toploop.directive_table
     "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.add_directive
-    Toploop.directive_table
     "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.add_directive
-    Toploop.directive_table
     "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
+  if toploop_get_directive name = None then
-    Hashtbl.add
+    Toploop.add_directive
-      Toploop.directive_table
       name
       (Toploop.Directive_string use_output)
+      default_info
 
 (* +-----------------------------------------------------------------+
    | Initialization                                                  |

src/lib/uTop_complete.ml

@@ -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
+    (List.fold_left
-       (fun dir kind map ->
+       (fun map dir ->
           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
           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 _) ->

src/lib/uTop_main.ml

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