scheme/guile/geiser/doc.scm

   1 ;;; doc.scm -- procedures providing documentation on scheme objects
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sun Feb 08, 2009 18:44
  11
  12 (define-module (geiser doc)
  13   #:export (autodoc
  14             symbol-documentation
  15             module-exports
  16             object-signature)
  17   #:use-module (geiser utils)
  18   #:use-module (geiser modules)
  19   #:use-module (system vm program)
  20   #:use-module (ice-9 session)
  21   #:use-module (ice-9 documentation)
  22   #:use-module (ice-9 regex)
  23   #:use-module (ice-9 format)
  24   #:use-module (oop goops)
  25   #:use-module (srfi srfi-1))
  26
  27 (define (autodoc ids)
  28   (if (not (list? ids))
  29       '()
  30       (map (lambda (id) (or (autodoc* id) (list id))) ids)))
  31
  32 (define* (autodoc* id)
  33   (let ((args (obj-args (symbol->object id))))
  34     (and args
  35          `(,@(signature id args)
  36            ("module" . ,(symbol-module id))))))
  37
  38 (define (object-signature name obj)
  39   (let ((args (obj-args obj)))
  40     (and args (signature name args))))
  41
  42 (define (value-str obj)
  43   (format #f "~:@y" obj))
  44
  45 (define* (signature id args-list #:optional (detail #t))
  46   (define (arglst args kind)
  47     (let ((args (assq-ref args kind)))
  48       (cond ((or (not args) (null? args)) '())
  49             ((list? args) args)
  50             (else (list args)))))
  51   (define (mkargs as)
  52     `(("required" ,@(arglst as 'required))
  53       ("optional" ,@(arglst as 'optional)
  54        ,@(if (assq-ref as 'rest) (list "...") '()))
  55       ("key" ,@(arglst as 'keyword))))
  56   (let* ((args-list (map mkargs (if (list? args-list) args-list '())))
  57          (value (and (and detail (null? args-list))
  58                      (value-str (symbol->object id)))))
  59     `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '()))))
  60
  61 (define default-macro-args '(((required ...))))
  62
  63 (define geiser-args-key (gensym "geiser-args-key-"))
  64
  65 (define (obj-args obj)
  66   (cond ((not obj) #f)
  67         ((or (procedure? obj) (program? obj))
  68          (cond ((procedure-property obj geiser-args-key))
  69                ((arguments obj) =>
  70                 (lambda (args)
  71                   (set-procedure-property! obj geiser-args-key args)
  72                   args))
  73                (else #f)))
  74         ((and (macro? obj) (macro-transformer obj)) => macro-args)
  75         ((macro? obj) default-macro-args)
  76         (else 'variable)))
  77
  78 (define (arguments proc)
  79   (define (p-args prog)
  80     (let ((as (map (lambda (a)
  81                      ((@@ (system vm program) arity->arguments-alist) prog a))
  82                      (or (program-arities prog) '()))))
  83       (and (not (null? as)) as)))
  84   (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y)))))
  85   (cond ((is-a? proc <generic>) (generic-args proc))
  86         ((doc->args proc) => list)
  87         ((procedure-property proc 'arglist) => (clist arglist->args))
  88         ((procedure-source proc) => (clist source->args))
  89         ((and (program? proc) (p-args proc)))
  90         ((procedure-property proc 'arity) => (clist arity->args))
  91         (else #f)))
  92
  93 (define (source->args src)
  94   (let ((formals (cadr src)))
  95     (cond ((list? formals) `((required . ,formals)))
  96           ((pair? formals)
  97            `((required . ,(car formals)) (rest . ,(cdr formals))))
  98           (else #f))))
  99
 100 (define (macro-args tf)
 101   (define* (collect args #:optional (req '()))
 102     (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f)))
 103           ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args)))
 104           ((and (pair? args) (symbol? (car args)))
 105            (collect (cdr args) (cons (car args) req)))
 106           (else #f)))
 107   (let* ((pats (procedure-property tf 'patterns))
 108          (args (and pats (filter-map collect pats))))
 109     (or (and args (not (null? args)) args) default-macro-args)))
 110
 111 (define (arity->args art)
 112   (define (gen-arg-names count)
 113     (map (lambda (x) '_) (iota (max count 0))))
 114   (let ((req (car art))
 115         (opt (cadr art))
 116         (rest (caddr art)))
 117     `(,@(if (> req 0)
 118             (list (cons 'required (gen-arg-names req)))
 119             '())
 120       ,@(if (> opt 0)
 121             (list (cons 'optional (gen-arg-names opt)))
 122             '())
 123       ,@(if rest (list (cons 'rest 'rest)) '()))))
 124
 125 (define (arglist->args arglist)
 126   `((required . ,(car arglist))
 127     (optional . ,(cadr arglist))
 128     (keyword . ,(caddr arglist))
 129     (rest . ,(car (cddddr arglist)))))
 130
 131 (define (doc->args proc)
 132   (define proc-rx "-- Scheme Procedure: ([^[\n]+)\n")
 133   (define proc-rx2 "-- Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)")
 134   (let ((doc (object-documentation proc)))
 135     (and doc
 136          (let ((match (or (string-match proc-rx doc)
 137                           (string-match proc-rx2 doc))))
 138            (and match
 139                 (parse-signature-string (match:substring match 1)))))))
 140
 141 (define (parse-signature-string str)
 142   (define opt-arg-rx "\\[([^] ]+)\\]?")
 143   (define opt-arg-rx2 "([^ ])+\\]+")
 144   (let ((tokens (string-tokenize str)))
 145     (if (< (length tokens) 2)
 146         '()
 147         (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f))
 148           (cond ((null? tokens)
 149                  `((required ,@(map string->symbol (reverse! req)))
 150                    (optional ,@(map string->symbol (reverse! opt)))
 151                    ,@(if rest
 152                          (list (cons 'rest (string->symbol rest)))
 153                          '())))
 154                 ((string=? "." (car tokens))
 155                  (if (not (null? (cdr tokens)))
 156                      (loop (cddr tokens) req opt (cadr tokens))
 157                      (loop '() req opt "rest")))
 158                 ((or (string-match opt-arg-rx (car tokens))
 159                      (string-match opt-arg-rx2 (car tokens)))
 160                  => (lambda (m)
 161                       (loop (cdr tokens)
 162                             req
 163                             (cons (match:substring m 1) opt)
 164                             rest)))
 165                 (else (loop (cdr tokens)
 166                             (cons (car tokens) req)
 167                             opt
 168                             rest)))))))
 169
 170 (define (generic-args gen)
 171   (define (src> src1 src2)
 172     (> (length (cadr src1)) (length (cadr src2))))
 173   (define (src m)
 174     (catch #t
 175       (lambda () (method-source m))
 176       (lambda (k . a) #f)))
 177   (let* ((methods (generic-function-methods gen))
 178          (srcs (filter identity (map src methods))))
 179     (cond ((and (null? srcs)
 180                 (not (null? methods))
 181                 (method-procedure (car methods))) => arguments)
 182           ((not (null? srcs)) (list (source->args (car (sort! srcs src>)))))
 183           (else '(((rest . rest)))))))
 184
 185 (define (symbol-documentation sym)
 186   (let ((obj (symbol->object sym)))
 187     (if obj
 188         `(("signature" . ,(or (obj-signature sym obj #f) sym))
 189           ("docstring" . ,(docstring sym obj))))))
 190
 191 (define (docstring sym obj)
 192   (define (valuable?)
 193     (not (or (macro? obj) (procedure? obj) (program? obj))))
 194   (with-output-to-string
 195     (lambda ()
 196       (let* ((type (cond ((macro? obj) "A macro")
 197                          ((procedure? obj) "A procedure")
 198                          ((program? obj) "A compiled program")
 199                          (else "An object")))
 200              (modname (symbol-module sym))
 201              (doc (object-documentation obj)))
 202         (display type)
 203         (if modname
 204             (begin
 205               (display " in module ")
 206               (display modname)
 207               (display ".")))
 208         (newline)
 209         (if doc (begin (newline) (display doc)))
 210         (if (valuable?) (begin (newline)
 211                                (display "Value:")
 212                                (newline)
 213                                (display "   ")
 214                                (display (value-str obj))))))))
 215
 216 (define* (obj-signature sym obj #:optional (detail #t))
 217   (let ((args (obj-args obj)))
 218     (and args (signature sym args detail))))
 219
 220 (define (module-exports mod-name)
 221   (define elt-sort (make-symbol-sort car))
 222   (let* ((mod (catch #t
 223                 (lambda () (resolve-interface mod-name))
 224                 (lambda args (resolve-module mod-name))))
 225          (elts (hash-fold classify-module-object
 226                           (list '() '() '())
 227                           (module-obarray mod)))
 228          (elts (map elt-sort elts))
 229          (subs (map (lambda (m) (list (module-name m)))
 230                     (submodules (resolve-module mod-name #f)))))
 231     (list (cons "modules" subs)
 232           (cons "procs" (car elts))
 233           (cons "syntax" (cadr elts))
 234           (cons "vars" (caddr elts)))))
 235
 236 (define (classify-module-object name var elts)
 237   (let ((obj (and (variable-bound? var)
 238                   (variable-ref var))))
 239     (cond ((or (not obj) (module? obj)) elts)
 240           ((or (procedure? obj) (program? obj))
 241            (list (cons (list name `("signature" . ,(obj-signature name obj)))
 242                        (car elts))
 243                  (cadr elts)
 244                  (caddr elts)))
 245           ((macro? obj)
 246            (list (car elts)
 247                  (cons (list name `("signature" . ,(obj-signature name obj)))
 248                        (cadr elts))
 249                  (caddr elts)))
 250           (else (list (car elts)
 251                       (cadr elts)
 252                       (cons (list name) (caddr elts)))))))