773 lines
30 KiB
OCaml
773 lines
30 KiB
OCaml
(*
|
|
* uTop_complete.ml
|
|
* ----------------
|
|
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
|
* Licence : BSD3
|
|
*
|
|
* This file is a part of utop.
|
|
*)
|
|
|
|
open Types
|
|
open LTerm_read_line
|
|
open UTop_token
|
|
|
|
module String_set = Set.Make(String)
|
|
module String_map = Map.Make(String)
|
|
|
|
let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.empty
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Utils |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* Transform a non-empty list of strings into a long-identifier. *)
|
|
let longident_of_list = function
|
|
| [] ->
|
|
invalid_arg "UTop_complete.longident_of_list"
|
|
| component :: rest ->
|
|
let rec loop acc = function
|
|
| [] -> acc
|
|
| component :: rest -> loop (Longident.Ldot(acc, component)) rest
|
|
in
|
|
loop (Longident.Lident component) rest
|
|
|
|
(* Check whether an identifier is a valid one. *)
|
|
let is_valid_identifier id =
|
|
id <> "" &&
|
|
(match id.[0] with
|
|
| 'A' .. 'Z' | 'a' .. 'z' | '_' -> true
|
|
| _ -> false)
|
|
|
|
let add id set = if is_valid_identifier id then String_set.add id set else set
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Parsing |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* The following functions takes a list of tokens in reverse order. *)
|
|
|
|
type value_or_field = Value | Field
|
|
(* Either a value, or a record field. *)
|
|
|
|
(* Parse something of the form [M1.M2. ... .Mn.id] or
|
|
[field.M1.M2. ... .Mn.id] *)
|
|
let parse_longident tokens =
|
|
let rec loop acc tokens =
|
|
match tokens with
|
|
| (Symbol, _, _, ".") :: (Uident, _, _, id) :: tokens ->
|
|
loop (id :: acc) tokens
|
|
| (Symbol, _, _, ".") :: (Lident, _, _, id) :: tokens ->
|
|
(Field,
|
|
match acc with
|
|
| [] -> None
|
|
| l -> Some (longident_of_list l))
|
|
| _ ->
|
|
(Value,
|
|
match acc with
|
|
| [] -> None
|
|
| l -> Some (longident_of_list l))
|
|
in
|
|
match tokens with
|
|
| ((Comment false | Doc false | String false | Quotation false), _, _, _) :: _ ->
|
|
(* An unterminated command, string, or quotation. *)
|
|
None
|
|
| ((Uident | Lident), start, _, id) :: tokens ->
|
|
(* An identifier. *)
|
|
let kind, path = loop [] tokens in
|
|
Some (kind, path, start, id)
|
|
| (Blanks, _, stop, _) :: tokens ->
|
|
(* Some blanks at the end. *)
|
|
let kind, path = loop [] tokens in
|
|
Some (kind, path, stop, "")
|
|
| (_, _, stop, _) :: _ ->
|
|
(* Otherwise complete after the last token. *)
|
|
let kind, path = loop [] tokens in
|
|
Some (kind, path, stop, "")
|
|
| [] ->
|
|
None
|
|
|
|
(* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp#m] *)
|
|
let parse_method tokens =
|
|
(* Collect [M1.M2. ... .Mn.id] and returns the corresponding
|
|
longidentifier. *)
|
|
let rec loop_uidents acc tokens =
|
|
match tokens with
|
|
| (Symbol, _, _, ".") :: (Uident, _, _, id) :: tokens ->
|
|
loop_uidents (id :: acc) tokens
|
|
| _ ->
|
|
longident_of_list acc
|
|
in
|
|
(* Collect [m1#m2# ... #mp] *)
|
|
let rec loop_methods acc tokens =
|
|
match tokens with
|
|
| (Lident, _, _, meth) :: (Symbol, _, _, "#") :: tokens ->
|
|
loop_methods (meth :: acc) tokens
|
|
| (Lident, _, _, id) :: tokens ->
|
|
Some (loop_uidents [id] tokens, acc)
|
|
| _ ->
|
|
None
|
|
in
|
|
match tokens with
|
|
| (Lident, start, _, meth) :: (Symbol, _, _, "#") :: tokens -> begin
|
|
match loop_methods [] tokens with
|
|
| None -> None
|
|
| Some (path, meths) -> Some (path, meths, start, meth)
|
|
end
|
|
| (Symbol, _, stop, "#") :: tokens
|
|
| (Blanks, _, stop, _) :: (Symbol, _, _, "#") :: tokens -> begin
|
|
match loop_methods [] tokens with
|
|
| None -> None
|
|
| Some (path, meths) -> Some (path, meths, stop, "")
|
|
end
|
|
| _ ->
|
|
None
|
|
|
|
type label_kind = Required | Optional
|
|
(* Kind of labels: required or optional. *)
|
|
|
|
type fun_or_new = Fun | New
|
|
(* Either a function application, either an object creation. *)
|
|
|
|
(* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp expr1 ... exprq ~label]
|
|
or [new M1.M2. ... .Mn.id expr1 ... exprq ~label] *)
|
|
let parse_label tokens =
|
|
(* Collect [M1.M2. ... .Mn] *)
|
|
let rec loop_uidents acc_uidents acc_methods tokens =
|
|
match tokens with
|
|
| (Lident, _, _, "new") :: _ ->
|
|
Some (New, longident_of_list acc_uidents, acc_methods)
|
|
| ((Lident | Uident), _, _, id) :: _ when String_set.mem id !UTop.keywords ->
|
|
Some (Fun, longident_of_list acc_uidents, acc_methods)
|
|
| (Symbol, _, _, ".") :: (Uident, _, _, id) :: tokens ->
|
|
loop_uidents (id :: acc_uidents) acc_methods tokens
|
|
| (Symbol, _, _, ("~" | "?" | ":" | "." | "#")) :: tokens ->
|
|
search tokens
|
|
| (Symbol, _, _, ")") :: tokens ->
|
|
skip tokens "(" []
|
|
| (Symbol, _, _, "}") :: tokens ->
|
|
skip tokens "{" []
|
|
| (Symbol, _, _, "]") :: tokens ->
|
|
skip tokens "[" []
|
|
| (Symbol, _, _, _) :: _ ->
|
|
Some (Fun, longident_of_list acc_uidents, acc_methods)
|
|
| _ :: tokens ->
|
|
search tokens
|
|
| [] ->
|
|
Some (Fun, longident_of_list acc_uidents, acc_methods)
|
|
and loop_methods acc tokens =
|
|
match tokens with
|
|
| ((Lident | Uident), _, _, id) :: _ when String_set.mem id !UTop.keywords ->
|
|
None
|
|
| (Symbol, _, _, ("~" | "?" | ":" | "." | "#")) :: tokens ->
|
|
search tokens
|
|
| (Symbol, _, _, ")") :: tokens ->
|
|
skip tokens "(" []
|
|
| (Symbol, _, _, "}") :: tokens ->
|
|
skip tokens "{" []
|
|
| (Symbol, _, _, "]") :: tokens ->
|
|
skip tokens "[" []
|
|
| (Symbol, _, _, _) :: _ ->
|
|
None
|
|
| (Lident, _, _, id) :: (Symbol, _, _, "#") :: tokens ->
|
|
loop_methods (id :: acc) tokens
|
|
| (Lident, _, _, id) :: tokens ->
|
|
loop_uidents [id] acc tokens
|
|
| _ :: tokens ->
|
|
search tokens
|
|
| [] ->
|
|
None
|
|
and search tokens =
|
|
match tokens with
|
|
| ((Lident | Uident), _, _, id) :: _ when String_set.mem id !UTop.keywords ->
|
|
None
|
|
| (Symbol, _, _, ("~" | "?" | ":" | "." | "#")) :: tokens ->
|
|
search tokens
|
|
| (Symbol, _, _, ")") :: tokens ->
|
|
skip tokens "(" []
|
|
| (Symbol, _, _, "}") :: tokens ->
|
|
skip tokens "{" []
|
|
| (Symbol, _, _, "]") :: tokens ->
|
|
skip tokens "[" []
|
|
| (Symbol, _, _, _) :: _ ->
|
|
None
|
|
| (Lident, _, _, id) :: (Symbol, _, _, "#") :: tokens ->
|
|
loop_methods [id] tokens
|
|
| (Lident, _, _, id) :: tokens ->
|
|
loop_uidents [id] [] tokens
|
|
| _ :: tokens ->
|
|
search tokens
|
|
| [] ->
|
|
None
|
|
and skip tokens top stack =
|
|
match tokens with
|
|
| (Symbol, _, _, symbol) :: tokens when symbol = top -> begin
|
|
match stack with
|
|
| [] -> search tokens
|
|
| top :: stack -> skip tokens top stack
|
|
end
|
|
| (Symbol, _, _, ")") :: tokens ->
|
|
skip tokens "(" (top :: stack)
|
|
| (Symbol, _, _, "}") :: tokens ->
|
|
skip tokens "{" (top :: stack)
|
|
| (Symbol, _, _, "]") :: tokens ->
|
|
skip tokens "[" (top :: stack)
|
|
| _ :: tokens ->
|
|
skip tokens top stack
|
|
| [] ->
|
|
None
|
|
in
|
|
match tokens with
|
|
| (Lident, start, _, label) :: (Symbol, _, _, "~") :: tokens -> begin
|
|
match search tokens with
|
|
| None -> None
|
|
| Some (kind, id, meths) -> Some (kind, id, meths, Required, start, label)
|
|
end
|
|
| (Symbol, _, stop, "~") :: tokens -> begin
|
|
match search tokens with
|
|
| None -> None
|
|
| Some (kind, id, meths) -> Some (kind, id, meths, Required, stop, "")
|
|
end
|
|
| (Lident, start, _, label) :: (Symbol, _, _, "?") :: tokens -> begin
|
|
match search tokens with
|
|
| None -> None
|
|
| Some (kind, id, meths) -> Some (kind, id, meths, Optional, start, label)
|
|
end
|
|
| (Symbol, _, stop, "?") :: tokens -> begin
|
|
match search tokens with
|
|
| None -> None
|
|
| Some (kind, id, meths) -> Some (kind, id, meths, Optional, stop, "")
|
|
end
|
|
| _ ->
|
|
None
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Directive listing |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let list_directives () =
|
|
String_map.bindings
|
|
(Hashtbl.fold
|
|
(fun dir kind map ->
|
|
let suffix =
|
|
match kind with
|
|
| Toploop.Directive_none _ -> ";;"
|
|
| Toploop.Directive_string _ -> " \""
|
|
| Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _ -> " "
|
|
in
|
|
String_map.add dir suffix map)
|
|
Toploop.directive_table
|
|
String_map.empty)
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| File listing |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
type file_kind = Directory | File
|
|
|
|
let basename name =
|
|
let name' = Filename.basename name in
|
|
if name' = "." && not (Zed_utf8.ends_with name ".") then
|
|
""
|
|
else
|
|
name'
|
|
|
|
let add_files filter acc dir =
|
|
Array.fold_left
|
|
(fun map name ->
|
|
let absolute_name = Filename.concat dir name in
|
|
if try Sys.is_directory absolute_name with Sys_error _ -> false then
|
|
String_map.add (Filename.concat name "") Directory map
|
|
else if filter name then
|
|
String_map.add name File map
|
|
else
|
|
map)
|
|
acc
|
|
(try Sys.readdir dir with Sys_error _ -> [||])
|
|
|
|
let list_directories dir =
|
|
String_set.elements
|
|
(Array.fold_left
|
|
(fun set name ->
|
|
let absolute_name = Filename.concat dir name in
|
|
if try Sys.is_directory absolute_name with Sys_error _ -> false then
|
|
String_set.add name set
|
|
else
|
|
set)
|
|
String_set.empty
|
|
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Names listing |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
module Path_map = Map.Make(struct type t = Path.t let compare = compare end)
|
|
module Longident_map = Map.Make(struct type t = Longident.t let compare = compare end)
|
|
|
|
(* All names accessible without a path. *)
|
|
let global_names = ref (lazy String_set.empty)
|
|
|
|
(* All names accessible with a path, by path. *)
|
|
let local_names_by_path = ref Path_map.empty
|
|
|
|
(* All names accessible with a path, by long identifier. *)
|
|
let local_names_by_longident = ref Longident_map.empty
|
|
|
|
(* All record fields accessible without a path. *)
|
|
let global_fields = ref (lazy String_set.empty)
|
|
|
|
(* All record fields accessible with a path, by path. *)
|
|
let local_fields_by_path = ref Path_map.empty
|
|
|
|
(* All record fields accessible with a path, by long identifier. *)
|
|
let local_fields_by_longident = ref Longident_map.empty
|
|
|
|
(* Returns [acc] plus all modules from [dir]. *)
|
|
let add_modules_from_directory acc dir =
|
|
Array.fold_left
|
|
(fun acc fname ->
|
|
if Filename.check_suffix fname ".cmi" then
|
|
String_set.add (String.capitalize (Filename.chop_suffix fname ".cmi")) acc
|
|
else
|
|
acc)
|
|
acc
|
|
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
|
|
|
|
let add_fields_of_type decl acc =
|
|
match decl.type_kind with
|
|
| Type_variant constructors ->
|
|
acc
|
|
| Type_record(fields, _) ->
|
|
List.fold_left (fun acc (name, _, _) -> add name acc) acc fields
|
|
| Type_abstract ->
|
|
acc
|
|
|
|
let add_names_of_type decl acc =
|
|
match decl.type_kind with
|
|
| Type_variant constructors ->
|
|
List.fold_left (fun acc (name, _) -> add name acc) acc constructors
|
|
| Type_record(fields, _) ->
|
|
List.fold_left (fun acc (name, _, _) -> add name acc) acc fields
|
|
| Type_abstract ->
|
|
acc
|
|
|
|
let rec names_of_module_type = function
|
|
| Tmty_signature decls ->
|
|
List.fold_left
|
|
(fun acc decl -> match decl with
|
|
| Tsig_value(id, _)
|
|
| Tsig_exception(id, _)
|
|
| Tsig_module(id, _, _)
|
|
| Tsig_modtype(id, _)
|
|
| Tsig_class(id, _, _)
|
|
| Tsig_cltype(id, _, _) ->
|
|
add (Ident.name id) acc
|
|
| Tsig_type(id, decl, _) ->
|
|
add_names_of_type decl (add (Ident.name id) acc))
|
|
String_set.empty decls
|
|
| Tmty_ident path -> begin
|
|
match try Some (Env.find_modtype path !Toploop.toplevel_env) with Not_found -> None with
|
|
| Some Tmodtype_abstract -> String_set.empty
|
|
| Some Tmodtype_manifest module_type -> names_of_module_type module_type
|
|
| None -> String_set.empty
|
|
end
|
|
| _ ->
|
|
String_set.empty
|
|
|
|
let rec fields_of_module_type = function
|
|
| Tmty_signature decls ->
|
|
List.fold_left
|
|
(fun acc decl -> match decl with
|
|
| Tsig_value(id, _)
|
|
| Tsig_exception(id, _)
|
|
| Tsig_module(id, _, _)
|
|
| Tsig_modtype(id, _)
|
|
| Tsig_class(id, _, _)
|
|
| Tsig_cltype(id, _, _) ->
|
|
acc
|
|
| Tsig_type(id, decl, _) ->
|
|
add_fields_of_type decl acc)
|
|
String_set.empty decls
|
|
| Tmty_ident path -> begin
|
|
match try Some (Env.find_modtype path !Toploop.toplevel_env) with Not_found -> None with
|
|
| Some Tmodtype_abstract -> String_set.empty
|
|
| Some Tmodtype_manifest module_type -> fields_of_module_type module_type
|
|
| None -> String_set.empty
|
|
end
|
|
| _ ->
|
|
String_set.empty
|
|
|
|
let names_of_module longident =
|
|
try
|
|
Longident_map.find longident !local_names_by_longident
|
|
with Not_found ->
|
|
match try Some (Env.lookup_module longident !Toploop.toplevel_env) with Not_found -> None with
|
|
| Some(path, module_type) ->
|
|
let names = names_of_module_type module_type in
|
|
local_names_by_path := Path_map.add path names !local_names_by_path;
|
|
local_names_by_longident := Longident_map.add longident names !local_names_by_longident;
|
|
names
|
|
| None ->
|
|
local_names_by_longident := Longident_map.add longident String_set.empty !local_names_by_longident;
|
|
String_set.empty
|
|
|
|
let fields_of_module longident =
|
|
try
|
|
Longident_map.find longident !local_fields_by_longident
|
|
with Not_found ->
|
|
match try Some (Env.lookup_module longident !Toploop.toplevel_env) with Not_found -> None with
|
|
| Some(path, module_type) ->
|
|
let fields = fields_of_module_type module_type in
|
|
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
|
|
local_fields_by_longident := Longident_map.add longident fields !local_fields_by_longident;
|
|
fields
|
|
| None ->
|
|
local_fields_by_longident := Longident_map.add longident String_set.empty !local_fields_by_longident;
|
|
String_set.empty
|
|
|
|
let list_global_names () =
|
|
let rec loop acc = function
|
|
| Env.Env_empty -> acc
|
|
| Env.Env_value(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_type(summary, id, decl) ->
|
|
loop (add_names_of_type decl (add (Ident.name id) acc)) summary
|
|
| Env.Env_exception(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_module(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_modtype(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_class(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_cltype(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_open(summary, path) ->
|
|
match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with
|
|
| Some names ->
|
|
loop (String_set.union acc names) summary
|
|
| None ->
|
|
match try Some (Env.find_module path !Toploop.toplevel_env) with Not_found -> None with
|
|
| Some module_type ->
|
|
let names = names_of_module_type module_type in
|
|
local_names_by_path := Path_map.add path names !local_names_by_path;
|
|
loop (String_set.union acc names) summary
|
|
| None ->
|
|
local_names_by_path := Path_map.add path String_set.empty !local_names_by_path;
|
|
loop acc summary
|
|
in
|
|
(* Add names of the environment: *)
|
|
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
|
|
(* Add accessible modules: *)
|
|
List.fold_left add_modules_from_directory acc !Config.load_path
|
|
|
|
let list_global_fields () =
|
|
let rec loop acc = function
|
|
| Env.Env_empty -> acc
|
|
| Env.Env_value(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_type(summary, id, decl) ->
|
|
loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
|
|
| Env.Env_exception(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_module(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_modtype(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_class(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_cltype(summary, id, _) ->
|
|
loop (add (Ident.name id) acc) summary
|
|
| Env.Env_open(summary, path) ->
|
|
match try Some (Path_map.find path !local_fields_by_path) with Not_found -> None with
|
|
| Some fields ->
|
|
loop (String_set.union acc fields) summary
|
|
| None ->
|
|
match try Some (Env.find_module path !Toploop.toplevel_env) with Not_found -> None with
|
|
| Some module_type ->
|
|
let fields = fields_of_module_type module_type in
|
|
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
|
|
loop (String_set.union acc fields) summary
|
|
| None ->
|
|
local_fields_by_path := Path_map.add path String_set.empty !local_fields_by_path;
|
|
loop acc summary
|
|
in
|
|
(* Add fields of the environment: *)
|
|
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
|
|
(* Add accessible modules: *)
|
|
List.fold_left add_modules_from_directory acc !Config.load_path
|
|
|
|
let reset () =
|
|
global_names := Lazy.lazy_from_fun list_global_names;
|
|
local_names_by_path := Path_map.empty;
|
|
local_names_by_longident := Longident_map.empty;
|
|
global_fields := Lazy.lazy_from_fun list_global_fields;
|
|
local_fields_by_path := Path_map.empty;
|
|
local_fields_by_longident := Longident_map.empty
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Listing methods |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let rec find_method meth type_expr =
|
|
match type_expr.desc with
|
|
| Tlink type_expr ->
|
|
find_method meth type_expr
|
|
| Tobject (type_expr, _) ->
|
|
find_method meth type_expr
|
|
| Tfield (name, _, type_expr, rest) ->
|
|
if name = meth then
|
|
Some type_expr
|
|
else
|
|
find_method meth rest
|
|
| Tpoly (type_expr, _) ->
|
|
find_method meth type_expr
|
|
| Tconstr (path, _, _) -> begin
|
|
match try Some (Env.find_type path !Toploop.toplevel_env) with Not_found -> None with
|
|
| None
|
|
| Some { type_manifest = None } ->
|
|
None
|
|
| Some { type_manifest = Some type_expr } ->
|
|
find_method meth type_expr
|
|
end
|
|
| _ ->
|
|
None
|
|
|
|
let rec methods_of_type acc type_expr =
|
|
match type_expr.desc with
|
|
| Tlink type_expr ->
|
|
methods_of_type acc type_expr
|
|
| Tobject (type_expr, _) ->
|
|
methods_of_type acc type_expr
|
|
| Tfield (name, _, _, rest) ->
|
|
methods_of_type (add name acc) rest
|
|
| Tpoly (type_expr, _) ->
|
|
methods_of_type acc type_expr
|
|
| Tconstr (path, _, _) -> begin
|
|
match try Some (Env.find_type path !Toploop.toplevel_env) with Not_found -> None with
|
|
| None
|
|
| Some { type_manifest = None } ->
|
|
acc
|
|
| Some { type_manifest = Some type_expr } ->
|
|
methods_of_type acc type_expr
|
|
end
|
|
| _ ->
|
|
acc
|
|
|
|
let rec find_object meths type_expr =
|
|
match meths with
|
|
| [] ->
|
|
Some type_expr
|
|
| meth :: meths ->
|
|
match find_method meth type_expr with
|
|
| Some type_expr ->
|
|
find_object meths type_expr
|
|
| None ->
|
|
None
|
|
|
|
let methods_of_object longident meths =
|
|
match try Some (Env.lookup_value longident !Toploop.toplevel_env) with Not_found -> None with
|
|
| None ->
|
|
[]
|
|
| Some (path, { val_type = type_expr }) ->
|
|
match find_object meths type_expr with
|
|
| None ->
|
|
[]
|
|
| Some type_expr ->
|
|
String_set.elements (methods_of_type String_set.empty type_expr)
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Listing labels |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let rec labels_of_type acc type_expr =
|
|
match type_expr.desc with
|
|
| Tlink te ->
|
|
labels_of_type acc te
|
|
| Tpoly (te, _) ->
|
|
labels_of_type acc te
|
|
| Tarrow(label, _, te, _) ->
|
|
if label = "" then
|
|
labels_of_type acc te
|
|
else if label.[0] = '?' then
|
|
labels_of_type (String_map.add (String.sub label 1 (String.length label - 1)) Optional acc) te
|
|
else
|
|
labels_of_type (String_map.add label Required acc) te
|
|
| Tconstr(path, _, _) -> begin
|
|
match try Some (Env.find_type path !Toploop.toplevel_env) with Not_found -> None with
|
|
| None
|
|
| Some { type_manifest = None } ->
|
|
String_map.bindings acc
|
|
| Some { type_manifest = Some type_expr } ->
|
|
labels_of_type acc type_expr
|
|
end
|
|
| _ ->
|
|
String_map.bindings acc
|
|
|
|
let labels_of_function longident meths =
|
|
match try Some (Env.lookup_value longident !Toploop.toplevel_env) with Not_found -> None with
|
|
| None ->
|
|
[]
|
|
| Some (path, { val_type = type_expr }) ->
|
|
match find_object meths type_expr with
|
|
| None ->
|
|
[]
|
|
| Some type_expr ->
|
|
labels_of_type String_map.empty type_expr
|
|
|
|
let labels_of_newclass longident =
|
|
match try Some (Env.lookup_class longident !Toploop.toplevel_env) with Not_found -> None with
|
|
| None ->
|
|
[]
|
|
| Some (path, { cty_new = None }) ->
|
|
[]
|
|
| Some (path, { cty_new = Some type_expr }) ->
|
|
labels_of_type String_map.empty type_expr
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Filtering |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* Filter blanks and comments except for the last token. *)
|
|
let rec filter tokens =
|
|
match tokens with
|
|
| [] -> []
|
|
| [((Blanks | Comment true | Doc true), start, stop, src)] -> [(Blanks, start, stop, src)]
|
|
| ((Blanks | Comment true | Doc true), _, _, _) :: rest -> filter rest
|
|
| x :: rest -> x :: filter rest
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Completion |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let complete str =
|
|
let tokens = UTop_lexer.lex_string str in
|
|
(* Filter blanks and comments. *)
|
|
let tokens = filter tokens in
|
|
match tokens with
|
|
|
|
(* Completion on directive names. *)
|
|
| [(Symbol, _, stop, "#")]
|
|
| [(Symbol, _, _, "#"); (Blanks, _, stop, _)] ->
|
|
(stop, list_directives ())
|
|
| [(Symbol, _, _, "#"); ((Lident | Uident), start, _, src)] ->
|
|
(start, lookup_assoc src (list_directives ()))
|
|
|
|
(* Complete with ";;" when possible. *)
|
|
| [(Symbol, _, _, "#"); ((Lident | Uident), _, _, _); (String true, _, stop, _)]
|
|
| [(Symbol, _, _, "#"); ((Lident | Uident), _, _, _); (String true, _, _, _); (Blanks, _, stop, _)] ->
|
|
(stop, [(";;", "")])
|
|
| [(Symbol, _, _, "#"); ((Lident | Uident), _, _, _); (String true, _, _, _); (Symbol, start, _, ";")] ->
|
|
(start, [(";;", "")])
|
|
|
|
(* Completion on #require. *)
|
|
| [(Symbol, _, _, "#"); (Lident, _, _, "require"); (String false, start, stop, str)] ->
|
|
let pkg = String.sub str 1 (String.length str - 1) in
|
|
let pkgs = lookup pkg (Fl_package_base.list_packages ()) in
|
|
(start + 1, List.map (fun pkg -> (pkg, "\";;")) (List.sort compare pkgs))
|
|
|
|
(* Completion on #load. *)
|
|
| [(Symbol, _, _, "#"); (Lident, _, _, "load"); (String false, start, stop, str)] ->
|
|
let file = String.sub str 1 (String.length str - 1) in
|
|
let filter name = Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo" in
|
|
let map =
|
|
if Filename.is_relative file then
|
|
let dir = Filename.dirname file in
|
|
List.fold_left
|
|
(fun acc d -> add_files filter acc (Filename.concat d dir))
|
|
String_map.empty
|
|
(Filename.current_dir_name :: !Config.load_path)
|
|
else
|
|
add_files filter String_map.empty (Filename.dirname file)
|
|
in
|
|
let list = String_map.bindings map in
|
|
let name = basename file in
|
|
let result = lookup_assoc name list in
|
|
(stop - Zed_utf8.length name,
|
|
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\";;")) result)
|
|
|
|
(* Completion on #use. *)
|
|
| [(Symbol, _, _, "#"); (Lident, _, _, "use"); (String false, start, stop, str)] ->
|
|
let file = String.sub str 1 (String.length str - 1) in
|
|
let filter name =
|
|
match try Some (String.rindex name '.') with Not_found -> None with
|
|
| None ->
|
|
true
|
|
| Some idx ->
|
|
let ext = String.sub name (idx + 1) (String.length name - (idx + 1)) in
|
|
ext = "ml"
|
|
in
|
|
let map =
|
|
if Filename.is_relative file then
|
|
let dir = Filename.dirname file in
|
|
List.fold_left
|
|
(fun acc d -> add_files filter acc (Filename.concat d dir))
|
|
String_map.empty
|
|
(Filename.current_dir_name :: !Config.load_path)
|
|
else
|
|
add_files filter String_map.empty (Filename.dirname file)
|
|
in
|
|
let list = String_map.bindings map in
|
|
let name = basename file in
|
|
let result = lookup_assoc name list in
|
|
(stop - Zed_utf8.length name,
|
|
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\";;")) result)
|
|
|
|
(* Completion on #directory and #cd. *)
|
|
| [(Symbol, _, _, "#"); (Lident, _, _, ("cd" | "directory")); (String false, start, stop, str)] ->
|
|
let file = String.sub str 1 (String.length str - 1) in
|
|
let list = list_directories (Filename.dirname file) in
|
|
let name = basename file in
|
|
let result = lookup name list in
|
|
(stop - Zed_utf8.length name, List.map (function dir -> (dir, "")) result)
|
|
|
|
(* Generic completion on directives. *)
|
|
| [(Symbol, _, _, "#"); ((Lident | Uident), _, _, dir); (Blanks, _, stop, _)] ->
|
|
(stop,
|
|
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
|
|
| Some (Toploop.Directive_none _) -> [(";;", "")]
|
|
| Some (Toploop.Directive_string _) -> [(" \"", "")]
|
|
| Some (Toploop.Directive_bool _) -> [("true", ";;"); ("false", ";;")]
|
|
| Some (Toploop.Directive_int _) -> []
|
|
| Some (Toploop.Directive_ident _) -> []
|
|
| None -> [])
|
|
| [(Symbol, _, _, "#"); ((Lident | Uident), _, _, dir); ((Lident | Uident), start, _, id)] ->
|
|
(start,
|
|
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
|
|
| Some (Toploop.Directive_none _) -> []
|
|
| Some (Toploop.Directive_string _) -> []
|
|
| Some (Toploop.Directive_bool _) -> lookup_assoc id [("true", ";;"); ("false", ";;")]
|
|
| Some (Toploop.Directive_int _) -> []
|
|
| Some (Toploop.Directive_ident _) -> []
|
|
| None -> [])
|
|
|
|
(* Completion on identifiers. *)
|
|
| [] ->
|
|
(0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (Lazy.force !global_names))))
|
|
| _ ->
|
|
let tokens = List.rev tokens in
|
|
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 (Lazy.force !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 (Lazy.force !global_fields))))
|
|
| Some (Field, Some longident, start, id) ->
|
|
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))
|