module/texinfo/reflection.scm

   1 ;;;; (texinfo reflection) -- documenting Scheme as stexinfo
   2 ;;;;
   3 ;;;;    Copyright (C) 2009, 2010, 2011  Free Software Foundation, Inc.
   4 ;;;;    Copyright (C) 2003,2004,2009  Andy Wingo <wingo at pobox dot com>
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19 ;;;;
  20 \f
  21 ;;; Commentary:
  22 ;;
  23 ;;Routines to generare @code{stexi} documentation for objects and
  24 ;;modules.
  25 ;;
  26 ;;Note that in this context, an @dfn{object} is just a value associated
  27 ;;with a location. It has nothing to do with GOOPS.
  28 ;;
  29 ;;; Code:
  30
  31 (define-module (texinfo reflection)
  32   #:use-module ((srfi srfi-1) #:select (append-map))
  33   #:use-module (oop goops)
  34   #:use-module (texinfo)
  35   #:use-module (texinfo plain-text)
  36   #:use-module (srfi srfi-13)
  37   #:use-module (ice-9 session)
  38   #:use-module (ice-9 documentation)
  39   #:use-module (ice-9 optargs)
  40   #:use-module ((sxml transform) #:select (pre-post-order))
  41   #:export (module-stexi-documentation
  42             script-stexi-documentation
  43             object-stexi-documentation
  44             package-stexi-standard-copying
  45             package-stexi-standard-titlepage
  46             package-stexi-generic-menu
  47             package-stexi-standard-menu
  48             package-stexi-extended-menu
  49             package-stexi-standard-prologue
  50             package-stexi-documentation
  51             package-stexi-documentation-for-include))
  52
  53 ;; List for sorting the definitions in a module
  54 (define defs
  55   '(deftp defcv defivar deftypeivar defop deftypeop defmethod
  56     deftypemethod defopt defvr defvar deftypevr deftypevar deffn
  57     deftypefn defmac defspec defun deftypefun))
  58
  59 (define (sort-defs ordering a b)
  60   (define (def x)
  61     ;; a and b are lists of the form ((anchor ...) (def* ...)...)
  62     (cadr x))
  63   (define (name x)
  64     (cadr (assq 'name (cdadr (def x)))))
  65   (define (priority x)
  66     (list-index defs (car (def x))))
  67   (define (order x)
  68     (or (list-index ordering (string->symbol (name x)))
  69         ;; if the def is not in the list, a big number
  70         1234567890))
  71   (define (compare-in-order proc eq? < . args)
  72     (if (not (eq? (proc a) (proc b)))
  73         (< (proc a) (proc b))
  74         (or (null? args)
  75             (apply compare-in-order args))))
  76   (compare-in-order order = <
  77                     priority = <
  78                     name string=? string<=?))
  79
  80 (define (list*-join l infix restfix)
  81   (let lp ((in l) (out '()))
  82     (cond ((null? in) (reverse! out))
  83           ((symbol? in) (reverse! (cons* in restfix out)))
  84           (else (lp (cdr in) (if (null? out)
  85                                  (list (car in))
  86                                  (cons* (car in) infix out)))))))
  87
  88 (define (process-args args)
  89   (map (lambda (x) (if (string? x) x (object->string x)))
  90        (list*-join (or args '())
  91                    " " " . ")))
  92
  93 (define (get-proc-args proc)
  94   (cond
  95    ((procedure-arguments proc)
  96     => (lambda (args)
  97          (let ((required-args (assq-ref args 'required))
  98                (optional-args (assq-ref args 'optional))
  99                (keyword-args  (assq-ref args 'keyword))
 100                (rest-arg (assq-ref args 'rest)))
 101            (process-args
 102             (append
 103              ;; start with the required args...
 104              (map symbol->string required-args)
 105
 106              ;; add any optional args if needed...
 107              (map (lambda (a)
 108                     (if (list? a)
 109                         (format #f "[~a = ~s]" (car a) (cadr a))
 110                         (format #f "[~a]" a)))
 111                   optional-args)
 112
 113              ;; now the keyword args..
 114              (map (lambda (a)
 115                     (if (pair? a)
 116                         (format #f "[~a]" (car a))
 117                         (format #f "[#:~a]" a)))
 118                   keyword-args)
 119
 120              ;; now the rest arg...
 121              (if rest-arg
 122                  (list "." (symbol->string rest-arg))
 123                  '()))))))))
 124
 125 (define (macro-arguments name type transformer)
 126   (process-args
 127    (case type
 128      ((syntax-rules)
 129       (let ((patterns (procedure-property transformer 'patterns)))
 130         (if (pair? patterns)
 131             (car patterns)
 132             '())))
 133      ((identifier-syntax)
 134       '())
 135      ((defmacro)
 136       (or (procedure-property transformer 'defmacro-args)
 137           '()))
 138      (else
 139       ;; a procedural (syntax-case) macro. how to document these?
 140       '()))))
 141
 142 (define (macro-additional-stexi name type transformer)
 143   (case type
 144     ((syntax-rules)
 145      (let ((patterns (procedure-property transformer 'patterns)))
 146        (if (pair? patterns)
 147            (map (lambda (x)
 148                   `(defspecx (% (name ,name)
 149                                 (arguments ,@(process-args x)))))
 150                 (cdr patterns))
 151            '())))
 152     (else
 153      '())))
 154
 155 (define many-space? (make-regexp "[[:space:]][[:space:]][[:space:]]"))
 156 (define initial-space? (make-regexp "^[[:space:]]"))
 157 (define (string->stexi str)
 158   (or (and (or (not str) (string-null? str))
 159            '(*fragment*))
 160       (and (or (string-index str #\@)
 161                (and (not (regexp-exec many-space? str))
 162                     (not (regexp-exec initial-space? str))))
 163            (false-if-exception
 164             (texi-fragment->stexi str)))
 165       `(*fragment* (verbatim ,str))))
 166
 167 (define method-formals
 168   (and (defined? 'method-formals) method-formals))
 169
 170 (define (method-stexi-arguments method)
 171   (cond
 172    (method-formals
 173     (let lp ((formals (method-formals method))
 174              (specializers (method-specializers method))
 175              (out '()))
 176       (define (arg-texinfo formal specializer)
 177         `(" (" (var ,(symbol->string formal)) " "
 178           (code ,(symbol->string (class-name specializer))) ")"))
 179       (cond
 180        ((null? formals) (reverse out))
 181        ((pair? formals)
 182         (lp (cdr formals) (cdr specializers)
 183             (append (reverse (arg-texinfo (car formals) (car specializers)))
 184                     out)))
 185        (else
 186         (append (reverse out) (arg-texinfo formals specializers)
 187                 (list "..."))))))
 188    ((method-source method)
 189     (let lp ((bindings (cadr (method-source method))) (out '()))
 190       (define (arg-texinfo arg)
 191         `(" (" (var ,(symbol->string (car arg))) " "
 192           (code ,(symbol->string (cadr arg))) ")"))
 193       (cond
 194        ((null? bindings)
 195         (reverse out))
 196        ((not (pair? (car bindings)))
 197         (append (reverse out) (arg-texinfo bindings) (list "...")))
 198        (else
 199         (lp (cdr bindings)
 200             (append (reverse (arg-texinfo (car bindings))) out))))))
 201    (else (warn method) '())))
 202
 203 (define* (object-stexi-documentation object #:optional (name "[unknown]")
 204                                      #:key (force #f))
 205   (if (symbol? name)
 206       (set! name (symbol->string name)))
 207   (let ((stexi ((lambda (x)
 208                   (cond ((string? x) (string->stexi x))
 209                         ((and (pair? x) (eq? (car x) '*fragment*)) x)
 210                         (force `(*fragment*))
 211                         (else #f)))
 212                 (object-documentation
 213                  (if (is-a? object <method>)
 214                      (method-procedure object)
 215                      object)))))
 216     (define (make-def type args)
 217       `(,type (% ,@args) ,@(cdr stexi)))
 218     (cond
 219      ((not stexi) #f)
 220      ;; stexi is now a list, headed by *fragment*.
 221      ((and (pair? (cdr stexi)) (pair? (cadr stexi))
 222            (memq (caadr stexi) defs))
 223       ;; it's already a deffoo.
 224       stexi)
 225      ((is-a? object <class>)
 226       (make-def 'deftp `((name ,name)
 227                          (category "Class"))))
 228      ((is-a? object <macro>)
 229       (let* ((proc (macro-transformer object))
 230              (type (and proc (procedure-property proc 'macro-type))))
 231         `(defspec (% (name ,name)
 232                      (arguments ,@(macro-arguments name type proc)))
 233            ,@(macro-additional-stexi name type proc)
 234            ,@(cdr stexi))))
 235
 236      ((is-a? object <procedure>)
 237       (make-def 'defun `((name ,name)
 238                          (arguments ,@(get-proc-args object)))))
 239      ((is-a? object <method>)
 240       (make-def 'deffn `((category "Method")
 241                          (name ,name)
 242                          (arguments ,@(method-stexi-arguments object)))))
 243      ((is-a? object <generic>)
 244       `(*fragment*
 245         ,(make-def 'deffn `((name ,name)
 246                             (category "Generic")))
 247         ,@(map
 248            (lambda (method)
 249              (object-stexi-documentation method name #:force force))
 250            (generic-function-methods object))))
 251      (else
 252       (make-def 'defvar `((name ,name)))))))
 253
 254 (define (module-name->node-name sym-name)
 255   (string-join (map symbol->string sym-name) " "))
 256
 257 ;; this copied from (ice-9 session); need to find a better way
 258 (define (module-filename name)
 259   (let* ((name (map symbol->string name))
 260          (reverse-name (reverse name))
 261          (leaf (car reverse-name))
 262          (dir-hint-module-name (reverse (cdr reverse-name)))
 263          (dir-hint (apply string-append
 264                           (map (lambda (elt)
 265                                  (string-append elt "/"))
 266                                dir-hint-module-name))))
 267     (%search-load-path (in-vicinity dir-hint leaf))))
 268
 269 (define (read-module name)
 270   (let ((filename (module-filename name)))
 271     (if filename
 272         (let ((port (open-input-file filename)))
 273           (let lp ((out '()) (form (read port)))
 274             (if (eof-object? form)
 275                 (reverse out)
 276                 (lp (cons form out) (read port)))))
 277         '())))
 278
 279 (define (module-export-list sym-name)
 280   (define (module-form-export-list form)
 281     (and (pair? form)
 282          (eq? (car form) 'define-module)
 283          (equal? (cadr form) sym-name)
 284          (and=> (memq #:export (cddr form)) cadr)))
 285   (let lp ((forms (read-module sym-name)))
 286     (cond ((null? forms) '())
 287           ((module-form-export-list (car forms)) => identity)
 288           (else (lp (cdr forms))))))
 289
 290 (define* (module-stexi-documentation sym-name
 291                                      #:optional %docs-resolver
 292                                      #:key (docs-resolver
 293                                             (or %docs-resolver
 294                                                 (lambda (name def) def))))
 295   "Return documentation for the module named @var{sym-name}. The
 296 documentation will be formatted as @code{stexi}
 297  (@pxref{texinfo,texinfo})."
 298   (if %docs-resolver
 299       (issue-deprecation-warning
 300        "module-stexi-documentation: use #:docs-resolver instead of a positional argument."))
 301   (let* ((commentary (and=> (module-commentary sym-name)
 302                             (lambda (x) (string-trim-both x #\newline))))
 303          (stexi (string->stexi commentary))
 304          (node-name (module-name->node-name sym-name))
 305          (name-str (with-output-to-string
 306                      (lambda () (display sym-name))))
 307          (module (resolve-interface sym-name))
 308          (export-list (module-export-list sym-name)))
 309     (define (anchor-name sym)
 310       (string-append node-name " " (symbol->string sym)))
 311     (define (make-defs)
 312       (sort!
 313        (module-map
 314         (lambda (sym var)
 315           `((anchor (% (name ,(anchor-name sym))))
 316             ,@((lambda (x)
 317                  (if (eq? (car x) '*fragment*)
 318                      (cdr x)
 319                      (list x)))
 320                (if (variable-bound? var)
 321                    (docs-resolver
 322                     sym
 323                     (object-stexi-documentation (variable-ref var) sym
 324                                                 #:force #t))
 325                    (begin
 326                      (warn "variable unbound!" sym)
 327                      `(defvar (% (name ,(symbol->string sym)))
 328                         "[unbound!]"))))))
 329         module)
 330        (lambda (a b) (sort-defs export-list a b))))
 331
 332     `(texinfo (% (title ,name-str))
 333               (node (% (name ,node-name)))
 334               (section "Overview")
 335               ,@(cdr stexi)
 336               (section "Usage")
 337               ,@(apply append! (make-defs)))))
 338
 339 (define (script-stexi-documentation scriptpath)
 340   "Return documentation for given script. The documentation will be
 341 taken from the script's commentary, and will be returned in the
 342 @code{stexi} format (@pxref{texinfo,texinfo})."
 343   (let ((commentary (file-commentary scriptpath)))
 344     `(texinfo (% (title ,(basename scriptpath)))
 345               (node (% (name ,(basename scriptpath))))
 346               ,@(if commentary
 347                     (cdr
 348                      (string->stexi
 349                       (string-trim-both commentary #\newline)))
 350                     '()))))
 351
 352 (cond
 353  ((defined? 'add-value-help-handler!)
 354   (add-value-help-handler!
 355    (lambda (name value)
 356      (stexi->plain-text
 357       (object-stexi-documentation value name #:force #t))))
 358   (add-name-help-handler!
 359    (lambda (name)
 360     (and (list? name)
 361          (and-map symbol? name)
 362          (stexi->plain-text (module-stexi-documentation name)))))))
 363
 364 ;; we could be dealing with an old (ice-9 session); fondle it to get
 365 ;; module-commentary
 366 (define module-commentary (@@ (ice-9 session) module-commentary))
 367
 368 (define (package-stexi-standard-copying name version updated years
 369                                         copyright-holder permissions)
 370   "Create a standard texinfo @code{copying} section.
 371
 372 @var{years} is a list of years (as integers) in which the modules
 373 being documented were released. All other arguments are strings."
 374   `(copying
 375     (para "This manual is for " ,name
 376           " (version " ,version ", updated " ,updated ")")
 377     (para "Copyright " ,(string-join (map number->string years) ",")
 378           " " ,copyright-holder)
 379     (quotation
 380      (para ,permissions))))
 381
 382 (define (package-stexi-standard-titlepage name version updated authors)
 383   "Create a standard GNU title page.
 384
 385 @var{authors} is a list of @code{(@var{name} . @var{email})}
 386 pairs. All other arguments are strings.
 387
 388 Here is an example of the usage of this procedure:
 389
 390 @smallexample
 391  (package-stexi-standard-titlepage
 392   \"Foolib\"
 393   \"3.2\"
 394   \"26 September 2006\"
 395   '((\"Alyssa P Hacker\" . \"alyssa@@example.com\"))
 396   '(2004 2005 2006)
 397   \"Free Software Foundation, Inc.\"
 398   \"Standard GPL permissions blurb goes here\")
 399 @end smallexample
 400 "
 401   `(;(setchapternewpage (% (all "odd"))) makes manuals too long
 402     (titlepage
 403      (title ,name)
 404      (subtitle "version " ,version ", updated " ,updated)
 405      ,@(map (lambda (pair)
 406               `(author ,(car pair)
 407                        " (" (email ,(cdr pair)) ")"))
 408             authors)
 409      (page)
 410      (vskip (% (all "0pt plus 1filll")))
 411      (insertcopying))))
 412
 413 (define (package-stexi-generic-menu name entries)
 414   "Create a menu from a generic alist of entries, the car of which
 415 should be the node name, and the cdr the description. As an exception,
 416 an entry of @code{#f} will produce a separator."
 417   (define (make-entry node description)
 418     `("* " ,node "::"
 419       ,(make-string (max (- 21 (string-length node)) 2) #\space)
 420       ,@description "\n"))
 421   `((ifnottex
 422      (node (% (name "Top")))
 423      (top (% (title ,name)))
 424      (insertcopying)
 425      (menu
 426       ,@(apply
 427          append
 428          (map
 429           (lambda (entry)
 430             (if entry
 431                 (make-entry (car entry) (cdr entry))
 432                 '("\n")))
 433           entries))))
 434     (iftex
 435      (shortcontents))))
 436
 437
 438 (define (package-stexi-standard-menu name modules module-descriptions
 439                                      extra-entries)
 440   "Create a standard top node and menu, suitable for processing
 441 by makeinfo."
 442   (package-stexi-generic-menu
 443    name
 444    (let ((module-entries (map cons
 445                               (map module-name->node-name modules)
 446                               module-descriptions))
 447          (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
 448      `(,@module-entries
 449        ,@(separate-sections extra-entries)))))
 450
 451 (define (package-stexi-extended-menu name module-pairs script-pairs
 452                                      extra-entries)
 453   "Create an \"extended\" menu, like the standard menu but with a
 454 section for scripts."
 455   (package-stexi-generic-menu
 456    name
 457    (let ((module-entries (map cons
 458                               (map module-name->node-name
 459                                    (map car module-pairs))
 460                               (map cdr module-pairs)))
 461          (script-entries (map cons
 462                               (map basename (map car script-pairs))
 463                               (map cdr script-pairs)))
 464          (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
 465      `(,@module-entries
 466        ,@(separate-sections script-entries)
 467        ,@(separate-sections extra-entries)))))
 468
 469 (define (package-stexi-standard-prologue name filename category
 470                                          description copying titlepage
 471                                          menu)
 472   "Create a standard prologue, suitable for later serialization
 473 to texinfo and .info creation with makeinfo.
 474
 475 Returns a list of stexinfo forms suitable for passing to
 476 @code{package-stexi-documentation} as the prologue. @xref{texinfo
 477 reflection package-stexi-documentation}, @ref{texinfo reflection
 478 package-stexi-standard-titlepage,package-stexi-standard-titlepage},
 479 @ref{texinfo reflection
 480 package-stexi-standard-copying,package-stexi-standard-copying},
 481 and @ref{texinfo reflection
 482 package-stexi-standard-menu,package-stexi-standard-menu}."
 483   `(,copying
 484     (dircategory (% (category ,category)))
 485     (direntry
 486      "* " ,name ": (" ,filename ").  " ,description ".")
 487     ,@titlepage
 488     ,@menu))
 489
 490 (define (stexi->chapter stexi)
 491   (pre-post-order
 492    stexi
 493    `((texinfo . ,(lambda (tag attrs node . body)
 494                    `(,node
 495                      (chapter ,@(assq-ref (cdr attrs) 'title))
 496                      ,@body)))
 497      (*text* . ,(lambda (tag text) text))
 498      (*default* . ,(lambda args args)))))
 499
 500 (define* (package-stexi-documentation modules name filename
 501                                       prologue epilogue
 502                                       #:key
 503                                       (module-stexi-documentation-args
 504                                        '())
 505                                       (scripts '()))
 506   "Create stexi documentation for a @dfn{package}, where a
 507 package is a set of modules that is released together.
 508
 509 @var{modules} is expected to be a list of module names, where a
 510 module name is a list of symbols. The stexi that is returned will
 511 be titled @var{name} and a texinfo filename of @var{filename}.
 512
 513 @var{prologue} and @var{epilogue} are lists of stexi forms that
 514 will be spliced into the output document before and after the
 515 generated modules documentation, respectively.
 516 @xref{texinfo reflection package-stexi-standard-prologue}, to
 517 create a conventional GNU texinfo prologue.
 518
 519 @var{module-stexi-documentation-args} is an optional argument that, if
 520 given, will be added to the argument list when
 521 @code{module-texi-documentation} is called. For example, it might be
 522 useful to define a @code{#:docs-resolver} argument."
 523   (define (verify-modules-list l)
 524     (define (all pred l)
 525       (and (pred (car l))
 526            (or (null? (cdr l)) (all pred (cdr l)))))
 527     (false-if-exception
 528      (all (lambda (x) (all symbol? x)) modules)))
 529   (if (not (verify-modules-list modules))
 530       (error "expected modules to be a list of a list of symbols"
 531              modules))
 532
 533   `(texinfo
 534     (% (title ,name)
 535        (filename ,filename))
 536     ,@prologue
 537     ,@(append-map (lambda (mod)
 538                     (stexi->chapter
 539                      (apply module-stexi-documentation
 540                             mod module-stexi-documentation-args)))
 541                   modules)
 542     ,@(append-map (lambda (script)
 543                     (stexi->chapter
 544                      (script-stexi-documentation script)))
 545                   scripts)
 546     ,@epilogue))
 547
 548 (define* (package-stexi-documentation-for-include modules module-descriptions
 549                                                   #:key
 550                                                   (module-stexi-documentation-args '()))
 551   "Create stexi documentation for a @dfn{package}, where a
 552 package is a set of modules that is released together.
 553
 554 @var{modules} is expected to be a list of module names, where a
 555 module name is a list of symbols. Returns an stexinfo fragment.
 556
 557 Unlike @code{package-stexi-documentation}, this function simply produces
 558 a menu and the module documentations instead of producing a full texinfo
 559 document. This can be useful if you write part of your manual by hand,
 560 and just use @code{@@include} to pull in the automatically generated
 561 parts.
 562
 563 @var{module-stexi-documentation-args} is an optional argument that, if
 564 given, will be added to the argument list when
 565 @code{module-texi-documentation} is called. For example, it might be
 566 useful to define a @code{#:docs-resolver} argument."
 567   (define (make-entry node description)
 568     `("* " ,node "::"
 569       ,(make-string (max (- 21 (string-length node)) 2) #\space)
 570       ,@description "\n"))
 571   `(*fragment*
 572     (menu
 573      ,@(append-map (lambda (modname desc)
 574                      (make-entry (module-name->node-name modname)
 575                                  desc))
 576                    modules
 577                    module-descriptions))
 578     ,@(append-map (lambda (modname)
 579                     (stexi->chapter
 580                      (apply module-stexi-documentation
 581                             modname
 582                             module-stexi-documentation-args)))
 583                   modules)))
 584
 585 ;;; arch-tag: bbe2bc03-e16d-4a9e-87b9-55225dc9836c