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

Contents of /src/hyperdoc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Tue Nov 18 17:01:38 2003 UTC (10 years, 5 months ago) by nsiivola
Branch: MAIN
Changes since 1.1: +38 -21 lines
API tweaking.
1 nsiivola 1.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 nsiivola 1.2 (defun package-string (package)
44     (etypecase package
45     (string package)
46     (symbol (symbol-name package))
47     (package (package-name package))))
48    
49     (defparameter *hyperdoc-types*
50     ;; These correspond to what DOCUMENTATION uses, plus macro-function
51     ;; and and symbol-function.
52     '(t symbol-function macro-function
53     function compiler-macro setf method-combination type structure
54     variable))
55    
56 nsiivola 1.1 ;;;; The meat and the bones
57    
58 nsiivola 1.2 (defvar *base-uris* (make-hash-table :test 'equal))
59 nsiivola 1.1
60     (defun base-uri (package)
61 nsiivola 1.2 "Base URI for hyperdocs for package."
62     (or (gethash (package-string package) *base-uris*)
63 nsiivola 1.1 (symbol-value (find-symbol "*HYPERDOC-BASE-URI*" package))
64 nsiivola 1.2 (error "No base URI for package ~A." (package-string package))))
65 nsiivola 1.1
66     (defun (setf base-uri) (uri package)
67 nsiivola 1.2 "Set new base URI for hyperdocs for PACKAGE."
68     (setf (gethash (package-string package) *base-uris*) uri))
69 nsiivola 1.1
70     (defun lookup-all-types (lookup package symbol)
71     (declare (symbol lookup))
72     (let (uris)
73 nsiivola 1.2 (dolist (doc-type (append *hyperdoc-types*
74     (find-value "*HYPERDOC-EXTRA-TYPES*" package)))
75 nsiivola 1.1 (let ((uri (funcall lookup symbol doc-type)))
76 nsiivola 1.2 (when uri
77     (pushnew (cons doc-type uri) uris :key 'cdr :test 'equal))))
78 nsiivola 1.1 uris))
79    
80 nsiivola 1.2 (defun lookup (symbol &optional (doc-type nil doc-type-p))
81     "Look up hyperdoc URI-string for symbol of doc-type. if no doc-type
82     is given, returns an list of applicable (doc-type . uri-string)
83     pairs.
84    
85     The considered doc-types are the same ones ANSI specifies for DOCUMENTATION,
86     plus symbol-function and symbol-macro. These are intended to represent subsets
87     of function. (ANSI used DOCUMENTATION symbol 'function for both macros and
88     functions.)"
89 nsiivola 1.1 (let* ((package (symbol-package symbol))
90     (lookup (find-symbol "HYPERDOC-LOOKUP" package)))
91     (if lookup
92 nsiivola 1.2 (let ((base (base-uri package)))
93     (if doc-type-p
94     (let ((uri (funcall lookup symbol doc-type)))
95     (when uri
96     (merge-uris base uri)))
97 nsiivola 1.1 (mapcar (lambda (pair)
98 nsiivola 1.2 (cons (car pair) (merge-uris base (cdr pair))))
99 nsiivola 1.1 (lookup-all-types lookup package symbol))))
100     (hyperspec:lookup (symbol-name symbol)))))
101    
102     ;;;; Introspection
103    
104     (defvar *hyperdoc-base-uri* "http://common-lisp.net/project/hyperdoc/doc/")
105    
106     (defun hyperdoc-lookup (symbol doc-type)
107     (declare (ignore doc-type))
108     #+nil (concatenate 'string "index.html#" (string-downcase (symbol-name symbol))))

  ViewVC Help
Powered by ViewVC 1.1.5