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

Contents of /src/hyperdoc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide 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 nsiivola 1.3 ;;;; 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 nsiivola 1.1
22     (defpackage :hyperdoc
23     (:use :cl)
24     (:export
25     #:lookup
26     #:base-uri
27 nsiivola 1.3 #:generate-index
28     #:*index-directory*
29 nsiivola 1.1 ))
30    
31     (in-package :hyperdoc)
32    
33     ;;;; Utility functions
34    
35     (defun find-value (name package)
36 nsiivola 1.3 "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 nsiivola 1.1 (let ((symbol (find-symbol name package)))
40     (if (and symbol (boundp symbol))
41     (values (symbol-value symbol) t)
42     (values nil nil))))
43    
44 nsiivola 1.3 (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 nsiivola 1.1 ;; Yuck. This is so WRONG.
56     (concatenate 'string base relative))
57    
58 nsiivola 1.2 (defun package-string (package)
59 nsiivola 1.3 "Returns the name of the designated package."
60 nsiivola 1.2 (etypecase package
61     (string package)
62     (symbol (symbol-name package))
63     (package (package-name package))))
64    
65 nsiivola 1.3 (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 nsiivola 1.2
111 nsiivola 1.1 ;;;; The meat and the bones
112    
113     (defun base-uri (package)
114 nsiivola 1.2 "Base URI for hyperdocs for package."
115     (or (gethash (package-string package) *base-uris*)
116 nsiivola 1.3 (find-value "*HYPERDOC-BASE-URI*" package)
117 nsiivola 1.2 (error "No base URI for package ~A." (package-string package))))
118 nsiivola 1.1
119     (defun (setf base-uri) (uri package)
120 nsiivola 1.2 "Set new base URI for hyperdocs for PACKAGE."
121     (setf (gethash (package-string package) *base-uris*) uri))
122 nsiivola 1.1
123 nsiivola 1.3 (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 nsiivola 1.1 (let* ((package (symbol-package symbol))
171     (lookup (find-symbol "HYPERDOC-LOOKUP" package)))
172 nsiivola 1.3 (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 nsiivola 1.1
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 nsiivola 1.3 #+nil
297     (concatenate 'string "index.html#" (string-downcase (symbol-name symbol))))

  ViewVC Help
Powered by ViewVC 1.1.5