1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SPRES-IMPL -*-
#|
DESC: spres/rules/method.lisp - the rules for methods
Copyright (c) 2000-2001 - Stig Erik Sand
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
|#
(in-package :spres-impl)
(def-rule-info
((:key :generic-fun-purpose)
(:name print-purpose)
(:req (?class sdoc-method)
(?document-type docbook-document))
)
(let ((purpose ""))
(let ((fields (tl-get-fields "purpose" obj)))
;; add if any found..
(when fields (warn ">> Purpose ~a" fields)))
#||
(unless (plusp (length purpose))
(let ((fields (tl-get-fields "documentation" obj)))
(when (and fields (stringp (first fields)))
(setf purpose (first fields)))))
||#
(unless (plusp (length purpose))
(cond ((is-generic-fun? obj)
(setf purpose (albert-setting '("albert" "presentation" "default-purpose-string" "generic"))))
(t
(setf purpose (albert-setting '("albert" "presentation" "default-purpose-string" "method"))))))
(when (eq purpose nil)
(setf purpose ""))
(put doc " <refpurpose>" purpose "</refpurpose>" (eol))
))
(def-rule-info
((:key :full-tpl-method/docbook)
(:name present-object)
(:desc "Presents a full GF.")
(:req (?class sdoc-method)
(?document-type docbook-document)
(?context (eql :full))
;; (eq ?prog-lang :java)
;; assertion, we should be below a class, ie a refsect1
(eq ?rec-state :reference)
)
(:variation
:never-print-execute))
;;(warn "Doing generic ~s for ~s" (get-object-name obj)
;; (mapcar #'get-object-name (sdoc-method.content obj))))
(with-ok-obj-document (doc obj doc)
(let ((cl-name (get-object-name obj))
(print-class-details t))
(put doc "<refentry id=\"" (make-obj-id doc obj ?parent) "\">" (eol))
(put doc "<refnamediv>" (eol)
"<refname>" cl-name "</refname>" (eol))
(print-purpose obj doc context)
(put doc "</refnamediv>" (eol))
(when-bind (doc-list (sdoc-method.doc obj))
(dolist (i doc-list)
(let ((type (slot-value i 'type))
(text (slot-value i 'text)))
(cond ((equal "desc" (first type))
(put doc
" <refsynopsisdiv>" (eol)
" <title class=\"contenttitle\">" (get-word "Description" doc) "</title>" (eol)
" <simpara>" (apispec-xml:xmlify-string (first text)) "</simpara>" (eol)
" </refsynopsisdiv>" (eol)))
(t
(warn "Albert: Unknown GF docs ~s ~s ~s" cl-name type text))))))
(add-spres-flag! :in-gf)
(let* ((?parent obj))
(present-with-content-manager obj doc (slot-value obj 'content)))
(remove-spres-flag! :in-gf)
(put doc "</refentry>" (eol))
)))
(def-rule-info
((:key :full-method/docbook)
(:name present-object)
(:desc "Presents a full method.")
(:req (?class sdoc-method)
(?document-type docbook-document)
(?context (eql :full))
;; (eq ?prog-lang :java)
;; assertion, we should be below a class, ie a refsect1
(or (eq ?rec-state :refsect1)
(eq ?rec-state :refsect2))
)
(:variation
:never-print-execute))
;;(when (should-have-individual-file-p obj ?context)
;;(return-from present-object t))
(let ((meth-name (get-object-name obj))
(exportclass ""))
(unless meth-name
(setq meth-name "{not-named}"))
(when (is-exported? obj meth-name)
(setf exportclass " class=\"exported\""))
;;(warn "EXPORT for ~s is ~s" meth-name (is-exported? obj meth-name))
#||
(when (string-equal meth-name "SDOC-VARIABLE.LOCATION")
(warn "S-V.LOC ~s vs ~s vs ~s ~s -> ~s" obj ?parent
(has-spres-flag? :related-methods) *scope-stack*
(make-obj-id doc obj ?parent)))
||#
(put doc
"<formalpara" exportclass ">" (eol)
"<title>"
(if (or (has-spres-flag? :in-gf)
(has-spres-flag? :dont-print-anchor))
""
(get-simple-anchor doc (make-obj-id doc obj ?parent :allow-cached nil)))
(cond ((has-spres-flag? :related-methods)
(let (;;(guess-package (find-if #'(lambda (x) (typep x 'sdoc-package)) *scope-stack*))
(up-package (get-enclosing-package obj)))
#||
(unless (string-equal (get-object-name guess-package) (get-object-name up-package))
(warn "Mismatch in enclosing package for obj ~s: ~s vs ~s"
obj (get-object-name guess-package) (get-object-name up-package)))
||#
;;(warn "For ~s we have ~s stack and ~s parent" meth-name *scope-stack* ?parent)
(if up-package
(concatenate 'string (get-object-name up-package) ":")
"")))
(t
""))
meth-name
"</title>"
(eol))
(put doc "<para>" (eol))
;; improve this later..
(let* ((the-obj obj)
(doc-list (sdoc-method.doc the-obj))
(loc-list nil)
(show-loc nil)
(not-wanted (list "mod" "class" "dispatch" "language" ))
(info-list nil))
(when-bind (where (slot-value obj 'where))
(setf loc-list (flatten (loop for x in where
collecting (slot-value x 'location)))))
(when (and loc-list (tl-show-location? :variable)
(not (has-spres-flag? :dont-print-location)))
(setf show-loc t))
(unless (albert-setting '("albert" "presentation" "funcallable" "calls"))
(push "calls" not-wanted))
(unless (albert-setting '("albert" "presentation" "funcallable" "calledby"))
(push "calledby" not-wanted))
(setf info-list (get-info-except-types (sdoc-method.info obj) not-wanted))
;;(warn "reduced ~s to ~s" (sdoc-method.info obj) info-list)
(put doc "<programlisting>"
(apispec-xml:xmlify-string (get-method-signature doc the-obj :linked nil :style :intuitive))
"</programlisting>" (eol))
(when (or doc-list info-list)
(put doc "<variablelist>" (eol))
(db-present-doc-list doc-list doc :method :suppress-wrapper t)
(db-present-info-list info-list doc :method :suppress-wrapper t)
(when show-loc
(setf loc-list (mapcar #'possibly-cvs-link loc-list))
(db-print-location loc-list doc :variable :suppress-wrapper t))
(put doc "</variablelist>" (eol))
))
(put doc "</para></formalpara>" (eol)))
;; small-gf hack
(when-bind (content (sdoc-method.content obj))
(add-spres-flag! :in-gf)
(dolist (i content)
(present-object i doc ?context))
(remove-spres-flag! :in-gf))
)
|
