source: trunk/source/doc/doc-splitter.lisp @ 9566

Last change on this file since 9566 was 9566, checked in by gz, 12 years ago

q&d tool to split ccl-documentation into sections

File size: 17.9 KB
Line 
1;;; Copyright (c) 2008 Clozure Associates.  All Rights Reserved.
2
3;;;
4;;; (doc-splitter:split-doc-file "ccl:doc;ccl-documentation.html" "ccl:doc;manual;")
5;;;
6
7(eval-when (eval compile load)
8  (defpackage doc-splitter
9    (:use common-lisp ccl)
10    (:export #:split-doc-file)))
11
12(in-package doc-splitter)
13
14(defparameter *output-template*
15  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
16<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
17<html xmlns=\"http://www.w3.org/1999/xhtml\">
18  <head>
19    <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />
20    <title>Clozure CL Documentation</title>
21  </head>
22  <body>
23
24<table width=\"100%\" cellspacing=\"1\" cellpadding=\"1\" border=\"1\">
25<tr><td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((PREVIOUS))</td>
26    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((NEXT))</td>
27    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"0%\"></td>
28    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((HOME))</td>
29    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((GLOSSARY))</td>
30    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((INDEX))</td>
31</tr></table>
32<hr>
33 ((BODY))
34<hr>
35<table width=\"100%\" cellspacing=\"1\" cellpadding=\"1\" border=\"1\">
36<tr><td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((PREVIOUS))</td>
37    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((NEXT))</td>
38    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"0%\"></td>
39    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((HOME))</td>
40    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((GLOSSARY))</td>
41    <td align=\"center\" bgcolor=\"((BGCOLOR))\" width=\"20%\">((INDEX))</td>
42</tr></table>
43</body>
44")
45
46(defparameter *links-bgcolor* "lightgray")
47
48(defparameter *link-names* '((:previous . "Previous")
49                             (:next . "Next")
50                             (:up . "Up")
51                             (:home . "Table of Contents")
52                             (:glossary . "Glossary")
53                             (:index . "Index")))
54
55(defun output-split-doc-header-link (stream sf link)
56  (let ((name (cdr (assq link *link-names*))))
57    (if sf
58      (format stream "<a href=\"~a\"><b>~a~@[ ~a~]</b></a>"
59              (split-file-name sf)
60              name
61              (and (memq link '(:previous :next))
62                   (if (eq (split-file-type sf) :sect1) "Section" "Chapter")))
63      (format stream "~:(~a~)" name))))
64
65
66;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
67
68(defstruct node
69  start
70  end)
71
72;; Text node
73(defstruct (tnode (:include node))
74  )
75
76;; Compound node
77(defstruct (cnode (:include node))
78  tag
79  tag-end
80  children)
81
82(defmethod print-object ((node cnode) stream)
83  (print-unreadable-object (node stream :type t) 
84    (format stream "~s ~s:~s:~s~a"
85            (cnode-tag node) (cnode-start node) (cnode-tag-end node) (cnode-end node)
86            (cond ((null (cnode-children node)) "")
87                  ((null (cdr (cnode-children node))) " 1 child")
88                  (t (format nil " ~s children" (length (cnode-children node))))))))
89
90(defun node-tag (node)
91  (and (cnode-p node) (cnode-tag node)))
92
93;; Toplevel node
94(defstruct html
95  string
96  node)
97
98(defmethod print-object ((node html) stream)
99  (print-unreadable-object (node stream :type t)
100    (let ((*print-string-length* 400))
101      (format stream ":STRING ~s :NODE ~s" (html-string node) (html-node node)))))
102
103(defstruct split-file
104  type
105  name
106  up
107  nodes)
108
109(defvar *cur-html* nil)
110
111(defun split-doc-file (html directory)
112  (unless (html-p html)
113    (setq html (read-html-file html)))
114  (ensure-directories-exist directory)
115  (let* ((*cur-html* html)
116         (splits (doc-file-splits html))
117         (id-table (make-hash-table :test #'equal))
118         (top (find :book splits :key #'split-file-type))
119         (glossary (find :glossary splits :key #'split-file-type))
120         (index (find :symbol-index splits :key #'split-file-type)))
121    (loop for sf in splits as name = (split-file-name sf)
122      do (loop for node in (split-file-nodes sf)
123           do (doc-file-register-ids node name id-table)))
124    (loop
125      for prev = nil then sf
126      for prev-chap = nil then (if (eq (split-file-type sf) :sect1) prev-chap sf)
127      for sfs on splits
128      for sf = (car sfs)
129      do (with-open-file (stream (merge-pathnames (split-file-name sf) directory)
130                                 :direction :output
131                                 :if-exists :supersede)
132           (output-split-doc-file sf stream id-table
133                                  :previous (if (eq (split-file-type sf) :sect1) prev prev-chap)
134                                  :next (if (eq (split-file-type sf) :sect1)
135                                          (cadr sfs)
136                                          (find :sect1 (cdr sfs) :key #'split-file-type :test #'neq))
137                                  :top top
138                                  :glossary glossary
139                                  :index index)))))
140
141(defun output-split-doc-file (sf stream id-table &key previous next top glossary index)
142  (loop with template = *output-template*
143    for start = 0 then (+ epos 2)
144    as bpos = (search "((" template :start2 start) while bpos
145    as epos = (search "))" template :start2 bpos)
146    do (write-string template stream :start start :end bpos)
147    do (ecase (intern (subseq template (+ bpos 2) epos) :keyword)
148         (:previous
149          (output-split-doc-header-link stream previous :previous))
150         (:next
151          (output-split-doc-header-link stream next :next))
152         (:home
153          (output-split-doc-header-link stream top :home))
154         (:glossary
155          (output-split-doc-header-link stream glossary :glossary))
156         (:index
157          (output-split-doc-header-link stream index :index))
158         (:bgcolor
159          (write-string *links-bgcolor* stream))
160         (:body
161          (output-split-doc-file-body stream sf id-table)))
162    finally (write-string template stream :start start)))
163
164;; (setq *print-string-length* 400 *print-length* 100 *print-level* 50)
165(defun read-html-file (pathname)
166  (with-open-file (stream pathname)
167    (let ((str (make-string (file-length stream))))
168      (read-sequence str stream)
169      (make-html :string str
170                 :node (read-html-form str (search "<html" str :test #'char-equal) (length str))))))
171
172
173(defun output-split-doc-file-body (stream sf id-table)
174  (let* ((up (split-file-up sf))
175         (up-title (and up (split-file-title up))))
176    (when up-title
177      (format stream "<a href=\"~a\">~a</a>" (split-file-name up) up-title)))
178  (loop with string = (html-string *cur-html*)
179    for node in (split-file-nodes sf)
180    do (let ((hrefs (doc-file-collect-hrefs node id-table)))
181         (setq hrefs (sort hrefs #'< :key #'car))
182         (assert (or (null hrefs) (<= (node-start node) (caar hrefs))))
183         (loop as start = (node-start node) then pos
184           for (pos . name) in hrefs
185           do (write-string string stream :start start :end pos)
186           do (write-string name stream)
187           finally (write-string string stream :start start :end (node-end node)))
188         (fresh-line stream))))
189
190(defun doc-file-register-ids (node name hash)
191  (when (cnode-p node)
192    (let ((id (and (eq (cnode-tag node) :a)
193                   (cnode-attribute-value node :id))))
194      (when id
195        (let ((old (gethash id hash)))
196          (when old
197            (warn "~s already registered in file ~s" id old)))
198        (setf (gethash id hash) name)))
199    (loop for subnode in (cnode-children node)
200      do (doc-file-register-ids subnode name hash))))
201
202(defun doc-file-collect-hrefs (node hash)
203  (when (cnode-p node)
204    (let* ((hrefs (loop for subnode in (cnode-children node)
205                    nconc (doc-file-collect-hrefs subnode hash)))
206           (href (and (eq (cnode-tag node) :a)
207                      (cnode-attribute-value node :href))))
208      (when (and href (position #\# href))
209        (assert (eql (char href 0) #\#))
210        (let ((name (gethash (subseq href 1) hash)))
211          (unless name
212             (warn "Couldn't find the split file id for href ~s" href))
213          (when name
214            (let ((pos (search (format nil "href=~s" href) (html-string *cur-html*)
215                               :start2 (cnode-start node) :end2 (cnode-tag-end node))))
216              (assert pos)
217              (push (cons (+ pos 6) name) hrefs)))))
218      hrefs)))
219
220(defparameter *times* 0)
221(defun split-file-title (sf)
222  (labels ((title (node)
223             (when (cnode-p node)
224               (if (and (eq (cnode-tag node) :h2)
225                        (equal (cnode-attribute-value node :class) "title"))
226                 (labels ((text (node)
227                            (if (tnode-p node)
228                              (subseq (html-string *cur-html*) (node-start node) (node-end node))
229                              (apply #'concatenate 'string
230                                     (loop for sub in (cnode-children node) collect (text sub))))))
231                   (text node))
232                 (loop for sub in (cnode-children node) thereis (title sub))))))
233    (loop for node in (split-file-nodes sf) thereis (title node))))
234
235(defun doc-file-splits (html)
236  (let* ((*cur-html* html)
237         (node (html-node html)))
238    (assert (eq (node-tag node) :html))
239    (setq node (find :body (cnode-children node) :key #'node-tag))
240    (assert node)
241    (setq node (find :div (cnode-children node) :key #'node-tag))
242    (assert node)
243    (assert (equal (cnode-attribute-value node :class) "book"))
244    (loop with nchapters = 0
245      for subnode in (cnode-children node)
246      as class = (and (eq (node-tag subnode) :div) (cnode-attribute-value subnode :class))
247      if (member class '("chapter" "glossary" "index") :test #'equal)
248      nconc (doc-file-chapter-splits subnode (incf nchapters)) into sections
249      else collect subnode into nodes
250      finally (let ((sf (make-split-file :name "index.html" :type :book :nodes nodes)))
251                (loop for sub in sections
252                  unless (eq (split-file-type sub) :sect1) do (setf (split-file-up sub) sf))
253                (return (cons sf sections))))))
254
255(defun doc-file-chapter-splits (node num)
256  (let* ((class (and (eq (node-tag node) :div) (cnode-attribute-value node :class))))
257    (cond ((equal class "chapter")
258           (loop with nsect = 0
259             for subnode in (cnode-children node)
260             as class = (and (eq (node-tag subnode) :div) (cnode-attribute-value subnode :class))
261             if (equal class "sect1")
262             collect (make-split-file :name (format nil "chapter~d.~d.html" num (incf nsect))
263                                      :type :sect1 :nodes (list subnode)) into sections
264             else collect subnode into nodes
265             finally (let ((sf (make-split-file :name (format nil "chapter~d.html" num)
266                                                    :type :chapter :nodes nodes)))
267                       (loop for sub in sections do (setf (split-file-up sub) sf))
268                       (return (cons sf sections)))))
269          ((equal class "glossary")
270           (list (make-split-file :name "glossary.html" :type :glossary :nodes (list node))))
271          ((equal class "index")
272           (list (make-split-file :name "symbol-index.html" :type :symbol-index :nodes (list node))))
273          (t (error "expected a chapter, glossary or index: ~s" class)))))
274
275;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
276
277;; Returns NIL for </tag> case.
278(defun read-html-tag (str s e &aux (s1 (1+ s)))
279  (and (< s e)
280       (eq (char str s) #\<)
281       (let* ((te (or (position-if #'(lambda (ch) (or (whitespacep ch)
282                                                      (char= ch #\>)
283                                                      (char= ch #\/)))
284                                   str :start s1 :end e)
285                      e)))
286         (and (< s1 te)
287              (intern (nstring-upcase (subseq str s1 te)) ccl::*keyword-package*)))))
288
289;; Returns NIL if at end of buffer or if looking at "</..."
290(defun read-html-form (str s e &optional (tag (read-html-tag str s e)))
291  (cond (tag
292         (let* ((te (1+ (position-ignoring-strings #\> str s e)))
293                (node (make-cnode :tag tag
294                                  :start s
295                                  :tag-end te
296                                  :end e
297                                  :children nil)))
298           (if (eq (char str (- te 2)) #\/)
299             (setf (node-end node) te)
300             (read-html-children-into-cnode str node))
301           node))
302        ((>= s e) NIL)
303        ((eq (char str s) #\<)
304         (assert (and (< (1+ s) e) (eq (char str (1+ s)) #\/)))
305         NIL)
306        (t (make-tnode :start s :end (or (position #\< str :start s :end e) e)))))
307
308(defun position-ignoring-strings (ch str start end)
309  (let* ((p (position ch str :start start :end end)))
310    (and p
311         (let ((q (position #\" str :start start :end p)))
312           (if (null q)
313             p
314             (let ((qe (position #\" str :start (1+ q) :end end)))
315               (and qe
316                    (position-ignoring-strings ch str (1+ qe) end))))))))
317
318(defun read-html-children-into-cnode (str node)
319  ;; This is entered with node-end = end of region, and it updates both
320  ;; cnode-children and node-end.  Eats up the ending tag if it matches
321  ;; the node tag, otherwise leaves it to be re-read.
322  (let* ((s (cnode-tag-end node))
323         (e (cnode-end node)))
324    (loop
325      (assert (< s e) () "Unended tag ~S" (subseq str (cnode-start node) e))
326      (when (string= "</" str :start2 s :end2 (min (+ s 2) e))
327        (let* ((te (1+ (position #\> str :start s :end e))))
328          (setf (cnode-end node)
329                (if (string-equal str (symbol-name (cnode-tag node))
330                                   :start1 (+ s 2) :end1 (1- te))
331                  te s))
332          (return)))
333      (let* ((ntag (read-html-tag str s e))
334             (child (read-html-form str s e ntag)))
335        (setq s (node-end child))
336        (push child (cnode-children node))))
337    (setf (cnode-children node) (nreverse (cnode-children node)))))
338
339(defun cnode-attributes (node &optional string-or-html &aux string)
340  (setq string-or-html (or string-or-html *cur-html*))
341  (setq string (if (html-p string-or-html) (html-string string-or-html) string-or-html))
342  (multiple-value-bind (start end)
343      (let* ((start (1+ (node-start node)))
344             (end (cnode-tag-end node))
345             (word-end (position-if #'(lambda (ch) (or (whitespacep ch)
346                                                       (char= ch #\>)
347                                                       (char= ch #\/)))
348                                    string :start start :end end)))
349        (assert word-end)
350        (values word-end (1- end)))
351    (flet ((next-token (type)
352             (when (setq start (position-if-not #'whitespacep string :start start :end end))
353               (let ((ch (char string start)))
354                 (incf start)
355                 (case ch
356                   ((#\" #\')
357                    (assert (eq type :value))
358                    (let ((tend (position ch string :start start :end end)))
359                      (prog1
360                          (subseq string start tend)
361                        (setq start (1+ tend)))))
362                   ((#\=)
363                    (assert (eq type :separator))
364                    t)
365                   ((nil)
366                    (assert (or (eq type :attribute) (eq type :separator)))
367                    nil)
368                   (t
369                    (assert (or (eq type :value) (eq type :attribute)))
370                    (let ((tend (or (position-if #'(lambda (ch) (or (whitespacep ch) (eql ch #\=)))
371                                                 string :start start :end end) end)))
372                      (prog1
373                          (subseq string (1- start) tend)
374                        (setq start tend)))))))))
375      (loop
376        as attribute = (next-token :attribute) while attribute
377        collect (cons (intern (string-upcase attribute) :keyword)
378                      (if (next-token :separator) (next-token :value) t))))))
379
380(defun cnode-attribute-value (node attribute &optional string-or-html)
381  (cdr (assoc attribute (cnode-attributes node string-or-html) :test #'eq)))
382
383#+debugging
384(defun debug-print-html (str node &key (stream t) (depth nil))
385  (when (html-p str) (setq str (html-string str)))
386  (if (null stream)
387    (with-output-to-string (s) (debug-print-html str node :stream s :depth depth))
388    (labels ((print (node cur-depth)
389               (etypecase node
390                 (tnode (format stream "~A" (subseq str (node-start node) (node-end node))))
391                 (cnode (format stream "~A" (subseq str (node-start node) (cnode-tag-end node)))
392                        (if (or (null depth) (< cur-depth depth))
393                          (dolist (child (cnode-children node))
394                            (print child (1+ cur-depth)))
395                          (format stream "..."))
396                        (format stream "</~A>" (node-tag node))))))
397      (print node 0))))
398
399#+debugging
400(defun debug-outline-html (str node &key (stream t) (depth nil))
401  (if (null stream)
402    (with-output-to-string (s) (debug-outline-html str node s depth))
403    (labels ((outline (node cur-depth idx)
404               (etypecase node
405                 (tnode (unless (loop for i from (node-start node) below (node-end node)
406                                  always (whitespacep (char str i)))
407                          (if idx (format stream "[~a]..." idx) (format stream "..."))))
408                 (cnode (fresh-line stream)
409                        (if idx (format stream "~&[~a]" idx) (format stream "~&"))
410                        (dotimes (i cur-depth) (write-char #\Space stream))
411                        (format stream "<~A ~:a>" (cnode-tag node) (cnode-attributes node str))
412                        (when (or (null depth) (< cur-depth depth))
413                          (loop for i upfrom 0 as child in  (cnode-children node)
414                            do (outline child (1+ cur-depth) (if idx (format nil "~a.~d" idx i)
415                                                               (format nil "~d" i)))))
416                        (format stream "</~A>" (node-tag node))))))
417      (outline node 0 nil))))
Note: See TracBrowser for help on using the repository browser.