diff options
Diffstat (limited to 'scheme/plt/geiser')
| -rw-r--r-- | scheme/plt/geiser/autodoc.ss | 57 |
1 files changed, 34 insertions, 23 deletions
diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index ef73cc1..c349f6e 100644 --- a/scheme/plt/geiser/autodoc.ss +++ b/scheme/plt/geiser/autodoc.ss @@ -31,11 +31,12 @@ (let* ((loc (symbol-location* id)) (name (car loc)) (path (cdr loc)) - (sgn (and path (find-signature path name id)))) - (and sgn + (sgns (and path (find-signatures path name id))) + (sgns (if (list? sgns) sgns '()))) + (and sgns `(,id (name . ,name) - (args ,@(format-signature sgn)) + (args ,@(map format-signature sgns)) (module . ,(module-path-name->name path))))))) (define (format-signature sign) @@ -51,11 +52,11 @@ (define-struct signature (required optional keys rest)) -(define (find-signature path name local-name) +(define (find-signatures path name local-name) (let ((path (if (path? path) (path->string path) path))) (hash-ref! (hash-ref! signatures path (lambda () (parse-signatures path))) name - (lambda () (infer-signature local-name))))) + (lambda () (infer-signatures local-name))))) (define (parse-signatures path) (let ((result (make-hasheq))) @@ -82,6 +83,8 @@ (add-signature! name formals store)) ((list 'define name (list 'lambda formals body ...)) (add-signature! name formals store)) + ((list 'define name (list 'case-lambda forms ...)) + (for-each (lambda (f) (parse-datum! (list 'define name (cons 'lambda f)))) forms)) ((list 'define-for-syntax (list name formals ...) body ...) (add-signature! name formals store)) ((list 'define-for-syntax name (list 'lambda formals body ...)) @@ -92,7 +95,10 @@ (define (add-signature! name formals store) (when (symbol? name) - (hash-set! store name (parse-formals formals)))) + (hash-set! store + name + (cons (parse-formals formals) + (hash-ref store name '()))))) (define (parse-formals formals) (let loop ((formals formals) (req '()) (opt '()) (keys '())) @@ -115,38 +121,43 @@ (cons name keys)))) (else (loop (cdr formals) (cons (car formals) req) opt keys))))) -(define (infer-signature name) +(define (infer-signatures name) (define syntax-tag (cons 1 0)) (define error-tag (cons 1 1)) (define generic-signature (make-signature '(...) '() '() #f)) (let ((value (with-handlers ((exn:fail:syntax? (lambda (_) syntax-tag)) (exn:fail:contract:variable? (lambda (_) error-tag))) (namespace-variable-value name)))) - (cond ((procedure? value) - (arity->signature (procedure-arity value))) - ((eq? value syntax-tag) generic-signature) + (cond ((procedure? value) (arity->signatures (procedure-arity value))) + ((eq? value syntax-tag) (list generic-signature)) ((eq? value error-tag) #f) (else 'variable)))) -(define (arity->signature arity) +(define (arity->signatures arity) (define (args fst count) (let* ((letts (list->vector '(#\x #\y #\z #\u #\v #\w #\r #\s))) (len (vector-length letts)) (lett (lambda (n) (vector-ref letts (modulo n len))))) (map (lambda (n) (string->symbol (format "~a" (lett n)))) (build-list count (lambda (n) (+ n fst)))))) - (cond ((number? arity) - (make-signature (args 0 arity) '() '() #f)) - ((arity-at-least? arity) - (make-signature (args 0 (arity-at-least-value arity)) '() '() 'rest)) - (else - (let* ((arg-nos (map (lambda (a) - (if (number? a) a (arity-at-least-value a))) - arity)) - (min-val (apply min arg-nos)) - (max-val (apply max arg-nos)) - (opt-no (- max-val min-val))) - (make-signature (args 0 min-val) (args min-val opt-no) '() #f))))) + (define (arity->signature arity) + (cond ((number? arity) + (make-signature (args 0 arity) '() '() #f)) + ((arity-at-least? arity) + (make-signature (args 0 (arity-at-least-value arity)) '() '() 'rest)))) + (define (conseq? lst) + (cond ((< (length lst) 2) (number? (car lst))) + ((and (number? (car lst)) + (number? (cadr lst)) + (eqv? (+ 1 (car lst)) (cadr lst))) + (conseq? (cdr lst))) + (else #f))) + (cond ((and (list? arity) (conseq? arity)) + (let ((mi (apply min arity)) + (ma (apply max arity))) + (list (make-signature (args 0 mi) (args mi (- ma mi)) '() #f)))) + ((list? arity) (map arity->signature arity)) + (else (list (arity->signature arity))))) (define (update-module-cache path . form) (when (and (string? path) |