summaryrefslogtreecommitdiff
path: root/src/geiser/geiser.ss
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2022-10-09 02:23:24 +0100
committerjao <jao@gnu.org>2022-10-09 02:31:21 +0100
commit21d35aa8d6b2e2b281a773514640fb77586a543c (patch)
tree7d1b5e7e6ed62cd4c0c505d06c2744f1ceaab13b /src/geiser/geiser.ss
parentdb4d645996d1c3da9d50504baa34f3c685cd3b83 (diff)
downloadgeiser-chez-21d35aa8d6b2e2b281a773514640fb77586a543c.tar.gz
geiser-chez-21d35aa8d6b2e2b281a773514640fb77586a543c.tar.bz2
autodoc improvements (signatures from arities, values)
Diffstat (limited to 'src/geiser/geiser.ss')
-rw-r--r--src/geiser/geiser.ss107
1 files changed, 51 insertions, 56 deletions
diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss
index 0a7798b..f20434b 100644
--- a/src/geiser/geiser.ss
+++ b/src/geiser/geiser.ss
@@ -94,71 +94,66 @@
(substring? prefix el))
(map write-to-string (library-list))))
- (define (procedure-parameter-list p)
+ (define (arity->parameter-list p)
+ (define (nparams n)
+ (map (lambda (n) (string->symbol (format "x~a" n))) (iota n)))
+ (let* ((m (procedure-arity-mask p))
+ (pm (if (< m 0) (+ 1 (lognot m)) m))
+ (n (if (> pm 0) (/ (log pm) (log 2)) 0)))
+ (let loop ((k 1) (pl '()))
+ (cond ((> k n)
+ (reverse (if (< m 0) (cons (append (car pl) '(...)) pl) pl)))
+ ((logbit? k pm) (loop (+ k 1) (cons (nparams k) pl)))
+ (else (loop (+ k 1) pl))))))
+
+ (define (source->parameter-list p)
;; same as (inspect object), then hitting c
- (let ((s (((inspect/object p) 'code) 'source)))
- (if s
- (let ((form (s 'value)))
- (if (and (list? form)
- (>= (length form) 2))
- (case (car form)
- [(lambda) (list (cadr form))]
- [(case-lambda) (map car (cdr form))]
- [(record-predicate record-accessor)
- (list (list (record-type-name (cadr (cadr form)))))]
- [(record-mutator)
- (let ([rtd (cadr (cadr form))]
- [field-idx (caddr form)])
- (list (list (record-type-name rtd)
- (vector-ref (record-type-field-names rtd) field-idx))))]
- [(record-constructor)
- (let* ([rcd (cadr (cadr form))]
- [rtd (((inspect/object rcd) 'ref 'rtd) 'value)])
- (list (vector->list (record-type-field-names rtd))))]
- [else #f])
- #f))
- #f)))
+ (let* ((s (((inspect/object p) 'code) 'source))
+ (form (and s (s 'value))))
+ (and (list? form)
+ (>= (length form) 2)
+ (case (car form)
+ [(lambda) (list (cadr form))]
+ [(case-lambda) (map car (cdr form))]
+ [(record-predicate record-accessor)
+ (list (list (record-type-name (cadr (cadr form)))))]
+ [(record-mutator)
+ (let ([rtd (cadr (cadr form))]
+ [field-idx (caddr form)])
+ (list (list (record-type-name rtd)
+ (vector-ref (record-type-field-names rtd)
+ field-idx))))]
+ [(record-constructor)
+ (let* ([rcd (cadr (cadr form))]
+ [rtd (((inspect/object rcd) 'ref 'rtd) 'value)])
+ (list (vector->list (record-type-field-names rtd))))]
+ [else #f]))))
(define (operator-arglist operator)
- (define (make-autodoc-arglist arglist)
- (let loop ([arglist arglist]
- [optionals? #f]
- [required '()]
- [optional '()])
- (cond ((null? arglist)
- `(("required" ,@(reverse required))
- ("optional" ,@(reverse optional))
- ("key")
- ;; ("module" ,module)
- ))
- ((symbol? arglist)
- (loop '()
- #t
- required
- (cons "..." (cons arglist optional))))
- (else
- (loop
- (cdr arglist)
- optionals?
- (if optionals? required (cons (car arglist) required))
- (if optionals? (cons (car arglist) optional) optional))))))
- (let ([binding (eval operator)])
+ (define (procedure-parameter-list p)
+ (and (procedure? p)
+ (or (source->parameter-list p)
+ (arity->parameter-list p))))
+ (define (autodoc-arglist* args req)
+ (cond ((null? args) (list (list* "required" (reverse req))))
+ ((pair? args) (autodoc-arglist* (cdr args) (cons (car args) req)))
+ (else `(("required" . ,(reverse req))
+ ("optional" ,args)))))
+ (define (autodoc-arglist arglist) (autodoc-arglist* arglist '()))
+ (let ([binding (with-exception-handler (lambda (e) #f)
+ (lambda () (eval operator)))])
(if binding
(let ([arglists (procedure-parameter-list binding)])
- `(,operator ("args" ,@(map make-autodoc-arglist arglists))))
+ (if arglists
+ `(,operator ("args" ,@(map autodoc-arglist arglists)))
+ `(,operator ("value" . ,(write-to-string binding)))))
'())))
-
(define (geiser:autodoc ids . rest)
(cond ((null? ids) '())
- ((not (list? ids))
- (geiser:autodoc (list ids)))
- ((not (symbol? (car ids)))
- (geiser:autodoc (cdr ids)))
- (else
- (map (lambda (id)
- (operator-arglist id))
- ids))))
+ ((not (list? ids)) (geiser:autodoc (list ids)))
+ ((not (symbol? (car ids))) (geiser:autodoc (cdr ids)))
+ (else (map operator-arglist ids))))
(define (geiser:no-values)
#f)