Refactoring: local bindings discovery moved to schemeland.

4 files changed, 51 insertions, 43 deletions

diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el
index 5d5befa..b1f5ae1 100644
--- a/elisp/geiser-autodoc.el
+++ b/elisp/geiser-autodoc.el
@@ -123,7 +123,7 @@ when `geiser-autodoc-display-module-p' is on."
 
 (defun geiser-autodoc--eldoc-function ()
   (condition-case e
-      (or (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp t)) "")
+      (or (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp)) "")
     (error (format "Autodoc not available (%s)" (error-message-string e)))))
 
 
diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el
index 7b5d7d7..7e1f642 100644
--- a/elisp/geiser-completion.el
+++ b/elisp/geiser-completion.el
@@ -29,6 +29,8 @@
 (require 'geiser-syntax)
 (require 'geiser-base)
 
+(eval-when-compile (require 'cl))
+
 
 ;;; Completions window handling, heavily inspired in slime's:
 
@@ -145,7 +147,11 @@ terminates a current completion."
 ;;; Completion functionality:
 
 (defsubst geiser-completion--symbol-list (prefix)
-  (geiser-eval--send/result `(:eval ((:ge completions) ,prefix))))
+  (delete-duplicates
+   (geiser-eval--send/result
+    `(:eval ((:ge completions) ,prefix
+             (quote (:scm ,(geiser-syntax--get-partial-sexp))))))
+   :test 'string=))
 
 (defsubst geiser-completion--module-list ()
   (geiser-eval--send/result '(:eval ((:ge all-modules)))))
diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
index a5e8878..8684f99 100644
--- a/elisp/geiser-syntax.el
+++ b/elisp/geiser-syntax.el
@@ -71,58 +71,37 @@
   (goto-char (point-min))
   (skip-syntax-forward "^("))
 
-(defun geiser-syntax--complete-partial-sexp (buffer begin end &optional str)
-  (set-buffer buffer)
-  (let ((inhibit-read-only t))
-    (copy-to-buffer (geiser-syntax--buffer) begin end))
+(defsubst geiser-syntax--del-sexp (arg)
+  (let ((p (point)))
+    (forward-sexp arg)
+    (delete-region p (point))))
+
+(defun geiser-syntax--complete-partial-sexp (buffer begin end)
   (geiser-syntax--with-buffer
-    (goto-char (point-max))
+    (erase-buffer)
+    (insert-buffer-substring-no-properties buffer begin end)
     (skip-syntax-backward "-<>")
     (delete-region (point) (point-max))
     (let ((pps (parse-partial-sexp (point-min) (point))))
       (when (nth 8 pps) ;; inside a comment or string
         (delete-region (nth 8 pps) (point-max))))
-    (cond ((eq (char-after (1- (point))) ?\)) (kill-sexp -1) (insert "XXpointXX"))
-          ((eq (char-after (point)) ?\() (kill-sexp 1) (insert "XXpointXX")))
+    (cond ((eq (char-after (1- (point))) ?\))
+           (geiser-syntax--del-sexp -1) (insert "XXpointXX"))
+          ((eq (char-after (point)) ?\()
+           (geiser-syntax--del-sexp 1) (insert "XXpointXX")))
     (when (memq (char-after (1- (point))) (list ?@ ?, ?\' ?\` ?\#))
       (skip-syntax-backward "^-(")
       (delete-region (point) (point-max))
       (insert "XXXpointXX"))
     (let ((depth (nth 0 (parse-partial-sexp (point-min) (point)))))
       (unless (zerop depth) (insert (make-string depth ?\)))))
-    (if str
-        (buffer-string)
-      (geiser-syntax--prepare-scheme-for-elisp-reader)
-      (read (current-buffer)))))
+    (buffer-substring-no-properties (point-min) (point))))
 
-(defsubst geiser-syntax--get-partial-sexp (&optional str)
+(defsubst geiser-syntax--get-partial-sexp ()
   (unless (zerop (nth 0 (syntax-ppss)))
     (let* ((end (save-excursion (skip-syntax-forward "^-()") (point)))
-         (begin (save-excursion (beginning-of-defun) (point))))
-    (geiser-syntax--complete-partial-sexp (current-buffer) begin end str))))
-
-(defun geiser-syntax--collect-local-symbols (sexp acc)
-  (cond ((or (null sexp) (not (listp sexp))) acc)
-        ((listp (car sexp))
-         (geiser-syntax--collect-local-symbols
-          (cdr sexp)
-          (geiser-syntax--collect-local-symbols (car sexp) acc)))
-        ((memq (car sexp) '(define define*))
-         (let* ((name (cadr sexp))
-                (name (if (symbolp name) name (car name)))
-                (acc (if (symbolp name) (cons name acc) acc)))
-           (geiser-syntax--collect-local-symbols (cddr sexp) acc)))
-        ((memq (car sexp) '(let let* letrec))
-         (let* ((n (if (listp (nth 1 sexp)) 1 2))
-                (syms (mapcar 'car (nth n sexp)))
-                (rest (if (= 1 n) (cddr sexp) (cdr (cddr sexp)))))
-           (geiser-syntax--collect-local-symbols rest (append syms acc))))
-        (t (geiser-syntax--collect-local-symbols (cdr sexp) acc))))
-
-(defsubst geiser-syntax--local-bindings ()
-  (ignore-errors
-    (mapcar 'symbol-name
-            (geiser-syntax--collect-local-symbols (geiser-syntax--get-partial-sexp) '()))))
+           (begin (save-excursion (beginning-of-defun) (point))))
+    (geiser-syntax--complete-partial-sexp (current-buffer) begin end))))
 
 
 ;;; Fontify strings as Scheme code:
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm
index 7e468e7..fd6784d 100644
--- a/scheme/guile/geiser/introspection.scm
+++ b/scheme/guile/geiser/introspection.scm
@@ -149,10 +149,33 @@ The alist keys that are currently defined are `required', `optional',
              ,@(if rest (list (cons 'rest 'rest)) '())))))
    (else #f)))
 
-(define (completions prefix)
-  (sort! (map symbol->string
-              (apropos-internal (string-append "^" prefix)))
-         string<?))
+(define (completions prefix . context)
+  (let ((context (and (not (null? context)) (car context)))
+        (prefix (string-append "^" (regexp-quote prefix))))
+    (append (filter (lambda (s) (string-match prefix s))
+                    (map symbol->string (local-bindings context)))
+            (sort! (map symbol->string (apropos-internal prefix)) string<?))))
+
+(define (local-bindings form)
+  (define (body f) (if (> (length f) 2) (cddr f) '()))
+  (define (decl-list d)
+    (let loop ((d d) (s '()))
+      (cond ((null? d) s)
+            ((symbol? d) (cons d s))
+            (else (loop (cdr d) (cons (car d) s))))))
+  (let loop ((form form) (bindings '()))
+    (cond ((not (pair? form)) bindings)
+          ((list? (car form))
+           (loop (cdr form) (append (local-bindings (car form)) bindings)))
+          ((and (list? form) (< (length form) 2)) bindings)
+          ((memq (car form) '(define define* lambda))
+           (loop (body form) (append (decl-list (cadr form)) bindings)))
+          ((and (memq (car form) '(let let* letrec letrec*))
+                (list? (cadr form)))
+           (loop (body form) (append (map car (cadr form)) bindings)))
+          ((and (eq? 'let (car form)) (symbol? (cadr form)))
+           (loop (cons 'let (body form)) (cons (cadr form) bindings)))
+          (else (loop (cdr form) bindings)))))
 
 (define (module-location name)
   (make-location (module-filename name) #f))