summaryrefslogtreecommitdiff
path: root/geiser/doc.scm
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-03-02 03:13:59 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-03-02 03:13:59 +0100
commit8cb76f1c5887d51fb96750f6dd97b8381f783fe6 (patch)
tree52e9114bf3a2e9b017ed895ecad7d0e97f66affe /geiser/doc.scm
parentd69ca12060ef0eee16a59528b6ebeefbc38cdde2 (diff)
downloadgeiser-guile-8cb76f1c5887d51fb96750f6dd97b8381f783fe6.tar.gz
geiser-guile-8cb76f1c5887d51fb96750f6dd97b8381f783fe6.tar.bz2
Breakdown of schemeland into neat submodules.
Diffstat (limited to 'geiser/doc.scm')
-rw-r--r--geiser/doc.scm183
1 files changed, 183 insertions, 0 deletions
diff --git a/geiser/doc.scm b/geiser/doc.scm
new file mode 100644
index 0000000..21ede9e
--- /dev/null
+++ b/geiser/doc.scm
@@ -0,0 +1,183 @@
+;; doc.scm -- name says it all
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Feb 08, 2009 18:44
+
+;; 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/>.
+
+;;; Comentary:
+
+;; Procedures providing documentation on scheme objects.
+
+;;; Code:
+
+(define-module (geiser doc)
+ #:export (autodoc
+ symbol-documentation)
+ #:use-module (geiser utils)
+ #:use-module (geiser modules)
+ #:use-module (system vm program)
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 documentation)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-1))
+
+(define (autodoc form)
+ (cond ((null? form) #f)
+ ((symbol? form) (describe-application (list form)))
+ ((and (pair? form) (not (list? form))) (autodoc (pair->list form)))
+ ((list? form)
+ (let ((lst (last form)))
+ (cond ((symbol? lst) (or (describe-application (list lst))
+ (describe-application form)))
+ ((pair? lst)
+ (or (autodoc (pair->list lst))
+ (autodoc (map (lambda (s) (if (pair? s) (gensym) s)) form))))
+ (else (describe-application form)))))
+ (else #f)))
+
+(define (describe-application form)
+ (let* ((fun (car form))
+ (args (obj-args (symbol->object fun))))
+ (and args
+ (list (cons 'signature (signature fun args))
+ (cons 'position (find-position args form))
+ (cons 'module (symbol-module fun))))))
+
+(define (arglst args kind)
+ (let ((args (assq-ref args kind)))
+ (cond ((or (not args) (null? args)) '())
+ ((list? args) args)
+ (else (list args)))))
+
+(define (signature fun args)
+ (let ((req (arglst args 'required))
+ (opt (arglst args 'optional))
+ (key (arglst args 'keyword))
+ (rest (assq-ref args 'rest)))
+ (let ((sgn `(,fun ,@req
+ ,@(if (not (null? opt)) (cons #:opt opt) '())
+ ,@(if (not (null? key)) (cons #:key key) '()))))
+ (if rest `(,@sgn #:rest ,rest) sgn))))
+
+(define (find-position args form)
+ (let* ((lf (length form))
+ (lf-1 (- lf 1)))
+ (if (= 1 lf) 0
+ (let ((req (length (arglst args 'required)))
+ (opt (length (arglst args 'optional)))
+ (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k)))
+ (arglst args 'keyword)))
+ (rest (assq-ref args 'rest)))
+ (cond ((<= lf (+ 1 req)) lf-1)
+ ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1))
+ ((or (memq (last form) keys)
+ (memq (car (take-right form 2)) keys)) =>
+ (lambda (sl)
+ (+ 2 req
+ (if (> opt 0) (+ 1 opt) 0)
+ (- (length keys) (length sl)))))
+ (else (+ 1 req
+ (if (> opt 0) (+ 1 opt) 0)
+ (if (null? keys) 0 (+ 1 (length keys)))
+ (if rest 2 0))))))))
+
+(define (obj-args obj)
+ (cond ((not obj) #f)
+ ((or (procedure? obj) (program? obj)) (arguments obj))
+ ((macro? obj) (or (obj-args (macro-transformer obj))
+ '((required ...))))
+ (else #f)))
+
+(define (arguments proc)
+ (cond
+ ((is-a? proc <generic>) (generic-args proc))
+ ((procedure-property proc 'arglist) => arglist->args)
+ ((procedure-source proc) => source->args)
+ ((program? proc) ((@ (system vm program) program-arguments) proc))
+ ((procedure-property proc 'arity) => arity->args)
+ (else #f)))
+
+(define (source->args src)
+ (let ((formals (cadr src)))
+ (cond ((list? formals) `((required . ,formals)))
+ ((pair? formals)
+ `((required . ,(car formals)) (rest . ,(cdr formals))))
+ (else #f))))
+
+(define (arity->args art)
+ (let ((req (car art))
+ (opt (cadr art))
+ (rest (caddr art)))
+ `(,@(if (> req 0) (list (cons 'required (gen-arg-names 1 req))) '())
+ ,@(if (> opt 0) (list (cons 'optional (gen-arg-names (+ 1 req) opt))) '())
+ ,@(if rest (list (cons 'rest 'rest)) '()))))
+
+(define (gen-arg-names fst count)
+ (map (lambda (n) (string->symbol (format "arg-~A" (+ fst n))))
+ (iota (max count 1))))
+
+(define (arglist->args arglist)
+ `((required . ,(car arglist))
+ (optional . ,(cadr arglist))
+ (keyword . ,(caddr arglist))
+ (rest . ,(car (cddddr arglist)))))
+
+(define (generic-args gen)
+ (define (src> src1 src2)
+ (> (length (cadr src1)) (length (cadr src2))))
+ (define (src m)
+ (catch #t
+ (lambda () (method-source m))
+ (lambda (k . a) #f)))
+ (let* ((methods (generic-function-methods gen))
+ (srcs (filter identity (map src methods))))
+ (cond ((and (null? srcs) (null? methods)) '((rest . rest)))
+ ((and (null? srcs)
+ (not (null? methods))
+ (method-procedure (car methods)))
+ => arguments)
+ ((not (null? srcs)) (source->args (car (sort! srcs src>))))
+ (else '((rest . rest))))))
+
+(define (symbol-documentation sym)
+ (let ((obj (symbol->object sym)))
+ (if obj
+ `((signature . ,(or (obj-signature sym obj) sym))
+ (docstring . ,(docstring sym obj))))))
+
+(define (docstring sym obj)
+ (with-output-to-string
+ (lambda ()
+ (let* ((type (cond ((macro? obj) "A macro")
+ ((procedure? obj) "A procedure")
+ ((program? obj) "A compiled program")
+ (else "An object")))
+ (modname (symbol-module sym))
+ (doc (object-documentation obj)))
+ (display type)
+ (if modname
+ (begin
+ (display " in module ")
+ (display modname)))
+ (newline)
+ (if doc (display doc))))))
+
+(define (obj-signature sym obj)
+ (let ((args (obj-args obj)))
+ (and args (signature sym args))))
+
+;;; doc.scm ends here