guile18/scripts/doc-snarf

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3 main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
   4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   5 !#
   6 ;;; doc-snarf --- Extract documentation from source files
   7
   8 ;;      Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this software; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301 USA
  24
  25 ;;; Author: Martin Grabmueller
  26
  27 ;;; Commentary:
  28
  29 ;; Usage: doc-snarf FILE
  30 ;;
  31 ;; This program reads in a Scheme source file and extracts docstrings
  32 ;; in the format specified below.  Additionally, a procedure protoype
  33 ;; is infered from the procedure definition line starting with
  34 ;; (define... ).
  35 ;;
  36 ;; Currently, two output modi are implemented: texinfo and plaintext.
  37 ;; Default is plaintext, texinfo can be switched on with the
  38 ;; `--texinfo, -t' command line option.
  39 ;;
  40 ;; Format: A docstring can span multiple lines and a docstring line
  41 ;; begins with `;; ' (two semicoli and a space). A docstring is ended
  42 ;; by either a line beginning with (define ...) or one or more lines
  43 ;; beginning with `;;-' (two semicoli and a dash). These lines are
  44 ;; called `options' and begin with a keyword, followed by a colon and
  45 ;; a string.
  46 ;;
  47 ;; Additionally, "standard internal docstrings" (for Scheme source) are
  48 ;; recognized and output as "options".  The output formatting is likely
  49 ;; to change in the future.
  50 ;;
  51 ;; Example:
  52
  53 ;; This procedure foos, or bars, depending on the argument @var{braz}.
  54 ;;-Author: Martin Grabmueller
  55 (define (foo/bar braz)
  56   (if braz 'foo 'bar))
  57
  58 ;;; Which results in the following docstring if texinfo output is
  59 ;;; enabled:
  60 #!
  61 \ffoo/bar
  62 @deffn procedure foo/bar braz
  63 This procedure foos, or bars, depending on the argument @var{braz}.
  64 @c Author: Martin Grabmueller
  65 @end deffn
  66 !#
  67
  68 ;;; Or in this if plaintext output is used:
  69 #!
  70 Procedure: foo/bar braz
  71 This procedure foos, or bars, depending on the argument @var{braz}.
  72 ;; Author: Martin Grabmueller
  73 ^L
  74 !#
  75
  76 ;; TODO: Convert option lines to alist.
  77 ;;       More parameterization.
  78 ;;       ../libguile/guile-doc-snarf emulation
  79
  80 (define doc-snarf-version "0.0.2") ; please update before publishing!
  81
  82 ;;; Code:
  83
  84 (define-module (scripts doc-snarf)
  85   :use-module (ice-9 getopt-long)
  86   :use-module (ice-9 regex)
  87   :use-module (ice-9 string-fun)
  88   :use-module (ice-9 rdelim)
  89   :export (doc-snarf))
  90
  91 (define command-synopsis
  92   '((version (single-char #\v) (value #f))
  93     (help    (single-char #\h) (value #f))
  94     (output  (single-char #\o) (value #t))
  95     (texinfo (single-char #\t) (value #f))
  96     (lang    (single-char #\l) (value #t))))
  97
  98 ;; Display version information and exit.
  99 ;;-ttn-mod: use var
 100 (define (display-version)
 101   (display "doc-snarf ") (display doc-snarf-version) (newline))
 102
 103 ;; Display the usage help message and exit.
 104 ;;-ttn-mod: change option "source" to "lang"
 105 (define (display-help)
 106   (display "Usage: doc-snarf [options...] inputfile\n")
 107   (display "  --help, -h              Show this usage information\n")
 108   (display "  --version, -v           Show version information\n")
 109   (display
 110    "  --output=FILE, -o       Specify output file [default=stdout]\n")
 111   (display "  --texinfo, -t           Format output as texinfo\n")
 112   (display "  --lang=[c,scheme], -l   Specify the input language\n"))
 113
 114 ;; Main program.
 115 ;;-ttn-mod: canonicalize lang
 116 (define (doc-snarf . args)
 117   (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
 118     (let ((help-wanted (option-ref options 'help #f))
 119           (version-wanted (option-ref options 'version #f))
 120           (texinfo-wanted (option-ref options 'texinfo #f))
 121           (lang (string->symbol
 122                  (string-downcase (option-ref options 'lang "scheme")))))
 123       (cond
 124        (version-wanted (display-version))
 125        (help-wanted (display-help))
 126        (else
 127         (let ((input (option-ref options '() #f))
 128               (output (option-ref options 'output #f)))
 129           (if
 130            ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
 131            ;; (and input (pair? input))
 132            (pair? input)
 133            (snarf-file (car input) output texinfo-wanted lang)
 134            (display-help))))))))
 135
 136 (define main doc-snarf)
 137
 138 ;; Supported languages and their parameters.  Each element has form:
 139 ;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
 140 ;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
 141 ;; LANG supports "standard internal docstring" (a string after the formals),
 142 ;; everything else is a string specifying a regexp.
 143 ;;-ttn-mod: new var
 144 (define supported-languages
 145   '((c
 146      "^/\\*(.*)"
 147      "^ \\*/"
 148      "^ \\* (.*)"
 149      "^ \\*-(.*)"
 150      "NOTHING AT THIS TIME!!!"
 151      #f
 152      )
 153     (scheme
 154      "^;; (.*)"
 155      "^;;\\."
 156      "^;; (.*)"
 157      "^;;-(.*)"
 158      "^\\(define"
 159      #t
 160      )))
 161
 162 ;; Get @var{lang}'s @var{parameter}.  Both args are symbols.
 163 ;;-ttn-mod: new proc
 164 (define (lang-parm lang parm)
 165   (list-ref (assq-ref supported-languages lang)
 166             (case parm
 167               ((docstring-start)  0)
 168               ((docstring-end)    1)
 169               ((docstring-prefix) 2)
 170               ((option-prefix)    3)
 171               ((signature-start)  4)
 172               ((std-int-doc?)     5))))
 173
 174 ;; Snarf all docstrings from the file @var{input} and write them to
 175 ;; file @var{output}.  Use texinfo format for the output if
 176 ;; @var{texinfo?} is true.
 177 ;;-ttn-mod: don't use string comparison, consult table instead
 178 (define (snarf-file input output texinfo? lang)
 179   (or (memq lang (map car supported-languages))
 180       (error "doc-snarf: input language must be c or scheme."))
 181   (write-output (snarf input lang) output
 182                 (if texinfo? format-texinfo format-plain)))
 183
 184 ;; fixme: this comment is required to trigger standard internal
 185 ;; docstring snarfing...  ideally, it wouldn't be necessary.
 186 ;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
 187 (define (find-std-int-doc line input-port)
 188   "Unread @var{line} from @var{input-port}, then read in the entire form and
 189 return the standard internal docstring if found.  Return #f if not."
 190   (unread-string line input-port)       ; ugh
 191   (let ((form (read input-port)))
 192     (cond ((and (list? form)            ; (define (PROC ARGS) "DOC" ...)
 193                 (< 3 (length form))
 194                 (eq? 'define (car form))
 195                 (pair? (cadr form))
 196                 (symbol? (caadr form))
 197                 (string? (caddr form)))
 198            (caddr form))
 199           ((and (list? form)            ; (define VAR (lambda ARGS "DOC" ...))
 200                 (< 2 (length form))
 201                 (eq? 'define (car form))
 202                 (symbol? (cadr form))
 203                 (list? (caddr form))
 204                 (< 3 (length (caddr form)))
 205                 (eq? 'lambda (car (caddr form)))
 206                 (string? (caddr (caddr form))))
 207            (caddr (caddr form)))
 208           (else #f))))
 209
 210 ;; Split @var{string} into lines, adding @var{prefix} to each.
 211 ;;-ttn-mod: new proc
 212 (define (split-prefixed string prefix)
 213   (separate-fields-discarding-char
 214    #\newline string
 215    (lambda lines
 216      (map (lambda (line)
 217             (string-append prefix line))
 218           lines))))
 219
 220 ;; snarf input-file output-file
 221 ;; Extract docstrings from the input file @var{input}, presumed
 222 ;; to be written in language @var{lang}.
 223 ;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 224 ;;-Created: 2001-02-17
 225 ;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
 226 (define (snarf input-file lang)
 227   (let* ((i-p (open-input-file input-file))
 228          (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
 229          (docstring-start  (parm-regexp 'docstring-start))
 230          (docstring-end    (parm-regexp 'docstring-end))
 231          (docstring-prefix (parm-regexp 'docstring-prefix))
 232          (option-prefix    (parm-regexp 'option-prefix))
 233          (signature-start  (parm-regexp 'signature-start))
 234          (augmented-options
 235           (lambda (line i-p options)
 236             (let ((int-doc (and (lang-parm lang 'std-int-doc?)
 237                                 (let ((d (find-std-int-doc line i-p)))
 238                                   (and d (split-prefixed d "internal: "))))))
 239               (if int-doc
 240                   (append (reverse int-doc) options)
 241                   options)))))
 242
 243     (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
 244              (options '()) (entries '()) (lno 0))
 245       (cond
 246        ((eof-object? line)
 247         (close-input-port i-p)
 248         (reverse entries))
 249
 250        ;; State 'neutral: we're currently not within a docstring or
 251        ;; option section
 252        ((eq? state 'neutral)
 253         (let ((m (regexp-exec docstring-start line)))
 254           (if m
 255             (lp (read-line i-p) 'doc-string
 256                 (list (match:substring m 1)) '() entries (+ lno 1))
 257             (lp (read-line i-p) state '() '() entries (+ lno 1)))))
 258
 259        ;; State 'doc-string: we have started reading a docstring and
 260        ;; are waiting for more, for options or for a define.
 261        ((eq? state 'doc-string)
 262         (let ((m0 (regexp-exec docstring-prefix line))
 263               (m1 (regexp-exec option-prefix line))
 264               (m2 (regexp-exec signature-start line))
 265               (m3 (regexp-exec docstring-end line)))
 266           (cond
 267            (m0
 268             (lp (read-line i-p) 'doc-string
 269                 (cons (match:substring m0 1) doc-strings) '() entries
 270                 (+ lno 1)))
 271            (m1
 272             (lp (read-line i-p) 'options
 273                 doc-strings (cons (match:substring m1 1) options) entries
 274                 (+ lno 1)))
 275            (m2
 276             (let ((options (augmented-options line i-p options))) ; ttn-mod
 277               (lp (read-line i-p) 'neutral '() '()
 278                   (cons (parse-entry doc-strings options line input-file lno)
 279                         entries)
 280                   (+ lno 1))))
 281            (m3
 282             (lp (read-line i-p) 'neutral '() '()
 283                 (cons (parse-entry doc-strings options #f input-file lno)
 284                       entries)
 285                 (+ lno 1)))
 286            (else
 287             (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
 288
 289        ;; State 'options: We're waiting for more options or for a
 290        ;; define.
 291        ((eq? state 'options)
 292         (let ((m1 (regexp-exec option-prefix line))
 293               (m2 (regexp-exec signature-start line))
 294               (m3 (regexp-exec docstring-end line)))
 295           (cond
 296            (m1
 297             (lp (read-line i-p) 'options
 298                 doc-strings (cons (match:substring m1 1) options) entries
 299                 (+ lno 1)))
 300            (m2
 301             (let ((options (augmented-options line i-p options))) ; ttn-mod
 302               (lp (read-line i-p) 'neutral '() '()
 303                   (cons (parse-entry doc-strings options line input-file lno)
 304                         entries)
 305                   (+ lno 1))))
 306            (m3
 307             (lp (read-line i-p) 'neutral '() '()
 308                 (cons (parse-entry doc-strings options #f input-file lno)
 309                       entries)
 310                 (+ lno 1)))
 311            (else
 312             (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
 313
 314 (define (make-entry symbol signature docstrings options filename line)
 315   (vector 'entry symbol signature docstrings options filename line))
 316 (define (entry-symbol e)
 317   (vector-ref e 1))
 318 (define (entry-signature e)
 319   (vector-ref e 2))
 320 (define (entry-docstrings e)
 321   (vector-ref e 3))
 322 (define (entry-options e)
 323   (vector-ref e 4))
 324 (define (entry-filename e)
 325   (vector-ref e 5))
 326 (define (entry-line e)
 327   "This docstring will not be snarfed, unfortunately..."
 328   (vector-ref e 6))
 329
 330 ;; Create a docstring entry from the docstring line list
 331 ;; @var{doc-strings}, the option line list @var{options} and the
 332 ;; define line @var{def-line}
 333 (define (parse-entry docstrings options def-line filename line-no)
 334 ;  (write-line docstrings)
 335   (cond
 336    (def-line
 337      (make-entry (get-symbol def-line)
 338                  (make-prototype def-line) (reverse docstrings)
 339                  (reverse options) filename
 340                  (+ (- line-no (length docstrings) (length options)) 1)))
 341    ((> (length docstrings) 0)
 342     (make-entry (string->symbol (car (reverse docstrings)))
 343                 (car (reverse docstrings))
 344                 (cdr (reverse docstrings))
 345                 (reverse options) filename
 346                 (+ (- line-no (length docstrings) (length options)) 1)))
 347    (else
 348     (make-entry 'foo "" (reverse docstrings) (reverse options) filename
 349                 (+ (- line-no (length docstrings) (length options)) 1)))))
 350
 351 ;; Create a string which is a procedure prototype.  The necessary
 352 ;; information for constructing the prototype is taken from the line
 353 ;; @var{def-line}, which is a line starting with @code{(define...}.
 354 (define (make-prototype def-line)
 355   (call-with-input-string
 356    def-line
 357    (lambda (s-p)
 358      (let* ((paren (read-char s-p))
 359             (keyword (read s-p))
 360             (tmp (read s-p)))
 361        (cond
 362         ((pair? tmp)
 363          (join-symbols tmp))
 364         ((symbol? tmp)
 365          (symbol->string tmp))
 366         (else
 367          ""))))))
 368
 369 (define (get-symbol def-line)
 370   (call-with-input-string
 371    def-line
 372    (lambda (s-p)
 373      (let* ((paren (read-char s-p))
 374             (keyword (read s-p))
 375             (tmp (read s-p)))
 376        (cond
 377         ((pair? tmp)
 378          (car tmp))
 379         ((symbol? tmp)
 380          tmp)
 381         (else
 382          'foo))))))
 383
 384 ;; Append the symbols in the string list @var{s}, separated with a
 385 ;; space character.
 386 (define (join-symbols s)
 387   (cond ((null? s)
 388          "")
 389         ((symbol? s)
 390          (string-append ". " (symbol->string s)))
 391         ((null? (cdr s))
 392          (symbol->string (car s)))
 393         (else
 394          (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
 395
 396 ;; Write @var{entries} to @var{output-file} using @var{writer}.
 397 ;; @var{writer} is a proc that takes one entry.
 398 ;; If @var{output-file} is #f, write to stdout.
 399 ;;-ttn-mod: new proc
 400 (define (write-output entries output-file writer)
 401   (with-output-to-port (cond (output-file (open-output-file output-file))
 402                              (else (current-output-port)))
 403     (lambda () (for-each writer entries))))
 404
 405 ;; Write an @var{entry} using texinfo format.
 406 ;;-ttn-mod: renamed from `texinfo-output', distilled
 407 (define (format-texinfo entry)
 408   (display "\n\f")
 409   (display (entry-symbol entry))
 410   (newline)
 411   (display "@c snarfed from ")
 412   (display (entry-filename entry))
 413   (display ":")
 414   (display (entry-line entry))
 415   (newline)
 416   (display "@deffn procedure ")
 417   (display (entry-signature entry))
 418   (newline)
 419   (for-each (lambda (s) (write-line s))
 420             (entry-docstrings entry))
 421   (for-each (lambda (s) (display "@c ") (write-line s))
 422             (entry-options entry))
 423   (write-line "@end deffn"))
 424
 425 ;; Write an @var{entry} using plain format.
 426 ;;-ttn-mod: renamed from `texinfo-output', distilled
 427 (define (format-plain entry)
 428   (display "Procedure: ")
 429   (display (entry-signature entry))
 430   (newline)
 431   (for-each (lambda (s) (write-line s))
 432             (entry-docstrings entry))
 433   (for-each (lambda (s) (display ";; ") (write-line s))
 434             (entry-options entry))
 435   (display "Snarfed from ")
 436   (display (entry-filename entry))
 437   (display ":")
 438   (display (entry-line entry))
 439   (newline)
 440   (write-line "\f"))
 441
 442 ;;; doc-snarf ends here