diff options
Diffstat (limited to 'geiser/doc.scm')
| -rw-r--r-- | geiser/doc.scm | 183 |
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 |