ice-9/documentation.scm

   1 ;;;;    Copyright (C) 2000 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 (define-module (ice-9 documentation)
  20   :no-backtrace)
  21
  22 \f
  23
  24 ;;
  25 ;; documentation-files is the list of places to look for documentation
  26 ;;
  27 (define-public documentation-files
  28   (map (lambda (vicinity)
  29          (in-vicinity (vicinity) "guile-procedures.txt"))
  30        (list %library-dir
  31              %package-data-dir
  32              %site-dir
  33              (lambda () "."))))
  34
  35 (define (find-documentation name)
  36   (or-map (lambda (file)
  37             (find-documentation-in-file name file))
  38           documentation-files))
  39
  40 (define entry-delimiter "\f")
  41
  42 (define (find-documentation-in-file name file)
  43   (and (file-exists? file)
  44        (let ((port (open-input-file file))
  45              (name (symbol->string name)))
  46          (let ((len (string-length name)))
  47            (read-delimited entry-delimiter port) ;skip to first entry
  48            (let loop ((entry (read-delimited entry-delimiter port)))
  49              (cond ((eof-object? entry) #f)
  50                    ;; match?
  51                    ((and ;; large enough?
  52                          (>= (string-length entry) len)
  53                          ;; matching name?
  54                          (string=? (substring entry 0 len) name)
  55                          ;; terminated?
  56                          (memq (string-ref entry len) '(#\newline)))
  57                     ;; cut away name tag and extra surrounding newlines
  58                     (substring entry (+ len 2) (- (string-length entry) 2)))
  59                    (else (loop (read-delimited entry-delimiter port)))))))))
  60
  61 ;; helper until the procedure documentation property is cleaned up
  62 (define (proc-doc proc)
  63   (or (procedure-documentation proc)
  64       (procedure-property proc 'documentation)))
  65
  66 (define-public (object-documentation object)
  67   "Return the docstring for OBJECT."
  68   (or (and (procedure? object)
  69            (proc-doc object))
  70       (and (macro? object)
  71            (let ((transformer (macro-transformer object)))
  72              (and transformer
  73                   (proc-doc transformer))))
  74       (object-property object 'documentation)
  75       ;; find-documentation currently only works for builtin primitives
  76       (and (procedure? object)
  77            (not (closure? object))
  78            (procedure-name object)
  79            (let ((docstring (find-documentation (procedure-name object))))
  80              (if docstring
  81                  (set-procedure-property! object 'documentation docstring))
  82              docstring))))