Add #help to list available toplevel directives.

berke · gasche · commit 70ee3c48cab1 · 2015-12-09T09:05:19.000+01:00
diff --git a/Changes b/Changes
@@ -874,6 +874,8 @@ Compilers:
 Toplevel interactive system:
 - PR#5377: New "#show_*" directives
   (ygrek, Jacques Garrigue and Alain Frisch)
+- PR#6113: Add descriptions to directives, and display them via #help
+  (Berke Durak)
 
 Runtime system:
 - New configure option "-no-naked-pointers" to improve performance by
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
@@ -27,7 +27,9 @@ let std_out = std_formatter
 
 let dir_quit () = exit 0
 
-let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit)
+let _ =
+  add_directive "quit" "Exit the toplevel loop and terminate the ocaml command."
+  (Directive_none dir_quit)
 
 (* To add a directory to the load path *)
 
@@ -36,7 +38,9 @@ let dir_directory s =
   Config.load_path := d :: !Config.load_path;
   Dll.add_path [d]
 
-let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
+let _ = add_directive "directory"
+  "Add <string> to search path for source and compiled files."
+  (Directive_string dir_directory)
 
 (* To remove a directory from the load path *)
 let dir_remove_directory s =
@@ -45,14 +49,16 @@ let dir_remove_directory s =
   Dll.remove_path [d]
 
 let _ =
-  Hashtbl.add directive_table "remove_directory"
+  add_directive "remove_directory"
+    "Remove <string> from the search path for source and compiled files."
     (Directive_string dir_remove_directory)
 
 (* To change the current directory *)
 
 let dir_cd s = Sys.chdir s
 
-let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
+let _ = add_directive "cd" "Change the current working directory"
+  (Directive_string dir_cd)
 
 (* Load in-core a .cmo file *)
 
@@ -173,12 +179,14 @@ and really_load_file recursive ppf name filename ic =
 
 let dir_load ppf name = ignore (load_file false ppf name)
 
-let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out))
+let _ = add_directive "load" "Load an object (.cmo) or a library (.cma) file"
+  (Directive_string (dir_load std_out))
 
 let dir_load_rec ppf name = ignore (load_file true ppf name)
 
-let _ = Hashtbl.add directive_table "load_rec"
-                    (Directive_string (dir_load_rec std_out))
+let _ =
+  add_directive "load_rec" "Like #load but recursively load missing modules"
+  (Directive_string (dir_load_rec std_out))
 
 let load_file = load_file false
 
@@ -187,9 +195,14 @@ let load_file = load_file false
 let dir_use ppf name = ignore(Toploop.use_file ppf name)
 let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name)
 
-let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out))
-let _ = Hashtbl.add directive_table "mod_use"
-                    (Directive_string (dir_mod_use std_out))
+let _ =
+  add_directive "use" "Read and execute source phrases from file <string>"
+  (Directive_string (dir_use std_out))
+
+let _ =
+  add_directive "mod_use"
+    "Like #use, but wraps code in a module named after <string>"
+    (Directive_string (dir_mod_use std_out))
 
 (* Install, remove a printer *)
 
@@ -324,10 +337,13 @@ let dir_remove_printer ppf lid =
     end
   with Exit -> ()
 
-let _ = Hashtbl.add directive_table "install_printer"
-             (Directive_ident (dir_install_printer std_out))
-let _ = Hashtbl.add directive_table "remove_printer"
-             (Directive_ident (dir_remove_printer std_out))
+let _ =
+  add_directive "install_printer"
+    "Register function <ident> as a printer for its argument type"
+    (Directive_ident (dir_install_printer std_out))
+
+let _ = add_directive "remove_printer" "Unregisters a printer"
+    (Directive_ident (dir_remove_printer std_out))
 
 (* The trace *)
 
@@ -422,6 +438,39 @@ let trim_signature = function
            sg)
   | mty -> mty
 
