Fuzzy matching for Chicken AutoDoc and Completions

Because Chicken allows symbols to be imported with prefixes, and because
'apropos' does not provide any utility to match with the loaded
prefixes, it is difficult to acquire information about prefixed symbols.

This solution hacks around the issue by providing naive
fuzzy-matching. If no match for a symbol can be found then the first
character is dropped and matching is attempted again; the process is
repeated until matches are found or the entire symbol is consumed.

Also removes the (now redundant and slow) geiser-chicken-prefix-delimiters.

2 files changed, 47 insertions, 49 deletions

diff --git a/elisp/geiser-chicken.el b/elisp/geiser-chicken.el
index 9775769..d0eb1d1 100644
--- a/elisp/geiser-chicken.el
+++ b/elisp/geiser-chicken.el
@@ -65,12 +65,6 @@
   "Customization for Geiser's Chicken flavour."
   :group 'geiser)
 
-(geiser-custom--defcustom geiser-chicken-prefix-delimiters
-    '("^:" "^#")
-    "Regex to match symbol prefix delimiters. Consider that it will be placed inside []."
-  :type '(repeat string)
-  :group 'geiser-chicken)
-
 (geiser-custom--defcustom geiser-chicken-binary
   (cond ((eq system-type 'windows-nt) '("csi.exe" "-:c"))
         ((eq system-type 'darwin) "csi")
@@ -189,19 +183,10 @@ This function uses `geiser-chicken-init-file' if it exists."
 (defun geiser-chicken--exit-command () ",q")
 
 (defun geiser-chicken--symbol-begin (module)
-  (apply
-   'max
-   (cons
-    (if module
-	(max (save-excursion (beginning-of-line) (point))
-	     (save-excursion (skip-syntax-backward "^(>") (1- (point))))
-      (save-excursion (skip-syntax-backward "^'-()>") (point)))
-    (let ((distance-to-beginning-of-line (- (point) (line-beginning-position))))
-      (mapcar
-       (lambda (match-string)
-	 (save-excursion
-	   (skip-chars-backward match-string distance-to-beginning-of-line) (point)))
-       geiser-chicken-prefix-delimiters)))))
+  (if module
+      (max (save-excursion (beginning-of-line) (point))
+	   (save-excursion (skip-syntax-backward "^(>") (1- (point))))
+    (save-excursion (skip-syntax-backward "^'-()>") (point))))
 
 
 ;;; Error display
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
index d5bddf5..8ec3440 100644
--- a/scheme/chicken/geiser/emacs.scm
+++ b/scheme/chicken/geiser/emacs.scm
@@ -242,13 +242,18 @@
 	    (apropos-information-list "" #:macros? #t)))))
 
   (define (find-symbol-information prefix)
+    (define (find-symbol-information* prefix skipped)
+      (let ((found (filter
+		    (lambda (info)
+		      (string-has-prefix? (car info) prefix))
+		    (symbol-information-list))))
+	(if (and (null? found) (< 1 (string-length prefix)))
+	    (find-symbol-information* (substring/shared prefix 1) (string-append skipped (substring prefix 0 1)))
+	    (cons found skipped))))
     (memoize
      `(find-symbol-information ,prefix)
      (lambda ()
-       (filter
-	(lambda (info)
-	  (string-has-prefix? (car info) (->string prefix)))
-	(symbol-information-list)))))
+       (find-symbol-information* (->string prefix) ""))))
   
   (define debug-log (make-parameter #f))
   (define (write-to-log form)
@@ -387,37 +392,42 @@
            (any (cut eq? type <>) types)))
        (match-nodes sym)))))
 
-  (define (make-module-list sym module-sym)
-    (if (not module-sym)
-	(find-standards-with-symbol sym)
-	(cons module-sym (find-standards-with-symbol sym))))
+  (define (make-module-list sym module-sym prefix-exists)
+    (append
+     (if prefix-exists '(fuzzy-match) '())
+     (if (not module-sym)
+	 (find-standards-with-symbol sym)
+	 (cons module-sym (find-standards-with-symbol sym)))))
   
-  (define (fmt node)
+  (define (fmt node prefix)
     (memoize
-     `(fmt ,node)
+     `(fmt ,node ,prefix)
      (lambda ()
-       (let* ((entry (string->symbol (car node)))
+       (let* ((original-entry (string->symbol (car node)))
+	      (fuzzy-entry (string->symbol (string-append prefix (car node))))
+	      (prefix-exists (not (= 0 (string-length prefix))))
 	      (module (cadr node))
 	      (module (if module (string->symbol module) #f))
 	      (rest (cddr node))
-	      (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
+	      (type (if (or (list? rest) (pair? rest)) (car rest) rest))
+	      (module-list (make-module-list fuzzy-entry module prefix-exists)))
 	 (cond
 	  ((equal? 'macro type)
-	   `(,entry ("args" (("required" <macro>)
-			     ("optional" ...)
-			     ("key")))
-		    ("module" ,@(make-module-list entry module))))
+	   `(,fuzzy-entry ("args" (("required" <macro>)
+				   ("optional" ...)
+				   ("key")))
+			  ("module" ,@module-list)))
 	  ((or (equal? 'variable type)
 	       (equal? 'constant type))
 	   (if (not module)
-	       `(,entry ("value" . ,(eval entry)))
+	       `(,fuzzy-entry ("value" . ,(eval original-entry)))
 	       (let* ((original-module (current-module))
 		      (desired-module (find-module module))
 		      (value (begin (switch-module desired-module)
-				    (eval entry))))
+				    (eval original-entry))))
 		 (switch-module original-module)
-		 `(,entry ("value" . ,value)
-			  ("module" ,@(make-module-list entry module))))))
+		 `(,fuzzy-entry ("value" . ,value)
+				("module" ,@module-list)))))
 	  (else
 	   (let ((reqs '())
 		 (opts '())
@@ -452,22 +462,20 @@
 
 	     (collect-args args)
 
-	     `(,entry ("args" (("required" ,@reqs)
-			       ("optional" ,@opts)
-			       ("key" ,@keys)))
-		      ("module" ,@(make-module-list entry module))))))))))
+	     `(,fuzzy-entry ("args" (("required" ,@reqs)
+				     ("optional" ,@opts)
+				     ("key" ,@keys)))
+			    ("module" ,@module-list)))))))))
 
   ;; Builds a signature list from an identifier
   (define (find-signatures sym)
     (memoize
      `(find-signatures ,sym)
      (lambda ()
-       (let ((str (symbol->string sym)))
+       (let ((result (find-symbol-information sym)))
 	 (map
-	  (cut fmt <>)
-	  (filter
-	   (lambda (lst) (string=? (car lst) str))
-	   (find-symbol-information sym)))))))
+	  (cut fmt <> (cdr result))
+	  (car result))))))
 
   ;; Builds the documentation from Chicken Doc for a specific symbol
   (define (make-doc symbol #!optional (filter-for-type #f))
@@ -584,7 +592,12 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
   (define (geiser-completions prefix . rest)
-    (map car (find-symbol-information prefix)))
+    (let* ((result (find-symbol-information prefix))
+	   (prefix (cdr result))
+	   (result-list (car result)))
+      (map
+       (cut string-append prefix <>)
+       (map car result-list))))
 
   (define (geiser-module-completions prefix . rest)
     (let ((prefix (->string prefix)))