summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-15 17:35:17 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-15 17:35:17 +0100
commit245e681f8ebd0f9304ae87815bf1d49a05241162 (patch)
tree2a10cfd68f30967428f768d64f46057274eb2830
parentf753d35c186ad448e70e84afbc91fb37db2fbb57 (diff)
downloadgeiser-chez-245e681f8ebd0f9304ae87815bf1d49a05241162.tar.gz
geiser-chez-245e681f8ebd0f9304ae87815bf1d49a05241162.tar.bz2
Initial support for module name completion.
-rw-r--r--README2
-rw-r--r--elisp/geiser-completion.el90
-rw-r--r--elisp/geiser-repl.el2
-rw-r--r--scheme/guile/geiser/emacs.scm3
-rw-r--r--scheme/guile/geiser/introspection.scm69
5 files changed, 113 insertions, 53 deletions
diff --git a/README b/README
index ac23b60..b489e37 100644
--- a/README
+++ b/README
@@ -20,6 +20,7 @@
| M-. | Edit symbol at point |
| M-, | Go back to where M-. was last invoked |
| M-TAB | Complete symbol at point |
+ | C-uM-TAB | Complete module name at point |
|---------------+-------------------------------------------------|
| C-M-x, C-cC-e | Eval definition around point |
| C-cMe | Eval definition around point and switch to REPL |
@@ -41,6 +42,7 @@
|--------------+-----------------------------------------|
| M-. | Edit symbol at point |
| TAB | Complete symbol at point |
+ | M-TAB | Complete module name at point |
|--------------+-----------------------------------------|
| M-p, M-n | Prompt history, matching current prefix |
|--------------+-----------------------------------------|
diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el
index 3a36187..2f1aa36 100644
--- a/elisp/geiser-completion.el
+++ b/elisp/geiser-completion.el
@@ -29,48 +29,6 @@
(require 'geiser-base)
-;;; Minibuffer map:
-
-(defvar geiser-completion--minibuffer-map
- (let ((map (make-keymap)))
- (set-keymap-parent map minibuffer-local-completion-map)
- (define-key map "?" 'self-insert-command)
- map))
-
-
-;;; Modules dictionary:
-
-;; (defvar geiser-completion--modules nil)
-
-;; (defun geiser-completion--modules (&optional reload)
-;; (when (or reload (not geiser-completion--modules))
-;; (geiser--respecting-message "Retrieving modules list")
-;; (let ((geiser-log--inhibit-p t))
-;; (setq geiser-completion--modules
-;; (geiser-eval--retort-result
-;; (geiser-eval--send/wait '(:gs (:ge (module-list :t)))))))
-;; geiser-completion--modules)
-
-;; (defun geiser-completion--read-module (&optional reload init-input history)
-;; (let ((minibuffer-local-completion-map geiser-completion--minibuffer-map)
-;; (modules (geiser-completion--modules reload)))
-;; (completing-read "Module name: " modules nil nil init-input history)))
-
-;; (defsubst geiser-completion--module-list (prefix)
-;; (geiser-eval--retort-result
-;; (geiser-eval--send/wait `(:gs (:ge (module-list ,prefix))))))
-
-;; (defvar geiser-completion--module-history nil)
-
-;; (defun geiser-completion--read-module (refresh)
-;; (let ((minibuffer-local-completion-map geiser-completion--minibuffer-map)
-;; (modules (geiser-completion--modules refresh))
-;; (prompt "Module name: "))
-;; (if modules
-;; (completing-read prompt modules nil nil nil geiser-completion--module-history)
-;; (read-string prompt nil geiser-completion--module-history))))
-
-
;;; Completions window handling, heavily inspired in slime's:
(defvar geiser-completion--comp-buffer "*Completions*")
@@ -167,16 +125,35 @@ terminates a current completion."
(scroll-up))))))
+;;; Minibuffer maps:
+
+(defvar geiser-completion--minibuffer-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map minibuffer-local-completion-map)
+ (define-key map "?" 'self-insert-command)
+ map))
+
+(defvar geiser-completion--module-minibuffer-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map minibuffer-local-completion-map)
+ (define-key map " " 'self-insert-command)
+ (define-key map "?" 'self-insert-command)
+ map))
+
+
;;; Completion functionality:
(defsubst geiser-completion--symbol-list (prefix)
(geiser-eval--send/result `(:gs ((:ge completions) ,prefix))))
+(defsubst geiser-completion--module-list ()
+ (geiser-eval--send/result '(:gs ((:ge all-modules)))))
+
(defvar geiser-completion--symbol-list-func
(completion-table-dynamic 'geiser-completion--symbol-list))
(defun geiser-completion--complete (prefix modules)
- (let* ((symbols (if modules nil ;; (geiser-completion--modules)
+ (let* ((symbols (if modules (geiser-completion--module-list)
(geiser-completion--symbol-list prefix)))
(completions (all-completions prefix symbols))
(partial (try-completion prefix symbols))
@@ -193,6 +170,16 @@ terminates a current completion."
(or history geiser-completion--symbol-history)
(or default (symbol-at-point)))))
+(defvar geiser-completion--module-history nil)
+
+(defun geiser-completion--read-module ()
+ (let ((minibuffer-local-completion-map geiser-completion--module-minibuffer-map)
+ (modules (geiser-completion--module-list))
+ (prompt "Module name: "))
+ (if modules
+ (completing-read prompt modules nil nil nil geiser-completion--module-history)
+ (read-string prompt nil geiser-completion--module-history))))
+
(defun geiser--respecting-message (format &rest format-args)
"Display TEXT as a message, without hiding any minibuffer contents."
(let ((text (format " [%s]" (apply #'format format format-args))))
@@ -200,14 +187,21 @@ terminates a current completion."
(minibuffer-message text)
(message "%s" text))))
-(defun geiser-completion--complete-symbol ()
+(defsubst geiser-completion--beg-pos (module)
+ (if module
+ (max (save-excursion (beginning-of-line) (point))
+ (save-excursion (skip-syntax-backward "^(") (1- (point))))
+ (save-excursion (skip-syntax-backward "^-()") (point))))
+
+(defun geiser-completion--complete-symbol (&optional arg)
"Complete the symbol at point.
-Perform completion similar to Emacs' complete-symbol."
- (interactive)
+Perform completion similar to Emacs' complete-symbol.
+With prefix, complete module name."
+ (interactive "P")
(let* ((end (point))
- (beg (save-excursion (skip-syntax-backward "^-()") (point)))
+ (beg (geiser-completion--beg-pos arg))
(prefix (buffer-substring-no-properties beg end))
- (result (geiser-completion--complete prefix nil))
+ (result (geiser-completion--complete prefix arg))
(completions (car result))
(partial (cdr result)))
(cond ((null completions)
diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el
index 508525a..e9a0eb0 100644
--- a/elisp/geiser-repl.el
+++ b/elisp/geiser-repl.el
@@ -156,6 +156,8 @@ REPL buffer."
(define-key geiser-repl-mode-map "\C-c\M-n" 'comint-next-input)
(define-key geiser-repl-mode-map (kbd "TAB") 'geiser-completion--complete-symbol)
+(define-key geiser-repl-mode-map (kbd "M-TAB")
+ '(lambda () (interactive) (geiser-completion--complete-symbol t)))
(define-key geiser-repl-mode-map "\M-." 'geiser-edit-symbol-at-point)
(define-key geiser-repl-mode-map "\M-," 'geiser-edit-pop-edit-symbol-stack)
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index 1458c73..3f2116a 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -30,7 +30,8 @@
ge:symbol-location
ge:compile-file
ge:load-file
- ge:docstring)
+ ge:docstring
+ ge:all-modules)
#:use-module ((geiser introspection)
:renamer (symbol-prefix-proc 'ge:))
#:use-module ((geiser eval)
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm
index 19ea2df..110ab01 100644
--- a/scheme/guile/geiser/introspection.scm
+++ b/scheme/guile/geiser/introspection.scm
@@ -25,7 +25,12 @@
;;; Code:
(define-module (geiser introspection)
- #:export (arguments completions symbol-location docstring)
+ #:export (arguments
+ completions
+ symbol-location
+ docstring
+ all-modules
+ module-children)
#:use-module (system vm program)
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
@@ -140,13 +145,69 @@
(display signature)
(newline)
(display type)
- (if modname (begin (display " in module ")
- (display modname)))
+ (if modname
+ (begin
+ (display " in module ")
+ (display modname)))
(newline)
- (if doc (begin (display doc)))))))
+ (if doc (display doc))))))
(define (docstring sym)
(with-output-to-string
(lambda () (display-docstring sym))))
+(define (all-modules)
+ (let ((roots ((@@ (ice-9 session) root-modules))))
+ (sort! (map (lambda (m)
+ (format "~A" (module-name m)))
+ (fold (lambda (m all)
+ (append (all-child-modules m) all))
+ roots
+ roots))
+ string<?)))
+
+(define (child-modules mod)
+ (delq mod ((@@ (ice-9 session) submodules) mod)))
+
+(define (all-child-modules mod)
+ (let ((children (child-modules mod)))
+ (fold (lambda (m all)
+ (append (all-child-modules m) all))
+ children children)))
+
+(define (module-children mod-name)
+ (let* ((elts (hash-fold classify-module-object
+ (list '() '() '())
+ (module-obarray (maybe-module-interface mod-name))))
+ (elts (map sort-symbols! elts)))
+ (list (cons 'modules (map (lambda (m) `(,@mod-name ,m)) (car elts)))
+ (cons 'procs (cadr elts))
+ (cons 'vars (caddr elts)))))
+
+(define (sort-symbols! syms)
+ (let ((cmp (lambda (l r)
+ (string<? (symbol->string l) (symbol->string r)))))
+ (sort! syms cmp)))
+
+(define (maybe-module-interface mod-name)
+ (catch #t
+ (lambda () (resolve-interface mod-name))
+ (lambda args (resolve-module mod-name))))
+
+(define (classify-module-object name var elts)
+ (let ((obj (and (variable-bound? var)
+ (variable-ref var))))
+ (cond ((not obj) elts)
+ ((and (module? obj) (eq? (module-kind obj) 'directory))
+ (list (cons name (car elts))
+ (cadr elts)
+ (caddr elts)))
+ ((or (procedure? obj) (program? obj) (macro? obj))
+ (list (car elts)
+ (cons name (cadr elts))
+ (caddr elts)))
+ (else (list (car elts)
+ (cadr elts)
+ (cons name (caddr elts)))))))
+
;;; introspection.scm ends here