share/guile/1.6.0/ice-9/documentation.scm

   1 ;;;;    Copyright (C) 2000,2001 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program 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
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; As a special exception, the Free Software Foundation gives permission
  19 ;;;; for additional uses of the text contained in its release of GUILE.
  20 ;;;;
  21 ;;;; The exception is that, if you link the GUILE library with other files
  22 ;;;; to produce an executable, this does not by itself cause the
  23 ;;;; resulting executable to be covered by the GNU General Public License.
  24 ;;;; Your use of that executable is in no way restricted on account of
  25 ;;;; linking the GUILE library code into it.
  26 ;;;;
  27 ;;;; This exception does not however invalidate any other reasons why
  28 ;;;; the executable file might be covered by the GNU General Public License.
  29 ;;;;
  30 ;;;; This exception applies only to the code released by the
  31 ;;;; Free Software Foundation under the name GUILE.  If you copy
  32 ;;;; code from other Free Software Foundation releases into a copy of
  33 ;;;; GUILE, as the General Public License permits, the exception does
  34 ;;;; not apply to the code that you add in this way.  To avoid misleading
  35 ;;;; anyone as to the status of such modified files, you must delete
  36 ;;;; this exception notice from them.
  37 ;;;;
  38 ;;;; If you write modifications of your own for GUILE, it is your choice
  39 ;;;; whether to permit this exception to apply to your modifications.
  40 ;;;; If you do not wish that, delete this exception notice.
  41 ;;;;
  42
  43 ;;; Commentary:
  44
  45 ;; * This module exports:
  46 ;;
  47 ;; file-commentary      -- a procedure that returns a file's "commentary"
  48 ;;
  49 ;; documentation-files  -- a search-list of files using the Guile
  50 ;;                         Documentation Format Version 2.
  51 ;;
  52 ;; search-documentation-files -- a procedure that takes NAME (a symbol)
  53 ;;                               and searches `documentation-files' for
  54 ;;                               associated documentation.  optional
  55 ;;                               arg FILES is a list of filenames to use
  56 ;;                               instead of `documentation-files'.
  57 ;;
  58 ;; object-documentation -- a procedure that returns its arg's docstring
  59 ;;
  60 ;; * Guile Documentation Format
  61 ;;
  62 ;; Here is the complete and authoritative documentation for the Guile
  63 ;; Documentation Format Version 2:
  64 ;;
  65 ;; HEADER
  66 ;; ^LPROC1
  67 ;; DOCUMENTATION1
  68 ;;
  69 ;; ^LPROC2
  70 ;; DOCUMENTATION2
  71 ;;
  72 ;; ^L...
  73 ;;
  74 ;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
  75 ;; and so on are symbols that name the element documented.  DOCUMENTATION1,
  76 ;; DOCUMENTATION2 and so on are the related documentation, w/o any further
  77 ;; formatting.  Note that there are two newlines before the next formfeed;
  78 ;; these are discarded when the documentation is read in.
  79 ;;
  80 ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
  81 ;; not documented anywhere except by this embarrassingly circular comment.)
  82 ;;
  83 ;; * File Commentary
  84 ;;
  85 ;; A file's commentary is the body of text found between comments
  86 ;;     ;;; Commentary:
  87 ;; and
  88 ;;     ;;; Code:
  89 ;; both of which must be at the beginning of the line.  In the result string,
  90 ;; semicolons at the beginning of each line are discarded.
  91 ;;
  92 ;; You can specify to `file-commentary' alternate begin and end strings, and
  93 ;; scrub procedure.  Use #t to get default values.  For example:
  94 ;;
  95 ;; (file-commentary "documentation.scm")
  96 ;; You should see this text!
  97 ;;
  98 ;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
  99 ;; You should see the rest of this file.
 100 ;;
 101 ;; (file-commentary "documentation.scm" #t #t string-upcase)
 102 ;; You should see this text very loudly (note semicolons untouched).
 103
 104 ;;; Code:
 105
 106 (define-module (ice-9 documentation)
 107   :use-module (ice-9 rdelim)
 108   :export (file-commentary
 109            documentation-files search-documentation-files
 110            object-documentation)
 111   :autoload (ice-9 regex) (match:suffix)
 112   :no-backtrace)
 113
 114 \f
 115 ;;
 116 ;; commentary extraction
 117 ;;
 118 (define default-in-line-re (make-regexp "^;;; Commentary:"))
 119 (define default-after-line-re (make-regexp "^;;; Code:"))
 120 (define default-scrub (let ((dirt (make-regexp "^;+")))
 121                         (lambda (line)
 122                           (let ((m (regexp-exec dirt line)))
 123                             (if m (match:suffix m) line)))))
 124
 125 (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
 126   ;; fixme: might be cleaner to use optargs here...
 127   (let ((in-line-re (if (> 1 (length cust))
 128                         default-in-line-re
 129                         (let ((v (car cust)))
 130                           (cond ((regexp? v) v)
 131                                 ((string? v) (make-regexp v))
 132                                 (else default-in-line-re)))))
 133         (after-line-re (if (> 2 (length cust))
 134                            default-after-line-re
 135                            (let ((v (cadr cust)))
 136                              (cond ((regexp? v) v)
 137                                    ((string? v) (make-regexp v))
 138                                    (else default-after-line-re)))))
 139         (scrub (if (> 3 (length cust))
 140                    default-scrub
 141                    (let ((v (caddr cust)))
 142                      (cond ((procedure? v) v)
 143                            (else default-scrub)))))
 144         (port (open-input-file filename)))
 145     (let loop ((line (read-delimited "\n" port))
 146                (doc "")
 147                (parse-state 'before))
 148       (if (or (eof-object? line) (eq? 'after parse-state))
 149           doc
 150           (let ((new-state
 151                  (cond ((regexp-exec in-line-re line) 'in)
 152                        ((regexp-exec after-line-re line) 'after)
 153                        (else parse-state))))
 154             (if (eq? 'after new-state)
 155                 doc
 156                 (loop (read-delimited "\n" port)
 157                       (if (and (eq? 'in new-state) (eq? 'in parse-state))
 158                           (string-append doc (scrub line) "\n")
 159                           doc)
 160                       new-state)))))))
 161
 162 \f
 163
 164 ;;
 165 ;; documentation-files is the list of places to look for documentation
 166 ;;
 167 (define documentation-files
 168   (map (lambda (vicinity)
 169          (in-vicinity (vicinity) "guile-procedures.txt"))
 170        (list %library-dir
 171              %package-data-dir
 172              %site-dir
 173              (lambda () "."))))
 174
 175 (define entry-delimiter "\f")
 176
 177 (define (find-documentation-in-file name file)
 178   (and (file-exists? file)
 179        (let ((port (open-input-file file))
 180              (name (symbol->string name)))
 181          (let ((len (string-length name)))
 182            (read-delimited entry-delimiter port) ;skip to first entry
 183            (let loop ((entry (read-delimited entry-delimiter port)))
 184              (cond ((eof-object? entry) #f)
 185                    ;; match?
 186                    ((and ;; large enough?
 187                          (>= (string-length entry) len)
 188                          ;; matching name?
 189                          (string=? (substring entry 0 len) name)
 190                          ;; terminated?
 191                          (memq (string-ref entry len) '(#\newline)))
 192                     ;; cut away name tag and extra surrounding newlines
 193                     (substring entry (+ len 2) (- (string-length entry) 2)))
 194                    (else (loop (read-delimited entry-delimiter port)))))))))
 195
 196 (define (search-documentation-files name . files)
 197   (or-map (lambda (file)
 198             (find-documentation-in-file name file))
 199           (cond ((null? files) documentation-files)
 200                 (else files))))
 201
 202 ;; helper until the procedure documentation property is cleaned up
 203 (define (proc-doc proc)
 204   (or (procedure-documentation proc)
 205       (procedure-property proc 'documentation)))
 206
 207 (define (object-documentation object)
 208   "Return the docstring for OBJECT.
 209 OBJECT can be a procedure, macro or any object that has its
 210 `documentation' property set."
 211   (or (and (procedure? object)
 212            (proc-doc object))
 213       (and (macro? object)
 214            (let ((transformer (macro-transformer object)))
 215              (and transformer
 216                   (proc-doc transformer))))
 217       (object-property object 'documentation)
 218       (and (procedure? object)
 219            (not (closure? object))
 220            (procedure-name object)
 221            (let ((docstring (search-documentation-files
 222                              (procedure-name object))))
 223              (if docstring
 224                  (set-procedure-property! object 'documentation docstring))
 225              docstring))))
 226
 227 ;;; documentation.scm ends here