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

Last change on this file since 13574 was 9568, checked in by gz, 11 years ago

Don't get confused by external #hrefs

File size: 17.8 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 (eql 0 (position #\# href)))
209        (let ((name (gethash (subseq href 1) hash)))
210          (unless name
211             (warn "Couldn't find the split file id for href ~s" href))
212          (when name
213            (let ((pos (search (format nil "href=~s" href) (html-string *cur-html*)
214                               :start2 (cnode-start node) :end2 (cnode-tag-end node))))
215              (assert pos)
216              (push (cons (+ pos 6) name) hrefs)))))
217      hrefs)))
218
219(defparameter *times* 0)
220(defun split-file-title (sf)
221  (labels ((title (node)
222             (when (cnode-p node)
223               (if (and (eq (cnode-tag node) :h2)
224                        (equal (cnode-attribute-value node :class) "title"))
225                 (labels ((text (node)
226                            (if (tnode-p node)
227                              (subseq (html-string *cur-html*) (node-start node) (node-end node))
228                              (apply #'concatenate 'string
229                                     (loop for sub in (cnode-children node) collect (text sub))))))
230                   (text node))
231                 (loop for sub in (cnode-children node) thereis (title sub))))))
232    (loop for node in (split-file-nodes sf) thereis (title node))))
233
234(defun doc-file-splits (html)
235  (let* ((*cur-html* html)
236         (node (html-node html)))
237    (assert (eq (node-tag node) :html))
238    (setq node (find :body (cnode-children node) :key #'node-tag))
239    (assert node)
240    (setq node (find :div (cnode-children node) :key #'node-tag))
241    (assert node)
242    (assert (equal (cnode-attribute-value node :class) "book"))
243    (loop with nchapters = 0
244      for subnode in (cnode-children node)
245      as class = (and (eq (node-tag subnode) :div) (cnode-attribute-value subnode :class))
246      if (member class '("chapter" "glossary" "index") :test #'equal)
247      nconc (doc-file-chapter-splits subnode (incf nchapters)) into sections
248      else collect subnode into nodes
249      finally (let ((sf (make-split-file :name "index.html" :type :book :nodes nodes)))
250                (loop for sub in sections
251                  unless (eq (split-file-type sub) :sect1) do (setf (split-file-up sub) sf))
252                (return (cons sf sections))))))
253
254(defun doc-file-chapter-splits (node num)
255  (let* ((class (and (eq (node-tag node) :div) (cnode-attribute-value node :class))))
256    (cond ((equal class "chapter")
257           (loop with nsect = 0
258             for subnode in (cnode-children node)
259             as class = (and (eq (node-tag subnode) :div) (cnode-attribute-value subnode :class))
260             if (equal class "sect1")
261             collect (make-split-file :name (format nil "chapter~d.~d.html" num (incf nsect))
262                                      :type :sect1 :nodes (list subnode)) into sections
263             else collect subnode into nodes
264             finally (let ((sf (make-split-file :name (format nil "chapter~d.html" num)
265                                                    :type :chapter :nodes nodes)))
266                       (loop for sub in sections do (setf (split-file-up sub) sf))
267                       (return (cons sf sections)))))
268          ((equal class "glossary")
269           (list (make-split-file :name "glossary.html" :type :glossary :nodes (list node))))
270          ((equal class "index")
271           (list (make-split-file :name "symbol-index.html" :type :symbol-index :nodes (list node))))
272          (t (error "expected a chapter, glossary or index: ~s" class)))))
273
274;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
275
276;; Returns NIL for </tag> case.
277(defun read-html-tag (str s e &aux (s1 (1+ s)))
278  (and (< s e)
279       (eq (char str s) #\<)
280       (let* ((te (or (position-if #'(lambda (ch) (or (whitespacep ch)
281                                                      (char= ch #\>)
282                                                      (char= ch #\/)))
283                                   str :start s1 :end e)
284                      e)))
285         (and (< s1 te)
286              (intern (nstring-upcase (subseq str s1 te)) ccl::*keyword-package*)))))
287
288;; Returns NIL if at end of buffer or if looking at "</..."
289(defun read-html-form (str s e &optional (tag (read-html-tag str s e)))
290  (cond (tag
291         (let* ((te (1+ (position-ignoring-strings #\> str s e)))
292                (node (make-cnode :tag tag
293                                  :start s
294                                  :tag-end te
295                                  :end e
296                                  :children nil)))
297           (if (eq (char str (- te 2)) #\/)
298             (setf (node-end node) te)
299             (read-html-children-into-cnode str node))
300           node))
301        ((>= s e) NIL)
302        ((eq (char str s) #\<)
303         (assert (and (< (1+ s) e) (eq (char str (1+ s)) #\/)))
304         NIL)
305        (t (make-tnode :start s :end (or (position #\< str :start s :end e) e)))))
306
307(defun position-ignoring-strings (ch str start end)
308  (let* ((p (position ch str :start start :end end)))
309    (and p
310         (let ((q (position #\" str :start start :end p)))
311           (if (null q)
312             p
313             (let ((qe (position #\" str :start (1+ q) :end end)))
314               (and qe
315                    (position-ignoring-strings ch str (1+ qe) end))))))))
316
317(defun read-html-children-into-cnode (str node)
318  ;; This is entered with node-end = end of region, and it updates both
319  ;; cnode-children and node-end.  Eats up the ending tag if it matches
320  ;; the node tag, otherwise leaves it to be re-read.
321  (let* ((s (cnode-tag-end node))
322         (e (cnode-end node)))
323    (loop
324      (assert (< s e) () "Unended tag ~S" (subseq str (cnode-start node) e))
325      (when (string= "</" str :start2 s :end2 (min (+ s 2) e))
326        (let* ((te (1+ (position #\> str :start s :end e))))
327          (setf (cnode-end node)
328                (if (string-equal str (symbol-name (cnode-tag node))
329                                   :start1 (+ s 2) :end1 (1- te))
330                  te s))
331          (return)))
332      (let* ((ntag (read-html-tag str s e))
333             (child (read-html-form str s e ntag)))
334        (setq s (node-end child))
335        (push child (cnode-children node))))
336    (setf (cnode-children node) (nreverse (cnode-children node)))))
337
338(defun cnode-attributes (node &optional string-or-html &aux string)
339  (setq string-or-html (or string-or-html *cur-html*))
340  (setq string (if (html-p string-or-html) (html-string string-or-html) string-or-html))
341  (multiple-value-bind (start end)
342      (let* ((start (1+ (node-start node)))
343             (end (cnode-tag-end node))
344             (word-end (position-if #'(lambda (ch) (or (whitespacep ch)
345                                                       (char= ch #\>)
346                                                       (char= ch #\/)))
347                                    string :start start :end end)))
348        (assert word-end)
349        (values word-end (1- end)))
350    (flet ((next-token (type)
351             (when (setq start (position-if-not #'whitespacep string :start start :end end))
352               (let ((ch (char string start)))
353                 (incf start)
354                 (case ch
355                   ((#\" #\')
356                    (assert (eq type :value))
357                    (let ((tend (position ch string :start start :end end)))
358                      (prog1
359                          (subseq string start tend)
360                        (setq start (1+ tend)))))
361                   ((#\=)
362                    (assert (eq type :separator))
363                    t)
364                   ((nil)
365                    (assert (or (eq type :attribute) (eq type :separator)))
366                    nil)
367                   (t
368                    (assert (or (eq type :value) (eq type :attribute)))
369                    (let ((tend (or (position-if #'(lambda (ch) (or (whitespacep ch) (eql ch #\=)))
370                                                 string :start start :end end) end)))
371                      (prog1
372                          (subseq string (1- start) tend)
373                        (setq start tend)))))))))
374      (loop
375        as attribute = (next-token :attribute) while attribute
376        collect (cons (intern (string-upcase attribute) :keyword)
377                      (if (next-token :separator) (next-token :value) t))))))
378
379(defun cnode-attribute-value (node attribute &optional string-or-html)
380  (cdr (assoc attribute (cnode-attributes node string-or-html) :test #'eq)))
381
382#+debugging
383(defun debug-print-html (str node &key (stream t) (depth nil))
384  (when (html-p str) (setq str (html-string str)))
385  (if (null stream)
386    (with-output-to-string (s) (debug-print-html str node :stream s :depth depth))
387    (labels ((print (node cur-depth)
388               (etypecase node
389                 (tnode (format stream "~A" (subseq str (node-start node) (node-end node))))
390                 (cnode (format stream "~A" (subseq str (node-start node) (cnode-tag-end node)))
391                        (if (or (null depth) (< cur-depth depth))
392                          (dolist (child (cnode-children node))
393                            (print child (1+ cur-depth)))
394                          (format stream "..."))
395                        (format stream "</~A>" (node-tag node))))))
396      (print node 0))))
397
398#+debugging
399(defun debug-outline-html (str node &key (stream t) (depth nil))
400  (if (null stream)
401    (with-output-to-string (s) (debug-outline-html str node s depth))
402    (labels ((outline (node cur-depth idx)
403               (etypecase node
404                 (tnode (unless (loop for i from (node-start node) below (node-end node)
405                                  always (whitespacep (char str i)))
406                          (if idx (format stream "[~a]..." idx) (format stream "..."))))
407                 (cnode (fresh-line stream)
408                        (if idx (format stream "~&[~a]" idx) (format stream "~&"))
409                        (dotimes (i cur-depth) (write-char #\Space stream))
410                        (format stream "<~A ~:a>" (cnode-tag node) (cnode-attributes node str))
411                        (when (or (null depth) (< cur-depth depth))
412                          (loop for i upfrom 0 as child in  (cnode-children node)
413                            do (outline child (1+ cur-depth) (if idx (format nil "~a.~d" idx i)
414                                                               (format nil "~d" i)))))
415                        (format stream "</~A>" (node-tag node))))))
416      (outline node 0 nil))))
Note: See TracBrowser for help on using the repository browser.