/[climacs]/climacs/html-syntax.lisp
ViewVC logotype

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (hide annotations)
Sat May 6 19:51:04 2006 UTC (7 years, 11 months ago) by dmurray
Branch: MAIN
Changes since 1.32: +1 -1 lines
Changed mark-visibility to region visibility. Turn it on
and off with Visible Region, for now.
1 rstrandh 1.16 ;;; -*- Mode: Lisp; Package: CLIMACS-HTML-SYNTAX -*-
2 rstrandh 1.1
3     ;;; (c) copyright 2005 by
4     ;;; Robert Strandh (strandh@labri.fr)
5    
6     ;;; This library is free software; you can redistribute it and/or
7     ;;; modify it under the terms of the GNU Library General Public
8     ;;; License as published by the Free Software Foundation; either
9     ;;; version 2 of the License, or (at your option) any later version.
10     ;;;
11     ;;; This library is distributed in the hope that it will be useful,
12     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14     ;;; Library General Public License for more details.
15     ;;;
16     ;;; You should have received a copy of the GNU Library General Public
17     ;;; License along with this library; if not, write to the
18     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19     ;;; Boston, MA 02111-1307 USA.
20    
21     ;;; Syntax for analysing HTML
22    
23 rstrandh 1.6 (in-package :climacs-html-syntax)
24 rstrandh 1.1
25 crhodes 1.31 (define-syntax html-syntax (basic-syntax)
26 rstrandh 1.30 ((lexer :reader lexer)
27     (valid-parse :initform 1)
28 crhodes 1.31 (parser))
29     (:name "HTML")
30     (:pathname-types "html" "htm"))
31 rstrandh 1.30
32 rstrandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33     ;;;
34     ;;; grammar classes
35    
36 rstrandh 1.17 (defclass html-parse-tree (parse-tree)
37 rstrandh 1.14 ((badness :initform 0 :initarg :badness :reader badness)))
38 rstrandh 1.1
39 rstrandh 1.17 (defmethod parse-tree-better ((t1 html-parse-tree) (t2 html-parse-tree))
40 rstrandh 1.1 (and (eq (class-of t1) (class-of t2))
41     (< (badness t1) (badness t2))))
42    
43 rstrandh 1.17 (defclass html-nonterminal (html-parse-tree) ())
44 rstrandh 1.6
45 rstrandh 1.17 (defclass html-token (html-parse-tree)
46 rstrandh 1.9 ((ink) (face)))
47 rstrandh 1.4
48 rstrandh 1.9 (defclass html-tag (html-token) ())
49 rstrandh 1.4
50 rstrandh 1.30 (defclass html-start-tag (html-tag)
51     ((start :initarg :start)
52     (name :initarg :name)
53     (attributes :initform nil :initarg :attributes)
54     (end :initarg :end)))
55    
56     (defmethod display-parse-tree ((entity html-start-tag) (syntax html-syntax) pane)
57     (with-slots (start name attributes end) entity
58     (display-parse-tree start syntax pane)
59     (display-parse-tree name syntax pane)
60     (unless (null attributes)
61     (display-parse-tree attributes syntax pane))
62     (display-parse-tree end syntax pane)))
63    
64     (defclass html-end-tag (html-tag)
65     ((start :initarg :start)
66     (name :initarg :name)
67     (end :initarg :end)))
68    
69     (defmethod display-parse-tree ((entity html-end-tag) (syntax html-syntax) pane)
70     (with-slots (start name attributes end) entity
71     (display-parse-tree start syntax pane)
72     (display-parse-tree name syntax pane)
73     (display-parse-tree end syntax pane)))
74    
75 rstrandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76     ;;;
77     ;;; lexer
78    
79 rstrandh 1.17 (defclass html-lexeme (html-token)
80 rstrandh 1.4 ((state :initarg :state)))
81    
82 rstrandh 1.17 (defclass start-lexeme (html-lexeme) ())
83 rstrandh 1.29 (defclass start-tag-start (html-lexeme) ())
84     (defclass end-tag-start (html-lexeme) ())
85 rstrandh 1.17 (defclass tag-end (html-lexeme) ())
86     (defclass word (html-lexeme) ())
87     (defclass delimiter (html-lexeme) ())
88 rstrandh 1.4
89 rstrandh 1.15 (defclass html-lexer (incremental-lexer) ())
90    
91 rstrandh 1.14 (defmethod next-lexeme ((lexer html-lexer) scan)
92 rstrandh 1.11 (flet ((fo () (forward-object scan)))
93     (let ((object (object-after scan)))
94     (case object
95 rstrandh 1.29 (#\< (fo) (cond ((or (end-of-buffer-p scan)
96     (not (eql (object-after scan) #\/)))
97     (make-instance 'start-tag-start))
98     (t (fo)
99     (make-instance 'end-tag-start))))
100 rstrandh 1.11 (#\> (fo) (make-instance 'tag-end))
101     (t (cond ((alphanumericp object)
102     (loop until (end-of-buffer-p scan)
103     while (alphanumericp (object-after scan))
104     do (fo))
105     (make-instance 'word))
106     (t
107     (fo) (make-instance 'delimiter))))))))
108 rstrandh 1.13
109 rstrandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110     ;;;
111     ;;; parser
112    
113 rstrandh 1.20 (defparameter *html-grammar* (grammar))
114 rstrandh 1.18
115 rstrandh 1.30 (defmacro add-html-rule (rule &key predict-test)
116     `(add-rule (grammar-rule ,rule :predict-test ,predict-test)
117     *html-grammar*))
118 rstrandh 1.21
119 rstrandh 1.18 (defun word-is (word string)
120 rstrandh 1.19 (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
121 rstrandh 1.18 string))
122 rstrandh 1.1
123 rstrandh 1.17 (defmacro define-start-tag (name string)
124     `(progn
125 rstrandh 1.30 (defclass ,name (html-start-tag) ())
126 rstrandh 1.17
127 rstrandh 1.21 (add-html-rule
128 rstrandh 1.29 (,name -> (start-tag-start
129     (word (and (= (end-offset start-tag-start) (start-offset word))
130 rstrandh 1.21 (word-is word ,string)))
131 rstrandh 1.30 (tag-end (= (end-offset word) (start-offset tag-end))))
132     :start start-tag-start :name word :end tag-end))))
133 rstrandh 1.17
134     (defmacro define-end-tag (name string)
135     `(progn
136 rstrandh 1.30 (defclass ,name (html-end-tag) ())
137 rstrandh 1.17
138 rstrandh 1.21 (add-html-rule
139 rstrandh 1.29 (,name -> (end-tag-start
140     (word (and (= (end-offset end-tag-start) (start-offset word))
141 rstrandh 1.21 (word-is word ,string)))
142 rstrandh 1.30 (tag-end (= (end-offset word) (start-offset tag-end))))
143     :start end-tag-start :name word :end tag-end)
144     :predict-test (lambda (token)
145     (typep token 'end-tag-start)))))
146 rstrandh 1.17
147     (defmacro define-tag-pair (start-name end-name string)
148     `(progn (define-start-tag ,start-name ,string)
149     (define-end-tag ,end-name ,string)))
150    
151     (define-tag-pair <head> </head> "head")
152     (define-tag-pair <title> </title> "title")
153     (define-tag-pair <body> </body> "body")
154    
155 rstrandh 1.25 (defmacro define-list (name item-name)
156     (let ((empty-name (gensym))
157     (nonempty-name (gensym)))
158     `(progn
159     (defclass ,name (html-nonterminal) ())
160     (defclass ,empty-name (,name) ())
161    
162     (defclass ,nonempty-name (,name)
163     ((items :initarg :items)
164     (item :initarg :item)))
165    
166     (add-html-rule (,name -> ()
167     (make-instance ',empty-name)))
168    
169     (add-html-rule (,name -> (,name ,item-name)
170     (make-instance ',nonempty-name
171 rstrandh 1.27 :items ,name :item ,item-name)))
172    
173     (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
174     (declare (ignore pane))
175     nil)
176    
177     (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
178     (with-slots (items item) entity
179     (display-parse-tree items syntax pane)
180     (display-parse-tree item syntax pane))))))
181    
182     (defmacro define-nonempty-list (name item-name)
183     (let ((empty-name (gensym))
184     (nonempty-name (gensym)))
185     `(progn
186     (defclass ,name (html-nonterminal) ())
187     (defclass ,empty-name (,name) ())
188    
189     (defclass ,nonempty-name (,name)
190     ((items :initarg :items)
191     (item :initarg :item)))
192    
193     (add-html-rule (,name -> (,item-name)
194     (make-instance ',nonempty-name
195     :items (make-instance ',empty-name)
196     :item ,item-name)))
197    
198     (add-html-rule (,name -> (,name ,item-name)
199     (make-instance ',nonempty-name
200     :items ,name :item ,item-name)))
201 rstrandh 1.25
202     (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
203     (declare (ignore pane))
204     nil)
205    
206     (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
207     (with-slots (items item) entity
208     (display-parse-tree items syntax pane)
209     (display-parse-tree item syntax pane))))))
210 rstrandh 1.17
211 rstrandh 1.22 ;;;;;;;;;;;;;;; string
212    
213     (defclass string-lexeme (html-lexeme) ())
214    
215     (add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\""))))))
216    
217     (defclass html-string (html-token)
218     ((start :initarg :start)
219     (lexemes :initarg :lexemes)
220     (end :initarg :end)))
221    
222 rstrandh 1.25 (define-list string-lexemes string-lexeme)
223 rstrandh 1.22
224     (add-html-rule (html-string -> ((start delimiter (word-is start "\""))
225     string-lexemes
226     (end delimiter (word-is end "\"")))
227     :start start :lexemes string-lexemes :end end))
228    
229     (defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane)
230     (with-slots (start lexemes end) entity
231     (display-parse-tree start syntax pane)
232     (with-text-face (pane :italic)
233     (display-parse-tree lexemes syntax pane))
234     (display-parse-tree end syntax pane)))
235    
236 rstrandh 1.21 ;;;;;;;;;;;;;;; attributes
237    
238     (defclass html-attribute (html-nonterminal)
239     ((name :initarg :name)
240     (equals :initarg :equals)))
241    
242     (defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane)
243     (with-slots (name equals) entity
244     (display-parse-tree name syntax pane)
245     (display-parse-tree equals syntax pane)))
246    
247 rstrandh 1.25 (defclass common-attribute (html-attribute) ())
248    
249     (defclass core-attribute (common-attribute) ())
250     (defclass i18n-attribute (common-attribute) ())
251     (defclass scripting-event (common-attribute) ())
252    
253     (define-list common-attributes common-attribute)
254 rstrandh 1.23
255 rstrandh 1.21 ;;;;;;;;;;;;;;; lang attribute
256    
257 rstrandh 1.23 (defclass lang-attr (i18n-attribute)
258 rstrandh 1.21 ((lang :initarg :lang)))
259    
260     (add-html-rule (lang-attr -> ((name word (word-is name "lang"))
261     (equals delimiter (and (= (end-offset name) (start-offset equals))
262     (word-is equals "=")))
263     (lang word (and (= (end-offset equals) (start-offset lang))
264     (= (- (end-offset lang) (start-offset lang))
265     2))))
266     :name name :equals equals :lang lang))
267    
268     (defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane)
269     (with-slots (lang) entity
270     (display-parse-tree lang syntax pane)))
271    
272     ;;;;;;;;;;;;;;; dir attribute
273    
274 rstrandh 1.23 (defclass dir-attr (i18n-attribute)
275 rstrandh 1.21 ((dir :initarg :dir)))
276    
277     (add-html-rule (dir-attr -> ((name word (word-is name "dir"))
278     (equals delimiter (and (= (end-offset name) (start-offset equals))
279     (word-is equals "=")))
280     (dir word (and (= (end-offset equals) (start-offset dir))
281     (or (word-is dir "rtl")
282     (word-is dir "ltr")))))
283     :name name :equals equals :dir dir))
284    
285     (defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane)
286     (with-slots (dir) entity
287     (display-parse-tree dir syntax pane)))
288    
289    
290 rstrandh 1.22 ;;;;;;;;;;;;;;; href attribute
291    
292     (defclass href-attr (html-attribute)
293     ((href :initarg :href)))
294    
295     (add-html-rule (href-attr -> ((name word (word-is name "href"))
296     (equals delimiter (and (= (end-offset name) (start-offset equals))
297     (word-is equals "=")))
298     (href html-string))
299     :name name :equals equals :href href))
300    
301     (defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane)
302     (with-slots (href) entity
303     (display-parse-tree href syntax pane)))
304    
305    
306 rstrandh 1.25 ;;;;;;;;;;;;;;; title
307 rstrandh 1.17
308 rstrandh 1.16 (defclass title-item (html-nonterminal)
309     ((item :initarg :item)))
310    
311 rstrandh 1.21 (add-html-rule (title-item -> (word) :item word))
312     (add-html-rule (title-item -> (delimiter) :item delimiter))
313 rstrandh 1.16
314     (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
315     (with-slots (item) entity
316     (display-parse-tree item syntax pane)))
317    
318 rstrandh 1.25 (define-list title-items title-item)
319 rstrandh 1.16
320     (defclass title (html-nonterminal)
321     ((<title> :initarg :<title>)
322     (items :initarg :items)
323     (</title> :initarg :</title>)))
324    
325 rstrandh 1.21 (add-html-rule (title -> (<title> title-items </title>)
326     :<title> <title> :items title-items :</title> </title>))
327 rstrandh 1.16
328     (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
329     (with-slots (<title> items </title>) entity
330     (display-parse-tree <title> syntax pane)
331     (with-text-face (pane :bold)
332     (display-parse-tree items syntax pane))
333     (display-parse-tree </title> syntax pane)))
334    
335 rstrandh 1.23 ;;;;;;;;;;;;;;; inline-element, block-level-element
336    
337     (defclass inline-element (html-nonterminal) ())
338     (defclass block-level-element (html-nonterminal) ())
339    
340 rstrandh 1.27 ;;;;;;;;;;;;;;; %inline
341 rstrandh 1.23
342 rstrandh 1.27 (defclass $inline (html-nonterminal)
343 rstrandh 1.24 ((contents :initarg :contents)))
344 rstrandh 1.23
345 rstrandh 1.30 (add-html-rule ($inline -> (inline-element) :contents inline-element)
346     :predict-test (lambda (token)
347     (typep token 'start-tag-start)))
348 rstrandh 1.27 (add-html-rule ($inline -> (word) :contents word))
349     (add-html-rule ($inline -> (delimiter) :contents delimiter))
350 rstrandh 1.23
351 rstrandh 1.27 (defmethod display-parse-tree ((entity $inline) (syntax html-syntax) pane)
352 rstrandh 1.23 (with-slots (contents) entity
353     (display-parse-tree contents syntax pane)))
354    
355 rstrandh 1.27 (define-list $inlines $inline)
356    
357     ;;;;;;;;;;;;;;; %flow
358    
359     (defclass $flow (html-nonterminal)
360     ((contents :initarg :contents)))
361    
362     (add-html-rule ($flow -> ($inline) :contents $inline))
363 rstrandh 1.30 (add-html-rule ($flow -> (block-level-element) :contents block-level-element)
364     :predict-test (lambda (token)
365     (typep token 'start-tag-start)))
366 rstrandh 1.27
367     (defmethod display-parse-tree ((entity $flow) (syntax html-syntax) pane)
368     (with-slots (contents) entity
369     (display-parse-tree contents syntax pane)))
370    
371     (define-list $flows $flow)
372 rstrandh 1.24
373     ;;;;;;;;;;;;;;; headings
374    
375     (defclass heading (block-level-element)
376     ((start :initarg :start)
377     (contents :initarg :contents)
378     (end :initarg :end)))
379    
380     (defmethod display-parse-tree ((entity heading) (syntax html-syntax) pane)
381     (with-slots (start contents end) entity
382     (display-parse-tree start syntax pane)
383 rstrandh 1.26 (with-text-face (pane :bold)
384     (display-parse-tree contents syntax pane))
385 rstrandh 1.24 (display-parse-tree end syntax pane)))
386    
387     (defmacro define-heading (class-name tag-string start-tag-name end-tag-name)
388     `(progn
389     (define-tag-pair ,start-tag-name ,end-tag-name ,tag-string)
390    
391     (defclass ,class-name (heading) ())
392    
393     (add-html-rule
394 rstrandh 1.27 (,class-name -> (,start-tag-name $inlines ,end-tag-name)
395     :start ,start-tag-name :contents $inlines :end ,end-tag-name))))
396 rstrandh 1.24
397    
398     (define-heading h1 "h1" <h1> </h1>)
399     (define-heading h2 "h2" <h2> </h2>)
400     (define-heading h3 "h3" <h3> </h3>)
401     (define-heading h4 "h4" <h4> </h4>)
402     (define-heading h5 "h5" <h5> </h5>)
403     (define-heading h6 "h6" <h6> </h6>)
404    
405 rstrandh 1.25 ;;;;;;;;;;;;;;; a element
406 rstrandh 1.18
407 rstrandh 1.22 (defclass <a>-attribute (html-nonterminal)
408     ((attribute :initarg :attribute)))
409 rstrandh 1.18
410 rstrandh 1.22 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
411 rstrandh 1.18
412 rstrandh 1.22 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
413     (with-slots (attribute) entity
414     (display-parse-tree attribute syntax pane)))
415 rstrandh 1.18
416 rstrandh 1.25 (define-list <a>-attributes <a>-attribute)
417 rstrandh 1.18
418 rstrandh 1.30 (defclass <a> (html-start-tag) ())
419 rstrandh 1.18
420 rstrandh 1.29 (add-html-rule (<a> -> (start-tag-start
421     (word (and (= (end-offset start-tag-start) (start-offset word))
422 rstrandh 1.22 (word-is word "a")))
423     <a>-attributes
424     tag-end)
425 rstrandh 1.29 :start start-tag-start :name word :attributes <a>-attributes :end tag-end))
426 rstrandh 1.18
427     (define-end-tag </a> "a")
428    
429 rstrandh 1.25 (defclass a-element (inline-element)
430 rstrandh 1.18 ((<a> :initarg :<a>)
431     (items :initarg :items)
432     (</a> :initarg :</a>)))
433    
434 rstrandh 1.27 (add-html-rule (a-element -> (<a> $inlines </a>)
435     :<a> <a> :items $inlines :</a> </a>))
436 rstrandh 1.18
437 rstrandh 1.25 (defmethod display-parse-tree ((entity a-element) (syntax html-syntax) pane)
438 rstrandh 1.18 (with-slots (<a> items </a>) entity
439     (display-parse-tree <a> syntax pane)
440 rstrandh 1.22 (with-text-face (pane :bold)
441     (display-parse-tree items syntax pane))
442 rstrandh 1.18 (display-parse-tree </a> syntax pane)))
443 rstrandh 1.24
444 rstrandh 1.28 ;;;;;;;;;;;;;;; br element
445    
446     (defclass br-element (inline-element)
447     ((<br> :initarg :<br>)))
448    
449     (define-start-tag <br> "br")
450    
451     (add-html-rule (br-element -> (<br>) :<br> <br>))
452    
453     (defmethod display-parse-tree ((entity br-element) (syntax html-syntax) pane)
454     (with-slots (<br>) entity
455     (display-parse-tree <br> syntax pane)))
456    
457 rstrandh 1.25 ;;;;;;;;;;;;;;; p element
458    
459 rstrandh 1.30 (defclass <p> (html-start-tag) ())
460 rstrandh 1.25
461 rstrandh 1.29 (add-html-rule (<p> -> (start-tag-start
462     (word (and (= (end-offset start-tag-start) (start-offset word))
463 rstrandh 1.25 (word-is word "p")))
464     common-attributes
465     tag-end)
466 rstrandh 1.29 :start start-tag-start :name word :attributes common-attributes :end tag-end))
467 rstrandh 1.25
468     (define-end-tag </p> "p")
469    
470     (defclass p-element (block-level-element)
471     ((<p> :initarg :<p>)
472     (contents :initarg :contents)
473     (</p> :initarg :</p>)))
474    
475 rstrandh 1.27 (add-html-rule (p-element -> (<p> $inlines </p>)
476     :<p> <p> :contents $inlines :</p> </p>))
477 rstrandh 1.25
478     (defmethod display-parse-tree ((entity p-element) (syntax html-syntax) pane)
479     (with-slots (<p> contents </p>) entity
480     (display-parse-tree <p> syntax pane)
481     (display-parse-tree contents syntax pane)
482     (display-parse-tree </p> syntax pane)))
483    
484 rstrandh 1.26 ;;;;;;;;;;;;;;; li element
485    
486 rstrandh 1.30 (defclass <li> (html-start-tag) ())
487 rstrandh 1.26
488 rstrandh 1.29 (add-html-rule (<li> -> (start-tag-start
489     (word (and (= (end-offset start-tag-start) (start-offset word))
490 rstrandh 1.26 (word-is word "li")))
491     common-attributes
492     tag-end)
493 rstrandh 1.29 :start start-tag-start
494 rstrandh 1.26 :name word
495     :attributes common-attributes
496     :end tag-end))
497    
498     (define-end-tag </li> "li")
499    
500     (defclass li-element (html-nonterminal)
501     ((<li> :initarg :<li>)
502     (items :initarg :items)
503     (</li> :initarg :</li>)))
504    
505 rstrandh 1.27 (add-html-rule (li-element -> (<li> $flows </li>)
506     :<li> <li> :items $flows :</li> </li>))
507     (add-html-rule (li-element -> (<li> $flows)
508     :<li> <li> :items $flows :</li> nil))
509 rstrandh 1.26
510     (defmethod display-parse-tree ((entity li-element) (syntax html-syntax) pane)
511     (with-slots (<li> items </li>) entity
512     (display-parse-tree <li> syntax pane)
513     (display-parse-tree items syntax pane)
514 rstrandh 1.27 (when </li>
515     (display-parse-tree </li> syntax pane))))
516 rstrandh 1.26
517     ;;;;;;;;;;;;;;; ul element
518    
519 rstrandh 1.30 (defclass <ul> (html-start-tag) ())
520 rstrandh 1.26
521 rstrandh 1.29 (add-html-rule (<ul> -> (start-tag-start
522     (word (and (= (end-offset start-tag-start) (start-offset word))
523 rstrandh 1.26 (word-is word "ul")))
524     common-attributes
525     tag-end)
526 rstrandh 1.29 :start start-tag-start
527 rstrandh 1.26 :name word
528     :attributes common-attributes
529     :end tag-end))
530    
531     (define-end-tag </ul> "ul")
532    
533 rstrandh 1.27 (define-nonempty-list li-elements li-element)
534 rstrandh 1.26
535     (defclass ul-element (block-level-element)
536     ((<ul> :initarg :<ul>)
537     (items :initarg :items)
538     (</ul> :initarg :</ul>)))
539    
540     (add-html-rule (ul-element -> (<ul> li-elements </ul>)
541     :<ul> <ul> :items li-elements :</ul> </ul>))
542    
543     (defmethod display-parse-tree ((entity ul-element) (syntax html-syntax) pane)
544     (with-slots (<ul> items </ul>) entity
545     (display-parse-tree <ul> syntax pane)
546     (display-parse-tree items syntax pane)
547     (display-parse-tree </ul> syntax pane)))
548 rstrandh 1.28
549     ;;;;;;;;;;;;;;; hr element
550    
551     (defclass hr-element (block-level-element)
552     ((<hr> :initarg :<hr>)))
553    
554     (define-start-tag <hr> "hr")
555    
556     (add-html-rule (hr-element -> (<hr>) :<hr> <hr>))
557    
558     (defmethod display-parse-tree ((entity hr-element) (syntax html-syntax) pane)
559     (with-slots (<hr>) entity
560     (display-parse-tree <hr> syntax pane)))
561 rstrandh 1.26
562 rstrandh 1.25 ;;;;;;;;;;;;;;; body element
563 rstrandh 1.24
564     (defclass body-item (html-nonterminal)
565     ((item :initarg :item)))
566    
567     (add-html-rule (body-item -> ((element block-level-element)) :item element))
568    
569     (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
570     (with-slots (item) entity
571     (display-parse-tree item syntax pane)))
572    
573 rstrandh 1.25 (define-list body-items body-item)
574 rstrandh 1.24
575     (defclass body (html-nonterminal)
576     ((<body> :initarg :<body>)
577     (items :initarg :items)
578     (</body> :initarg :</body>)))
579    
580     (add-html-rule (body -> (<body> body-items </body>)
581     :<body> <body> :items body-items :</body> </body>))
582    
583     (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
584     (with-slots (<body> items </body>) entity
585     (display-parse-tree <body> syntax pane)
586     (display-parse-tree items syntax pane)
587     (display-parse-tree </body> syntax pane)))
588 rstrandh 1.18
589     ;;;;;;;;;;;;;;; head
590    
591     (defclass head (html-nonterminal)
592     ((<head> :initarg :<head>)
593     (title :initarg :title)
594     (</head> :initarg :</head>)))
595    
596 rstrandh 1.21 (add-html-rule (head -> (<head> title </head>)
597     :<head> <head> :title title :</head> </head>))
598 rstrandh 1.20
599 rstrandh 1.18 (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
600     (with-slots (<head> title </head>) entity
601     (display-parse-tree <head> syntax pane)
602     (display-parse-tree title syntax pane)
603     (display-parse-tree </head> syntax pane)))
604    
605     ;;;;;;;;;;;;;;; html
606 rstrandh 1.25
607     (defclass <html>-attribute (html-nonterminal)
608     ((attribute :initarg :attribute)))
609    
610     (defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
611     (with-slots (attribute) entity
612     (display-parse-tree attribute syntax pane)))
613    
614     (add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
615     (add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))
616    
617     (define-list <html>-attributes <html>-attribute)
618    
619 rstrandh 1.30 (defclass <html> (html-start-tag) ())
620 rstrandh 1.25
621 rstrandh 1.29 (add-html-rule (<html> -> (start-tag-start
622     (word (and (= (end-offset start-tag-start) (start-offset word))
623 rstrandh 1.25 (word-is word "html")))
624     <html>-attributes
625     tag-end)
626 rstrandh 1.29 :start start-tag-start :name word :attributes <html>-attributes :end tag-end))
627 rstrandh 1.25
628     (define-end-tag </html> "html")
629 rstrandh 1.18
630     (defclass html (html-nonterminal)
631     ((<html> :initarg :<html>)
632     (head :initarg :head)
633     (body :initarg :body)
634     (</html> :initarg :</html>)))
635 rstrandh 1.20
636 rstrandh 1.21 (add-html-rule (html -> (<html> head body </html>)
637     :<html> <html> :head head :body body :</html> </html>))
638 rstrandh 1.18
639     (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
640     (with-slots (<html> head body </html>) entity
641     (display-parse-tree <html> syntax pane)
642     (display-parse-tree head syntax pane)
643     (display-parse-tree body syntax pane)
644     (display-parse-tree </html> syntax pane)))
645    
646     ;;;;;;;;;;;;;;;
647    
648 rstrandh 1.1 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
649     (declare (ignore args))
650 rstrandh 1.13 (with-slots (parser lexer buffer) syntax
651 rstrandh 1.1 (setf parser (make-instance 'parser
652     :grammar *html-grammar*
653     :target 'html))
654 rstrandh 1.13 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
655 rstrandh 1.19 (let ((m (clone-mark (low-mark buffer) :left))
656     (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
657 abakic 1.12 (setf (offset m) 0)
658 rstrandh 1.19 (setf (start-offset lexeme) m
659     (end-offset lexeme) 0)
660     (insert-lexeme lexer 0 lexeme))))
661 rstrandh 1.4
662 rstrandh 1.6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
663     ;;;
664     ;;; update syntax
665    
666 rstrandh 1.13
667 rstrandh 1.4 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
668 rstrandh 1.13 (with-slots (parser lexer valid-parse) syntax
669     (loop until (= valid-parse (nb-lexemes lexer))
670     while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
671     do (let ((current-token (lexeme lexer (1- valid-parse)))
672     (next-lexeme (lexeme lexer valid-parse)))
673 rstrandh 1.11 (setf (slot-value next-lexeme 'state)
674     (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
675 rstrandh 1.4 (incf valid-parse))))
676 rstrandh 1.1
677 rstrandh 1.13 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
678 rstrandh 1.11 (whitespacep object))
679    
680 rstrandh 1.1 (defmethod update-syntax (buffer (syntax html-syntax))
681 rstrandh 1.13 (with-slots (lexer valid-parse) syntax
682 rstrandh 1.11 (let* ((low-mark (low-mark buffer))
683 rstrandh 1.17 (high-mark (high-mark buffer)))
684     (when (mark<= low-mark high-mark)
685     (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
686     (setf valid-parse first-invalid-position)
687     (update-lex lexer first-invalid-position high-mark))))))
688 rstrandh 1.6
689     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
690     ;;;
691     ;;; display
692    
693 rstrandh 1.9 (defvar *white-space-start* nil)
694    
695     (defvar *cursor-positions* nil)
696     (defvar *current-line* 0)
697    
698 rstrandh 1.7 (defun handle-whitespace (pane buffer start end)
699     (let ((space-width (space-width pane))
700     (tab-width (tab-width pane)))
701     (loop while (< start end)
702     do (ecase (buffer-object buffer start)
703 rstrandh 1.9 (#\Newline (terpri pane)
704     (setf (aref *cursor-positions* (incf *current-line*))
705     (multiple-value-bind (x y) (stream-cursor-position pane)
706 rstrandh 1.10 (declare (ignore x))
707 rstrandh 1.9 y)))
708 rstrandh 1.7 (#\Space (stream-increment-cursor-position
709     pane space-width 0))
710     (#\Tab (let ((x (stream-cursor-position pane)))
711     (stream-increment-cursor-position
712     pane (- tab-width (mod x tab-width)) 0))))
713     (incf start))))
714 rstrandh 1.6
715 rstrandh 1.17 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
716 rstrandh 1.8 (with-slots (top bot) pane
717 rstrandh 1.17 (when (and (end-offset entity) (mark> (end-offset entity) top))
718 rstrandh 1.8 (call-next-method))))
719    
720 rstrandh 1.30 (defmethod display-parse-tree ((entity html-lexeme) (syntax html-syntax) pane)
721 rstrandh 1.9 (flet ((cache-test (t1 t2)
722 rstrandh 1.30 (let ((result (and (eq t1 t2)
723     (eq (slot-value t1 'ink)
724     (medium-ink (sheet-medium pane)))
725     (eq (slot-value t1 'face)
726     (text-style-face (medium-text-style (sheet-medium pane)))))))
727     result)))
728 rstrandh 1.9 (updating-output (pane :unique-id entity
729     :id-test #'eq
730     :cache-value entity
731     :cache-test #'cache-test)
732     (with-slots (ink face) entity
733     (setf ink (medium-ink (sheet-medium pane))
734     face (text-style-face (medium-text-style (sheet-medium pane))))
735 rstrandh 1.19 (present (coerce (buffer-sequence (buffer syntax)
736     (start-offset entity)
737     (end-offset entity))
738 rstrandh 1.9 'string)
739     'string
740     :stream pane)))))
741    
742     (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
743 rstrandh 1.26 (with-drawing-options (pane :ink +green4+)
744 rstrandh 1.9 (call-next-method)))
745    
746 rstrandh 1.30 (defmethod display-parse-tree :before ((entity html-lexeme) (syntax html-syntax) pane)
747 rstrandh 1.9 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
748     (setf *white-space-start* (end-offset entity)))
749 rstrandh 1.10
750 rstrandh 1.8 (defgeneric display-parse-stack (symbol stack syntax pane))
751    
752     (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
753     (let ((next (parse-stack-next stack)))
754     (unless (null next)
755     (display-parse-stack (parse-stack-symbol next) next syntax pane))
756     (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
757     do (display-parse-tree parse-tree syntax pane))))
758    
759     (defun display-parse-state (state syntax pane)
760     (let ((top (parse-stack-top state)))
761     (if (not (null top))
762     (display-parse-stack (parse-stack-symbol top) top syntax pane)
763     (display-parse-tree (target-parse-tree state) syntax pane))))
764    
765 rstrandh 1.7 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
766     (with-slots (top bot) pane
767 rstrandh 1.9 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
768     *current-line* 0
769     (aref *cursor-positions* 0) (stream-cursor-position pane))
770 rstrandh 1.13 (with-slots (lexer) syntax
771     (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
772 rstrandh 1.7 1.0)))
773     ;; find the last token before bot
774     (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
775     ;; go back to a token before bot
776 rstrandh 1.13 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
777 rstrandh 1.7 do (decf end-token-index))
778 rstrandh 1.8 ;; go forward to the last token before bot
779 rstrandh 1.13 (loop until (or (= end-token-index (nb-lexemes lexer))
780     (mark> (start-offset (lexeme lexer end-token-index)) bot))
781 rstrandh 1.7 do (incf end-token-index))
782     (let ((start-token-index end-token-index))
783 rstrandh 1.8 ;; go back to the first token after top, or until the previous token
784     ;; contains a valid parser state
785 rstrandh 1.13 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
786 rstrandh 1.9 (not (parse-state-empty-p
787 rstrandh 1.13 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
788 rstrandh 1.7 do (decf start-token-index))
789 rstrandh 1.9 (let ((*white-space-start* (offset top)))
790     ;; display the parse tree if any
791 rstrandh 1.13 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
792     (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
793 rstrandh 1.9 syntax
794     pane))
795 rstrandh 1.11 ;; display the lexemes
796 rstrandh 1.9 (with-drawing-options (pane :ink +red+)
797     (loop while (< start-token-index end-token-index)
798 rstrandh 1.13 do (let ((token (lexeme lexer start-token-index)))
799 rstrandh 1.9 (display-parse-tree token syntax pane))
800     (incf start-token-index))))))))
801 dmurray 1.33 (when (region-visible-p pane) (display-region pane syntax))
802 dmurray 1.32 (display-cursor pane syntax current-p)))
803 rstrandh 1.7

  ViewVC Help
Powered by ViewVC 1.1.5