#info directive

src/lib/config/ocp_index_off.ml

@@ -0,0 +1,6 @@
+let complete _input _names_of_module _global_names= function
+  | _-> None
+
+let add_directive _directive_table _render_out_phrase _print_error= ()
+
+let init_ocp_index ()= -1

src/lib/config/ocp_index_on.ml

@@ -0,0 +1,143 @@
+open LTerm_read_line
+open UTop_token
+
+module String_set = Set.Make(String)
+module String_map = Map.Make(String)
+
+let cmd_input_line cmd =
+  try
+    let ic = Unix.open_process_in (cmd ^ " 2>/dev/null") in
+    let r = input_line ic in
+    let r =
+      let len = String.length r in
+      if len>0 && r.[len - 1] = '\r' then String.sub r 0 (len-1) else r
+    in
+    match Unix.close_process_in ic with
+    | Unix.WEXITED 0 -> r
+    | _ -> failwith "cmd_input_line"
+  with
+  | End_of_file | Unix.Unix_error _ | Sys_error _ -> failwith "cmd_input_line"
+
+let complete input names_of_module global_names tokens=
+  if Sys.os_type = "Unix" then
+    match tokens with
+    | [(Symbol "#", _); (Lident "info", _); (String (tlen, false), loc)] ->
+      let prefix = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
+      begin match Longident.parse prefix with
+      | Longident.Ldot (lident, last_prefix) ->
+        let set = names_of_module lident in
+        let compls = lookup last_prefix (String_set.elements set) in
+        let start = loc.idx1 + 1 + (String.length prefix - String.length last_prefix) in
+        Some (start, List.map (fun w -> (w, "")) compls)
+      | _ ->
+        let set = global_names () in
+        let compls = lookup prefix (String_set.elements set) in
+        Some (loc.idx1 + 1, List.map (fun w -> (w, "")) compls)
+      end
+    | _-> None
+  else
+    None
+
+#if OCAML_VERSION >= (4, 04, 0)
+let lookup_type longident env = Env.lookup_type longident env
+#else
+let lookup_type id env= let path, _= Env.lookup_type id env in path
+#endif
+
+let req_query= ref stdout
+let rep_query= ref stdin
+
+let query_info render_out_phrase print_error sid =
+  let sid= String.trim sid in
+  let id  = Longident.parse sid in
+  let env = !Toploop.toplevel_env in
+  let from_type_desc = function
+    | Types.Tconstr (path, _, _) ->
+      let typ_decl = Env.find_type path env in
+      path, typ_decl
+    | _ -> assert false
+  in
+  let name=
+    try
+      let path = lookup_type id env in
+      Some (Path.name path)
+    with Not_found ->
+    try
+      let (path, _val_descr) = Env.lookup_value id env in
+      Some (Path.name path)
+    with Not_found ->
+    try
+      let lbl_desc = Env.lookup_label id env in
+      let (path, _ty_decl) = from_type_desc lbl_desc.Types.lbl_res.Types.desc in
+      Some (Path.name path)
+    with Not_found ->
+    try
+      let path = Env.lookup_module id env ~load:true in
+      Some (Path.name path)
+    with Not_found ->
+    try
+      let (path, _mty_decl) = Env.lookup_modtype id env in
+      Some (Path.name path)
+    with Not_found ->
+    try
+      let cstr_desc = Env.lookup_constructor id env in
+      match cstr_desc.Types.cstr_tag with
+      | _ ->
+        let (path, _ty_decl) = from_type_desc cstr_desc.Types.cstr_res.Types.desc in
+        Some (Path.name path)
+    with Not_found ->
+      None
+  in
+  let name= match name with Some name-> name | None-> sid in
+  let open Lwt in
+  output_string !req_query @@ name ^ "\n"; flush !req_query;
+  match input_value !rep_query with
+  | Some info->
+    Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term info)
+  | None->
+    Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> print_error term "Unknown info\n")
+
+let add_directive directive_table render_out_phrase print_error=
+  if Sys.os_type = "Unix" then
+    Hashtbl.add directive_table "info"
+      (Toploop.Directive_string (query_info render_out_phrase print_error))
+  else ()
+
+let child req_query rep_query=
+  let req_query= Unix.in_channel_of_descr req_query
+  and rep_query= Unix.out_channel_of_descr rep_query in
+  let index=
+    let ocaml_lib= try (cmd_input_line) "ocamlc -where" with _-> "" in
+    let opam_lib= try (cmd_input_line) "opam config var lib" with _-> "" in
+    LibIndex.load @@ LibIndex.Misc.unique_subdirs [ocaml_lib; opam_lib]
+  in
+  let query_info name=
+    (try
+      let info= LibIndex.Print.info ~color:false (LibIndex.get index name) in
+      output_value rep_query (Some info)
+    with Not_found->
+      output_value rep_query None);
+    flush rep_query;
+  in
+  let rec watching ()=
+    let query= input_line req_query in
+    query_info query;
+    watching ()
+  in
+  watching ()
+
+let init_ocp_index ()=
+  if Sys.os_type = "Unix" then
+    let r1, w1= Unix.pipe ()
+    and r2, w2= Unix.pipe () in
+    match Unix.fork () with
+    | 0->
+      let req_query= r1 and rep_query= w2
+      in child req_query rep_query
+    | child->
+      req_query:= Unix.out_channel_of_descr w1;
+      rep_query:= Unix.in_channel_of_descr r2;
+      child
+  else
+    -1
+

