Commit | Line | Data |
---|---|---|
1e23b461 | 1 | ;;;; Copyright (C) 2000,2001, 2002, 2003, 2006, 2009, 2010 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 | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
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) |
115d80dc TTN |
83 | :export (file-commentary |
84 | documentation-files search-documentation-files | |
85 | object-documentation) | |
70afc25b | 86 | :autoload (ice-9 regex) (match:suffix) |
245dfe7f MD |
87 | :no-backtrace) |
88 | ||
89 | \f | |
70afc25b TTN |
90 | ;; |
91 | ;; commentary extraction | |
92 | ;; | |
70afc25b TTN |
93 | |
94 | (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB) | |
5be9f729 KR |
95 | |
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. | |
100 | ;; | |
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 "^;+"))) | |
104 | (lambda (line) | |
105 | (let ((m (regexp-exec dirt line))) | |
106 | (if m (match:suffix m) line))))) | |
107 | ||
70afc25b TTN |
108 | ;; fixme: might be cleaner to use optargs here... |
109 | (let ((in-line-re (if (> 1 (length cust)) | |
110 | default-in-line-re | |
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)) | |
122 | default-scrub | |
123 | (let ((v (caddr cust))) | |
124 | (cond ((procedure? v) v) | |
a3e01368 KR |
125 | (else default-scrub)))))) |
126 | (call-with-input-file filename | |
127 | (lambda (port) | |
128 | (let loop ((line (read-delimited "\n" port)) | |
129 | (doc "") | |
130 | (parse-state 'before)) | |
131 | (if (or (eof-object? line) (eq? 'after parse-state)) | |
132 | doc | |
133 | (let ((new-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) | |
138 | doc | |
139 | (loop (read-delimited "\n" port) | |
140 | (if (and (eq? 'in new-state) (eq? 'in parse-state)) | |
141 | (string-append doc (scrub line) "\n") | |
142 | doc) | |
143 | new-state))))))))) | |
70afc25b TTN |
144 | |
145 | \f | |
245dfe7f MD |
146 | |
147 | ;; | |
148 | ;; documentation-files is the list of places to look for documentation | |
149 | ;; | |
70afc25b | 150 | (define documentation-files |
245dfe7f MD |
151 | (map (lambda (vicinity) |
152 | (in-vicinity (vicinity) "guile-procedures.txt")) | |
153 | (list %library-dir | |
154 | %package-data-dir | |
155 | %site-dir | |
156 | (lambda () ".")))) | |
157 | ||
245dfe7f | 158 | (define entry-delimiter "\f") |
245dfe7f MD |
159 | |
160 | (define (find-documentation-in-file name file) | |
161 | (and (file-exists? file) | |
a3e01368 KR |
162 | (call-with-input-file file |
163 | (lambda (port) | |
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) | |
169 | ;; match? | |
170 | ((and ;; large enough? | |
db611983 | 171 | (>= (string-length entry) len) |
245dfe7f | 172 | ;; matching name? |
db611983 | 173 | (string=? (substring entry 0 len) name) |
245dfe7f | 174 | ;; terminated? |
db611983 | 175 | (memq (string-ref entry len) '(#\newline))) |
a3e01368 KR |
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))))))))))) | |
245dfe7f | 179 | |
115d80dc TTN |
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) | |
184 | (else files)))) | |
185 | ||
70afc25b TTN |
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." | |
245dfe7f | 190 | (or (and (procedure? object) |
1e23b461 | 191 | (procedure-documentation object)) |
245dfe7f | 192 | (object-property object 'documentation) |
81fd3152 AW |
193 | (and (macro? object) |
194 | (object-documentation (macro-transformer object))) | |
245dfe7f | 195 | (and (procedure? object) |
245dfe7f | 196 | (procedure-name object) |
115d80dc TTN |
197 | (let ((docstring (search-documentation-files |
198 | (procedure-name object)))) | |
245dfe7f MD |
199 | (if docstring |
200 | (set-procedure-property! object 'documentation docstring)) | |
201 | docstring)))) | |
70afc25b TTN |
202 | |
203 | ;;; documentation.scm ends here |