summaryrefslogtreecommitdiff
path: root/scheme/plt/geiser
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-05-04 01:05:33 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-05-04 01:05:33 +0200
commitcdd90c3af5a1a0fcd206293e8c8cb584b575e4f0 (patch)
treec38ee1af6ce65bf1a462b93142353c53493f96f4 /scheme/plt/geiser
parent10fc0f3411cf838ee67e01df75fe8d84de367319 (diff)
downloadgeiser-chez-cdd90c3af5a1a0fcd206293e8c8cb584b575e4f0.tar.gz
geiser-chez-cdd90c3af5a1a0fcd206293e8c8cb584b575e4f0.tar.bz2
PLT: autodoc (without argument positions).
Diffstat (limited to 'scheme/plt/geiser')
-rw-r--r--scheme/plt/geiser/autodoc.ss160
-rw-r--r--scheme/plt/geiser/eval.ss4
-rw-r--r--scheme/plt/geiser/locations.ss7
-rw-r--r--scheme/plt/geiser/utils.ss43
4 files changed, 195 insertions, 19 deletions
diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss
new file mode 100644
index 0000000..bcd1218
--- /dev/null
+++ b/scheme/plt/geiser/autodoc.ss
@@ -0,0 +1,160 @@
+;; autodoc.ss -- support for autodoc
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun May 03, 2009 14:45
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+#lang scheme
+
+(provide autodoc update-module-cache)
+
+(require geiser/utils geiser/locations)
+
+(define (autodoc form)
+ (cond ((null? form) #f)
+ ((symbol? form) (describe-application (list form)))
+ ((not (pair? form)) #f)
+ ((not (list? form)) (autodoc (pair->list form)))
+ ((define-head? form) => autodoc)
+ (else (autodoc/list form))))
+
+(define (autodoc/list form)
+ (let ((lst (last form)))
+ (cond ((and (symbol? lst) (describe-application (list lst))))
+ ((and (pair? lst) (not (memq (car lst) '(quote))) (autodoc lst)))
+ (else (describe-application form)))))
+
+(define (define-head? form)
+ (define defforms '(-define
+ define define-values
+ define-method define-class define-generic define-struct
+ define-syntax define-syntaxes -define-syntax))
+ (and (= 2 (length form))
+ (memq (car form) defforms)
+ (car form)))
+
+(define (describe-application form)
+ (let* ((fun (car form))
+ (loc (symbol-location* fun))
+ (name (car loc))
+ (path (cdr loc))
+ (sgn (and path (signature path name fun))))
+ (and sgn
+ (list (cons 'signature (cons fun sgn))
+ (cons 'position 0)
+ (cons 'module (module-path-name->name path))))))
+
+(define signatures (make-hash))
+
+(define (signature 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)))))
+
+(define (parse-signatures path)
+ (let ((result (make-hasheq)))
+ (with-handlers ((exn? (lambda (e) result)))
+ (with-input-from-file path
+ (lambda ()
+ (parameterize ((read-accept-reader #t))
+ (let loop ((stx (read-syntax path)))
+ (cond ((eof-object? stx) void)
+ ((syntax->datum stx) =>
+ (lambda (datum)
+ (parse-datum! datum result)
+ (loop (read-syntax path))))
+ (else void)))))))
+ result))
+
+(define (parse-datum! datum store)
+ (match datum
+ ((list 'module name lang forms ...)
+ (for-each (lambda (f) (parse-datum! f store)) forms))
+ ((list 'define (list name formals ...) body ...)
+ (add-signature! name formals store))
+ ((list 'define name (list 'lambda formals body ...))
+ (add-signature! name formals store))
+ (_ void)))
+
+(define (add-signature! name formals store)
+ (hash-set! store name (parse-formals formals)))
+
+(define (parse-formals formals)
+ (let loop ((formals formals) (req '()) (opt '()) (keys '()))
+ (cond ((null? formals) (make-signature req opt keys #f))
+ ((symbol? formals) (make-signature req opt keys formals))
+ ((pair? (car formals)) (loop (cdr formals)
+ req
+ (cons (car formals) opt)
+ keys))
+ ((keyword? (car formals)) (let* ((kname (keyword->symbol (car formals)))
+ (arg-id (cadr formals))
+ (name (if (pair? arg-id)
+ (list kname (cadr arg-id))
+ kname)))
+ (loop (cddr formals)
+ req
+ opt
+ (cons name keys))))
+ (else (loop (cdr formals) (cons (car formals) req) opt keys)))))
+
+(define (make-signature req opt keys rest)
+ `(,@(reverse req)
+ ,@(if (null? opt) opt
+ (cons '#:opt (reverse opt)))
+ ,@(if (null? keys) keys
+ (cons '#:key (reverse keys)))
+ ,@(if rest (list '#:rest rest) '())))
+
+(define (update-module-cache path . form)
+ (when (and (string? path)
+ (or (null? form)
+ (and (list? (car form))
+ (not (null? (car form)))
+ (memq (caar form) '(define)))))
+ (hash-remove! signatures path)))
+
+(define (infer-signature name)
+ (let ((value (namespace-variable-value name (lambda () #f))))
+ (and (procedure? value)
+ (arity->signature (procedure-arity value)))))
+
+(define (arity->signature arity)
+ (cond ((number? arity)
+ (make-signature (gen-arg-names 1 arity) '() '() #f))
+ ((arity-at-least? arity)
+ (make-signature (gen-arg-names 1 (arity-at-least-value arity))
+ '() '() 'rest))
+ (else
+ (let ((arg (map (lambda (a)
+ (if (number? a) a (list (arity-at-least-value a) '...)))
+ arity)))
+ (make-signature (list arg) '() '() #f)))))
+
+(define (gen-arg-names fst count)
+ (let* ((letts (list->vector '(#\x #\y #\z #\u #\v #\w #\t)))
+ (len (vector-length letts))
+ (lett (lambda (n) (vector-ref letts (modulo n len)))))
+ (reverse (map (lambda (n) (string->symbol (format "~a" (lett (- n 1)))))
+ (build-list (max count 1) (lambda (n) (+ n fst)))))))
+
+;;; autodoc.ss ends here
diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss
index 9c6534e..694802a 100644
--- a/scheme/plt/geiser/eval.ss
+++ b/scheme/plt/geiser/eval.ss
@@ -33,7 +33,7 @@
macroexpand
make-repl-reader)
-(require scheme/enter geiser/utils)
+(require scheme/enter geiser/utils geiser/autodoc)
(define last-result (void))
(define nowhere (open-output-nowhere))
@@ -85,6 +85,7 @@
(define (eval-in form spec)
(set-last-result (void))
(with-handlers ((exn? set-last-error))
+ (update-module-cache spec form)
(call-with-values
(lambda () (eval form (ensure-namespace spec)))
set-last-result))
@@ -95,6 +96,7 @@
(define (load-file file)
(with-handlers ((exn? set-last-error))
(let ((current-path (namespace->module-path-name (last-namespace))))
+ (update-module-cache file)
(set-last-result
(string-append (with-output-to-string
(lambda ()
diff --git a/scheme/plt/geiser/locations.ss b/scheme/plt/geiser/locations.ss
index b738a48..d1c5cb7 100644
--- a/scheme/plt/geiser/locations.ss
+++ b/scheme/plt/geiser/locations.ss
@@ -27,12 +27,13 @@
#lang scheme
(provide symbol-location
+ symbol-location*
symbol-module-name
symbol-module-path-name)
(require geiser/utils)
-(define (%symbol-location sym)
+(define (symbol-location* sym)
(let* ((id (namespace-symbol->identifier sym))
(binding (and id (identifier-binding id))))
(if (list? binding)
@@ -43,13 +44,13 @@
(cons sym #f))))
(define (symbol-location sym)
- (let* ((loc (%symbol-location sym))
+ (let* ((loc (symbol-location* sym))
(name (car loc))
(path (cdr loc)))
(list (cons 'name name)
(cons 'file (if (path? path) (path->string path) '())))))
-(define symbol-module-path-name (compose cdr %symbol-location))
+(define symbol-module-path-name (compose cdr symbol-location*))
(define symbol-module-name
(compose module-path-name->name symbol-module-path-name))
diff --git a/scheme/plt/geiser/utils.ss b/scheme/plt/geiser/utils.ss
index 9a774df..258a55d 100644
--- a/scheme/plt/geiser/utils.ss
+++ b/scheme/plt/geiser/utils.ss
@@ -26,24 +26,37 @@
#lang scheme
-(provide module-path-name->name)
+(provide module-path-name->name
+ pair->list
+ keyword->symbol)
(require srfi/13)
(define (module-path-name->name path)
- (if (path? path)
- (let* ((path (path->string path))
- (cpaths (map path->string (current-library-collection-paths)))
- (prefix-len (lambda (p)
- (let ((pl (string-length p)))
- (if (= pl (string-prefix-length p path)) pl 0))))
- (lens (map prefix-len cpaths))
- (real-path (substring path (apply max lens))))
- (if (absolute-path? real-path)
- (call-with-values (lambda () (split-path path))
- (lambda (_ basename __) basename))
- (regexp-replace "\\.[^./]*$" real-path "")))
- "<top>"))
-
+ (cond ((path? path)
+ (let* ((path (path->string path))
+ (cpaths (map (compose path->string path->directory-path)
+ (current-library-collection-paths)))
+ (prefix-len (lambda (p)
+ (let ((pl (string-length p)))
+ (if (= pl (string-prefix-length p path)) pl 0))))
+ (lens (map prefix-len cpaths))
+ (real-path (substring path (apply max lens))))
+ (if (absolute-path? real-path)
+ (call-with-values (lambda () (split-path path))
+ (lambda (_ basename __) (path->string basename)))
+ (regexp-replace "\\.[^./]*$" real-path ""))))
+ ((eq? path '#%kernel) "(kernel)")
+ ((string? path) path)
+ ((symbol? path) (symbol->string path))
+ (else "<top>")))
+
+(define (pair->list pair)
+ (let loop ((d pair) (s '()))
+ (cond ((null? d) (reverse s))
+ ((symbol? d) (reverse (cons d s)))
+ (else (loop (cdr d) (cons (car d) s))))))
+
+(define keyword->symbol (compose string->symbol keyword->string))
;;; utils.ss ends here