src/lib/dune

@@ -1,12 +1,15 @@
 (library
- (name uTop)
- (public_name utop)
- (wrapped false)
- (flags :standard -safe-string)
- (modes byte)
- (libraries compiler-libs.toplevel findlib.top lambda-term threads)
- (preprocess
-  (action
-   (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))))
+  (name uTop)
+  (public_name utop)
+  (wrapped false)
+  (flags :standard -safe-string)
+  (modes byte)
+  (libraries compiler-libs.toplevel findlib.top lambda-term threads
+    (select ocp_index_hook.ml from
+      (ocp-index.lib -> config/ocp_index_on.ml)
+      (!ocp-index.lib -> config/ocp_index_off.ml)))
+  (preprocess
+    (action
+      (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))))
 
 (ocamllex uTop_lexer)

src/lib/uTop_complete.ml

@@ -1002,77 +1002,82 @@ let complete ~phrase_terminator ~input =
         let result = lookup name list in
         (loc.idx2 - Zed_utf8.length name, List.map (function dir -> (dir, "")) result)
 
-    (* 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
-           | Some (Toploop.Directive_none _) -> [(phrase_terminator, "")]
-           | Some (Toploop.Directive_string _) -> [(" \"", "")]
-           | Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)]
-           | Some (Toploop.Directive_int _) -> []
-           | 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
-          | Some (Toploop.Directive_none _) ->
-              (0, [])
-          | Some (Toploop.Directive_string _) ->
-              (0, [])
-          | Some (Toploop.Directive_bool _) -> begin
-              match tokens with
-                | [(Lident id, { idx1 = start })] ->
-                    (start, lookup_assoc id [(true_name, phrase_terminator); (false_name, phrase_terminator)])
-                | _ ->
-                    (0, [])
-            end
-          | Some (Toploop.Directive_int _) ->
-              (0, [])
-          | Some (Toploop.Directive_ident _) -> begin
-              match parse_longident (List.rev tokens) with
-                | Some (Value, None, start, id) ->
-                    (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names ()))))
-                | Some (Value, Some longident, start, id) ->
-                    (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
-                | _ ->
-                    (0, [])
-            end
-          | None ->
-              (0, [])
-      end
-
-    (* Completion on identifiers. *)
-    | _ ->
-        match find_context tokens tokens with
-          | None ->
-              (0, [])
-          | Some [] ->
-              (0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names ()))))
-          | Some tokens ->
-              match parse_method tokens with
-                | Some (longident, meths, start, meth) ->
-                    (start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths)))
-                | None ->
-                    match parse_label tokens with
-                      | Some (Fun, longident, meths, Optional, start, label) ->
-                          (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_function longident meths))))
-                      | Some (Fun, longident, meths, Required, start, label) ->
-                          (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function longident meths)))
-                      | Some (New, longident, meths, Optional, start, label) ->
-                          (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_newclass longident))))
-                      | Some (New, longident, meths, Required, start, label) ->
-                          (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_newclass longident)))
-                      | None ->
-                          match parse_longident tokens with
-                            | None ->
-                                (0, [])
-                            | Some (Value, None, start, id) ->
-                                (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names ())))))
-                            | Some (Value, Some longident, start, id) ->
-                                (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
-                            | Some (Field, None, start, id) ->
-                                (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_fields ()))))
-                            | Some (Field, Some longident, start, id) ->
-                                (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))
+    | _-> match Ocp_index_hook.complete input names_of_module global_names tokens with
+      | Some r-> r
+      | None->
+        match tokens with
+
+        (* 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
+              | Some (Toploop.Directive_none _) -> [(phrase_terminator, "")]
+              | Some (Toploop.Directive_string _) -> [(" \"", "")]
+              | Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)]
+              | Some (Toploop.Directive_int _) -> []
+              | 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
+              | Some (Toploop.Directive_none _) ->
+                  (0, [])
+              | Some (Toploop.Directive_string _) ->
+                  (0, [])
+              | Some (Toploop.Directive_bool _) -> begin
+                  match tokens with
+                    | [(Lident id, { idx1 = start })] ->
+                        (start, lookup_assoc id [(true_name, phrase_terminator); (false_name, phrase_terminator)])
+                    | _ ->
+                        (0, [])
+                end
+              | Some (Toploop.Directive_int _) ->
+                  (0, [])
+              | Some (Toploop.Directive_ident _) -> begin
+                  match parse_longident (List.rev tokens) with
+                    | Some (Value, None, start, id) ->
+                        (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names ()))))
+                    | Some (Value, Some longident, start, id) ->
+                        (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
+                    | _ ->
+                        (0, [])
+                end
+              | None ->
+                  (0, [])
+          end
+
+        (* Completion on identifiers. *)
+        | _ ->
+            match find_context tokens tokens with
+              | None ->
+                  (0, [])
+              | Some [] ->
+                  (0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names ()))))
+              | Some tokens ->
+                  match parse_method tokens with
+                    | Some (longident, meths, start, meth) ->
+                        (start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths)))
+                    | None ->
+                        match parse_label tokens with
+                          | Some (Fun, longident, meths, Optional, start, label) ->
+                              (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_function longident meths))))
+                          | Some (Fun, longident, meths, Required, start, label) ->
+                              (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function longident meths)))
+                          | Some (New, longident, meths, Optional, start, label) ->
+                              (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_newclass longident))))
+                          | Some (New, longident, meths, Required, start, label) ->
+                              (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_newclass longident)))
+                          | None ->
+                              match parse_longident tokens with
+                                | None ->
+                                    (0, [])
+                                | Some (Value, None, start, id) ->
+                                    (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names ())))))
+                                | Some (Value, Some longident, start, id) ->
+                                    (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
+                                | Some (Field, None, start, id) ->
+                                    (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_fields ()))))
+                                | Some (Field, Some longident, start, id) ->
+                                    (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))
 
 let complete ~phrase_terminator ~input =
   try

