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

Contents of /src/hyperdoc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Mon Nov 17 15:28:48 2003 UTC (10 years, 5 months ago) by nsiivola
Branch: nikodemus
CVS Tags: initial
Changes since 1.1: +0 -0 lines
Initial import.
1 ;; Copyright (c) 2003 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 ))
28
29 (in-package :hyperdoc)
30
31 ;;;; Utility functions
32
33 (defun find-value (name package)
34 (let ((symbol (find-symbol name package)))
35 (if (and symbol (boundp symbol))
36 (values (symbol-value symbol) t)
37 (values nil nil))))
38
39 (defun merge-uris (base relative)
40 ;; Yuck. This is so WRONG.
41 (concatenate 'string base relative))
42
43 ;;;; The meat and the bones
44
45 (defvar *base-uris* ())
46
47 (defun base-uri (package)
48 "Base URI for hyperdocs for PACKAGE."
49 (or (cdr (assoc-if (lambda (id)
50 (eq package (find-package id)))
51 *base-uris*))
52 (symbol-value (find-symbol "*HYPERDOC-BASE-URI*" package))
53 (error "No base URI for package ~A." (package-name package))))
54
55 (defun (setf base-uri) (uri package)
56 "Set new base URI for hyperdocs for PACKAGE."
57 (push (cons package uri) *base-uris*))
58
59
60 (defun lookup-all-types (lookup package symbol)
61 (declare (symbol lookup))
62 (let (uris)
63 (dolist (doc-type (list* 't 'function 'compiler-macro 'setf
64 'method-combination 'type 'structure 'variable
65 (find-value "*HYPERDOC-EXTRA-TYPES*" package)))
66 (let ((uri (funcall lookup symbol doc-type)))
67 (when (and uri (not (assoc uri uris :test 'equal)))
68 (push (cons uri (symbol-name doc-type)) uris))))
69 uris))
70
71 (defun lookup (symbol &optional doc-type)
72 "Look up hyperdoc URI(s) for SYMBOL of DOC-TYPE."
73 (let* ((package (symbol-package symbol))
74 (lookup (find-symbol "HYPERDOC-LOOKUP" package)))
75 (if lookup
76 (let ((uri (funcall lookup symbol doc-type))
77 (base (base-uri package)))
78 (if (or uri doc-type)
79 (merge-uris base uri)
80 (mapcar (lambda (pair)
81 (cons (merge-uris base (car pair)) (cdr pair)))
82 (lookup-all-types lookup package symbol))))
83 (hyperspec:lookup (symbol-name symbol)))))
84
85 ;;;; Introspection
86
87 (defvar *hyperdoc-base-uri* "http://common-lisp.net/project/hyperdoc/doc/")
88
89 (defun hyperdoc-lookup (symbol doc-type)
90 (declare (ignore doc-type))
91 #+nil (concatenate 'string "index.html#" (string-downcase (symbol-name symbol))))

  ViewVC Help
Powered by ViewVC 1.1.5