+let dir_help ppf () =
+  pp_open_tbox ppf ();
+  fprintf ppf "Directive            ";
+  pp_set_tab ppf ();
+  fprintf ppf "Argument(s)      ";
+  pp_set_tab ppf ();
+  fprintf ppf "Description@\n@\n";
+  let directives =
+    List.sort
+      (fun (key1,_) (key2,_) -> compare key1 key2)
+      (Hashtbl.fold (fun key x res -> (key, x) :: res) directive_table [])
+  in
+  List.iter
+    (fun (key, (kind, desc)) ->
+      let kind_desc =
+        match kind with
+        | Directive_ident _ -> "<ident>"
+        | Directive_none _ -> " "
+        | Directive_int _ -> "<int>"
+        | Directive_bool _ -> "<bool>"
+        | Directive_string _ -> "<string>"
+      in
+      fprintf ppf "#%s" key;
+      pp_print_tbreak ppf 0 0;
+      fprintf ppf "%s" kind_desc;
+      pp_print_tbreak ppf 0 0;
+      fprintf ppf "%s@\n" desc;
+    )
+    directives;
+  pp_close_tbox ppf ();
+  fprintf ppf "@."
+[@@warning "-3"] (* Tabulation boxes are deprecated in 4.03+dev *)
+
 let show_prim to_sig ppf lid =
   let env = !Toploop.toplevel_env in
   let loc = Location.none in
@@ -445,26 +494,30 @@ let show_prim to_sig ppf lid =
 
 let all_show_funs = ref []
 
-let reg_show_prim name to_sig =
+let reg_show_prim name ~help to_sig =
   all_show_funs := to_sig :: !all_show_funs;
-  Hashtbl.add directive_table name (Directive_ident (show_prim to_sig std_out))
+  add_directive "show"
+    (Printf.sprintf
+      "Describe the %s with this name if it exists in the environment."
+      help)
+    (Directive_ident (show_prim to_sig std_out))
 
 let () =
-  reg_show_prim "show_val"
+  reg_show_prim "show_val" ~help:"value"
     (fun env loc id lid ->
        let path, desc = Typetexp.find_value env loc lid in
        [ Sig_value (id, desc) ]
     )
 
 let () =
-  reg_show_prim "show_type"
+  reg_show_prim "show_type" ~help:"type"
     (fun env loc id lid ->
        let path, desc = Typetexp.find_type env loc lid in
        [ Sig_type (id, desc, Trec_not) ]
     )
 
 let () =
-  reg_show_prim "show_exception"
+  reg_show_prim "show_exception" ~help:"exception"
     (fun env loc id lid ->
        let desc = Typetexp.find_constructor env loc lid in
        if not (Ctype.equal env true [desc.cstr_res] [Predef.type_exn]) then
@@ -486,29 +539,29 @@ let () =
     )
 
 let () =
-  reg_show_prim "show_module"
+  reg_show_prim "show_module" ~help:"module"
     (fun env loc id lid ->
        let path, md = Typetexp.find_module env loc lid in
        [ Sig_module (id, {md with md_type = trim_signature md.md_type},
                      Trec_not) ]
     )
 
 let () =
-  reg_show_prim "show_module_type"
+  reg_show_prim "show_module_type" ~help:"module type"
     (fun env loc id lid ->
        let path, desc = Typetexp.find_modtype env loc lid in
        [ Sig_modtype (id, desc) ]
     )
 
 let () =
-  reg_show_prim "show_class"
+  reg_show_prim "show_class" ~help:"class"
     (fun env loc id lid ->
        let path, desc = Typetexp.find_class env loc lid in
        [ Sig_class (id, desc, Trec_not) ]
     )
 
 let () =
