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

completion on identifiers 

Ignore-this: 3045e07571a9000b25ad6ca85c8233db

darcs-hash:20110727080629-c41ad-07674844d2eccc42353195583a07274bb1d6a53a
This commit is contained in:
Jeremie Dimino 2011-07-27 10:06:29 +02:00
parent 02c2395a79
commit 02d98fff98
6 changed files with 265 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
_oasis
View File

@ -22,7 +22,9 @@ Library utop
Path: src
Modules: UTop
InternalModules: UTop_private
BuildDepends: findlib, lambda-term, lwt.syntax
XMETADescription: utop configuration
XMETARequires: findlib, lambda-term
Executable utop
Install: true

240
src/uTop_complete.ml
View File

@ -7,9 +7,12 @@
* 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
@ -18,13 +21,176 @@ let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.
+-----------------------------------------------------------------+ *)
let get_directives () =
Hashtbl.fold (fun k v set -> String_set.add k set) Toploop.directive_table String_set.empty
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)
let directive_suffix dir =
match Hashtbl.find Toploop.directive_table dir with
| Toploop.Directive_none _ -> ";;"
| Toploop.Directive_string _ -> " \""
| Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _ -> " "
(* +-----------------------------------------------------------------+
| Files |
+-----------------------------------------------------------------+ *)
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 list_files filter dir =
String_map.bindings
(Array.fold_left
(fun map name ->
let absolute_name = Filename.concat dir name in
if try Sys.is_directory absolute_name with _ -> false then
String_map.add (Filename.concat name "") Directory map
else if filter name then
String_map.add name File map
else
map)
String_map.empty
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir)))
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 _ -> false then
String_set.add name set
else
set)
String_set.empty
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir)))
(* +-----------------------------------------------------------------+
| Identifiers |
+-----------------------------------------------------------------+ *)
let rec get_ident acc tokens =
match tokens with
| [(Uident, _, _, id); (Symbol, _, stop, ".")]
| [(Uident, _, _, id); (Symbol, _, _, "."); (Blanks, _, stop, _)] ->
Some (List.rev (id :: acc) , "", stop)
| (Uident, _, _, id) :: (Symbol, _, _, ".") :: rest ->
get_ident (id :: acc) rest
| [((Uident | Lident), start, _, id)] ->
Some (List.rev acc, id, start)
| [((Comment false | Doc false | String false | Quotation false), _, _, _)] ->
None
| [(_, _, stop, _)] ->
Some ([], "", stop)
| [] ->
None
| _ :: rest ->
get_ident [] rest
type path =
| Path of Path.t
| Longident of Longident.t
module Path_map = Map.Make(struct type t = path let compare = compare end)
let global_env = ref (lazy (raise Exit))
let local_envs = ref Path_map.empty
(* Returns [acc] plus all modules of [dir] *)
let add_modules_from_directory acc dir =
let acc = ref acc in
Array.iter
(fun fname ->
if Filename.check_suffix fname ".cmi" then
acc := String_set.add (String.capitalize (Filename.chop_suffix fname ".cmi")) !acc)
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir));
!acc
let valid id =
id <> "" &&
(match id.[0] with
| 'A' .. 'Z' | 'a' .. 'z' | '_' -> true
| _ -> false)
(* List all names of the module with path [path] *)
let get_names_of_module path =
try
match
match path with
| Path path ->
Env.find_module path !Toploop.toplevel_env
| Longident ident ->
snd (Env.lookup_module ident !Toploop.toplevel_env)
with
| Tmty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Tsig_value(id, _)
| Tsig_type(id, _, _)
| Tsig_exception(id, _)
| Tsig_module(id, _, _)
| Tsig_modtype(id, _)
| Tsig_class(id, _, _)
| Tsig_cltype(id, _, _) ->
let id = Ident.name id in
if valid id then
String_set.add id acc
else
acc)
String_set.empty decls
| _ ->
String_set.empty
with Not_found ->
String_set.empty
let names_of_module path =
try
Path_map.find path !local_envs
with Not_found ->
let names = get_names_of_module path in
local_envs := Path_map.add path names !local_envs;
names
(* List all names accessible without a path *)
let env_names () =
let rec loop acc = function
| Env.Env_empty -> acc
| Env.Env_value(summary, id, _) -> let id = Ident.name id in loop (if valid id then String_set.add id acc else acc) summary
| Env.Env_type(summary, id, _) -> loop (String_set.add (Ident.name id) acc) summary
| Env.Env_exception(summary, id, _) -> loop (String_set.add (Ident.name id) acc) summary
| Env.Env_module(summary, id, _) -> loop (String_set.add (Ident.name id) acc) summary
| Env.Env_modtype(summary, id, _) -> loop (String_set.add (Ident.name id) acc) summary
| Env.Env_class(summary, id, _) -> loop (String_set.add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) -> loop (String_set.add (Ident.name id) acc) summary
| Env.Env_open(summary, path) -> loop (String_set.union acc (names_of_module (Path path))) 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 make_path l =
match l with
| [] ->
invalid_arg "UTop_complete.make_path"
| ident :: rest ->
let rec loop path = function
| [] -> Longident path
| component :: rest -> loop (Longident.Ldot(path, component)) rest
in
loop (Longident.Lident ident) rest
let reset () =
global_env := lazy(env_names ());
local_envs := Path_map.empty
(* +-----------------------------------------------------------------+
| Filtering |
@ -34,8 +200,8 @@ let directive_suffix dir =
let rec filter tokens =
match tokens with
| [] -> []
| [((Blanks | Comment | Doc), start, stop, src)] -> [(Blanks, start, stop, src)]
| ((Blanks | Comment | Doc), _, _, _) :: rest -> filter rest
| [((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
(* +-----------------------------------------------------------------+
@ -48,30 +214,53 @@ let complete str =
let tokens = filter tokens in
match tokens with
(* +-------------------------------------------------------------+
| Completion on directives |
+-------------------------------------------------------------+ *)
(* Completion on directive names. *)
| [(Symbol, _, stop, "#")]
| [(Symbol, _, _, "#"); (Blanks, _, stop, _)] ->
(stop, List.map (fun dir -> (dir, directive_suffix dir)) (String_set.elements (get_directives ())))
(stop, get_directives ())
| [(Symbol, _, _, "#"); ((Lident | Uident), start, _, src)] ->
let prefix, words = LTerm_read_line.lookup src (String_set.elements (get_directives ())) in
(start, List.map (fun dir -> (dir, directive_suffix dir)) words)
(start, lookup_assoc src (get_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 packages. *)
(* Completion on #require. *)
| [(Symbol, _, _, "#"); (Lident, _, _, "require"); (String false, start, stop, str)] ->
let pkg = String.sub str 1 (String.length str - 1) in
let prefix, pkgs = LTerm_read_line.lookup pkg (Fl_package_base.list_packages ()) in
let pkgs = lookup pkg (Fl_package_base.list_packages ()) in
(start + 1, List.map (fun pkg -> (pkg, "\";;")) (List.sort compare pkgs))
(* Generic completion. *)
(* Completion on #load. *)
| [(Symbol, _, _, "#"); (Lident, _, _, "load"); (String false, start, stop, str)] ->
let file = String.sub str 1 (String.length str - 1) in
let list = list_files (fun name -> Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo") (Filename.dirname file) 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 list = list_files (fun name -> true) (Filename.dirname file) 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
@ -86,12 +275,19 @@ let complete str =
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 _) ->
let _, words = LTerm_read_line.lookup id ["true"; "false"] in
List.map (fun w -> (w, ";;")) words
| 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_env))))
| _ ->
(0, [])
match get_ident [] tokens with
| None ->
(0, [])
| Some ([], id, start) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (Lazy.force !global_env)))))
| Some (path, id, start) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module (make_path path)))))

