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             object-signature)
  16   #:use-module (geiser utils)
  17   #:use-module (geiser modules)
  18   #:use-module (system vm program)
  19   #:use-module (ice-9 session)
  20   #:use-module (ice-9 documentation)
  21   #:use-module (ice-9 regex)
  22   #:use-module (ice-9 format)
  23   #:use-module (oop goops)
  24   #:use-module (srfi srfi-1))
  25
  26 (define (autodoc ids)
  27   (if (not (list? ids))
  28       '()
  29       (map (lambda (id) (or (autodoc* id) (list id))) ids)))
  30
  31 (define (autodoc* id)
  32   (let ((args (obj-args (symbol->object id))))
  33     (and args
  34          `(,@(signature id args)
  35            (module . ,(symbol-module id))))))
  36
  37 (define (object-signature name obj)
  38   (let ((args (obj-args obj)))
  39     (and args (signature name args))))
  40
  41 (define (signature id args-list)
  42   (define (arglst args kind)
  43     (let ((args (assq-ref args kind)))
  44       (cond ((or (not args) (null? args)) '())
  45             ((list? args) args)
  46             (else (list args)))))
  47   (define (mkargs as)
  48     `((required ,@(arglst as 'required))
  49       (optional ,@(arglst as 'optional)
  50                 ,@(let ((rest (assq-ref as 'rest)))
  51                     (if rest (list "...") '())))
  52       (key ,@(arglst as 'keyword))))
  53   (let* ((args-list (map mkargs (if (list? args-list) args-list '())))
  54          (value (if (null? args-list)
  55                     (format #f "~:@y" (symbol->object id))
  56                     "")))
  57     (list id (cons 'args args-list) (cons 'value value))))
  58
  59 (define default-macro-args '(((required ...))))
  60
  61 (define (obj-args obj)
  62   (cond ((not obj) #f)
  63         ((or (procedure? obj) (program? obj)) (arguments obj))
  64         ((and (macro? obj) (macro-transformer obj)) => macro-args)
  65         ((macro? obj) default-macro-args)
  66         (else 'variable)))
  67
  68 (define (arguments proc)
  69   (define (p-arguments prog)
  70     (map (lambda (a) ((@@ (system vm program) arity->arguments-alist) prog a))
  71          (or (program-arities prog) '())))
  72   (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y)))))
  73   (cond ((is-a? proc <generic>) (generic-args proc))
  74         ((procedure-property proc 'arglist) => (clist arglist->args))
  75         ((procedure-source proc) => (clist source->args))
  76         ((doc->args proc) => list)
  77         ((program? proc) (let ((a (p-arguments proc)))
  78                            (and (not (null? a)) a)))
  79         ((procedure-property proc 'arity) => (clist arity->args))
  80         (else #f)))
  81
  82 (define (source->args src)
  83   (let ((formals (cadr src)))
  84     (cond ((list? formals) `((required . ,formals)))
  85           ((pair? formals)
  86            `((required . ,(car formals)) (rest . ,(cdr formals))))
  87           (else #f))))
  88
  89 (define (macro-args tf)
  90   (define* (collect args #:optional (req '()))
  91     (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f)))
  92           ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args)))
  93           ((and (pair? args) (symbol? (car args)))
  94            (collect (cdr args) (cons (car args) req)))
  95           (else #f)))
  96   (let* ((pats (procedure-property tf 'patterns))
  97          (args (and pats (filter-map collect pats))))
  98     (or (and args (not (null? args)) args) default-macro-args)))
  99
 100 (define (arity->args art)
 101   (define (gen-arg-names count)
 102     (map (lambda (x) '_) (iota (max count 0))))
 103   (let ((req (car art))
 104         (opt (cadr art))
 105         (rest (caddr art)))
 106     `(,@(if (> req 0)
 107             (list (cons 'required (gen-arg-names req)))
 108             '())
 109       ,@(if (> opt 0)
 110             (list (cons 'optional (gen-arg-names opt)))
 111             '())
 112       ,@(if rest (list (cons 'rest 'rest)) '()))))
 113
 114 (define (arglist->args arglist)
 115   `((required . ,(car arglist))
 116     (optional . ,(cadr arglist))
 117     (keyword . ,(caddr arglist))
 118     (rest . ,(car (cddddr arglist)))))
 119
 120 (define (doc->args proc)
 121   (define proc-rx "-- Scheme Procedure: ([^[\n]+)\n")
 122   (define proc-rx2 "-- Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)")
 123   (cond ((procedure-property proc 'geiser-document-args))
 124         ((object-documentation proc)
 125          => (lambda (doc)
 126               (let* ((match (or (string-match proc-rx doc)
 127                                 (string-match proc-rx2 doc)))
 128                      (args (and match
 129                                 (parse-signature-string
 130                                  (match:substring match 1)))))
 131                 (set-procedure-property! proc 'geiser-document-args args)
 132                 args)))
 133         (else #f)))
 134
 135 (define (parse-signature-string str)
 136   (define opt-arg-rx "\\[([^] ]+)\\]?")
 137   (define opt-arg-rx2 "([^ ])+\\]+")
 138   (let ((tokens (string-tokenize str)))
 139     (if (< (length tokens) 2)
 140         '()
 141         (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f))
 142           (cond ((null? tokens)
 143                  `((required ,@(map string->symbol (reverse! req)))
 144                    (optional ,@(map string->symbol (reverse! opt)))
 145                    ,@(if rest
 146                          (list (cons 'rest (string->symbol rest)))
 147                          '())))
 148                 ((string=? "." (car tokens))
 149                  (if (not (null? (cdr tokens)))
 150                      (loop (cddr tokens) req opt (cadr tokens))
 151                      (loop '() req opt "rest")))
 152                 ((or (string-match opt-arg-rx (car tokens))
 153                      (string-match opt-arg-rx2 (car tokens)))
 154                  => (lambda (m)
 155                       (loop (cdr tokens)
 156                             req
 157                             (cons (match:substring m 1) opt)
 158                             rest)))
 159                 (else (loop (cdr tokens)
 160                             (cons (car tokens) req)
 161                             opt
 162                             rest)))))))
 163
 164 (define (generic-args gen)
 165   (define (src> src1 src2)
 166     (> (length (cadr src1)) (length (cadr src2))))
 167   (define (src m)
 168     (catch #t
 169       (lambda () (method-source m))
 170       (lambda (k . a) #f)))
 171   (let* ((methods (generic-function-methods gen))
 172          (srcs (filter identity (map src methods))))
 173     (cond ((and (null? srcs)
 174                 (not (null? methods))
 175                 (method-procedure (car methods))) => arguments)
 176           ((not (null? srcs)) (list (source->args (car (sort! srcs src>)))))
 177           (else '(((rest . rest)))))))
 178
 179 (define (symbol-documentation sym)
 180   (let ((obj (symbol->object sym)))
 181     (if obj
 182         `((signature . ,(or (obj-signature sym obj) sym))
 183           (docstring . ,(docstring sym obj))))))
 184
 185 (define (docstring sym obj)
 186   (with-output-to-string
 187     (lambda ()
 188       (let* ((type (cond ((macro? obj) "A macro")
 189                          ((procedure? obj) "A procedure")
 190                          ((program? obj) "A compiled program")
 191                          (else "An object")))
 192              (modname (symbol-module sym))
 193              (doc (object-documentation obj)))
 194         (display type)
 195         (if modname
 196             (begin
 197               (display " in module ")
 198               (display modname)))
 199         (newline)
 200         (if doc (begin (newline) (display doc)))))))
 201
 202 (define (obj-signature sym obj)
 203   (let ((args (obj-args obj)))
 204     (and args (signature sym args))))
 205
 206 ;;; doc.scm ends here