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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26 - (show annotations)
Fri Apr 8 14:36:59 2005 UTC (9 years ago) by rstrandh
Branch: MAIN
Changes since 1.25: +100 -4 lines
Added <ul>...</ul> and <li>...</li> elements.

Modified some html files to be conform.
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 ;;;;;;;;;;;;;;; string
149
150 (defclass string-lexeme (html-lexeme) ())
151
152 (add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\""))))))
153
154 (defclass html-string (html-token)
155 ((start :initarg :start)
156 (lexemes :initarg :lexemes)
157 (end :initarg :end)))
158
159 (define-list string-lexemes string-lexeme)
160
161 (add-html-rule (html-string -> ((start delimiter (word-is start "\""))
162 string-lexemes
163 (end delimiter (word-is end "\"")))
164 :start start :lexemes string-lexemes :end end))
165
166 (defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane)
167 (with-slots (start lexemes end) entity
168 (display-parse-tree start syntax pane)
169 (with-text-face (pane :italic)
170 (display-parse-tree lexemes syntax pane))
171 (display-parse-tree end syntax pane)))
172
173 ;;;;;;;;;;;;;;; attributes
174
175 (defclass html-attribute (html-nonterminal)
176 ((name :initarg :name)
177 (equals :initarg :equals)))
178
179 (defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane)
180 (with-slots (name equals) entity
181 (display-parse-tree name syntax pane)
182 (display-parse-tree equals syntax pane)))
183
184 (defclass common-attribute (html-attribute) ())
185
186 (defclass core-attribute (common-attribute) ())
187 (defclass i18n-attribute (common-attribute) ())
188 (defclass scripting-event (common-attribute) ())
189
190 (define-list common-attributes common-attribute)
191
192 ;;;;;;;;;;;;;;; lang attribute
193
194 (defclass lang-attr (i18n-attribute)
195 ((lang :initarg :lang)))
196
197 (add-html-rule (lang-attr -> ((name word (word-is name "lang"))
198 (equals delimiter (and (= (end-offset name) (start-offset equals))
199 (word-is equals "=")))
200 (lang word (and (= (end-offset equals) (start-offset lang))
201 (= (- (end-offset lang) (start-offset lang))
202 2))))
203 :name name :equals equals :lang lang))
204
205 (defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane)
206 (with-slots (lang) entity
207 (display-parse-tree lang syntax pane)))
208
209 ;;;;;;;;;;;;;;; dir attribute
210
211 (defclass dir-attr (i18n-attribute)
212 ((dir :initarg :dir)))
213
214 (add-html-rule (dir-attr -> ((name word (word-is name "dir"))
215 (equals delimiter (and (= (end-offset name) (start-offset equals))
216 (word-is equals "=")))
217 (dir word (and (= (end-offset equals) (start-offset dir))
218 (or (word-is dir "rtl")
219 (word-is dir "ltr")))))
220 :name name :equals equals :dir dir))
221
222 (defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane)
223 (with-slots (dir) entity
224 (display-parse-tree dir syntax pane)))
225
226
227 ;;;;;;;;;;;;;;; href attribute
228
229 (defclass href-attr (html-attribute)
230 ((href :initarg :href)))
231
232 (add-html-rule (href-attr -> ((name word (word-is name "href"))
233 (equals delimiter (and (= (end-offset name) (start-offset equals))
234 (word-is equals "=")))
235 (href html-string))
236 :name name :equals equals :href href))
237
238 (defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane)
239 (with-slots (href) entity
240 (display-parse-tree href syntax pane)))
241
242
243 ;;;;;;;;;;;;;;; title
244
245 (defclass title-item (html-nonterminal)
246 ((item :initarg :item)))
247
248 (add-html-rule (title-item -> (word) :item word))
249 (add-html-rule (title-item -> (delimiter) :item delimiter))
250
251 (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
252 (with-slots (item) entity
253 (display-parse-tree item syntax pane)))
254
255 (define-list title-items title-item)
256
257 (defclass title (html-nonterminal)
258 ((<title> :initarg :<title>)
259 (items :initarg :items)
260 (</title> :initarg :</title>)))
261
262 (add-html-rule (title -> (<title> title-items </title>)
263 :<title> <title> :items title-items :</title> </title>))
264
265 (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
266 (with-slots (<title> items </title>) entity
267 (display-parse-tree <title> syntax pane)
268 (with-text-face (pane :bold)
269 (display-parse-tree items syntax pane))
270 (display-parse-tree </title> syntax pane)))
271
272 ;;;;;;;;;;;;;;; inline-element, block-level-element
273
274 (defclass inline-element (html-nonterminal) ())
275 (defclass block-level-element (html-nonterminal) ())
276
277 ;;;;;;;;;;;;;;; inline-element-or-text
278
279 (defclass inline-element-or-text (html-nonterminal)
280 ((contents :initarg :contents)))
281
282 (add-html-rule (inline-element-or-text -> (inline-element) :contents inline-element))
283 (add-html-rule (inline-element-or-text -> (word) :contents word))
284 (add-html-rule (inline-element-or-text -> (delimiter) :contents delimiter))
285
286 (defmethod display-parse-tree ((entity inline-element-or-text) (syntax html-syntax) pane)
287 (with-slots (contents) entity
288 (display-parse-tree contents syntax pane)))
289
290 (define-list inline-things inline-element-or-text)
291
292 ;;;;;;;;;;;;;;; headings
293
294 (defclass heading (block-level-element)
295 ((start :initarg :start)
296 (contents :initarg :contents)
297 (end :initarg :end)))
298
299 (defmethod display-parse-tree ((entity heading) (syntax html-syntax) pane)
300 (with-slots (start contents end) entity
301 (display-parse-tree start syntax pane)
302 (with-text-face (pane :bold)
303 (display-parse-tree contents syntax pane))
304 (display-parse-tree end syntax pane)))
305
306 (defmacro define-heading (class-name tag-string start-tag-name end-tag-name)
307 `(progn
308 (define-tag-pair ,start-tag-name ,end-tag-name ,tag-string)
309
310 (defclass ,class-name (heading) ())
311
312 (add-html-rule
313 (,class-name -> (,start-tag-name inline-things ,end-tag-name)
314 :start ,start-tag-name :contents inline-things :end ,end-tag-name))))
315
316
317 (define-heading h1 "h1" <h1> </h1>)
318 (define-heading h2 "h2" <h2> </h2>)
319 (define-heading h3 "h3" <h3> </h3>)
320 (define-heading h4 "h4" <h4> </h4>)
321 (define-heading h5 "h5" <h5> </h5>)
322 (define-heading h6 "h6" <h6> </h6>)
323
324 ;;;;;;;;;;;;;;; a element
325
326 (defclass <a>-attribute (html-nonterminal)
327 ((attribute :initarg :attribute)))
328
329 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
330
331 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
332 (with-slots (attribute) entity
333 (display-parse-tree attribute syntax pane)))
334
335 (define-list <a>-attributes <a>-attribute)
336
337 (defclass <a> (html-tag)
338 ((start :initarg :start)
339 (name :initarg :name)
340 (attributes :initarg :attributes)
341 (end :initarg :end)))
342
343 (add-html-rule (<a> -> (tag-start
344 (word (and (= (end-offset tag-start) (start-offset word))
345 (word-is word "a")))
346 <a>-attributes
347 tag-end)
348 :start tag-start :name word :attributes <a>-attributes :end tag-end))
349
350 (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane)
351 (with-slots (start name attributes end) entity
352 (display-parse-tree start syntax pane)
353 (display-parse-tree name syntax pane)
354 (display-parse-tree attributes syntax pane)
355 (display-parse-tree end syntax pane)))
356
357 (define-end-tag </a> "a")
358
359 (defclass a-element (inline-element)
360 ((<a> :initarg :<a>)
361 (items :initarg :items)
362 (</a> :initarg :</a>)))
363
364 (add-html-rule (a-element -> (<a> inline-things </a>)
365 :<a> <a> :items inline-things :</a> </a>))
366
367 (defmethod display-parse-tree ((entity a-element) (syntax html-syntax) pane)
368 (with-slots (<a> items </a>) entity
369 (display-parse-tree <a> syntax pane)
370 (with-text-face (pane :bold)
371 (display-parse-tree items syntax pane))
372 (display-parse-tree </a> syntax pane)))
373
374 ;;;;;;;;;;;;;;; p element
375
376 (defclass <p> (html-tag)
377 ((start :initarg :start)
378 (name :initarg :name)
379 (attributes :initarg :attributes)
380 (end :initarg :end)))
381
382 (add-html-rule (<p> -> (tag-start
383 (word (and (= (end-offset tag-start) (start-offset word))
384 (word-is word "p")))
385 common-attributes
386 tag-end)
387 :start tag-start :name word :attributes common-attributes :end tag-end))
388
389 (defmethod display-parse-tree ((entity <p>) (syntax html-syntax) pane)
390 (with-slots (start name attributes end) entity
391 (display-parse-tree start syntax pane)
392 (display-parse-tree name syntax pane)
393 (display-parse-tree attributes syntax pane)
394 (display-parse-tree end syntax pane)))
395
396 (define-end-tag </p> "p")
397
398 (defclass p-element (block-level-element)
399 ((<p> :initarg :<p>)
400 (contents :initarg :contents)
401 (</p> :initarg :</p>)))
402
403 (add-html-rule (p-element -> (<p> inline-things </p>)
404 :<p> <p> :contents inline-things :</p> </p>))
405
406 (defmethod display-parse-tree ((entity p-element) (syntax html-syntax) pane)
407 (with-slots (<p> contents </p>) entity
408 (display-parse-tree <p> syntax pane)
409 (display-parse-tree contents syntax pane)
410 (display-parse-tree </p> syntax pane)))
411
412 ;;;;;;;;;;;;;;; li element
413
414 (defclass <li> (html-tag)
415 ((start :initarg :start)
416 (name :initarg :name)
417 (attributes :initarg :attributes)
418 (end :initarg :end)))
419
420 (add-html-rule (<li> -> (tag-start
421 (word (and (= (end-offset tag-start) (start-offset word))
422 (word-is word "li")))
423 common-attributes
424 tag-end)
425 :start tag-start
426 :name word
427 :attributes common-attributes
428 :end tag-end))
429
430 (defmethod display-parse-tree ((entity <li>) (syntax html-syntax) pane)
431 (with-slots (start name attributes end) entity
432 (display-parse-tree start syntax pane)
433 (display-parse-tree name syntax pane)
434 (display-parse-tree attributes syntax pane)
435 (display-parse-tree end syntax pane)))
436
437 (define-end-tag </li> "li")
438
439 (defclass li-item (html-nonterminal)
440 ((item :initarg :item)))
441
442 (add-html-rule (li-item -> (block-level-element) :item block-level-element))
443 (add-html-rule (li-item -> (inline-element) :item inline-element))
444
445 (defmethod display-parse-tree ((entity li-item) (syntax html-syntax) pane)
446 (with-slots (item) entity
447 (display-parse-tree item syntax pane)))
448
449 (define-list li-items li-item)
450
451 (defclass li-element (html-nonterminal)
452 ((<li> :initarg :<li>)
453 (items :initarg :items)
454 (</li> :initarg :</li>)))
455
456 (add-html-rule (li-element -> (<li> li-items </li>)
457 :<li> <li> :items li-items :</li> </li>))
458
459 (defmethod display-parse-tree ((entity li-element) (syntax html-syntax) pane)
460 (with-slots (<li> items </li>) entity
461 (display-parse-tree <li> syntax pane)
462 (display-parse-tree items syntax pane)
463 (display-parse-tree </li> syntax pane)))
464
465
466 ;;;;;;;;;;;;;;; ul element
467
468 (defclass <ul> (html-tag)
469 ((start :initarg :start)
470 (name :initarg :name)
471 (attributes :initarg :attributes)
472 (end :initarg :end)))
473
474 (add-html-rule (<ul> -> (tag-start
475 (word (and (= (end-offset tag-start) (start-offset word))
476 (word-is word "ul")))
477 common-attributes
478 tag-end)
479 :start tag-start
480 :name word
481 :attributes common-attributes
482 :end tag-end))
483
484 (defmethod display-parse-tree ((entity <ul>) (syntax html-syntax) pane)
485 (with-slots (start name attributes end) entity
486 (display-parse-tree start syntax pane)
487 (display-parse-tree name syntax pane)
488 (display-parse-tree attributes syntax pane)
489 (display-parse-tree end syntax pane)))
490
491 (define-end-tag </ul> "ul")
492
493 (define-list li-elements li-element)
494
495 (defclass ul-element (block-level-element)
496 ((<ul> :initarg :<ul>)
497 (items :initarg :items)
498 (</ul> :initarg :</ul>)))
499
500 (add-html-rule (ul-element -> (<ul> li-elements </ul>)
501 :<ul> <ul> :items li-elements :</ul> </ul>))
502
503 (defmethod display-parse-tree ((entity ul-element) (syntax html-syntax) pane)
504 (with-slots (<ul> items </ul>) entity
505 (display-parse-tree <ul> syntax pane)
506 (display-parse-tree items syntax pane)
507 (display-parse-tree </ul> syntax pane)))
508
509 ;;;;;;;;;;;;;;; body element
510
511 (defclass body-item (html-nonterminal)
512 ((item :initarg :item)))
513
514 (add-html-rule (body-item -> (word) :item word))
515 (add-html-rule (body-item -> (delimiter) :item delimiter))
516 (add-html-rule (body-item -> ((element block-level-element)) :item element))
517
518 (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
519 (with-slots (item) entity
520 (display-parse-tree item syntax pane)))
521
522 (define-list body-items body-item)
523
524 (defclass body (html-nonterminal)
525 ((<body> :initarg :<body>)
526 (items :initarg :items)
527 (</body> :initarg :</body>)))
528
529 (add-html-rule (body -> (<body> body-items </body>)
530 :<body> <body> :items body-items :</body> </body>))
531
532 (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
533 (with-slots (<body> items </body>) entity
534 (display-parse-tree <body> syntax pane)
535 (display-parse-tree items syntax pane)
536 (display-parse-tree </body> syntax pane)))
537
538 ;;;;;;;;;;;;;;; head
539
540 (defclass head (html-nonterminal)
541 ((<head> :initarg :<head>)
542 (title :initarg :title)
543 (</head> :initarg :</head>)))
544
545 (add-html-rule (head -> (<head> title </head>)
546 :<head> <head> :title title :</head> </head>))
547
548 (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
549 (with-slots (<head> title </head>) entity
550 (display-parse-tree <head> syntax pane)
551 (display-parse-tree title syntax pane)
552 (display-parse-tree </head> syntax pane)))
553
554 ;;;;;;;;;;;;;;; html
555
556 (defclass <html>-attribute (html-nonterminal)
557 ((attribute :initarg :attribute)))
558
559 (defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
560 (with-slots (attribute) entity
561 (display-parse-tree attribute syntax pane)))
562
563 (add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
564 (add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))
565
566 (define-list <html>-attributes <html>-attribute)
567
568 (defclass <html> (html-tag)
569 ((start :initarg :start)
570 (name :initarg :name)
571 (attributes :initarg :attributes)
572 (end :initarg :end)))
573
574 (add-html-rule (<html> -> (tag-start
575 (word (and (= (end-offset tag-start) (start-offset word))
576 (word-is word "html")))
577 <html>-attributes
578 tag-end)
579 :start tag-start :name word :attributes <html>-attributes :end tag-end))
580
581 (defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane)
582 (with-slots (start name attributes end) entity
583 (display-parse-tree start syntax pane)
584 (display-parse-tree name syntax pane)
585 (display-parse-tree attributes syntax pane)
586 (display-parse-tree end syntax pane)))
587
588 (define-end-tag </html> "html")
589
590 (defclass html (html-nonterminal)
591 ((<html> :initarg :<html>)
592 (head :initarg :head)
593 (body :initarg :body)
594 (</html> :initarg :</html>)))
595
596 (add-html-rule (html -> (<html> head body </html>)
597 :<html> <html> :head head :body body :</html> </html>))
598
599 (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
600 (with-slots (<html> head body </html>) entity
601 (display-parse-tree <html> syntax pane)
602 (display-parse-tree head syntax pane)
603 (display-parse-tree body syntax pane)
604 (display-parse-tree </html> syntax pane)))
605
606 ;;;;;;;;;;;;;;;
607
608 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
609 (declare (ignore args))
610 (with-slots (parser lexer buffer) syntax
611 (setf parser (make-instance 'parser
612 :grammar *html-grammar*
613 :target 'html))
614 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
615 (let ((m (clone-mark (low-mark buffer) :left))
616 (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
617 (setf (offset m) 0)
618 (setf (start-offset lexeme) m
619 (end-offset lexeme) 0)
620 (insert-lexeme lexer 0 lexeme))))
621
622 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
623 ;;;
624 ;;; update syntax
625
626
627 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
628 (with-slots (parser lexer valid-parse) syntax
629 (loop until (= valid-parse (nb-lexemes lexer))
630 while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
631 do (let ((current-token (lexeme lexer (1- valid-parse)))
632 (next-lexeme (lexeme lexer valid-parse)))
633 (setf (slot-value next-lexeme 'state)
634 (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
635 (incf valid-parse))))
636
637 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
638 (whitespacep object))
639
640 (defmethod update-syntax (buffer (syntax html-syntax))
641 (with-slots (lexer valid-parse) syntax
642 (let* ((low-mark (low-mark buffer))
643 (high-mark (high-mark buffer)))
644 (when (mark<= low-mark high-mark)
645 (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
646 (setf valid-parse first-invalid-position)
647 (update-lex lexer first-invalid-position high-mark))))))
648
649 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
650 ;;;
651 ;;; display
652
653 (defvar *white-space-start* nil)
654
655 (defvar *cursor-positions* nil)
656 (defvar *current-line* 0)
657
658 (defun handle-whitespace (pane buffer start end)
659 (let ((space-width (space-width pane))
660 (tab-width (tab-width pane)))
661 (loop while (< start end)
662 do (ecase (buffer-object buffer start)
663 (#\Newline (terpri pane)
664 (setf (aref *cursor-positions* (incf *current-line*))
665 (multiple-value-bind (x y) (stream-cursor-position pane)
666 (declare (ignore x))
667 y)))
668 (#\Space (stream-increment-cursor-position
669 pane space-width 0))
670 (#\Tab (let ((x (stream-cursor-position pane)))
671 (stream-increment-cursor-position
672 pane (- tab-width (mod x tab-width)) 0))))
673 (incf start))))
674
675 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
676 (with-slots (top bot) pane
677 (when (and (end-offset entity) (mark> (end-offset entity) top))
678 (call-next-method))))
679
680 (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
681 (flet ((cache-test (t1 t2)
682 (and (eq t1 t2)
683 (eq (slot-value t1 'ink)
684 (medium-ink (sheet-medium pane)))
685 (eq (slot-value t1 'face)
686 (text-style-face (medium-text-style (sheet-medium pane)))))))
687 (updating-output (pane :unique-id entity
688 :id-test #'eq
689 :cache-value entity
690 :cache-test #'cache-test)
691 (with-slots (ink face) entity
692 (setf ink (medium-ink (sheet-medium pane))
693 face (text-style-face (medium-text-style (sheet-medium pane))))
694 (present (coerce (buffer-sequence (buffer syntax)
695 (start-offset entity)
696 (end-offset entity))
697 'string)
698 'string
699 :stream pane)))))
700
701 (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
702 (with-drawing-options (pane :ink +green4+)
703 (call-next-method)))
704
705 (defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
706 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
707 (setf *white-space-start* (end-offset entity)))
708
709 (defgeneric display-parse-stack (symbol stack syntax pane))
710
711 (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
712 (let ((next (parse-stack-next stack)))
713 (unless (null next)
714 (display-parse-stack (parse-stack-symbol next) next syntax pane))
715 (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
716 do (display-parse-tree parse-tree syntax pane))))
717
718 (defun display-parse-state (state syntax pane)
719 (let ((top (parse-stack-top state)))
720 (if (not (null top))
721 (display-parse-stack (parse-stack-symbol top) top syntax pane)
722 (display-parse-tree (target-parse-tree state) syntax pane))))
723
724 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
725 (with-slots (top bot) pane
726 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
727 *current-line* 0
728 (aref *cursor-positions* 0) (stream-cursor-position pane))
729 (with-slots (lexer) syntax
730 (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
731 1.0)))
732 ;; find the last token before bot
733 (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
734 ;; go back to a token before bot
735 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
736 do (decf end-token-index))
737 ;; go forward to the last token before bot
738 (loop until (or (= end-token-index (nb-lexemes lexer))
739 (mark> (start-offset (lexeme lexer end-token-index)) bot))
740 do (incf end-token-index))
741 (let ((start-token-index end-token-index))
742 ;; go back to the first token after top, or until the previous token
743 ;; contains a valid parser state
744 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
745 (not (parse-state-empty-p
746 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
747 do (decf start-token-index))
748 (let ((*white-space-start* (offset top)))
749 ;; display the parse tree if any
750 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
751 (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
752 syntax
753 pane))
754 ;; display the lexemes
755 (with-drawing-options (pane :ink +red+)
756 (loop while (< start-token-index end-token-index)
757 do (let ((token (lexeme lexer start-token-index)))
758 (display-parse-tree token syntax pane))
759 (incf start-token-index))))))))
760 (let* ((cursor-line (number-of-lines-in-region top (point pane)))
761 (height (text-style-height (medium-text-style pane) pane))
762 (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
763 (cursor-column (column-number (point pane)))
764 (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
765 (updating-output (pane :unique-id -1)
766 (draw-rectangle* pane
767 (1- cursor-x) (- cursor-y (* 0.2 height))
768 (+ cursor-x 2) (+ cursor-y (* 0.8 height))
769 :ink (if current-p +red+ +blue+))))))
770

  ViewVC Help
Powered by ViewVC 1.1.5