src/lib/uTop_main.ml

@@ -1247,6 +1247,8 @@ let () =
   Hashtbl.add Toploop.directive_table "typeof"
     (Toploop.Directive_string typeof)
 
+let ()= Ocp_index_hook.add_directive Toploop.directive_table render_out_phrase print_error
+
 (* +-----------------------------------------------------------------+
    | Entry point                                                     |
    +-----------------------------------------------------------------+ *)
@@ -1498,7 +1500,13 @@ let main_internal ~initial_env =
     flush stderr;
     exit 2
 
-let main () = main_internal ~initial_env:None
+let main () =
+  let child_ocp_index= Ocp_index_hook.init_ocp_index () in
+  let children= [child_ocp_index] in
+  let children= List.filter (fun child-> child > 0) children in
+  Lwt_main.at_exit (fun ()->
+    List.iter (fun child-> Unix.kill child Sys.sigterm) children; Lwt.return ());
+  main_internal ~initial_env:None
 
 type value = V : string * _ -> value
 

utop.opam

@@ -18,6 +18,9 @@ depends: [
   "cppo" {build & >= "1.1.2"}
   "dune" {build}
 ]
+depopts: [
+  "ocp-index"
+]
 build: [
   ["dune" "subst"] {pinned}
   ["dune" "build" "-p" name "-j" jobs]