haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

refactoring 

Ignore-this: 33a617ed993d635789e8708aaa18f1d5

darcs-hash:20110730223055-c41ad-74657407a65b35358b87eec1aef3dfa91dfe2726
This commit is contained in:
Jeremie Dimino 2011-07-31 00:30:55 +02:00
parent 493a98fd17
commit 4e2a46ac0d
1 changed files with 410 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

700
src/uTop_complete.ml
View File

@ -20,22 +20,231 @@ let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.
| Utils | | Utils |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
let longident_of_list l = (* Transform a non-empty list of strings into a long-identifier. *)
match l with let longident_of_list = function
| [] -> | [] ->
invalid_arg "UTop_complete.longident_of_list" invalid_arg "UTop_complete.longident_of_list"
| component :: rest -> | component :: rest ->
let rec loop acc = function let rec loop acc = function
| [] -> acc | [] -> acc
| component :: rest -> loop (Longident.Ldot(acc, component)) rest | component :: rest -> loop (Longident.Ldot(acc, component)) rest
in in
loop (Longident.Lident component) rest 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
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Directives | | Parsing |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
let get_directives () = (* 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 String_map.bindings
(Hashtbl.fold (Hashtbl.fold
(fun dir kind map -> (fun dir kind map ->
@ -50,7 +259,7 @@ let get_directives () =
String_map.empty) String_map.empty)
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Files | | File listing |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
type file_kind = Directory | File type file_kind = Directory | File
@ -88,64 +297,40 @@ let list_directories dir =
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||])) (try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Identifiers | | Names listing |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
type path_kind = Value | Record 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)
let rec get_path acc tokens = (* All names accessible without a path. *)
match tokens with let global_names = ref (lazy String_set.empty)
| (Symbol, _, _, ".") :: (Uident, _, _, id) :: tokens ->
get_path (id :: acc) tokens
| (Symbol, _, _, ".") :: (Lident, _, _, id) :: tokens ->
(Record, acc)
| _ ->
(Value, acc)
let rec get_ident tokens = (* All names accessible with a path, by path. *)
match tokens with let local_names_by_path = ref Path_map.empty
| ((Comment false | Doc false | String false | Quotation false), _, _, _) :: _ ->
None
| ((Uident | Lident), start, _, id) :: tokens ->
let kind, path = get_path [] tokens in
Some (kind, path, id, start)
| (Blanks, _, stop, _) :: tokens ->
let kind, path = get_path [] tokens in
Some (kind, path, "", stop)
| (_, _, stop, _) :: _ ->
let kind, path = get_path [] tokens in
Some (kind, path, "", stop)
| [] ->
None
type path = (* All names accessible with a path, by long identifier. *)
| Path of Path.t let local_names_by_longident = ref Longident_map.empty
| Longident of Longident.t
module Path_map = Map.Make(struct type t = path let compare = compare end) (* All record fields accessible without a path. *)
let global_fields = ref (lazy String_set.empty)
let global_env = ref (lazy (raise Exit)) (* All record fields accessible with a path, by path. *)
let local_envs = ref Path_map.empty let local_fields_by_path = ref Path_map.empty
let global_fields = ref (lazy (raise Exit))
let local_fields = ref Path_map.empty
(* Returns [acc] plus all modules of [dir] *) (* 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 = let add_modules_from_directory acc dir =
let acc = ref acc in Array.fold_left
Array.iter (fun acc fname ->
(fun fname ->
if Filename.check_suffix fname ".cmi" then if Filename.check_suffix fname ".cmi" then
acc := String_set.add (String.capitalize (Filename.chop_suffix fname ".cmi")) !acc) String_set.add (String.capitalize (Filename.chop_suffix fname ".cmi")) acc
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir)); else
!acc acc)
acc
let valid id = (Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
id <> "" &&
(match id.[0] with
| 'A' .. 'Z' | 'a' .. 'z' | '_' -> true
| _ -> false)
let add id set = if valid id then String_set.add id set else set
let add_fields_of_type decl acc = let add_fields_of_type decl acc =
match decl.type_kind with match decl.type_kind with
@ -165,7 +350,7 @@ let add_names_of_type decl acc =
| Type_abstract -> | Type_abstract ->
acc acc
let rec get_names_of_module_type = function let rec names_of_module_type = function
| Tmty_signature decls -> | Tmty_signature decls ->
List.fold_left List.fold_left
(fun acc decl -> match decl with (fun acc decl -> match decl with
@ -182,13 +367,13 @@ let rec get_names_of_module_type = function
| Tmty_ident path -> begin | Tmty_ident path -> begin
match try Some (Env.find_modtype path !Toploop.toplevel_env) with Not_found -> None with match try Some (Env.find_modtype path !Toploop.toplevel_env) with Not_found -> None with
| Some Tmodtype_abstract -> String_set.empty | Some Tmodtype_abstract -> String_set.empty
| Some Tmodtype_manifest module_type -> get_names_of_module_type module_type | Some Tmodtype_manifest module_type -> names_of_module_type module_type
| None -> String_set.empty | None -> String_set.empty
end end
| _ -> | _ ->
String_set.empty String_set.empty
let rec get_fields_of_module_type = function let rec fields_of_module_type = function
| Tmty_signature decls -> | Tmty_signature decls ->
List.fold_left List.fold_left
(fun acc decl -> match decl with (fun acc decl -> match decl with
@ -205,86 +390,106 @@ let rec get_fields_of_module_type = function
| Tmty_ident path -> begin | Tmty_ident path -> begin
match try Some (Env.find_modtype path !Toploop.toplevel_env) with Not_found -> None with match try Some (Env.find_modtype path !Toploop.toplevel_env) with Not_found -> None with
| Some Tmodtype_abstract -> String_set.empty | Some Tmodtype_abstract -> String_set.empty
| Some Tmodtype_manifest module_type -> get_fields_of_module_type module_type | Some Tmodtype_manifest module_type -> fields_of_module_type module_type
| None -> String_set.empty | None -> String_set.empty
end end
| _ -> | _ ->
String_set.empty String_set.empty
(* List all names of the module with path [path] *) let names_of_module longident =
let get_names_of_module path =
match
try
match path with
| Path path ->
Some (Env.find_module path !Toploop.toplevel_env)
| Longident ident ->
Some (snd (Env.lookup_module ident !Toploop.toplevel_env))
with Not_found ->
None
with
| Some module_type -> get_names_of_module_type module_type
| None -> String_set.empty
let get_fields_of_module path =
match
try
match path with
| Path path ->
Some (Env.find_module path !Toploop.toplevel_env)
| Longident ident ->
Some (snd (Env.lookup_module ident !Toploop.toplevel_env))
with Not_found ->
None
with
| Some module_type -> get_fields_of_module_type module_type
| None -> String_set.empty
let names_of_module path =
try try
Path_map.find path !local_envs Longident_map.find longident !local_names_by_longident
with Not_found -> with Not_found ->
let names = get_names_of_module path in match try Some (Env.lookup_module longident !Toploop.toplevel_env) with Not_found -> None with
local_envs := Path_map.add path names !local_envs; | Some(path, module_type) ->
names 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 path = let fields_of_module longident =
try try
Path_map.find path !local_fields Longident_map.find longident !local_fields_by_longident
with Not_found -> with Not_found ->
let fields = get_fields_of_module path in match try Some (Env.lookup_module longident !Toploop.toplevel_env) with Not_found -> None with
local_fields := Path_map.add path fields !local_fields; | Some(path, module_type) ->
fields 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
(* List all names accessible without a path *) let list_global_names () =
let env_names () =
let rec loop acc = function let rec loop acc = function
| Env.Env_empty -> acc | Env.Env_empty -> acc
| Env.Env_value(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_value(summary, id, _) ->
| Env.Env_type(summary, id, decl) -> loop (add_names_of_type decl (add (Ident.name id) acc)) summary loop (add (Ident.name id) acc) summary
| Env.Env_exception(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_type(summary, id, decl) ->
| Env.Env_module(summary, id, _) -> loop (add (Ident.name id) acc) summary loop (add_names_of_type decl (add (Ident.name id) acc)) summary
| Env.Env_modtype(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_exception(summary, id, _) ->
| Env.Env_class(summary, id, _) -> loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_module(summary, id, _) ->
| Env.Env_open(summary, path) -> loop (String_set.union acc (names_of_module (Path path))) summary 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 in
(* Add names of the environment: *) (* Add names of the environment: *)
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
(* Add accessible modules: *) (* Add accessible modules: *)
List.fold_left add_modules_from_directory acc !Config.load_path List.fold_left add_modules_from_directory acc !Config.load_path
let env_fields () = let list_global_fields () =
let rec loop acc = function let rec loop acc = function
| Env.Env_empty -> acc | Env.Env_empty -> acc
| Env.Env_value(summary, id, _) -> loop acc summary | Env.Env_value(summary, id, _) ->
| Env.Env_type(summary, id, decl) -> loop (add_fields_of_type decl acc) summary loop (add (Ident.name id) acc) summary
| Env.Env_exception(summary, id, _) -> loop acc summary | Env.Env_type(summary, id, decl) ->
| Env.Env_module(summary, id, _) -> loop acc summary loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
| Env.Env_modtype(summary, id, _) -> loop acc summary | Env.Env_exception(summary, id, _) ->
| Env.Env_class(summary, id, _) -> loop acc summary loop (add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) -> loop acc summary | Env.Env_module(summary, id, _) ->
| Env.Env_open(summary, path) -> loop (String_set.union acc (fields_of_module (Path path))) summary 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 in
(* Add fields of the environment: *) (* Add fields of the environment: *)
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
@ -292,153 +497,17 @@ let env_fields () =
List.fold_left add_modules_from_directory acc !Config.load_path List.fold_left add_modules_from_directory acc !Config.load_path
let reset () = let reset () =
global_env := lazy(env_names ()); global_names := Lazy.lazy_from_fun list_global_names;
local_envs := Path_map.empty; local_names_by_path := Path_map.empty;
global_fields := lazy (env_fields ()); local_names_by_longident := Longident_map.empty;
local_fields := Path_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
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Labels | | Listing methods |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
type label_kind = Req | Opt
let rec get_label_func acc tokens =
match tokens with
| (Symbol, _, _, ".") :: (Uident, _, _, id) :: tokens when acc <> [] ->
get_label_func (id :: acc) tokens
| (Symbol, _, _, ("~" | "?" | ":" | "." | "#")) :: tokens ->
get_label_func [] tokens
| (Symbol, _, _, ")") :: tokens ->
get_label_skip tokens "(" []
| (Symbol, _, _, "}") :: tokens ->
get_label_skip tokens "{" []
| (Symbol, _, _, "]") :: tokens ->
get_label_skip tokens "[" []
| (Symbol, _, _, _) :: _ ->
acc
| ((Lident | Uident), _, _, id) :: _ when String_set.mem id !UTop.keywords ->
acc
| (Lident, _, _, id) :: tokens ->
get_label_func [id] tokens
| _ :: tokens ->
get_label_func [] tokens
| [] ->
acc
and get_label_skip tokens top stack =
match tokens with
| (Symbol, _, _, symbol) :: tokens when symbol = top -> begin
match stack with
| [] -> get_label_func [] tokens
| top :: stack -> get_label_skip tokens top stack
end
| (Symbol, _, _, ")") :: tokens ->
get_label_skip tokens "(" (top :: stack)
| (Symbol, _, _, "}") :: tokens ->
get_label_skip tokens "{" (top :: stack)
| (Symbol, _, _, "]") :: tokens ->
get_label_skip tokens "[" (top :: stack)
| _ :: tokens ->
get_label_skip tokens top stack
| [] ->
[]
let get_label tokens =
match tokens with
| (Lident, start, _, id) :: (Symbol, _, _, "~") :: tokens -> begin
match get_label_func [] tokens with
| [] -> None
| path -> Some (path, Req, start, id)
end
| (Symbol, _, stop, "~") :: tokens -> begin
match get_label_func [] tokens with
| [] -> None
| path -> Some (path, Req, stop, "")
end
| (Lident, start, _, id) :: (Symbol, _, _, "?") :: tokens -> begin
match get_label_func [] tokens with
| [] -> None
| path -> Some (path, Opt, start, id)
end
| (Symbol, _, stop, "?") :: tokens -> begin
match get_label_func [] tokens with
| [] -> None
| path -> Some (path, Opt, stop, "")
end
| _ ->
None
let rec labels_of_type acc type_expr =
match type_expr.desc with
| Tlink 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)) Opt acc) te
else
labels_of_type (String_map.add label Req 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 path =
let longident = longident_of_list path in
match try Some (Env.lookup_value longident !Toploop.toplevel_env) with Not_found -> None with
| None ->
[]
| Some (path, { val_type = type_expr }) ->
labels_of_type String_map.empty type_expr
(* +-----------------------------------------------------------------+
| Methods |
+-----------------------------------------------------------------+ *)
let rec get_path acc tokens =
match tokens with
| (Symbol, _, _, ".") :: (Uident, _, _, id) :: tokens ->
get_path (id :: acc) tokens
| _ ->
acc
let rec get_methods acc tokens =
match tokens with
| (Lident, _, _, meth) :: (Symbol, _, _, "#") :: tokens ->
get_methods (meth :: acc) tokens
| (Lident, _, _, id) :: tokens ->
Some (get_path [id] tokens, acc)
| _ ->
None
let get_method tokens =
match tokens with
| (Lident, start, _, meth) :: (Symbol, _, _, "#") :: tokens -> begin
match get_methods [] tokens with
| Some (path, meths) ->
Some (path, meths, start, meth)
| None ->
None
end
| (Symbol, _, stop, "#") :: tokens
| (Blanks, _, stop, _) :: (Symbol, _, _, "#") :: tokens -> begin
match get_methods [] tokens with
| Some (path, meths) ->
Some (path, meths, stop, "")
| None ->
None
end
| _ ->
None
let rec find_method meth type_expr = let rec find_method meth type_expr =
match type_expr.desc with match type_expr.desc with
| Tlink type_expr -> | Tlink type_expr ->
@ -484,29 +553,76 @@ let rec methods_of_type acc type_expr =
| _ -> | _ ->
acc acc
let rec get_object meths type_expr = let rec find_object meths type_expr =
match meths with match meths with
| [] -> | [] ->
Some type_expr Some type_expr
| meth :: meths -> | meth :: meths ->
match find_method meth type_expr with match find_method meth type_expr with
| Some type_expr -> | Some type_expr ->
get_object meths type_expr find_object meths type_expr
| None -> | None ->
None None
let methods_of_object path meths = let methods_of_object longident meths =
let longident = longident_of_list path in
match try Some (Env.lookup_value longident !Toploop.toplevel_env) with Not_found -> None with match try Some (Env.lookup_value longident !Toploop.toplevel_env) with Not_found -> None with
| None -> | None ->
[] []
| Some (path, { val_type = type_expr }) -> | Some (path, { val_type = type_expr }) ->
match get_object meths type_expr with match find_object meths type_expr with
| None -> | None ->
[] []
| Some type_expr -> | Some type_expr ->
String_set.elements (methods_of_type String_set.empty 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 | | Filtering |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
@ -532,9 +648,9 @@ let complete str =
(* Completion on directive names. *) (* Completion on directive names. *)
| [(Symbol, _, stop, "#")] | [(Symbol, _, stop, "#")]
| [(Symbol, _, _, "#"); (Blanks, _, stop, _)] -> | [(Symbol, _, _, "#"); (Blanks, _, stop, _)] ->
(stop, get_directives ()) (stop, list_directives ())
| [(Symbol, _, _, "#"); ((Lident | Uident), start, _, src)] -> | [(Symbol, _, _, "#"); ((Lident | Uident), start, _, src)] ->
(start, lookup_assoc src (get_directives ())) (start, lookup_assoc src (list_directives ()))
(* Complete with ";;" when possible. *) (* Complete with ";;" when possible. *)
| [(Symbol, _, _, "#"); ((Lident | Uident), _, _, _); (String true, _, stop, _)] | [(Symbol, _, _, "#"); ((Lident | Uident), _, _, _); (String true, _, stop, _)]
@ -626,27 +742,31 @@ let complete str =
(* Completion on identifiers. *) (* Completion on identifiers. *)
| [] -> | [] ->
(0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (Lazy.force !global_env)))) (0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (Lazy.force !global_names))))
| _ -> | _ ->
let tokens = List.rev tokens in let tokens = List.rev tokens in
match get_method tokens with match parse_method tokens with
| Some (path, meths, start, meth) -> | Some (longident, meths, start, meth) ->
(start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object path meths))) (start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths)))
| None -> | None ->
match get_label tokens with match parse_label tokens with
| Some (path, Opt, start, label) -> | Some (Fun, longident, meths, Optional, start, label) ->
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Opt) -> true | (w, Req) -> false) (labels_of_function path)))) (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 (path, Req, start, label) -> | Some (Fun, longident, meths, Required, start, label) ->
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function path))) (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 -> | None ->
match get_ident tokens with match parse_longident tokens with
| None -> | None ->
(0, []) (0, [])
| Some (Value, [], id, start) -> | Some (Value, None, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (Lazy.force !global_env))))) (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (Lazy.force !global_names)))))
| Some (Value, path, id, start) -> | Some (Value, Some longident, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module (Longident (longident_of_list path)))))) (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
| Some (Record, [], id, start) -> | Some (Field, None, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (Lazy.force !global_fields)))) (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (Lazy.force !global_fields))))
| Some (Record, path, id, start) -> | Some (Field, Some longident, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module (Longident (longident_of_list path)))))) (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))