/[defdoc]/DefDoc/src/frontends/basic/engine.lisp
ViewVC logotype

Contents of /DefDoc/src/frontends/basic/engine.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Sun Feb 15 05:01:45 2004 UTC (10 years, 2 months ago) by rjain
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +1 -1 lines
additions and tweaks for the defdoc-generated defdoc website:
elements that are abbreviations for more complex sequences of elements
hyperlink document element
small-caps style element
subtitle in documents
1 rjain 1.1 (in-package :defdoc.frontends.basic)
2    
3     (defvar *documents* (make-hash-table :test 'eq))
4    
5     (defun quote-keynames (arglist)
6     (loop
7     for (name val) on arglist by #'cddr
8     collect `',name
9     collect val))
10    
11     (defun make-contents-form (contents)
12     (if (every (lambda (item) (typep item '(or string character))) contents)
13     (apply 'concatenate 'string contents)
14     `(list ,@(mapcar (lambda (item)
15     (if (or (stringp item) (characterp item))
16     item
17     `(doc ,@item)))
18     contents))))
19    
20 rjain 1.2 (defmacro doc (type &optional initargs &body body)
21 rjain 1.1 (let ((initargs (quote-keynames initargs)))
22     `(make-instance ',type
23     'contents ,(make-contents-form body)
24     ,@initargs)))
25    
26     (defmacro defdoc (name (&optional (type 'document) &rest initargs) &body body)
27     (let ((initargs (quote-keynames initargs)))
28     `(setf (gethash ',name *documents*)
29     (make-instance ',type
30     'contents ,(make-contents-form body)
31     ,@initargs))))
32    
33     (defun undefdoc (name)
34     (remhash name *documents*))
35    
36     (defun find-doc (name)
37     (gethash name *documents*))
38    
39     (defun convert-doc (name target-type &rest other-initargs)
40     (convert (find-doc name)
41     (apply #'make-instance target-type other-initargs)))
42    
43     (defmacro pprint-doc-body ()
44     '(progn
45     (pprint-indent :block 1)
46     (loop
47     (pprint-exit-if-list-exhausted)
48     (write-char #\space)
49     (pprint-newline :linear)
50     (pprint-doc-element *standard-output* (pprint-pop)))))
51    
52     (defmacro pprint-doc-initargs ()
53     '(progn
54     (pprint-exit-if-list-exhausted)
55     (loop
56     (write (pprint-pop)) ; key
57     (write-char #\space)
58     (pprint-newline :miser)
59     (write (pprint-pop)) ; val
60     (pprint-exit-if-list-exhausted)
61     (write-char #\space)
62     (pprint-newline :fill))))
63    
64     (set-pprint-dispatch
65     '(cons (member defdoc))
66     (lambda (*standard-output* obj)
67     (pprint-logical-block (*standard-output* obj :prefix "(" :suffix ")")
68     (write (pprint-pop)) ; defdoc
69     (write-char #\space)
70     (pprint-newline :miser)
71     (pprint-indent :current 0)
72     (write (pprint-pop)) ; name
73     (write-char #\space)
74     (pprint-newline :fill)
75     (pprint-logical-block (*standard-output*
76     (pprint-pop) :prefix "(" :suffix ")")
77     (pprint-exit-if-list-exhausted)
78     (write (pprint-pop)) ; type
79     (write-char #\space)
80     (pprint-newline :linear)
81     (pprint-indent :current 0)
82     (pprint-doc-initargs))
83     (pprint-doc-body))))
84    
85     (defun pprint-doc-element (*standard-output* obj)
86     (pprint-logical-block (*standard-output* obj :prefix "(" :suffix ")")
87     (pprint-indent :block 3)
88     (write (pprint-pop)) ; type
89     (write-char #\space)
90     (pprint-newline :fill)
91     (pprint-logical-block (*standard-output* (pprint-pop) :prefix "(" :suffix ")")
92     (pprint-doc-initargs))
93     (pprint-indent :block 1)
94     (pprint-doc-body)))
95    
96     (set-pprint-dispatch
97     '(cons (member doc))
98     (lambda (*standard-output* obj)
99     (pprint-logical-block (*standard-output*
100     obj :prefix "(" :suffix ")")
101     (write (pprint-pop)) ; doc
102     (write-char #\space)
103     (pprint-newline :miser)
104     (pprint-indent :current 0)
105     (write (pprint-pop)) ; type
106     (write-char #\space)
107     (pprint-newline :fill)
108     (pprint-logical-block (*standard-output* (pprint-pop) :prefix "(" :suffix ")")
109     (pprint-doc-initargs))
110     (pprint-indent :block 1)
111     (pprint-doc-body))))

  ViewVC Help
Powered by ViewVC 1.1.5