1 ;;;; Copyright (C) 2000,2001, 2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
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 3 of the License, or (at your option) any later version.
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.
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
20 ;; * This module exports:
22 ;; file-commentary -- a procedure that returns a file's "commentary"
24 ;; documentation-files -- a search-list of files using the Guile
25 ;; Documentation Format Version 2.
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'.
33 ;; object-documentation -- a procedure that returns its arg's docstring
35 ;; * Guile Documentation Format
37 ;; Here is the complete and authoritative documentation for the Guile
38 ;; Documentation Format Version 2:
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.
55 ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
56 ;; not documented anywhere except by this embarrassingly circular comment.)
60 ;; A file's commentary is the body of text found between comments
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.
67 ;; You can specify to `file-commentary' alternate begin and end strings, and
68 ;; scrub procedure. Use #t to get default values. For example:
70 ;; (file-commentary "documentation.scm")
71 ;; You should see this text!
73 ;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
74 ;; You should see the rest of this file.
76 ;; (file-commentary "documentation.scm" #t #t string-upcase)
77 ;; You should see this text very loudly (note semicolons untouched).
81 (define-module (ice-9 documentation)
82 :use-module (ice-9 rdelim)
83 :export (file-commentary
84 documentation-files search-documentation-files
86 :autoload (ice-9 regex) (match:suffix)
91 ;; commentary extraction
94 (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
96 ;; These are constants but are not at the top level because the repl in
97 ;; boot-9.scm loads session.scm which in turn loads this file, and we want
98 ;; that to work even even when regexps are not available (ie. make-regexp
99 ;; doesn't exist), as for instance is the case on mingw.
101 (define default-in-line-re (make-regexp "^;;; Commentary:"))
102 (define default-after-line-re (make-regexp "^;;; Code:"))
103 (define default-scrub (let ((dirt (make-regexp "^;+")))
105 (let ((m (regexp-exec dirt line)))
106 (if m (match:suffix m) line)))))
108 ;; fixme: might be cleaner to use optargs here...
109 (let ((in-line-re (if (> 1 (length cust))
111 (let ((v (car cust)))
112 (cond ((regexp? v) v)
113 ((string? v) (make-regexp v))
114 (else default-in-line-re)))))
115 (after-line-re (if (> 2 (length cust))
116 default-after-line-re
117 (let ((v (cadr cust)))
118 (cond ((regexp? v) v)
119 ((string? v) (make-regexp v))
120 (else default-after-line-re)))))
121 (scrub (if (> 3 (length cust))
123 (let ((v (caddr cust)))
124 (cond ((procedure? v) v)
125 (else default-scrub))))))
126 (call-with-input-file filename
128 (let loop ((line (read-delimited "\n" port))
130 (parse-state 'before))
131 (if (or (eof-object? line) (eq? 'after parse-state))
134 (cond ((regexp-exec in-line-re line) 'in)
135 ((regexp-exec after-line-re line) 'after)
136 (else parse-state))))
137 (if (eq? 'after new-state)
139 (loop (read-delimited "\n" port)
140 (if (and (eq? 'in new-state) (eq? 'in parse-state))
141 (string-append doc (scrub line) "\n")
148 ;; documentation-files is the list of places to look for documentation
150 (define documentation-files
151 (map (lambda (vicinity)
152 (in-vicinity (vicinity) "guile-procedures.txt"))
158 (define entry-delimiter "\f")
160 (define (find-documentation-in-file name file)
161 (and (file-exists? file)
162 (call-with-input-file file
164 (let ((name (symbol->string name)))
165 (let ((len (string-length name)))
166 (read-delimited entry-delimiter port) ;skip to first entry
167 (let loop ((entry (read-delimited entry-delimiter port)))
168 (cond ((eof-object? entry) #f)
170 ((and ;; large enough?
171 (>= (string-length entry) len)
173 (string=? (substring entry 0 len) name)
175 (memq (string-ref entry len) '(#\newline)))
176 ;; cut away name tag and extra surrounding newlines
177 (substring entry (+ len 2) (- (string-length entry) 2)))
178 (else (loop (read-delimited entry-delimiter port)))))))))))
180 (define (search-documentation-files name . files)
181 (or-map (lambda (file)
182 (find-documentation-in-file name file))
183 (cond ((null? files) documentation-files)
186 (define (object-documentation object)
187 "Return the docstring for OBJECT.
188 OBJECT can be a procedure, macro or any object that has its
189 `documentation' property set."
190 (or (and (procedure? object)
191 (procedure-documentation object))
192 (object-property object 'documentation)
194 (object-documentation (macro-transformer object)))
195 (and (procedure? object)
196 (procedure-name object)
197 (let ((docstring (search-documentation-files
198 (procedure-name object))))
200 (set-procedure-property! object 'documentation docstring))
203 ;;; documentation.scm ends here