module/texinfo/reflection.scm

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