4
src/uTop_complete.mli
View File

@ -12,3 +12,7 @@
val complete : string -> int * (string * string) list
(** [complete str] returns the start of the completed word in [str]
and the list of possible completions with their suffixes. *)
val reset : unit -> unit
(** Reset global cache. It must be called before each interactive
read line. *)

38
src/uTop_console.ml
View File

@ -87,16 +87,22 @@ let init_history () =
+-----------------------------------------------------------------+ *)
(* The pending line to add to the history. *)
let pending = ref ""
let pending = ref None
class read_line ~term ~prompt = object(self)
class read_line ~term ~prompt =
let pending =
match !pending with
| None -> ""
| Some line -> line ^ "\n"
in
let pending_length = Zed_utf8.length pending in
object(self)
inherit LTerm_read_line.read_line ~history:!history () as super
inherit [Zed_utf8.t] LTerm_read_line.term term
method stylise =
let styled, position = super#stylise in
let tokens = UTop_lexer.lex_string (!pending ^ LTerm_text.to_string styled) in
let pending_length = Zed_utf8.length !pending in
let tokens = UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled) in
let rec loop tokens =
match tokens with
| [] ->
@ -110,9 +116,9 @@ class read_line ~term ~prompt = object(self)
| Constant -> styles.style_constant
| Char -> styles.style_char
| String _ -> styles.style_string
| Quotation -> styles.style_quotation
| Comment -> styles.style_comment
| Doc -> styles.style_doc
| Quotation _ -> styles.style_quotation
| Comment _ -> styles.style_comment
| Doc _ -> styles.style_doc
| Blanks -> styles.style_blanks
| Error -> styles.style_error
in
@ -138,8 +144,7 @@ class read_line ~term ~prompt = object(self)
(styled, position)
method completion =
let pos, words = UTop_complete.complete (!pending ^ Zed_rope.to_string self#input_prev) in
let pending_length = Zed_utf8.length !pending in
let pos, words = UTop_complete.complete (pending ^ Zed_rope.to_string self#input_prev) in
if pos < pending_length then self#set_completion 0 [] else self#set_completion (pos - pending_length) words
initializer
@ -168,12 +173,19 @@ let rec read_input term prompt buffer len =
let prompt_to_display =
match prompt with
| "# " ->
(* Reset completion. *)
UTop_complete.reset ();
(* increment the command counter. *)
UTop_private.set_count (S.value UTop_private.count + 1);
(* Add the previous line to the history. *)
history := LTerm_read_line.add_entry !pending !history;
pending := "";
(match !pending with
| None ->
()
| Some line ->
history := LTerm_read_line.add_entry line !history;
pending := None);
!UTop.prompt
@ -194,7 +206,9 @@ let rec read_input term prompt buffer len =
return txt
) in
pending := !pending ^ txt;
pending := Some (match !pending with
| None -> txt
| Some line -> line ^ "\n" ^ txt);
(* Add a newline character at the end. *)
input := txt ^ "\n";

20
src/uTop_lexer.mll
View File

@ -86,7 +86,7 @@ rule token = parse
| float_literal
{ Constant }
| '"'
{ string lexbuf }
{ String (string lexbuf) }
| "'" [^'\'' '\\'] "'"
{ Char }
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof
@ -102,11 +102,11 @@ rule token = parse
| "'\\" uchar
{ Error }
| "(**"
{ comment 0 lexbuf; Doc }
{ Doc (comment 0 lexbuf) }
| "(*"
{ comment 0 lexbuf; Comment }
{ Comment (comment 0 lexbuf) }
| '<' (':' ident)? ('@' locname)? '<'
{ quotation lexbuf; Quotation }
{ Quotation (quotation lexbuf) }
| ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::"
| ":=" | ":>" | ";" | ";;" | "_"
| left_delimitor | right_delimitor )
@ -122,29 +122,29 @@ and comment depth = parse
| "(*"
{ comment (depth + 1) lexbuf }
| "*)"
{ if depth > 0 then comment (depth - 1) lexbuf }
{ if depth > 0 then comment (depth - 1) lexbuf else true }
| uchar
{ comment depth lexbuf }
| eof
{ () }
{ false }
and string = parse
| '"'
{ String true }
{ true }
| "\\\""
{ string lexbuf }
| uchar
{ string lexbuf }
| eof
{ String false }
{ false }
and quotation = parse
| ">>"
{ () }
{ true }
| uchar
{ quotation lexbuf }
| eof
{ () }
{ false }
{
let lex_string str =

8
src/uTop_token.ml
View File

@ -7,6 +7,8 @@
* This file is a part of utop.
*)
(** Type of tokens. Tokens with a boolean parameter takes as argument
wheter the token is terminated or not. *)
type t =
| Symbol
| Lident
@ -14,8 +16,8 @@ type t =
| Constant
| Char
| String of bool
| Quotation
| Comment
| Doc
| Quotation of bool
| Comment of bool
| Doc of bool
| Blanks
| Error