/[hyperdoc]/src/hyperdoc.lisp
ViewVC logotype

Contents of /src/hyperdoc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sat Apr 24 20:04:40 2004 UTC (9 years, 11 months ago) by nsiivola
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +249 -60 lines
Restructuring, initial version of static indices
1 ;;;; Copyright (c) 2003, 2004 Nikodemus Siivola
2 ;;;;
3 ;;;; Permission is hereby granted, free of charge, to any person obtaining
4 ;;;; a copy of this software and associated documentation files (the
5 ;;;; "Software"), to deal in the Software without restriction, including
6 ;;;; without limitation the rights to use, copy, modify, merge, publish,
7 ;;;; distribute, sublicense, and/or sell copies of the Software, and to
8 ;;;; permit persons to whom the Software is furnished to do so, subject to
9 ;;;; the following conditions:
10 ;;;;
11 ;;;; The above copyright notice and this permission notice shall be
12 ;;;; included in all copies or substantial portions of the Software.
13 ;;;;
14 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16 ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17 ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18 ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19 ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20 ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22 (defpackage :hyperdoc
23 (:use :cl)
24 (:export
25 #:lookup
26 #:base-uri
27 #:generate-index
28 #:*index-directory*
29 ))
30
31 (in-package :hyperdoc)
32
33 ;;;; Utility functions
34
35 (defun find-value (name package)
36 "Returns the symbol-value of the symbol NAME in PACKAGE, and T as a
37 secondary value if the symbol is bound. Returns NIL, NIL if the symbol
38 doesn't exist or is not bound."
39 (let ((symbol (find-symbol name package)))
40 (if (and symbol (boundp symbol))
41 (values (symbol-value symbol) t)
42 (values nil nil))))
43
44 (defun find-function (name package)
45 "Returns the symbol-funciton of the symbol NAME in PACKAGE, and T as
46 a secondary value if the symbol is fbound. Returns NIL, NIL if the
47 symbol doesn't exist or is not fbound."
48 (let ((symbol (find-symbol name package)))
49 (if (and symbol (fboundp symbol))
50 (symbol-function symbol)
51 nil)))
52
53 (defun merge-uris (relative base)
54 "Merges RELATIVE to BASE."
55 ;; Yuck. This is so WRONG.
56 (concatenate 'string base relative))
57
58 (defun package-string (package)
59 "Returns the name of the designated package."
60 (etypecase package
61 (string package)
62 (symbol (symbol-name package))
63 (package (package-name package))))
64
65 (defun hash-alist (hash)
66 "Returns an alist corresponding to the HASH."
67 (let (alist)
68 (maphash (lambda (key value)
69 (push (cons key value) alist))
70 hash)
71 alist))
72
73 (defun alist-hash (alist &key (test #'eql))
74 "Returns a hash corresponding to the ALIST."
75 (let ((hash (make-hash-table :test test)))
76 (dolist (x alist)
77 (setf (gethash (car x) hash) (cdr x)))
78 hash))
79
80 ;;;; Varaibles
81
82 (defvar *index* nil
83 "In memory index. FIXME: This should be loaded when hyperdoc is
84 loaded -- or at least lazily on first call to X.")
85
86 (defvar *index-directory* (merge-pathnames ".hyperdoc/" (user-homedir-pathname))
87 "The directory where Hyperdoc keeps the pregenerated indices.")
88
89 (defvar *name-index-version* "Hyperdoc Name Index -- Version 1"
90 "Magic version indentifier used in the name index files.")
91
92 (defvar *package-index-version* "Hyperdoc Package Index -- Version 1"
93 "Magic version indentifier used in the package index files.")
94
95 (defvar *index-herald*
96 ";;;; This is an automatically generated index -- do not edit by hand!
97 ;;;; See http://www.common-lisp.net/project/hyperdoc/ for more information."
98 "Herald printed in the beginning of the index file to discourage tampering.")
99
100 (defparameter *documentation-types*
101 (list "T" "SYMBOL-MACRO" "MACRO" "CONDITION" "METHOD"
102 "GENERIC-FUNCTION" "CLASS" "TYPE" "FUNCTION" "COMPILER-MACRO" "SETF"
103 "METHOD-COMBINATION" "TYPE" "STRUCTURE"
104 "VARIABLE" "CONSTANT")
105 "Names string of documentation types used by Hyperdoc. These
106 correspond to what DOCUMENTATION uses with a few additions.")
107
108 (defvar *base-uris* (make-hash-table :test #'equal)
109 "Holds the locally defined base-uris of various packages. Accessed via BASE-URI and (SETF BASE-URI).")
110
111 ;;;; The meat and the bones
112
113 (defun base-uri (package)
114 "Base URI for hyperdocs for package."
115 (or (gethash (package-string package) *base-uris*)
116 (find-value "*HYPERDOC-BASE-URI*" package)
117 (error "No base URI for package ~A." (package-string package))))
118
119 (defun (setf base-uri) (uri package)
120 "Set new base URI for hyperdocs for PACKAGE."
121 (setf (gethash (package-string package) *base-uris*) uri))
122
123 (defun lookup (package-designator symbol-name &optional doc-type)
124 "Look up documentation URI-string for the named symbol of doc-type
125 in the designated package. If the package is not loaded pregenerated
126 indices are used.
127
128 If package doesn't support Hyperdoc, or no documentation for the named
129 symbol is found, a call to hyperspec:lookup with the symbol-name is
130 attempted.
131
132 If the package supports Hyperdoc, but no doc-type is given and there
133 are multiple matches, a list of applicable (doc-type . uri-string)
134 pairs is returned -- if only single doc-type matches just the URI is
135 returned."
136 (let* ((package (find-package package-designator))
137 (uris
138 (or (if package
139 (introspective-lookup (intern symbol-name package) doc-type)
140 (index-lookup (package-string package-designator)
141 symbol-name doc-type))
142 (hyperspec:lookup symbol-name))))
143 (if (and (listp uris) (null (cdr uris)))
144 (cdr (first uris))
145 uris)))
146
147 (defun introspective-lookup (symbol &optional doc-type)
148 "Looks up hyperdocumentation for the symbol in the current image."
149 (let ((base-uri (base-uri (symbol-package symbol))))
150 (mapcar (lambda (pair)
151 (cons (car pair) (merge-uris (cdr pair) base-uri)))
152 (%lookup symbol doc-type))))
153
154 (defun index-lookup (package-name symbol-name doc-type)
155 "Looks up hyperdocumentation for the symbol in the pregenerated indices."
156 (unless *index*
157 (setf *index* (read-index)))
158 (let* ((name (gethash package-name (name-table *index*)))
159 (base-uri (gethash name (base-uri-table *index*))))
160 (mapcar (lambda (pair)
161 (cons (car pair) (merge-uris (cdr pair) base-uri)))
162 (let ((uris (gethash symbol-name
163 (gethash name (package-table *index*)))))
164 (if doc-type
165 (assoc doc-type uris)
166 uris)))))
167
168 (defun %lookup (symbol &optional doc-type)
169 "Primitive for introspective hyperdoc lookup. Doesn't merge the uris."
170 (let* ((package (symbol-package symbol))
171 (lookup (find-symbol "HYPERDOC-LOOKUP" package)))
172 (when lookup
173 (remove-duplicates (mapcan (lambda (type)
174 (let ((uri (funcall lookup symbol type)))
175 (when uri
176 (list (cons type uri)))))
177 (if doc-type
178 (list doc-type)
179 (all-documentation-types package)))
180 :test #'string=
181 :key #'cdr))))
182
183 (defun all-documentation-types (package)
184 (union *documentation-types*
185 (find-symbol "*HYPERDOC-DOCUMENTATION-TYPES*" package)
186 :test #'string=))
187
188 (defun name-index-pathname ()
189 (merge-pathnames "names.sexp" *index-directory*))
190
191 (defun package-index-pathname (package)
192 (merge-pathnames (make-pathname :name (package-string package)
193 :type "sexp" )
194 (merge-pathnames "packages/" *index-directory*)))
195
196 ;;;; Static indexes
197
198 (defclass index ()
199 ((names :accessor name-table
200 :initform (make-hash-table :test #'equal))
201 (base-uris :accessor base-uri-table
202 :initform (make-hash-table :test #'equal))
203 (package-tables :accessor package-table
204 :initform (make-hash-table :test #'equal))))
205
206 (defun generate-index (package-designator)
207 "Generate Hyperdoc index for the designated package."
208 (unless *index*
209 (setf *index* (read-index)))
210 (let* ((package (or (find-package package-designator)
211 (error "No such package: ~S." package-designator)))
212 (name (package-name package))
213 (all-names (cons name (package-nicknames package)))
214 (base-uri (base-uri package))
215 (name-table (name-table *index*))
216 (base-uri-table (base-uri-table *index*))
217 (package-table (package-table *index*)))
218
219 ;; Clear old entries
220 (let (old-name)
221 (maphash (lambda (key value)
222 (when (member key all-names :test #'string=)
223 (setf old-name value)
224 (remhash key name-table)))
225 name-table)
226 (remhash old-name base-uri-table)
227 (remhash old-name package-table)
228 ;; Handle case where the canonical name has changed
229 (when (gethash old-name name-table)
230 (remhash old-name name-table)))
231
232 ;; New entries
233 (dolist (n all-names)
234 (setf (gethash n name-table) name))
235 (setf (gethash name base-uri-table) base-uri)
236 (let ((symbol-table (make-hash-table :test #'equal)))
237 (do-external-symbols (sym package)
238 (let ((docs (%lookup sym)))
239 (when docs
240 (setf (gethash (symbol-name sym) symbol-table) docs))))
241 (setf (gethash name package-table) symbol-table))
242
243 ;; Save
244 (ensure-directories-exist *index-directory*)
245 (with-standard-io-syntax
246 (with-open-file (f (name-index-pathname)
247 :direction :output
248 :if-exists :rename)
249 (write-line *index-herald* f)
250 (prin1 *name-index-version* f)
251 (terpri f)
252 (prin1 (hash-alist name-table) f)
253 (terpri f))
254 (let ((package-index (package-index-pathname name)))
255 (ensure-directories-exist package-index)
256 (with-open-file (f package-index
257 :direction :output
258 :if-exists :rename)
259 (write-line *index-herald* f)
260 (prin1 *package-index-version* f)
261 (terpri f)
262 (prin1 `(("BASE-URI" . ,base-uri)
263 ("SYMBOLS" . ,(hash-alist (gethash name package-table))))
264 f)
265 (terpri f))))))
266
267 (defun read-index ()
268 (let ((index (make-instance 'index))
269 (names (with-open-file (f (name-index-pathname))
270 (unless (equal *name-index-version* (read f))
271 (error "Name index version mismatch. Oh dear."))
272 (read f))))
273 (dolist (n names)
274 (setf (gethash (car n) (name-table index)) (cdr n)))
275 (maphash (lambda (nick name)
276 (declare (ignore nick))
277 (with-open-file (f (package-index-pathname name))
278 (unless (equal *package-index-version* (read f))
279 (error "Package index version mismatch. Opps."))
280 (let ((package-index (read f)))
281 (setf (gethash name (package-table index))
282 (alist-hash (cdr (assoc "SYMBOLS" package-index
283 :test #'string=))
284 :test #'equal))
285 (setf (gethash name (base-uri-table index))
286 (cdr (assoc "BASE-URI" package-index :test #'string=))))))
287 (name-table index))
288 index))
289
290 ;;;; Introspection
291
292 (defvar *hyperdoc-base-uri* "http://common-lisp.net/project/hyperdoc/doc/")
293
294 (defun hyperdoc-lookup (symbol doc-type)
295 (declare (ignore doc-type))
296 #+nil
297 (concatenate 'string "index.html#" (string-downcase (symbol-name symbol))))

  ViewVC Help
Powered by ViewVC 1.1.5