Initial support for module name completion.

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