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
  19 ;;; Commentary:
  20
  21 ;; * This module exports:
  22 ;;
  23 ;; file-commentary      -- a procedure that returns a file's "commentary"
  24 ;;
  25 ;; documentation-files  -- a search-list of files using the Guile
  26 ;;                         Documentation Format Version 2.
  27 ;;
  28 ;; object-documentation -- a procedure that returns its arg's docstring
  29 ;;
  30 ;; * Guile Documentation Format
  31 ;;
  32 ;; Here is the complete and authoritative documentation for the Guile
  33 ;; Documentation Format Version 2:
  34 ;;
  35 ;; HEADER
  36 ;; ^LPROC1
  37 ;; DOCUMENTATION1
  38 ;; ^LPROC2
  39 ;; DOCUMENTATION2
  40 ;; ...
  41 ;;
  42 ;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
  43 ;; and so on are symbols that name the element documented.  DOCUMENTATION1,
  44 ;; DOCUMENTATION2 and so on are the related documentation, w/o any further
  45 ;; formatting.
  46 ;;
  47 ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
  48 ;; not documented anywhere except by this embarrassingly circular comment.)
  49 ;;
  50 ;; * File Commentary
  51 ;;
  52 ;; A file's commentary is the body of text found between comments
  53 ;;     ;;; Commentary:
  54 ;; and
  55 ;;     ;;; Code:
  56 ;; both of which must be at the beginning of the line.  In the result string,
  57 ;; semicolons at the beginning of each line are discarded.
  58 ;;
  59 ;; You can specify to `file-commentary' alternate begin and end strings, and
  60 ;; scrub procedure.  Use #t to get default values.  For example:
  61 ;;
  62 ;; (file-commentary "documentation.scm")
  63 ;; You should see this text!
  64 ;;
  65 ;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
  66 ;; You should see the rest of this file.
  67 ;;
  68 ;; (file-commentary "documentation.scm" #t #t string-upcase)
  69 ;; You should see this text very loudly (note semicolons untouched).
  70
  71 ;;; Code:
  72
  73 (define-module (ice-9 documentation)
  74   :use-module (ice-9 rdelim)
  75   :export (file-commentary documentation-files object-documentation)
  76   :autoload (ice-9 regex) (match:suffix)
  77   :no-backtrace)
  78
  79 \f
  80 ;;
  81 ;; commentary extraction
  82 ;;
  83 (define default-in-line-re (make-regexp "^;;; Commentary:"))
  84 (define default-after-line-re (make-regexp "^;;; Code:"))
  85 (define default-scrub (let ((dirt (make-regexp "^;+")))
  86                         (lambda (line)
  87                           (let ((m (regexp-exec dirt line)))
  88                             (if m (match:suffix m) line)))))
  89
  90 (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
  91   ;; fixme: might be cleaner to use optargs here...
  92   (let ((in-line-re (if (> 1 (length cust))
  93                         default-in-line-re
  94                         (let ((v (car cust)))
  95                           (cond ((regexp? v) v)
  96                                 ((string? v) (make-regexp v))
  97                                 (else default-in-line-re)))))
  98         (after-line-re (if (> 2 (length cust))
  99                            default-after-line-re
 100                            (let ((v (cadr cust)))
 101                              (cond ((regexp? v) v)
 102                                    ((string? v) (make-regexp v))
 103                                    (else default-after-line-re)))))
 104         (scrub (if (> 3 (length cust))
 105                    default-scrub
 106                    (let ((v (caddr cust)))
 107                      (cond ((procedure? v) v)
 108                            (else default-scrub)))))
 109         (port (open-input-file filename)))
 110     (let loop ((line (read-delimited "\n" port))
 111                (doc "")
 112                (parse-state 'before))
 113       (if (or (eof-object? line) (eq? 'after parse-state))
 114           doc
 115           (let ((new-state
 116                  (cond ((regexp-exec in-line-re line) 'in)
 117                        ((regexp-exec after-line-re line) 'after)
 118                        (else parse-state))))
 119             (if (eq? 'after new-state)
 120                 doc
 121                 (loop (read-delimited "\n" port)
 122                       (if (and (eq? 'in new-state) (eq? 'in parse-state))
 123                           (string-append doc (scrub line) "\n")
 124                           doc)
 125                       new-state)))))))
 126
 127 \f
 128
 129 ;;
 130 ;; documentation-files is the list of places to look for documentation
 131 ;;
 132 (define documentation-files
 133   (map (lambda (vicinity)
 134          (in-vicinity (vicinity) "guile-procedures.txt"))
 135        (list %library-dir
 136              %package-data-dir
 137              %site-dir
 138              (lambda () "."))))
 139
 140 (define (find-documentation name)
 141   (or-map (lambda (file)
 142             (find-documentation-in-file name file))
 143           documentation-files))
 144
 145 (define entry-delimiter "\f")
 146
 147 (define (find-documentation-in-file name file)
 148   (and (file-exists? file)
 149        (let ((port (open-input-file file))
 150              (name (symbol->string name)))
 151          (let ((len (string-length name)))
 152            (read-delimited entry-delimiter port) ;skip to first entry
 153            (let loop ((entry (read-delimited entry-delimiter port)))
 154              (cond ((eof-object? entry) #f)
 155                    ;; match?
 156                    ((and ;; large enough?
 157                          (>= (string-length entry) len)
 158                          ;; matching name?
 159                          (string=? (substring entry 0 len) name)
 160                          ;; terminated?
 161                          (memq (string-ref entry len) '(#\newline)))
 162                     ;; cut away name tag and extra surrounding newlines
 163                     (substring entry (+ len 2) (- (string-length entry) 2)))
 164                    (else (loop (read-delimited entry-delimiter port)))))))))
 165
 166 ;; helper until the procedure documentation property is cleaned up
 167 (define (proc-doc proc)
 168   (or (procedure-documentation proc)
 169       (procedure-property proc 'documentation)))
 170
 171 (define (object-documentation object)
 172   "Return the docstring for OBJECT.
 173 OBJECT can be a procedure, macro or any object that has its
 174 `documentation' property set."
 175   (or (and (procedure? object)
 176            (proc-doc object))
 177       (and (macro? object)
 178            (let ((transformer (macro-transformer object)))
 179              (and transformer
 180                   (proc-doc transformer))))
 181       (object-property object 'documentation)
 182       ;; find-documentation currently only works for builtin primitives
 183       (and (procedure? object)
 184            (not (closure? object))
 185            (procedure-name object)
 186            (let ((docstring (find-documentation (procedure-name object))))
 187              (if docstring
 188                  (set-procedure-property! object 'documentation docstring))
 189              docstring))))
 190
 191 ;;; documentation.scm ends here