Commit | Line | Data |
---|---|---|
abce330c | 1 | ;;;; Copyright (C) 2000,2001, 2002 Free Software Foundation, Inc. |
70afc25b | 2 | ;;;; |
245dfe7f MD |
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. | |
70afc25b | 7 | ;;;; |
245dfe7f MD |
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. | |
70afc25b | 12 | ;;;; |
245dfe7f MD |
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 | |
70afc25b | 17 | ;;;; |
a482f2cc MV |
18 | ;;;; As a special exception, the Free Software Foundation gives permission |
19 | ;;;; for additional uses of the text contained in its release of GUILE. | |
20 | ;;;; | |
21 | ;;;; The exception is that, if you link the GUILE library with other files | |
22 | ;;;; to produce an executable, this does not by itself cause the | |
23 | ;;;; resulting executable to be covered by the GNU General Public License. | |
24 | ;;;; Your use of that executable is in no way restricted on account of | |
25 | ;;;; linking the GUILE library code into it. | |
26 | ;;;; | |
27 | ;;;; This exception does not however invalidate any other reasons why | |
28 | ;;;; the executable file might be covered by the GNU General Public License. | |
29 | ;;;; | |
30 | ;;;; This exception applies only to the code released by the | |
31 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
32 | ;;;; code from other Free Software Foundation releases into a copy of | |
33 | ;;;; GUILE, as the General Public License permits, the exception does | |
34 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
35 | ;;;; anyone as to the status of such modified files, you must delete | |
36 | ;;;; this exception notice from them. | |
37 | ;;;; | |
38 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
39 | ;;;; whether to permit this exception to apply to your modifications. | |
40 | ;;;; If you do not wish that, delete this exception notice. | |
41 | ;;;; | |
70afc25b TTN |
42 | |
43 | ;;; Commentary: | |
44 | ||
45 | ;; * This module exports: | |
46 | ;; | |
47 | ;; file-commentary -- a procedure that returns a file's "commentary" | |
48 | ;; | |
49 | ;; documentation-files -- a search-list of files using the Guile | |
50 | ;; Documentation Format Version 2. | |
51 | ;; | |
115d80dc TTN |
52 | ;; search-documentation-files -- a procedure that takes NAME (a symbol) |
53 | ;; and searches `documentation-files' for | |
54 | ;; associated documentation. optional | |
55 | ;; arg FILES is a list of filenames to use | |
56 | ;; instead of `documentation-files'. | |
57 | ;; | |
70afc25b TTN |
58 | ;; object-documentation -- a procedure that returns its arg's docstring |
59 | ;; | |
60 | ;; * Guile Documentation Format | |
61 | ;; | |
62 | ;; Here is the complete and authoritative documentation for the Guile | |
63 | ;; Documentation Format Version 2: | |
64 | ;; | |
65 | ;; HEADER | |
66 | ;; ^LPROC1 | |
67 | ;; DOCUMENTATION1 | |
115d80dc | 68 | ;; |
70afc25b TTN |
69 | ;; ^LPROC2 |
70 | ;; DOCUMENTATION2 | |
115d80dc TTN |
71 | ;; |
72 | ;; ^L... | |
70afc25b TTN |
73 | ;; |
74 | ;; The HEADER is completely ignored. The "^L" are formfeeds. PROC1, PROC2 | |
75 | ;; and so on are symbols that name the element documented. DOCUMENTATION1, | |
76 | ;; DOCUMENTATION2 and so on are the related documentation, w/o any further | |
115d80dc TTN |
77 | ;; formatting. Note that there are two newlines before the next formfeed; |
78 | ;; these are discarded when the documentation is read in. | |
70afc25b TTN |
79 | ;; |
80 | ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being | |
81 | ;; not documented anywhere except by this embarrassingly circular comment.) | |
82 | ;; | |
83 | ;; * File Commentary | |
84 | ;; | |
85 | ;; A file's commentary is the body of text found between comments | |
86 | ;; ;;; Commentary: | |
87 | ;; and | |
88 | ;; ;;; Code: | |
89 | ;; both of which must be at the beginning of the line. In the result string, | |
90 | ;; semicolons at the beginning of each line are discarded. | |
91 | ;; | |
92 | ;; You can specify to `file-commentary' alternate begin and end strings, and | |
93 | ;; scrub procedure. Use #t to get default values. For example: | |
94 | ;; | |
95 | ;; (file-commentary "documentation.scm") | |
96 | ;; You should see this text! | |
97 | ;; | |
98 | ;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$") | |
99 | ;; You should see the rest of this file. | |
100 | ;; | |
101 | ;; (file-commentary "documentation.scm" #t #t string-upcase) | |
102 | ;; You should see this text very loudly (note semicolons untouched). | |
103 | ||
104 | ;;; Code: | |
245dfe7f MD |
105 | |
106 | (define-module (ice-9 documentation) | |
6d36532c | 107 | :use-module (ice-9 rdelim) |
115d80dc TTN |
108 | :export (file-commentary |
109 | documentation-files search-documentation-files | |
110 | object-documentation) | |
70afc25b | 111 | :autoload (ice-9 regex) (match:suffix) |
245dfe7f MD |
112 | :no-backtrace) |
113 | ||
114 | \f | |
70afc25b TTN |
115 | ;; |
116 | ;; commentary extraction | |
117 | ;; | |
118 | (define default-in-line-re (make-regexp "^;;; Commentary:")) | |
119 | (define default-after-line-re (make-regexp "^;;; Code:")) | |
120 | (define default-scrub (let ((dirt (make-regexp "^;+"))) | |
121 | (lambda (line) | |
122 | (let ((m (regexp-exec dirt line))) | |
123 | (if m (match:suffix m) line))))) | |
124 | ||
125 | (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB) | |
126 | ;; fixme: might be cleaner to use optargs here... | |
127 | (let ((in-line-re (if (> 1 (length cust)) | |
128 | default-in-line-re | |
129 | (let ((v (car cust))) | |
130 | (cond ((regexp? v) v) | |
131 | ((string? v) (make-regexp v)) | |
132 | (else default-in-line-re))))) | |
133 | (after-line-re (if (> 2 (length cust)) | |
134 | default-after-line-re | |
135 | (let ((v (cadr cust))) | |
136 | (cond ((regexp? v) v) | |
137 | ((string? v) (make-regexp v)) | |
138 | (else default-after-line-re))))) | |
139 | (scrub (if (> 3 (length cust)) | |
140 | default-scrub | |
141 | (let ((v (caddr cust))) | |
142 | (cond ((procedure? v) v) | |
143 | (else default-scrub))))) | |
144 | (port (open-input-file filename))) | |
145 | (let loop ((line (read-delimited "\n" port)) | |
146 | (doc "") | |
147 | (parse-state 'before)) | |
148 | (if (or (eof-object? line) (eq? 'after parse-state)) | |
149 | doc | |
150 | (let ((new-state | |
151 | (cond ((regexp-exec in-line-re line) 'in) | |
152 | ((regexp-exec after-line-re line) 'after) | |
153 | (else parse-state)))) | |
154 | (if (eq? 'after new-state) | |
155 | doc | |
156 | (loop (read-delimited "\n" port) | |
157 | (if (and (eq? 'in new-state) (eq? 'in parse-state)) | |
158 | (string-append doc (scrub line) "\n") | |
159 | doc) | |
160 | new-state))))))) | |
161 | ||
162 | \f | |
245dfe7f MD |
163 | |
164 | ;; | |
165 | ;; documentation-files is the list of places to look for documentation | |
166 | ;; | |
70afc25b | 167 | (define documentation-files |
245dfe7f MD |
168 | (map (lambda (vicinity) |
169 | (in-vicinity (vicinity) "guile-procedures.txt")) | |
170 | (list %library-dir | |
171 | %package-data-dir | |
172 | %site-dir | |
173 | (lambda () ".")))) | |
174 | ||
245dfe7f | 175 | (define entry-delimiter "\f") |
245dfe7f MD |
176 | |
177 | (define (find-documentation-in-file name file) | |
178 | (and (file-exists? file) | |
179 | (let ((port (open-input-file file)) | |
180 | (name (symbol->string name))) | |
db611983 | 181 | (let ((len (string-length name))) |
245dfe7f MD |
182 | (read-delimited entry-delimiter port) ;skip to first entry |
183 | (let loop ((entry (read-delimited entry-delimiter port))) | |
184 | (cond ((eof-object? entry) #f) | |
185 | ;; match? | |
186 | ((and ;; large enough? | |
db611983 | 187 | (>= (string-length entry) len) |
245dfe7f | 188 | ;; matching name? |
db611983 | 189 | (string=? (substring entry 0 len) name) |
245dfe7f | 190 | ;; terminated? |
db611983 NJ |
191 | (memq (string-ref entry len) '(#\newline))) |
192 | ;; cut away name tag and extra surrounding newlines | |
193 | (substring entry (+ len 2) (- (string-length entry) 2))) | |
245dfe7f MD |
194 | (else (loop (read-delimited entry-delimiter port))))))))) |
195 | ||
115d80dc TTN |
196 | (define (search-documentation-files name . files) |
197 | (or-map (lambda (file) | |
198 | (find-documentation-in-file name file)) | |
199 | (cond ((null? files) documentation-files) | |
200 | (else files)))) | |
201 | ||
245dfe7f MD |
202 | ;; helper until the procedure documentation property is cleaned up |
203 | (define (proc-doc proc) | |
204 | (or (procedure-documentation proc) | |
205 | (procedure-property proc 'documentation))) | |
206 | ||
70afc25b TTN |
207 | (define (object-documentation object) |
208 | "Return the docstring for OBJECT. | |
209 | OBJECT can be a procedure, macro or any object that has its | |
210 | `documentation' property set." | |
245dfe7f MD |
211 | (or (and (procedure? object) |
212 | (proc-doc object)) | |
abce330c MD |
213 | (and (defmacro? object) |
214 | (proc-doc (defmacro-transformer object))) | |
245dfe7f MD |
215 | (and (macro? object) |
216 | (let ((transformer (macro-transformer object))) | |
217 | (and transformer | |
218 | (proc-doc transformer)))) | |
219 | (object-property object 'documentation) | |
245dfe7f MD |
220 | (and (procedure? object) |
221 | (not (closure? object)) | |
222 | (procedure-name object) | |
115d80dc TTN |
223 | (let ((docstring (search-documentation-files |
224 | (procedure-name object)))) | |
245dfe7f MD |
225 | (if docstring |
226 | (set-procedure-property! object 'documentation docstring)) | |
227 | docstring)))) | |
70afc25b TTN |
228 | |
229 | ;;; documentation.scm ends here |