[nongnu] elpa/geiser-chicken ff59903 061/102: Improvements to Chicken completion speed

[Philip Kaludercic]

branch: elpa/geiser-chicken
commit ff59903e90d17e31a9e2207f14e2f67b4f39bd7a
Author: Dan Leslie <dan@ironoxide.ca>
Commit: Dan Leslie <dan@ironoxide.ca>

    Improvements to Chicken completion speed
    
    Removed all of the symbol-interning code, and in the process greatly
    reduced the amount of CPU time.
    
    Should resolve jaor/geiser#174
---
 geiser/emacs.scm | 138 ++++++++++++++++++++++++-------------------------------
 1 file changed, 59 insertions(+), 79 deletions(-)

diff --git a/geiser/emacs.scm b/geiser/emacs.scm
index d60cbb9..b6af65e 100644
--- a/geiser/emacs.scm
+++ b/geiser/emacs.scm
@@ -28,8 +28,7 @@
    geiser-module-completions
    geiser-macroexpand
    geiser-chicken-use-debug-log
-   geiser-chicken-load-paths
-   geiser-chicken-symbol-match-limit)
+   geiser-chicken-load-paths)
 
   (import chicken scheme)
   (use
@@ -51,9 +50,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Symbol lists
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (define geiser-chicken-symbol-match-limit
-    (make-parameter 20))
   
   (define geiser-r4rs-symbols
     (make-parameter
@@ -226,47 +222,33 @@
   (define (list-modules) (map car ##sys#module-table))
 
   (define memo (make-parameter (make-hash-table)))
+  (define symbol-memo (make-parameter (make-hash-table)))
   (define (clear-memo) (hash-table-clear! (memo)))
+  (define (memoize/tbl table tag thunk)
+    (if (hash-table-exists? table tag)
+       (begin
+         (write-to-log '[[Cache Hit]])
+         (hash-table-ref table tag))
+       (fluid-let ((memoize/tbl (lambda (table tag thunk) (thunk))))
+         (write-to-log '[[Cache Miss]])
+         (hash-table-set! table tag (thunk))
+         
+         (hash-table-ref table tag))))
+
   (define (memoize tag thunk)
-    (let ((table (memo)))
-      (if (hash-table-exists? table tag)
-         (begin
-           (write-to-log '[[Cache Hit]])
-           (hash-table-ref table tag))
-         (fluid-let ((memoize (lambda (tag thunk) (thunk))))
-           (write-to-log '[[Cache Miss]])
-           (hash-table-set! table tag (thunk))
-           
-           (hash-table-ref table tag)))))
-  
-  (define (symbol-information-list)
-    (memoize
-     '(symbol-information-list)
-     (lambda ()
-       (map (lambda (lst)
-              (let* ((module (if (eq? (string->symbol "") (caar lst)) #f 
(symbol->string (caar lst))))
-                     (name (symbol->string (cdar lst))))
-                (append (list name module) (cdr lst))))
-           (apropos-information-list "" #:macros? #t)))))
+    (memoize/tbl (memo) tag thunk))
 
-  (define (find-symbol-information prefix)
-    (define (filter/limit pred? limit lst)
-      (cond
-       ((<= limit 0) '())
-       ((or (null? lst) (not (list? lst))) '())
-       ((pred? (car lst)) (cons (car lst) (filter/limit pred? (- limit 1) (cdr 
lst))))
-       (else (filter/limit pred? limit (cdr lst)))))
-    (define (find-symbol-information* prefix skipped)
-      (let ((found (filter/limit
-                   (lambda (info)
-                     (string-has-prefix? (car info) prefix))
-                   (geiser-chicken-symbol-match-limit)
-                   (symbol-information-list))))        
-       (cons found skipped)))
+  (define empty-symbol (string->symbol ""))
+
+  (define (symbol-information-list partial-string)
     (memoize
-     `(find-symbol-information ,prefix)
-     (lambda ()
-       (find-symbol-information* (->string prefix) ""))))
+     `(symbol-information-list ,partial-string)
+     (lambda ()       
+       (map (lambda (lst)
+             (let* ((module (if (eq? empty-symbol (caar lst)) #f (caar lst)))
+                    (name (cdar lst)))
+               (append (list name module) (cdr lst))))
+           (apropos-information-list partial-string #:macros? #t)))))
   
   (define debug-log (make-parameter #f))
   (define (write-to-log form)
@@ -397,42 +379,47 @@
            (any (cut eq? type <>) types)))
        (match-nodes sym)))))
 
-  (define (make-module-list sym module-sym prefix-exists)
+  (define (make-module-list sym module-sym)
     (append
-     (if prefix-exists '(fuzzy-match) '())
      (if (not module-sym)
         (find-standards-with-symbol sym)
         (cons module-sym (find-standards-with-symbol sym)))))
+
+  (define (read* str)
+    (with-input-from-string str (lambda () (read))))
   
-  (define (fmt node prefix)
+  (define (eval* str)
+    (cond
+     ((symbol? str) (eval str))
+     ((string? str) (eval (read* str)))
+     (else (eval* (->string str)))))
+  
+  (define (fmt node)
     (memoize
-     `(fmt ,node ,prefix)
+     `(fmt ,node)
      (lambda ()
-       (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))
+       (let* ((mod (cadr node))
+             (sym (car node))
              (rest (cddr node))
              (type (if (or (list? rest) (pair? rest)) (car rest) rest))
-             (module-list (make-module-list fuzzy-entry module prefix-exists)))
+             (mod-list (make-module-list sym mod)))
         (cond
          ((equal? 'macro type)
-          `(,fuzzy-entry ("args" (("required" <macro>)
-                                  ("optional" ...)
-                                  ("key")))
-                         ("module" ,@module-list)))
+          `(,sym ("args" (("required" <macro>)
+                          ("optional" ...)
+                          ("key")))
+            ("module" ,@mod-list)))
          ((or (equal? 'variable type)
               (equal? 'constant type))
-          (if (not module)
-              `(,fuzzy-entry ("value" . ,(eval original-entry)))
+          (if (not mod)
+              `(,sym ("value" . ,(eval* sym)))
               (let* ((original-module (current-module))
-                     (desired-module (find-module module))
+                     (desired-module (find-module mod))
                      (value (begin (switch-module desired-module)
-                                   (eval original-entry))))
+                                   (eval* sym))))
                 (switch-module original-module)
-                `(,fuzzy-entry ("value" . ,value)
-                               ("module" ,@module-list)))))
+                `(,sym ("value" . ,value)
+                       ("module" ,@mod-list)))))
          (else
           (let ((reqs '())
                 (opts '())
@@ -441,7 +428,7 @@
 
             (define (clean-arg arg)
               (let ((s (->string arg)))
-                (string->symbol (substring/shared s 0 (add1 (string-skip-right 
s char-set:digit))))))
+                (read* (substring/shared s 0 (add1 (string-skip-right s 
char-set:digit))))))
 
             (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
               (when (not (null? args))
@@ -467,20 +454,18 @@
 
             (collect-args args)
 
-            `(,fuzzy-entry ("args" (("required" ,@reqs)
-                                    ("optional" ,@opts)
-                                    ("key" ,@keys)))
-                           ("module" ,@module-list)))))))))
+            `(,sym ("args" (("required" ,@reqs)
+                            ("optional" ,@opts)
+                            ("key" ,@keys)))
+                   ("module" ,@mod-list)))))))))
 
   ;; Builds a signature list from an identifier
   (define (find-signatures sym)
     (memoize
      `(find-signatures ,sym)
      (lambda ()
-       (let ((result (find-symbol-information sym)))
-        (map
-         (cut fmt <> (cdr result))
-         (car result))))))
+       (let ((result (symbol-information-list sym)))
+        (map fmt result)))))
 
   ;; Builds the documentation from Chicken Doc for a specific symbol
   (define (make-doc symbol #!optional (filter-for-type #f))
@@ -597,12 +582,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
   (define (geiser-completions prefix . rest)
-    (let* ((result (find-symbol-information prefix))
-          (prefix (cdr result))
-          (result-list (car result)))
-      (map
-       (cut string-append prefix <>)
-       (map car result-list))))
+    (let ((prefix (->string prefix)))
+      (filter (cut string-has-prefix? <> prefix)
+             (map ->string (map car (symbol-information-list prefix))))))
 
   (define (geiser-module-completions prefix . rest)
     (let ((prefix (->string prefix)))
@@ -613,8 +595,6 @@
      ((null? ids) '())
      ((not (list? ids))
       (geiser-autodoc (list ids)))
-     ((not (symbol? (car ids)))
-      (geiser-autodoc (cdr ids)))
      (else
       (let ((details (find-signatures (car ids))))
        (if (null? details)