diff --git a/src/lib/config/ocp_index_off.ml b/src/lib/config/ocp_index_off.ml new file mode 100644 index 00000000..c5416a3f --- /dev/null +++ b/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 diff --git a/src/lib/config/ocp_index_on.ml b/src/lib/config/ocp_index_on.ml new file mode 100644 index 00000000..5cfb251d --- /dev/null +++ b/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 + diff --git a/src/lib/dune b/src/lib/dune index 316a5582..431e18dd 100644 --- a/src/lib/dune +++ b/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) diff --git a/src/lib/uTop_complete.ml b/src/lib/uTop_complete.ml index 86b7b39d..eb72816b 100644 --- a/src/lib/uTop_complete.ml +++ b/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 diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index 11f361ea..87dc83c4 100644 --- a/src/lib/uTop_main.ml +++ b/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 diff --git a/utop.opam b/utop.opam index 53f15a8e..3b98f25a 100644 --- a/utop.opam +++ b/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]