-  reg_show_prim "show_class_type"
+  reg_show_prim "show_class_type" ~help:"class type"
     (fun env loc id lid ->
        let path, desc = Typetexp.find_class_type env loc lid in
        [ Sig_class_type (id, desc, Trec_not) ]
@@ -524,39 +577,47 @@ let show env loc id lid =
   if sg = [] then raise Not_found else sg
 
 let () =
-  Hashtbl.add directive_table "show" (Directive_ident (show_prim show std_out))
+  add_directive "show"
+    "Describe this name if it exists in the environment;\
+     see also #show_val, #show_type, #show_module etc."
+    (Directive_ident (show_prim show std_out))
 
 let _ =
-  Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
-  Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
-  Hashtbl.add directive_table
-    "untrace_all" (Directive_none (dir_untrace_all std_out));
+  add_directive "trace" "Trace calls to function <ident>"
+    (Directive_ident (dir_trace std_out));
+  add_directive "untrace" "Stop tracing function <ident>"
+    (Directive_ident (dir_untrace std_out));
+  add_directive "untrace_all" "Stop all function traces"
+    (Directive_none (dir_untrace_all std_out));
 
 (* Control the printing of values *)
 
-  Hashtbl.add directive_table "print_depth"
-             (Directive_int(fun n -> max_printer_depth := n));
-  Hashtbl.add directive_table "print_length"
-             (Directive_int(fun n -> max_printer_steps := n));
+  add_directive "print_depth" "Limit the depth of printed values to <int>"
+    (Directive_int(fun n -> max_printer_depth := n));
+  add_directive "print_length" "Limit the number of values printed to <int>"
+    (Directive_int(fun n -> max_printer_steps := n));
 
 (* Set various compiler flags *)
 
-  Hashtbl.add directive_table "labels"
+  add_directive "labels" "Ignore labels in function types (if true)"
              (Directive_bool(fun b -> Clflags.classic := not b));
 
-  Hashtbl.add directive_table "principal"
+  add_directive "principal" "Ensure that inferred types are principal (if true)"
              (Directive_bool(fun b -> Clflags.principal := b));
 
-  Hashtbl.add directive_table "rectypes"
+  add_directive "rectypes" "Allow arbitrary recursive types"
              (Directive_none(fun () -> Clflags.recursive_types := true));
 
-  Hashtbl.add directive_table "ppx"
+  add_directive "ppx" "Pass input phrases through a ppx preprocessor"
     (Directive_string(fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx));
 
-  Hashtbl.add directive_table "warnings"
+  add_directive "warnings" "Apply the warning filter <string>"
              (Directive_string (parse_warnings std_out false));
 
-  Hashtbl.add directive_table "warn_error"
+  add_directive "warn_error" "Swap listed items between warning and error"
              (Directive_string (parse_warnings std_out true));
 
+  add_directive "help" "This help screen"
+     (Directive_none (dir_help std_out));
+
   ()
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
@@ -224,7 +224,15 @@ let print_exception_outcome ppf exn =
 (* The table of toplevel directives.
    Filled by functions from module topdirs. *)
 
-let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
+let directive_table =
+  (Hashtbl.create 13 : (string, directive_fun * string) Hashtbl.t)
+
+let add_directive dir_name dir_descr dir_arg =
+  Hashtbl.add directive_table dir_name (dir_arg, dir_descr)
+
+let find_directive dir_name =
+  let (f, _) = Hashtbl.find directive_table dir_name in
+  f
 
 (* Execute a toplevel phrase *)
 
@@ -294,7 +302,7 @@ let execute_phrase print_outcome ppf phr =
       end
   | Ptop_dir(dir_name, dir_arg) ->
       let d =
-        try Some (Hashtbl.find directive_table dir_name)
+        try Some (find_directive dir_name)
         with Not_found -> None
       in
       begin match d with
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
@@ -40,8 +40,11 @@ type directive_fun =
    | Directive_ident of (Longident.t -> unit)
    | Directive_bool of (bool -> unit)
 
-val directive_table : (string, directive_fun) Hashtbl.t
-        (* Table of known directives, with their execution function *)
+val directive_table : (string, directive_fun * string) Hashtbl.t
+        (* Table of known directives, with their execution function and
+           description *)
+val add_directive : string -> string -> directive_fun -> unit
+        (* Add a directive to the table with a short description *)
 val toplevel_env : Env.t ref
         (* Typing environment for the toplevel *)
 val initialize_toplevel_env : unit -> unit
