Breakdown of schemeland into neat submodules.

1 files changed, 183 insertions, 0 deletions

diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm
new file mode 100644
index 0000000..21ede9e
--- /dev/null
+++ b/scheme/guile/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