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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5