summaryrefslogtreecommitdiff
path: root/scheme/chicken/geiser
diff options
context:
space:
mode:
Diffstat (limited to 'scheme/chicken/geiser')
-rw-r--r--scheme/chicken/geiser/emacs.scm192
1 files changed, 103 insertions, 89 deletions
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
index aca0e04..d5bddf5 100644
--- a/scheme/chicken/geiser/emacs.scm
+++ b/scheme/chicken/geiser/emacs.scm
@@ -231,7 +231,25 @@
(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-values (((name module) (remove-internal-name-mangling (car lst))))
+ (append (list name module) (cdr lst))))
+ (apropos-information-list "" #:macros? #t)))))
+
+ (define (find-symbol-information prefix)
+ (memoize
+ `(find-symbol-information ,prefix)
+ (lambda ()
+ (filter
+ (lambda (info)
+ (string-has-prefix? (car info) (->string prefix)))
+ (symbol-information-list)))))
+
(define debug-log (make-parameter #f))
(define (write-to-log form)
(when (geiser-use-debug-log)
@@ -242,19 +260,20 @@
(file-write (debug-log) "\n")))
(define (remove-internal-name-mangling sym)
- (let* ((sym (->string sym))
+ (let* ((sym (symbol->string sym))
(octothorpe-index (string-index-right sym #\#)))
(if octothorpe-index
(values (substring/shared sym (add1 octothorpe-index))
(substring/shared sym 0 octothorpe-index))
- (values sym '()))))
+ (values sym #f))))
(define (string-has-prefix? s prefix)
- (let ((s-length (string-length s))
- (prefix-length (string-length prefix)))
- (and
- (< prefix-length s-length)
- (string-contains s prefix 0 prefix-length))))
+ (cond
+ ((= 0 (string-length prefix)) #t)
+ ((= 0 (string-length s)) #f)
+ ((eq? (string-ref s 0) (string-ref prefix 0))
+ (string-has-prefix? (substring/shared s 1) (substring/shared prefix 1)))
+ (else #f)))
;; This really should be a chicken library function
(define (write-exception exn)
@@ -369,87 +388,86 @@
(match-nodes sym)))))
(define (make-module-list sym module-sym)
- (if (null? module-sym)
+ (if (not module-sym)
(find-standards-with-symbol sym)
(cons module-sym (find-standards-with-symbol sym))))
-
- (define (fmt sym node)
- (let* ((entry-str (car node))
- (module (cadr node))
- (rest (cddr node))
- (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
- (cond
- ((equal? 'macro type)
- `(,entry-str ("args" (("required" <macro>)
- ("optional" ...)
- ("key")))
- ("module" ,@(make-module-list sym module))))
- ((or (equal? 'variable type)
- (equal? 'constant type))
- (if (null? module)
- `(,entry-str ("value" . ,(eval sym)))
- (let* ((original-module (current-module))
- (desired-module (find-module (string->symbol module)))
- (value (begin (switch-module desired-module)
- (eval sym))))
- (switch-module original-module)
- `(,entry-str ("value" . ,value)
- ("module" ,@(make-module-list sym module))))))
- (else
- (let ((reqs '())
- (opts '())
- (keys '())
- (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
-
- (define (clean-arg arg)
- (let ((s (->string arg)))
- (string->symbol (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))
- (cond
- ((or (pair? args) (list? args))
- (cond
- ((eq? '#!key (car args))
- (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
- ((eq? '#!optional (car args))
- (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
- (else
- (begin
- (cond
- (reqs?
- (set! reqs (append reqs (list (clean-arg (car args))))))
- (opts?
- (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
- (keys?
- (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
- (collect-args (cdr args))))))
- (else
- (set! opts (list (clean-arg args) '...))))))
-
- (collect-args args)
-
- `(,entry-str ("args" (("required" ,@reqs)
- ("optional" ,@opts)
- ("key" ,@keys)))
- ("module" ,@(make-module-list sym module))))))))
+
+ (define (fmt node)
+ (memoize
+ `(fmt ,node)
+ (lambda ()
+ (let* ((entry (string->symbol (car node)))
+ (module (cadr node))
+ (module (if module (string->symbol module) #f))
+ (rest (cddr node))
+ (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
+ (cond
+ ((equal? 'macro type)
+ `(,entry ("args" (("required" <macro>)
+ ("optional" ...)
+ ("key")))
+ ("module" ,@(make-module-list entry module))))
+ ((or (equal? 'variable type)
+ (equal? 'constant type))
+ (if (not module)
+ `(,entry ("value" . ,(eval entry)))
+ (let* ((original-module (current-module))
+ (desired-module (find-module module))
+ (value (begin (switch-module desired-module)
+ (eval entry))))
+ (switch-module original-module)
+ `(,entry ("value" . ,value)
+ ("module" ,@(make-module-list entry module))))))
+ (else
+ (let ((reqs '())
+ (opts '())
+ (keys '())
+ (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+ (define (clean-arg arg)
+ (let ((s (->string arg)))
+ (string->symbol (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))
+ (cond
+ ((or (pair? args) (list? args))
+ (cond
+ ((eq? '#!key (car args))
+ (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
+ ((eq? '#!optional (car args))
+ (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
+ (else
+ (begin
+ (cond
+ (reqs?
+ (set! reqs (append reqs (list (clean-arg (car args))))))
+ (opts?
+ (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
+ (keys?
+ (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
+ (collect-args (cdr args))))))
+ (else
+ (set! opts (list (clean-arg args) '...))))))
+
+ (collect-args args)
+
+ `(,entry ("args" (("required" ,@reqs)
+ ("optional" ,@opts)
+ ("key" ,@keys)))
+ ("module" ,@(make-module-list entry module))))))))))
;; Builds a signature list from an identifier
(define (find-signatures sym)
- (map
- (cut fmt sym <>)
- (filter
- (lambda (v)
- (eq? (car v) sym))
- (map
- (lambda (s)
- ;; Remove egg name and add module
- (let-values
- (((name module) (remove-internal-name-mangling (car s))))
- (cons (string->symbol name)
- (cons (if (string? module) (string->symbol module) module)
- (cdr s)))))
- (apropos-information-list sym #:macros? #t)))))
+ (memoize
+ `(find-signatures ,sym)
+ (lambda ()
+ (let ((str (symbol->string sym)))
+ (map
+ (cut fmt <>)
+ (filter
+ (lambda (lst) (string=? (car lst) str))
+ (find-symbol-information sym)))))))
;; Builds the documentation from Chicken Doc for a specific symbol
(define (make-doc symbol #!optional (filter-for-type #f))
@@ -566,11 +584,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (geiser-completions prefix . rest)
- (let ((prefix (->string prefix)))
- (filter
- (cut string-has-prefix? <> prefix)
- (map remove-internal-name-mangling
- (apropos-list prefix #:macros? #t)))))
+ (map car (find-symbol-information prefix)))
(define (geiser-module-completions prefix . rest)
(let ((prefix (->string prefix)))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:34:34 +0000