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                 ,@(let ((rest (assq-ref as 'rest)))
  55                     (if rest (list "...") '())))
  56       (key ,@(arglst as 'keyword))))
  57   (let* ((args-list (map mkargs (if (list? args-list) args-list '())))
  58          (value (and (and detail (null? args-list))
  59                      (value-str (symbol->object id)))))
  60     `(,id (args ,@args-list) ,@(if value `((value . ,value)) '()))))
  61
  62 (define default-macro-args '(((required ...))))
  63
  64 (define geiser-args-key (gensym "geiser-args-key-"))
  65
  66 (define (obj-args obj)
  67   (cond ((not obj) #f)
  68         ((or (procedure? obj) (program? obj))
  69          (cond ((procedure-property obj geiser-args-key))
  70                ((arguments obj) =>
  71                 (lambda (args)
  72                   (set-procedure-property! obj geiser-args-key args)
  73                   args))
  74                (else #f)))
  75         ((and (macro? obj) (macro-transformer obj)) => macro-args)
  76         ((macro? obj) default-macro-args)
  77         (else 'variable)))
  78
  79 (define (arguments proc)
  80   (define (p-args prog)
  81     (let ((as (map (lambda (a)
  82                      ((@@ (system vm program) arity->arguments-alist) prog a))
  83                      (or (program-arities prog) '()))))
  84       (and (not (null? as)) as)))
  85   (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y)))))
  86   (cond ((is-a? proc <generic>) (generic-args proc))
  87         ((doc->args proc) => list)
  88         ((procedure-property proc 'arglist) => (clist arglist->args))
  89         ((procedure-source proc) => (clist source->args))
  90         ((and (program? proc) (p-args proc)))
  91         ((procedure-property proc 'arity) => (clist arity->args))
  92         (else #f)))
  93
  94 (define (source->args src)
  95   (let ((formals (cadr src)))
  96     (cond ((list? formals) `((required . ,formals)))
  97           ((pair? formals)
  98            `((required . ,(car formals)) (rest . ,(cdr formals))))
  99           (else #f))))
 100
 101 (define (macro-args tf)
 102   (define* (collect args #:optional (req '()))
 103     (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f)))
 104           ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args)))
 105           ((and (pair? args) (symbol? (car args)))
 106            (collect (cdr args) (cons (car args) req)))
 107           (else #f)))
 108   (let* ((pats (procedure-property tf 'patterns))
 109          (args (and pats (filter-map collect pats))))
 110     (or (and args (not (null? args)) args) default-macro-args)))
 111
 112 (define (arity->args art)
 113   (define (gen-arg-names count)
 114     (map (lambda (x) '_) (iota (max count 0))))
 115   (let ((req (car art))
 116         (opt (cadr art))
 117         (rest (caddr art)))
 118     `(,@(if (> req 0)
 119             (list (cons 'required (gen-arg-names req)))
 120             '())
 121       ,@(if (> opt 0)
 122             (list (cons 'optional (gen-arg-names opt)))
 123             '())
 124       ,@(if rest (list (cons 'rest 'rest)) '()))))
 125
 126 (define (arglist->args arglist)
 127   `((required . ,(car arglist))
 128     (optional . ,(cadr arglist))
 129     (keyword . ,(caddr arglist))
 130     (rest . ,(car (cddddr arglist)))))
 131
 132 (define (doc->args proc)
 133   (define proc-rx "-- Scheme Procedure: ([^[\n]+)\n")
 134   (define proc-rx2 "-- Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)")
 135   (let ((doc (object-documentation proc)))
 136     (and doc
 137          (let ((match (or (string-match proc-rx doc)
 138                           (string-match proc-rx2 doc))))
 139            (and match
 140                 (parse-signature-string (match:substring match 1)))))))
 141
 142 (define (parse-signature-string str)
 143   (define opt-arg-rx "\\[([^] ]+)\\]?")
 144   (define opt-arg-rx2 "([^ ])+\\]+")
 145   (let ((tokens (string-tokenize str)))
 146     (if (< (length tokens) 2)
 147         '()
 148         (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f))
 149           (cond ((null? tokens)
 150                  `((required ,@(map string->symbol (reverse! req)))
 151                    (optional ,@(map string->symbol (reverse! opt)))
 152                    ,@(if rest
 153                          (list (cons 'rest (string->symbol rest)))
 154                          '())))
 155                 ((string=? "." (car tokens))
 156                  (if (not (null? (cdr tokens)))
 157                      (loop (cddr tokens) req opt (cadr tokens))
 158                      (loop '() req opt "rest")))
 159                 ((or (string-match opt-arg-rx (car tokens))
 160                      (string-match opt-arg-rx2 (car tokens)))
 161                  => (lambda (m)
 162                       (loop (cdr tokens)
 163                             req
 164                             (cons (match:substring m 1) opt)
 165                             rest)))
 166                 (else (loop (cdr tokens)
 167                             (cons (car tokens) req)
 168                             opt
 169                             rest)))))))
 170
 171 (define (generic-args gen)
 172   (define (src> src1 src2)
 173     (> (length (cadr src1)) (length (cadr src2))))
 174   (define (src m)
 175     (catch #t
 176       (lambda () (method-source m))
 177       (lambda (k . a) #f)))
 178   (let* ((methods (generic-function-methods gen))
 179          (srcs (filter identity (map src methods))))
 180     (cond ((and (null? srcs)
 181                 (not (null? methods))
 182                 (method-procedure (car methods))) => arguments)
 183           ((not (null? srcs)) (list (source->args (car (sort! srcs src>)))))
 184           (else '(((rest . rest)))))))
 185
 186 (define (symbol-documentation sym)
 187   (let ((obj (symbol->object sym)))
 188     (if obj
 189         `((signature . ,(or (obj-signature sym obj #f) sym))
 190           (docstring . ,(docstring sym obj))))))
 191
 192 (define (docstring sym obj)
 193   (define (valuable?)
 194     (not (or (macro? obj) (procedure? obj) (program? obj))))
 195   (with-output-to-string
 196     (lambda ()
 197       (let* ((type (cond ((macro? obj) "A macro")
 198                          ((procedure? obj) "A procedure")
 199                          ((program? obj) "A compiled program")
 200                          (else "An object")))
 201              (modname (symbol-module sym))
 202              (doc (object-documentation obj)))
 203         (display type)
 204         (if modname
 205             (begin
 206               (display " in module ")
 207               (display modname)
 208               (display ".")))
 209         (newline)
 210         (if doc (begin (newline) (display doc)))
 211         (if (valuable?) (begin (newline)
 212                                (display "Value:")
 213                                (newline)
 214                                (display "   ")
 215                                (display (value-str obj))))))))
 216
 217 (define* (obj-signature sym obj #:optional (detail #t))
 218   (let ((args (obj-args obj)))
 219     (and args (signature sym args detail))))
 220
 221 (define (module-exports mod-name)
 222   (define elt-sort (make-symbol-sort car))
 223   (let* ((mod (catch #t
 224                 (lambda () (resolve-interface mod-name))
 225                 (lambda args (resolve-module mod-name))))
 226          (elts (hash-fold classify-module-object
 227                           (list '() '() '())
 228                           (module-obarray mod)))
 229          (elts (map elt-sort elts))
 230          (subs (map (lambda (m) (list (module-name m)))
 231                     (submodules (resolve-module mod-name #f)))))
 232     (list (cons 'modules subs)
 233           (cons 'procs (car elts))
 234           (cons 'syntax (cadr elts))
 235           (cons 'vars (caddr elts)))))
 236
 237 (define (classify-module-object name var elts)
 238   (let ((obj (and (variable-bound? var)
 239                   (variable-ref var))))
 240     (cond ((or (not obj) (module? obj)) elts)
 241           ((or (procedure? obj) (program? obj))
 242            (list (cons (list name `(signature . ,(obj-signature name obj)))
 243                        (car elts))
 244                  (cadr elts)
 245                  (caddr elts)))
 246           ((macro? obj)
 247            (list (car elts)
 248                  (cons (list name `(signature . ,(obj-signature name obj)))
 249                        (cadr elts))
 250                  (caddr elts)))
 251           (else (list (car elts)
 252                       (cadr elts)
 253                       (cons (list name) (caddr elts)))))))