Commit | Line | Data |
---|---|---|
cd5fea8d | 1 | ;;;; Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc. |
70afc25b | 2 | ;;;; |
73be1d9e MV |
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, | |
245dfe7f | 9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
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 | |
92205699 | 15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 16 | ;;;; |
70afc25b TTN |
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 | ;; | |
115d80dc TTN |
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 | ;; | |
70afc25b TTN |
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 | |
115d80dc | 43 | ;; |
70afc25b TTN |
44 | ;; ^LPROC2 |
45 | ;; DOCUMENTATION2 | |
115d80dc TTN |
46 | ;; |
47 | ;; ^L... | |
70afc25b TTN |
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 | |
115d80dc TTN |
52 | ;; formatting. Note that there are two newlines before the next formfeed; |
53 | ;; these are discarded when the documentation is read in. | |
70afc25b TTN |
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: | |
245dfe7f MD |
80 | |
81 | (define-module (ice-9 documentation) | |
6d36532c | 82 | :use-module (ice-9 rdelim) |
8befde00 | 83 | :use-module ((system vm program) :select (program? program-documentation)) |
115d80dc TTN |
84 | :export (file-commentary |
85 | documentation-files search-documentation-files | |
86 | object-documentation) | |
70afc25b | 87 | :autoload (ice-9 regex) (match:suffix) |
245dfe7f MD |
88 | :no-backtrace) |
89 | ||
90 | \f | |
70afc25b TTN |
91 | ;; |
92 | ;; commentary extraction | |
93 | ;; | |
70afc25b TTN |
94 | |
95 | (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB) | |
5be9f729 KR |
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 | ||
70afc25b TTN |
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) | |
a3e01368 KR |
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))))))))) | |
70afc25b TTN |
145 | |
146 | \f | |
245dfe7f MD |
147 | |
148 | ;; | |
149 | ;; documentation-files is the list of places to look for documentation | |
150 | ;; | |
70afc25b | 151 | (define documentation-files |
245dfe7f MD |
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 | ||
245dfe7f | 159 | (define entry-delimiter "\f") |
245dfe7f MD |
160 | |
161 | (define (find-documentation-in-file name file) | |
162 | (and (file-exists? file) | |
a3e01368 KR |
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? | |
db611983 | 172 | (>= (string-length entry) len) |
245dfe7f | 173 | ;; matching name? |
db611983 | 174 | (string=? (substring entry 0 len) name) |
245dfe7f | 175 | ;; terminated? |
db611983 | 176 | (memq (string-ref entry len) '(#\newline))) |
a3e01368 KR |
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))))))))))) | |
245dfe7f | 180 | |
115d80dc TTN |
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 | ||
245dfe7f MD |
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 | ||
70afc25b TTN |
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." | |
245dfe7f MD |
196 | (or (and (procedure? object) |
197 | (proc-doc object)) | |
abce330c MD |
198 | (and (defmacro? object) |
199 | (proc-doc (defmacro-transformer object))) | |
245dfe7f MD |
200 | (and (macro? object) |
201 | (let ((transformer (macro-transformer object))) | |
202 | (and transformer | |
203 | (proc-doc transformer)))) | |
204 | (object-property object 'documentation) | |
8befde00 AW |
205 | (and (program? object) |
206 | (program-documentation object)) | |
245dfe7f MD |
207 | (and (procedure? object) |
208 | (not (closure? object)) | |
209 | (procedure-name object) | |
115d80dc TTN |
210 | (let ((docstring (search-documentation-files |
211 | (procedure-name object)))) | |
245dfe7f MD |
212 | (if docstring |
213 | (set-procedure-property! object 'documentation docstring)) | |
214 | docstring)))) | |
70afc25b TTN |
215 | |
216 | ;;; documentation.scm ends here |