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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show 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 ;;; -*- 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 (basic-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 (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76 ;;;
77 ;;; lexer
78
79 (defclass html-lexeme (html-token)
80 ((state :initarg :state)))
81
82 (defclass start-lexeme (html-lexeme) ())
83 (defclass start-tag-start (html-lexeme) ())
84 (defclass end-tag-start (html-lexeme) ())
85 (defclass tag-end (html-lexeme) ())
86 (defclass word (html-lexeme) ())
87 (defclass delimiter (html-lexeme) ())
88
89 (defclass html-lexer (incremental-lexer) ())
90
91 (defmethod next-lexeme ((lexer html-lexer) scan)
92 (flet ((fo () (forward-object scan)))
93 (let ((object (object-after scan)))
94 (case object
95 (#\< (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 (#\> (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
109 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110 ;;;
111 ;;; parser
112
113 (defparameter *html-grammar* (grammar))
114
115 (defmacro add-html-rule (rule &key predict-test)
116 `(add-rule (grammar-rule ,rule :predict-test ,predict-test)
117 *html-grammar*))
118
119 (defun word-is (word string)
120 (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
121 string))
122
123 (defmacro define-start-tag (name string)
124 `(progn
125 (defclass ,name (html-start-tag) ())
126
127 (add-html-rule
128 (,name -> (start-tag-start
129 (word (and (= (end-offset start-tag-start) (start-offset word))
130 (word-is word ,string)))
131 (tag-end (= (end-offset word) (start-offset tag-end))))
132 :start start-tag-start :name word :end tag-end))))
133
134 (defmacro define-end-tag (name string)
135 `(progn
136 (defclass ,name (html-end-tag) ())
137
138 (add-html-rule
139 (,name -> (end-tag-start
140 (word (and (= (end-offset end-tag-start) (start-offset word))
141 (word-is word ,string)))
142 (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
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 (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 :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
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
211 ;;;;;;;;;;;;;;; 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 (define-list string-lexemes string-lexeme)
223
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 ;;;;;;;;;;;;;;; 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 (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
255 ;;;;;;;;;;;;;;; lang attribute
256
257 (defclass lang-attr (i18n-attribute)
258 ((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 (defclass dir-attr (i18n-attribute)
275 ((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 ;;;;;;;;;;;;;;; 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 ;;;;;;;;;;;;;;; title
307
308 (defclass title-item (html-nonterminal)
309 ((item :initarg :item)))
310
311 (add-html-rule (title-item -> (word) :item word))
312 (add-html-rule (title-item -> (delimiter) :item delimiter))
313
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 (define-list title-items title-item)
319
320 (defclass title (html-nonterminal)
321 ((<title> :initarg :<title>)
322 (items :initarg :items)
323 (</title> :initarg :</title>)))
324
325 (add-html-rule (title -> (<title> title-items </title>)
326 :<title> <title> :items title-items :</title> </title>))
327
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 ;;;;;;;;;;;;;;; inline-element, block-level-element
336
337 (defclass inline-element (html-nonterminal) ())
338 (defclass block-level-element (html-nonterminal) ())
339
340 ;;;;;;;;;;;;;;; %inline
341
342 (defclass $inline (html-nonterminal)
343 ((contents :initarg :contents)))
344
345 (add-html-rule ($inline -> (inline-element) :contents inline-element)
346 :predict-test (lambda (token)
347 (typep token 'start-tag-start)))
348 (add-html-rule ($inline -> (word) :contents word))
349 (add-html-rule ($inline -> (delimiter) :contents delimiter))
350
351 (defmethod display-parse-tree ((entity $inline) (syntax html-syntax) pane)
352 (with-slots (contents) entity
353 (display-parse-tree contents syntax pane)))
354
355 (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 (add-html-rule ($flow -> (block-level-element) :contents block-level-element)
364 :predict-test (lambda (token)
365 (typep token 'start-tag-start)))
366
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
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 (with-text-face (pane :bold)
384 (display-parse-tree contents syntax pane))
385 (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 (,class-name -> (,start-tag-name $inlines ,end-tag-name)
395 :start ,start-tag-name :contents $inlines :end ,end-tag-name))))
396
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 ;;;;;;;;;;;;;;; a element
406
407 (defclass <a>-attribute (html-nonterminal)
408 ((attribute :initarg :attribute)))
409
410 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
411
412 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
413 (with-slots (attribute) entity
414 (display-parse-tree attribute syntax pane)))
415
416 (define-list <a>-attributes <a>-attribute)
417
418 (defclass <a> (html-start-tag) ())
419
420 (add-html-rule (<a> -> (start-tag-start
421 (word (and (= (end-offset start-tag-start) (start-offset word))
422 (word-is word "a")))
423 <a>-attributes
424 tag-end)
425 :start start-tag-start :name word :attributes <a>-attributes :end tag-end))
426
427 (define-end-tag </a> "a")
428
429 (defclass a-element (inline-element)
430 ((<a> :initarg :<a>)
431 (items :initarg :items)
432 (</a> :initarg :</a>)))
433
434 (add-html-rule (a-element -> (<a> $inlines </a>)
435 :<a> <a> :items $inlines :</a> </a>))
436
437 (defmethod display-parse-tree ((entity a-element) (syntax html-syntax) pane)
438 (with-slots (<a> items </a>) entity
439 (display-parse-tree <a> syntax pane)
440 (with-text-face (pane :bold)
441 (display-parse-tree items syntax pane))
442 (display-parse-tree </a> syntax pane)))
443
444 ;;;;;;;;;;;;;;; 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 ;;;;;;;;;;;;;;; p element
458
459 (defclass <p> (html-start-tag) ())
460
461 (add-html-rule (<p> -> (start-tag-start
462 (word (and (= (end-offset start-tag-start) (start-offset word))
463 (word-is word "p")))
464 common-attributes
465 tag-end)
466 :start start-tag-start :name word :attributes common-attributes :end tag-end))
467
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 (add-html-rule (p-element -> (<p> $inlines </p>)
476 :<p> <p> :contents $inlines :</p> </p>))
477
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 ;;;;;;;;;;;;;;; li element
485
486 (defclass <li> (html-start-tag) ())
487
488 (add-html-rule (<li> -> (start-tag-start
489 (word (and (= (end-offset start-tag-start) (start-offset word))
490 (word-is word "li")))
491 common-attributes
492 tag-end)
493 :start start-tag-start
494 :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 (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
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 (when </li>
515 (display-parse-tree </li> syntax pane))))
516
517 ;;;;;;;;;;;;;;; ul element
518
519 (defclass <ul> (html-start-tag) ())
520
521 (add-html-rule (<ul> -> (start-tag-start
522 (word (and (= (end-offset start-tag-start) (start-offset word))
523 (word-is word "ul")))
524 common-attributes
525 tag-end)
526 :start start-tag-start
527 :name word
528 :attributes common-attributes
529 :end tag-end))
530
531 (define-end-tag </ul> "ul")
532
533 (define-nonempty-list li-elements li-element)
534
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
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
562 ;;;;;;;;;;;;;;; body element
563
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 (define-list body-items body-item)
574
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
589 ;;;;;;;;;;;;;;; head
590
591 (defclass head (html-nonterminal)
592 ((<head> :initarg :<head>)
593 (title :initarg :title)
594 (</head> :initarg :</head>)))
595
596 (add-html-rule (head -> (<head> title </head>)
597 :<head> <head> :title title :</head> </head>))
598
599 (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
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 (defclass <html> (html-start-tag) ())
620
621 (add-html-rule (<html> -> (start-tag-start
622 (word (and (= (end-offset start-tag-start) (start-offset word))
623 (word-is word "html")))
624 <html>-attributes
625 tag-end)
626 :start start-tag-start :name word :attributes <html>-attributes :end tag-end))
627
628 (define-end-tag </html> "html")
629
630 (defclass html (html-nonterminal)
631 ((<html> :initarg :<html>)
632 (head :initarg :head)
633 (body :initarg :body)
634 (</html> :initarg :</html>)))
635
636 (add-html-rule (html -> (<html> head body </html>)
637 :<html> <html> :head head :body body :</html> </html>))
638
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 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
649 (declare (ignore args))
650 (with-slots (parser lexer buffer) syntax
651 (setf parser (make-instance 'parser
652 :grammar *html-grammar*
653 :target 'html))
654 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
655 (let ((m (clone-mark (low-mark buffer) :left))
656 (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
657 (setf (offset m) 0)
658 (setf (start-offset lexeme) m
659 (end-offset lexeme) 0)
660 (insert-lexeme lexer 0 lexeme))))
661
662 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
663 ;;;
664 ;;; update syntax
665
666
667 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
668 (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 (setf (slot-value next-lexeme 'state)
674 (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
675 (incf valid-parse))))
676
677 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
678 (whitespacep object))
679
680 (defmethod update-syntax (buffer (syntax html-syntax))
681 (with-slots (lexer valid-parse) syntax
682 (let* ((low-mark (low-mark buffer))
683 (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
689 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
690 ;;;
691 ;;; display
692
693 (defvar *white-space-start* nil)
694
695 (defvar *cursor-positions* nil)
696 (defvar *current-line* 0)
697
698 (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 (#\Newline (terpri pane)
704 (setf (aref *cursor-positions* (incf *current-line*))
705 (multiple-value-bind (x y) (stream-cursor-position pane)
706 (declare (ignore x))
707 y)))
708 (#\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
715 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
716 (with-slots (top bot) pane
717 (when (and (end-offset entity) (mark> (end-offset entity) top))
718 (call-next-method))))
719
720 (defmethod display-parse-tree ((entity html-lexeme) (syntax html-syntax) pane)
721 (flet ((cache-test (t1 t2)
722 (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 (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 (present (coerce (buffer-sequence (buffer syntax)
736 (start-offset entity)
737 (end-offset entity))
738 'string)
739 'string
740 :stream pane)))))
741
742 (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
743 (with-drawing-options (pane :ink +green4+)
744 (call-next-method)))
745
746 (defmethod display-parse-tree :before ((entity html-lexeme) (syntax html-syntax) pane)
747 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
748 (setf *white-space-start* (end-offset entity)))
749
750 (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 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
766 (with-slots (top bot) pane
767 (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 (with-slots (lexer) syntax
771 (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
772 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 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
777 do (decf end-token-index))
778 ;; go forward to the last token before bot
779 (loop until (or (= end-token-index (nb-lexemes lexer))
780 (mark> (start-offset (lexeme lexer end-token-index)) bot))
781 do (incf end-token-index))
782 (let ((start-token-index end-token-index))
783 ;; go back to the first token after top, or until the previous token
784 ;; contains a valid parser state
785 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
786 (not (parse-state-empty-p
787 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
788 do (decf start-token-index))
789 (let ((*white-space-start* (offset top)))
790 ;; display the parse tree if any
791 (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 syntax
794 pane))
795 ;; display the lexemes
796 (with-drawing-options (pane :ink +red+)
797 (loop while (< start-token-index end-token-index)
798 do (let ((token (lexeme lexer start-token-index)))
799 (display-parse-tree token syntax pane))
800 (incf start-token-index))))))))
801 (when (region-visible-p pane) (display-region pane syntax))
802 (display-cursor pane syntax current-p)))
803

  ViewVC Help
Powered by ViewVC 1.1.5