module/ice-9/documentation.scm

   1 ;;;;    Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17
  18 ;;; Commentary:
  19
  20 ;; * This module exports:
  21 ;;
  22 ;; file-commentary      -- a procedure that returns a file's "commentary"
  23 ;;
  24 ;; documentation-files  -- a search-list of files using the Guile
  25 ;;                         Documentation Format Version 2.
  26 ;;
  27 ;; search-documentation-files -- a procedure that takes NAME (a symbol)
  28 ;;                               and searches `documentation-files' for
  29 ;;                               associated documentation.  optional
  30 ;;                               arg FILES is a list of filenames to use
  31 ;;                               instead of `documentation-files'.
  32 ;;
  33 ;; object-documentation -- a procedure that returns its arg's docstring
  34 ;;
  35 ;; * Guile Documentation Format
  36 ;;
  37 ;; Here is the complete and authoritative documentation for the Guile
  38 ;; Documentation Format Version 2:
  39 ;;
  40 ;; HEADER
  41 ;; ^LPROC1
  42 ;; DOCUMENTATION1
  43 ;;
  44 ;; ^LPROC2
  45 ;; DOCUMENTATION2
  46 ;;
  47 ;; ^L...
  48 ;;
  49 ;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
  50 ;; and so on are symbols that name the element documented.  DOCUMENTATION1,
  51 ;; DOCUMENTATION2 and so on are the related documentation, w/o any further
  52 ;; formatting.  Note that there are two newlines before the next formfeed;
  53 ;; these are discarded when the documentation is read in.
  54 ;;
  55 ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
  56 ;; not documented anywhere except by this embarrassingly circular comment.)
  57 ;;
  58 ;; * File Commentary
  59 ;;
  60 ;; A file's commentary is the body of text found between comments
  61 ;;     ;;; Commentary:
  62 ;; and
  63 ;;     ;;; Code:
  64 ;; both of which must be at the beginning of the line.  In the result string,
  65 ;; semicolons at the beginning of each line are discarded.
  66 ;;
  67 ;; You can specify to `file-commentary' alternate begin and end strings, and
  68 ;; scrub procedure.  Use #t to get default values.  For example:
  69 ;;
  70 ;; (file-commentary "documentation.scm")
  71 ;; You should see this text!
  72 ;;
  73 ;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
  74 ;; You should see the rest of this file.
  75 ;;
  76 ;; (file-commentary "documentation.scm" #t #t string-upcase)
  77 ;; You should see this text very loudly (note semicolons untouched).
  78
  79 ;;; Code:
  80
  81 (define-module (ice-9 documentation)
  82   :use-module (ice-9 rdelim)
  83   :use-module ((system vm program) :select (program? program-documentation))
  84   :export (file-commentary
  85            documentation-files search-documentation-files
  86            object-documentation)
  87   :autoload (ice-9 regex) (match:suffix)
  88   :no-backtrace)
  89
  90 \f
  91 ;;
  92 ;; commentary extraction
  93 ;;
  94
  95 (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
  96
  97   ;; These are constants but are not at the top level because the repl in
  98   ;; boot-9.scm loads session.scm which in turn loads this file, and we want
  99   ;; that to work even even when regexps are not available (ie. make-regexp
 100   ;; doesn't exist), as for instance is the case on mingw.
 101   ;;
 102   (define default-in-line-re (make-regexp "^;;; Commentary:"))
 103   (define default-after-line-re (make-regexp "^;;; Code:"))
 104   (define default-scrub (let ((dirt (make-regexp "^;+")))
 105                           (lambda (line)
 106                             (let ((m (regexp-exec dirt line)))
 107                               (if m (match:suffix m) line)))))
 108
 109   ;; fixme: might be cleaner to use optargs here...
 110   (let ((in-line-re (if (> 1 (length cust))
 111                         default-in-line-re
 112                         (let ((v (car cust)))
 113                           (cond ((regexp? v) v)
 114                                 ((string? v) (make-regexp v))
 115                                 (else default-in-line-re)))))
 116         (after-line-re (if (> 2 (length cust))
 117                            default-after-line-re
 118                            (let ((v (cadr cust)))
 119                              (cond ((regexp? v) v)
 120                                    ((string? v) (make-regexp v))
 121                                    (else default-after-line-re)))))
 122         (scrub (if (> 3 (length cust))
 123                    default-scrub
 124                    (let ((v (caddr cust)))
 125                      (cond ((procedure? v) v)
 126                            (else default-scrub))))))
 127     (call-with-input-file filename
 128       (lambda (port)
 129         (let loop ((line (read-delimited "\n" port))
 130                    (doc "")
 131                    (parse-state 'before))
 132           (if (or (eof-object? line) (eq? 'after parse-state))
 133               doc
 134               (let ((new-state
 135                      (cond ((regexp-exec in-line-re line) 'in)
 136                            ((regexp-exec after-line-re line) 'after)
 137                            (else parse-state))))
 138                 (if (eq? 'after new-state)
 139                     doc
 140                     (loop (read-delimited "\n" port)
 141                           (if (and (eq? 'in new-state) (eq? 'in parse-state))
 142                               (string-append doc (scrub line) "\n")
 143                               doc)
 144                           new-state)))))))))
 145
 146 \f
 147
 148 ;;
 149 ;; documentation-files is the list of places to look for documentation
 150 ;;
 151 (define documentation-files
 152   (map (lambda (vicinity)
 153          (in-vicinity (vicinity) "guile-procedures.txt"))
 154        (list %library-dir
 155              %package-data-dir
 156              %site-dir
 157              (lambda () "."))))
 158
 159 (define entry-delimiter "\f")
 160
 161 (define (find-documentation-in-file name file)
 162   (and (file-exists? file)
 163        (call-with-input-file file
 164          (lambda (port)
 165            (let ((name (symbol->string name)))
 166              (let ((len (string-length name)))
 167                (read-delimited entry-delimiter port) ;skip to first entry
 168                (let loop ((entry (read-delimited entry-delimiter port)))
 169                  (cond ((eof-object? entry) #f)
 170                        ;; match?
 171                        ((and ;; large enough?
 172                          (>= (string-length entry) len)
 173                          ;; matching name?
 174                          (string=? (substring entry 0 len) name)
 175                          ;; terminated?
 176                          (memq (string-ref entry len) '(#\newline)))
 177                         ;; cut away name tag and extra surrounding newlines
 178                         (substring entry (+ len 2) (- (string-length entry) 2)))
 179                        (else (loop (read-delimited entry-delimiter port)))))))))))
 180
 181 (define (search-documentation-files name . files)
 182   (or-map (lambda (file)
 183             (find-documentation-in-file name file))
 184           (cond ((null? files) documentation-files)
 185                 (else files))))
 186
 187 ;; helper until the procedure documentation property is cleaned up
 188 (define (proc-doc proc)
 189   (or (procedure-documentation proc)
 190       (procedure-property proc 'documentation)))
 191
 192 (define (object-documentation object)
 193   "Return the docstring for OBJECT.
 194 OBJECT can be a procedure, macro or any object that has its
 195 `documentation' property set."
 196   (or (and (procedure? object)
 197            (proc-doc object))
 198       (and (defmacro? object)
 199            (proc-doc (defmacro-transformer object)))
 200       (and (macro? object)
 201            (let ((transformer (macro-transformer object)))
 202              (and transformer
 203                   (proc-doc transformer))))
 204       (object-property object 'documentation)
 205       (and (program? object)
 206            (program-documentation object))
 207       (and (procedure? object)
 208            (not (closure? object))
 209            (procedure-name object)
 210            (let ((docstring (search-documentation-files
 211                              (procedure-name object))))
 212              (if docstring
 213                  (set-procedure-property! object 'documentation docstring))
 214              docstring))))
 215
 216 ;;; documentation.scm ends here