root/trunk/thirdparty/atdoc/atdoc.lisp

Revision 3110, 15.4 KB (checked in by hans, 2 years ago)

checkpoint atdoc port to ccl

Line 
1;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
2
3;;; Copyright (c) 2006,2007,2008 David Lichteblau. All rights reserved.
4
5;;; Redistribution and use in source and binary forms, with or without
6;;; modification, are permitted provided that the following conditions
7;;; are met:
8;;;
9;;;   * Redistributions of source code must retain the above copyright
10;;;     notice, this list of conditions and the following disclaimer.
11;;;
12;;;   * Redistributions in binary form must reproduce the above
13;;;     copyright notice, this list of conditions and the following
14;;;     disclaimer in the documentation and/or other materials
15;;;     provided with the distribution.
16;;;
17;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29(in-package :atdoc)
30
31(defun function-arglist (fun)
32  (swank::arglist fun))
33
34(defun magic-namestring (file)
35  (let ((atdoc-directory (asdf:component-pathname (asdf:find-system :atdoc))))
36    (unless (and (stringp file) (char= (char file 0) #\.))
37      (let* ((kind (pathname-type file))
38             (base (merge-pathnames (format nil "~A/" kind) atdoc-directory)))
39        (setf file (merge-pathnames file base))))
40    (namestring file)))
41
42(defparameter *apply-stylesheet*
43  ;; 'apply-stylesheet/xsltproc
44  'apply-stylesheet/xuriella)
45
46#+(or)
47(setf *apply-stylesheet* 'apply-stylesheet/xsltproc)
48
49(defun apply-stylesheet/xuriella (stylesheet input output)
50  (xuriella:apply-stylesheet (pathname (magic-namestring stylesheet))
51                             (pathname (magic-namestring input))
52                             :output (pathname (magic-namestring output))))
53
54#+sbcl
55(defun apply-stylesheet/xsltproc (stylesheet input output)
56  (let* ((asdf::*verbose-out* (make-string-output-stream))
57         (code (asdf:run-shell-command
58                "cd ~S && xsltproc ~S ~S >~S"
59                (magic-namestring *default-pathname-defaults*)
60                (magic-namestring stylesheet)
61                (magic-namestring input)
62                (magic-namestring output))))
63    (unless (zerop code)
64      (error "running xsltproc failed with code ~A [~%~A~%]"
65             code
66             (get-output-stream-string asdf::*verbose-out*)))))
67
68#+allegro
69(defun apply-stylesheet/xsltproc (stylesheet input output)
70  (multiple-value-bind (stdout stderr exitcode)
71      (excl.osi:command-output
72       (format nil "xsltproc ~S ~S >~S"
73               (magic-namestring stylesheet)
74               (magic-namestring input)
75               (magic-namestring output))
76       :directory (magic-namestring *default-pathname-defaults*)
77       :whole T)
78    (declare (ignore stdout))
79    (unless (zerop exitcode)
80      (error "running xsltproc failed with code ~A [~%~A~%]"
81             exitcode stderr))))
82
83(defun apply-stylesheet (stylesheet input output)
84  (funcall *apply-stylesheet* stylesheet input output))
85
86(defun copy-file (a b &key (if-exists :error))
87  (with-open-file (in a :element-type '(unsigned-byte 8))
88    (with-open-file (out b
89                         :direction :output
90                         :if-exists if-exists
91                         :element-type '(unsigned-byte 8))
92      (let ((buf (make-array #x2000 :element-type '(unsigned-byte 8))))
93        (loop
94           for pos = (read-sequence buf in)
95           until (zerop pos)
96           do (write-sequence buf out :end pos))))))
97
98(defun generate-documentation
99    (packages directory &key (index-title "No Title")
100                             (heading "No Heading")
101                             css
102                             (logo nil)
103                             (apply-stylesheets-p t))
104  (unless css
105    (warn "no CSS stylesheet specified, falling back to default.css")
106    (setf css "default.css"))
107  (setf packages (mapcar #'find-package packages))
108  (with-open-file (s (merge-pathnames ".atdoc.xml" directory)
109                     :element-type '(unsigned-byte 8)
110                     :direction :output
111                     :if-does-not-exist :create
112                     :if-exists :rename-and-delete)
113    (cxml:with-xml-output (cxml:make-octet-stream-sink s)
114      (cxml:with-element "documentation"
115        (cxml:attribute "logo" logo)
116        (cxml:attribute "index-title" index-title)
117        (cxml:attribute "css" "index.css")
118        (cxml:attribute "heading" heading)
119        (dolist (package packages)
120          (emit-package package packages)))))
121  (when apply-stylesheets-p
122    (let ((*default-pathname-defaults* (merge-pathnames directory)))
123      (copy-file (magic-namestring css) "index.css"
124                 :if-exists :rename-and-delete)
125      (apply-stylesheet "macros.xsl" "html.xsl" ".atdoc.html.xsl.out")
126      (apply-stylesheet "cleanup.xsl" ".atdoc.xml" ".atdoc.tmp1")
127      (apply-stylesheet ".atdoc.html.xsl.out" ".atdoc.tmp1" ".atdoc.tmp2")
128      (apply-stylesheet "paginate.xsl" ".atdoc.tmp2" (merge-pathnames "index.html")))))
129
130(defun munge-name (name kind)
131  (format nil "~(~A~)__~A__~(~A~)"
132          (package-name (symbol-package name))
133          kind
134          (cl-ppcre:regex-replace-all "[/*%]" (symbol-name name) "_")))
135
136(defun name (name kind)
137  (cxml:attribute "id" (munge-name name kind))
138  (unexported-name name))
139
140(defun unexported-name (name)
141  (cxml:attribute "name" (string-downcase (symbol-name name)))
142  (cxml:attribute "package"
143                  (string-downcase (package-name (symbol-package name)))))
144
145(defun symbol-status (symbol)
146  (nth-value 1 (find-symbol (symbol-name symbol) (symbol-package symbol))))
147
148(defun good-symbol-p (symbol other-packages)
149  (and (find (symbol-package symbol) other-packages)
150       (not (eq (symbol-status symbol) :internal))))
151
152(defun random-name (name other-packages kind)
153  (cxml:attribute "status" (symbol-name (symbol-status name)))
154  (if (good-symbol-p name other-packages)
155      (name name kind)
156      (unexported-name name)))
157
158(defun emit-package (package other-packages)
159  (flet ((handle-symbol (sym)
160           (when (boundp sym)
161             (emit-variable sym))
162           (when (fboundp sym)
163             (if (macro-function sym)
164                 (emit-macro sym)
165                 (emit-function sym)))
166           (when (find-class sym nil)
167             (emit-class (find-class sym) other-packages))
168           (when (documentation sym 'type) ;; is there a better CLTL-way to check whether SYM designates a type?
169             (emit-type sym)))
170         (is-internal? (sym pkg)
171           "Check whether SYM is internal in PKG."
172           (multiple-value-bind (symbol status)
173               (intern (symbol-name sym) pkg)
174             (declare (ignore symbol))
175             (eq status :internal))))
176    (cxml:with-element "package"
177      (cxml:attribute "name" (string-downcase (package-name package)))
178      (cxml:attribute "id" (string-downcase (package-name package)))
179      (emit-docstring package (or (documentation package t)
180                                  "no documentation string found"))
181      (cxml:with-element "external-symbols"
182        (do-external-symbols (sym package)
183          (handle-symbol sym)))
184      (cxml:with-element "internal-symbols"
185        (do-symbols (sym package)
186          (when (is-internal? sym package)
187            (handle-symbol sym)))))))
188
189(defun emit-variable (name)
190  (cxml:with-element "variable-definition"
191    (name name "variable")
192    (emit-docstring name (documentation name 'variable))))
193
194(defun emit-type (name)
195  (cxml:with-element "type-definition"
196    (name name "type")
197    (emit-docstring name (documentation name 'type))))
198
199(defun emit-function (name)
200  (cxml:with-element "function-definition"
201    (name name "fun")
202    (cxml:with-element "lambda-list"
203      (dolist (arg (function-arglist (symbol-function name)))
204        (cxml:with-element "elt"
205          (cxml:text (write-to-string arg
206                                      :pretty t
207                                      :escape nil
208                                      :case :downcase)))))
209    (emit-docstring name (documentation name 'function))))
210
211(defun emit-macro (name)
212  (cxml:with-element "macro-definition"
213    (name name "macro")
214    (cxml:with-element "lambda-list"
215      (dolist (arg (function-arglist (macro-function name)))
216        (cxml:with-element "elt"
217          (cxml:text (write-to-string arg
218                                      :pretty t
219                                      :escape nil
220                                      :case :downcase)))))
221    (emit-docstring name (documentation name 'function))))
222
223(defun emit-slot (slot-def)
224  (cxml:with-element "slot"
225    (name (closer-mop:slot-definition-name slot-def) "slot")
226    (cxml:attribute "allocation" (munge-name (closer-mop:slot-definition-allocation slot-def) "symbol"))
227    (cxml:attribute "type" (format nil "~A" (closer-mop:slot-definition-type slot-def))) ;; may be a complicated typespec
228    (cxml:with-element "initargs"
229      (dolist (ia (closer-mop:slot-definition-initargs slot-def))
230        (cxml:with-element "initarg" (name ia "symbol"))))
231    (cxml:with-element "readers"
232      (dolist (reader (closer-mop:slot-definition-readers slot-def))
233        (cxml:with-element "reader" (name reader "symbol"))))
234    ;; FIXME: writer methods will be of the form (setf name) which breaks in munge-name
235    ;;     (cxml:with-element "writers"
236    ;;       (dolist (writer (closer-mop:slot-definition-writers slot-def))
237    ;;  (cxml:attribute "writer" (munge-name writer "writer"))))
238    (emit-docstring (closer-mop:slot-definition-name slot-def)
239                    (documentation slot-def T))))
240
241(defun emit-class (class other-packages)
242  (cxml:with-element "class-definition"
243    (name (class-name class) "class")
244    #+sbcl (sb-pcl:finalize-inheritance class)
245    #+allegro (unless (typep class 'structure-class)
246                (aclmop:finalize-inheritance class))
247    #+openmcl (unless (typep class 'structure-class)
248                (ccl:finalize-inheritance class))
249    (cxml:with-element "cpl"
250      (dolist (super (cdr #+sbcl (sb-pcl:class-precedence-list class)
251                          #+allegro (aclmop:class-precedence-list class)
252                          #+openmcl (ccl:class-precedence-list class)))
253        (cxml:with-element "superclass"
254          (random-name (class-name super) other-packages "class"))))
255    (cxml:with-element "subclasses"
256      (labels ((recurse (c)
257                 (dolist (sub #+sbcl (sb-pcl:class-direct-subclasses c)
258                              #+allegro (aclmop:class-direct-subclasses c)
259                              #+openmcl (ccl:class-direct-subclasses c))
260                   (if (good-symbol-p (class-name sub) other-packages)
261                       (cxml:with-element "subclass"
262                         (random-name (class-name sub) other-packages "class"))
263                       (recurse sub)))))
264        (recurse class)))
265    (unless (typep class 'structure-class)
266      (cxml:with-element "direct-slots"
267        (dolist (slot (closer-mop:class-direct-slots class))
268          (emit-slot slot))))
269    (emit-docstring (class-name class) (documentation class t))))
270
271(defun emit-docstring (package-designator str)
272  (let ((package (etypecase package-designator
273                   (symbol (symbol-package package-designator))
274                   (package package-designator))))
275    (when str
276      (cxml:with-element "documentation-string"
277        (cxml::maybe-emit-start-tag)
278        (parse-docstring str (make-instance 'docstring-parser
279                               :docstring-package package
280                               :chained-handler cxml::*sink*))))))
281
282(defun parse-docstring (str handler)
283  (with-input-from-string (s str)
284    (parse-docstring-1 s handler nil)))
285
286(defun characters (handler str)
287  (let ((lines (coerce (split-sequence:split-sequence #\newline str) 'vector))
288        (ignore nil))
289    (sax:characters handler (elt lines 0))
290    (when (> (length lines) 1)
291      (loop
292          for i from 1 below (1- (length lines))
293          for line = (elt lines i)
294          do
295            (cond
296              ((zerop (length (string-trim " " line)))
297                (unless ignore
298                  (sax:start-element handler nil "break" "break" nil)
299                  (sax:end-element handler nil "break" "break"))
300                (setf ignore t))
301              (t
302                (sax:characters handler (string #\newline))
303                (sax:characters handler line)
304                (setf ignore nil))))
305      (sax:characters handler (elt lines (1- (length lines)))))))
306
307(defun parse-docstring-1 (stream handler close)
308  (let ((out (make-string-output-stream)))
309    (loop for c = (read-char stream nil) do
310          (cond
311            ((null c)
312              (when close
313                (error "unexpected end of documentation string"))
314              (return))
315            ((eql c #\@)
316              (cond
317                ((eql (peek-char nil stream nil) #\})
318                  (write-char (read-char stream) out))
319                ((eql (peek-char nil stream nil) #\@)
320                  (write-char c out))
321                (t
322                  (characters handler (get-output-stream-string out))
323                  (let ((name (read-delimited-string stream "[{")))
324                    (when (equal name "end")
325                      (read-char stream)
326                      (unless
327                          (equal (read-delimited-string stream "}" t) close)
328                        (error "invalid close tag"))
329                      (return))
330                    (parse-docstring-element stream handler name)))))
331            ((eql c #\})
332              (when (eq close t)
333                (return))
334              (error "unexpected closing brace"))
335            (t
336              (write-char c out))))
337    (characters handler (get-output-stream-string out))))
338
339(defun read-delimited-string (stream bag &optional eat-limit)
340  (let ((out (make-string-output-stream)))
341    (loop
342        for c = (read-char stream nil)
343        do
344          (when (null c)
345            (error "unexpected end of documentation string"))
346          (when (find c bag)
347            (unless eat-limit
348              (unread-char c stream))
349            (return (get-output-stream-string out)))
350          (write-char c out))))
351
352(defun parse-docstring-element (stream handler name)
353  (let ((close t)
354        (arg nil)
355        (attrs '()))
356    (when (eql (read-char stream) #\[)
357      (setf arg (read-delimited-string stream "]" t))
358      (unless (eql (read-char stream) #\{)
359        (error "expected opening brace after closing bracket")))
360    (when (equal name "begin")
361      (setf name (read-delimited-string stream "}" t))
362      (setf close name))
363    (when arg
364      (push (sax:make-attribute :qname name :value arg) attrs))
365    (sax:start-element handler nil name name attrs)
366    (parse-docstring-1 stream handler close)
367    (sax:end-element handler nil name name)))
368
369(defclass docstring-parser (cxml:sax-proxy)
370    ((docstring-package :initarg :docstring-package
371                        :accessor docstring-package)
372     (current-name :initform nil :accessor current-name)
373     (current-kind :accessor current-kind)
374     (current-attributes :accessor current-attributes)
375     (current-text :accessor current-text)))
376
377(defmethod sax:start-element ((handler docstring-parser) uri lname qname attrs)
378  (declare (ignore lname uri))
379  (cond
380    ((or (equal qname "fun")
381         (equal qname "class")
382         (equal qname "type")
383         (equal qname "variable")
384         (equal qname "slot")
385         (equal qname "see")
386         (equal qname "see-slot")
387         (equal qname "see-constructor"))
388      (setf (current-name handler) qname)
389      (setf (current-kind handler)
390            (case (intern qname :atdoc)
391              ((|fun| |class| |type| |variable| |slot|) qname)
392              ((|see| |see-slot|) "fun")
393              (|see-constructor| "fun")))
394      (setf (current-attributes handler) attrs)
395      (setf (current-text handler) ""))
396    (t
397      (call-next-method))))
398
399(defmethod sax:characters ((handler docstring-parser) data)
400  (if (current-name handler)
401      (setf (current-text handler)
402            (concatenate 'string (current-text handler) data))
403      (call-next-method)))
404
405(defmethod sax:end-element ((handler docstring-parser) uri lname qname)
406  (declare (ignore lname uri))
407  (let ((name (current-name handler)))
408    (when (equal qname name)
409      (let* ((next (cxml:proxy-chained-handler handler))
410             (attrs (current-attributes handler))
411             (text (current-text handler))
412             (munged-name
413              (munge-name
414               (let ((*package* (docstring-package handler)))
415                 (read-from-string text))
416               (current-kind handler))))
417        (push (sax:make-attribute :qname "id" :value munged-name) attrs)
418        (sax:start-element next nil name name attrs)
419        (sax:characters next text)
420        (setf (current-name handler) nil))))
421  (call-next-method))
Note: See TracBrowser for help on using the browser.