Yet another deklugdification: locals scanning moved to elisp.

... and say goodbye to the ugly parse partial sexp, reducing not only
sloppy code, but also duplication and data transfers.

4 files changed, 62 insertions, 96 deletions

diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el
index 799280e..28aef12 100644
--- a/elisp/geiser-completion.el
+++ b/elisp/geiser-completion.el
@@ -148,9 +148,8 @@ terminates a current completion."
 
 (defsubst geiser-completion--symbol-list (prefix)
   (delete-duplicates
-   (geiser-eval--send/result
-    `(:eval ((:ge completions) ,prefix
-             (quote (:scm ,(or (geiser-syntax--get-partial-sexp) "()"))))))
+   (append (mapcar (lambda (s) (format "%s" s)) (geiser-syntax--locals-around-point))
+           (geiser-eval--send/result `(:eval ((:ge completions) ,prefix))))
    :test 'string=))
 
 (defsubst geiser-completion--module-list (prefix)
diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
index 6cadf61..6af04a1 100644
--- a/elisp/geiser-syntax.el
+++ b/elisp/geiser-syntax.el
@@ -84,15 +84,11 @@
 
 (geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode)
 
-(defsubst geiser-syntax--del-sexp (arg)
-  (let ((p (point)))
-    (forward-sexp arg)
-    (delete-region p (point))))
+(defsubst geiser-syntax--skip-comment/string ()
+  (goto-char (or (nth 8 (syntax-ppss)) (point))))
 
-(defconst geiser-syntax--placeholder (format "___%s___" (random 100)))
-
-(defsubst geiser-syntax--beginning-of-form ()
-  (memq (char-after (point)) '(?\" ?\()))
+(defsubst geiser-syntax--nesting-level ()
+  (or (nth 0 (syntax-ppss)) 0))
 
 (defun geiser-syntax--scan-sexp ()
   (let ((p (point))
@@ -112,7 +108,7 @@
 
 (defun geiser-syntax--scan-sexps ()
   (save-excursion
-    (goto-char (or (nth 8 (syntax-ppss)) (point)))
+    (geiser-syntax--skip-comment/string)
     (let* ((sap (symbol-at-point))
            (fst (and sap (geiser-syntax--scan-sexp)))
            (path (and fst
@@ -123,46 +119,55 @@
         (when (listp fst) (push fst path)))
       (nreverse path))))
 
-(defun geiser-syntax--complete-partial-sexp (buffer begin end)
-  (geiser-syntax--with-buffer
-    (erase-buffer)
-    (insert-buffer-substring-no-properties buffer begin end)
-    (when (not (geiser-syntax--beginning-of-form))
-      (skip-syntax-backward "-<>")
-      (delete-region (point) (point-max)))
-    (let ((p (nth 8 (syntax-ppss))))
-      (when p ;; inside a comment or string
-        (delete-region p (point-max))
-        (insert geiser-syntax--placeholder)))
-    (when (cond ((eq (char-after (1- (point))) ?\))
-                 (geiser-syntax--del-sexp -1) t)
-                ((geiser-syntax--beginning-of-form)
-                 (delete-region (point) (point-max)) t)
-                ((memq (char-after (1- (point))) (list ?. ?@ ?, ?\' ?\` ?\# ?\\))
-                 (skip-syntax-backward "^-(")
-                 (delete-region (point) (point-max))
-                 t))
-      (insert geiser-syntax--placeholder))
+(defun geiser-syntax--read-list (p)
+  (let ((list (ignore-errors (read (current-buffer)))))
+    (if (and list (< (point) p))
+        list
+      (goto-char p)
+      nil)))
+
+(defconst geiser-syntax--delim-regexp "\\(?:[\s-\s<\s>$\n]+\\)")
+
+(defconst geiser-syntax--ident-regexp
+  (format "\\(?:%s\\([^ (]+?\\)\\)" geiser-syntax--delim-regexp))
+
+(defconst geiser-syntax--let-regexp
+  (format "\\=(let\\(?:\\*\\|rec\\|%s\\|%s\\)%s*("
+          geiser-syntax--ident-regexp
+          geiser-syntax--delim-regexp
+          geiser-syntax--delim-regexp))
+
+(defconst geiser-syntax--ldefine-regexp
+  (format "\\=(define%s%s" geiser-syntax--ident-regexp geiser-syntax--delim-regexp))
+
+(defconst geiser-syntax--define-regexp
+  (format "\\=(\\(?:define\\|lambda\\)%s(" geiser-syntax--delim-regexp))
+
+(defun geiser-syntax--locals-around-point ()
+  (when (eq major-mode 'scheme-mode)
     (save-excursion
-      (goto-char (point-min))
-      (while (re-search-forward "[.@,'`#\\\\]" nil t)
-        (replace-match "" nil nil))
-      (goto-char (point-min))
-      (while (re-search-forward "\\[" nil t)
-        (replace-match "(" nil nil))
-      (goto-char (point-min))
-      (while (re-search-forward "\\]" nil t)
-        (replace-match ")" nil nil)))
-    (let ((depth (nth 0 (parse-partial-sexp (point-min) (point)))))
-      (unless (zerop depth) (insert (make-string depth ?\)))))
-    (when (< (point-min) (point)) (buffer-substring (point-min) (point)))))
-
-(defsubst geiser-syntax--get-partial-sexp ()
-  (unless (zerop (nth 0 (syntax-ppss)))
-    (let* ((end (if (geiser-syntax--beginning-of-form) (1+ (point))
-                  (save-excursion (skip-syntax-forward "^-\"<>()") (point))))
-           (begin (save-excursion (beginning-of-defun) (point))))
-      (geiser-syntax--complete-partial-sexp (current-buffer) begin end))))
+      (geiser-syntax--skip-comment/string)
+      (let ((ids))
+        (while (not (zerop (geiser-syntax--nesting-level)))
+          (let ((p (point)))
+            (backward-up-list)
+            (save-excursion
+              (while (< (point) p)
+                (cond ((re-search-forward geiser-syntax--let-regexp p t)
+                       (when (match-string 1) (push (intern (match-string 1)) ids))
+                       (backward-char 1)
+                       (dolist (l (nreverse (geiser-syntax--read-list p)))
+                         (when (and (listp l) (symbolp (car l)))
+                           (push (car l) ids))))
+                      ((re-search-forward geiser-syntax--ldefine-regexp p t)
+                       (when (match-string 1) (push (intern (match-string 1)) ids)))
+                      ((re-search-forward geiser-syntax--define-regexp p t)
+                       (backward-char 1)
+                       (dolist (s (nreverse (geiser-syntax--read-list p)))
+                         (let ((sn (if (listp s) (car s) s)))
+                           (when (symbolp sn) (push sn ids)))))
+                      (t (goto-char (1+ p))))))))
+        (nreverse ids)))))
 
 
 ;;; Fontify strings as Scheme code:
diff --git a/scheme/guile/geiser/completion.scm b/scheme/guile/geiser/completion.scm
index f4342bb..564b8f5 100644
--- a/scheme/guile/geiser/completion.scm
+++ b/scheme/guile/geiser/completion.scm
@@ -31,28 +31,9 @@
   #:use-module (ice-9 session)
   #:use-module (ice-9 regex))
 
-(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) '()))
-  (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 (pair->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 (completions prefix)
+  (let ((prefix (string-append "^" (regexp-quote prefix))))
+    (sort! (map symbol->string (apropos-internal prefix)) string<?)))
 
 (define (module-completions prefix)
   (let* ((prefix (string-append "^" (regexp-quote prefix)))
diff --git a/scheme/plt/geiser/completions.ss b/scheme/plt/geiser/completions.ss
index 4537feb..15bc081 100644
--- a/scheme/plt/geiser/completions.ss
+++ b/scheme/plt/geiser/completions.ss
@@ -35,29 +35,10 @@
   (filter (lambda (s) (string-prefix? prefix s))
           (if sort? (sort lst string<?) lst)))
 
-(define (symbol-completions prefix (context #f))
-  (append (filter-prefix prefix
-                         (map symbol->string (local-bindings context))
-                         #f)
-          (filter-prefix prefix
-                         (map symbol->string (namespace-mapped-symbols))
-                         #t)))
-
-(define (local-bindings form)
-  (define (body f) (if (> (length f) 2) (cddr f) '()))
-  (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 (pair->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 (symbol-completions prefix)
+  (filter-prefix prefix
+                 (map symbol->string (namespace-mapped-symbols))
+                 #t))
 
 (define (module-completions prefix)
   (filter-prefix prefix (module-list) #f))