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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5