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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Fri Apr 8 05:59:27 2005 UTC (9 years ago) by rstrandh
Branch: MAIN
Changes since 1.23: +65 -35 lines
headings h1 -- h6 added
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 (define-tag-pair <p> </p> "p")
121 (define-tag-pair <ul> </ul> "ul")
122 (define-tag-pair <li> </li> "li")
123
124 (defmacro define-list (name empty-name nonempty-name item-name)
125 `(progn
126 (defclass ,name (html-nonterminal) ())
127 (defclass ,empty-name (,name) ())
128
129 (defclass ,nonempty-name (,name)
130 ((items :initarg :items)
131 (item :initarg :item)))
132
133 (add-html-rule (,name -> ()
134 (make-instance ',empty-name)))
135
136 (add-html-rule (,name -> (,name ,item-name)
137 (make-instance ',nonempty-name
138 :items ,name :item ,item-name)))
139
140 (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
141 (declare (ignore pane))
142 nil)
143
144 (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
145 (with-slots (items item) entity
146 (display-parse-tree items syntax pane)
147 (display-parse-tree item syntax pane)))))
148
149 ;;;;;;;;;;;;;;; string
150
151 (defclass string-lexeme (html-lexeme) ())
152
153 (add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\""))))))
154
155 (defclass html-string (html-token)
156 ((start :initarg :start)
157 (lexemes :initarg :lexemes)
158 (end :initarg :end)))
159
160 (define-list string-lexemes empty-string-lexeme nonempty-string-lexeme string-lexeme)
161
162 (add-html-rule (html-string -> ((start delimiter (word-is start "\""))
163 string-lexemes
164 (end delimiter (word-is end "\"")))
165 :start start :lexemes string-lexemes :end end))
166
167 (defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane)
168 (with-slots (start lexemes end) entity
169 (display-parse-tree start syntax pane)
170 (with-text-face (pane :italic)
171 (display-parse-tree lexemes syntax pane))
172 (display-parse-tree end syntax pane)))
173
174 ;;;;;;;;;;;;;;; attributes
175
176 (defclass html-attribute (html-nonterminal)
177 ((name :initarg :name)
178 (equals :initarg :equals)))
179
180 (defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane)
181 (with-slots (name equals) entity
182 (display-parse-tree name syntax pane)
183 (display-parse-tree equals syntax pane)))
184
185 (defclass core-attribute (html-attribute) ())
186 (defclass i18n-attribute (html-attribute) ())
187 (defclass scripting-event (html-attribute) ())
188
189 ;;;;;;;;;;;;;;; lang attribute
190
191 (defclass lang-attr (i18n-attribute)
192 ((lang :initarg :lang)))
193
194 (add-html-rule (lang-attr -> ((name word (word-is name "lang"))
195 (equals delimiter (and (= (end-offset name) (start-offset equals))
196 (word-is equals "=")))
197 (lang word (and (= (end-offset equals) (start-offset lang))
198 (= (- (end-offset lang) (start-offset lang))
199 2))))
200 :name name :equals equals :lang lang))
201
202 (defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane)
203 (with-slots (lang) entity
204 (display-parse-tree lang syntax pane)))
205
206 ;;;;;;;;;;;;;;; dir attribute
207
208 (defclass dir-attr (i18n-attribute)
209 ((dir :initarg :dir)))
210
211 (add-html-rule (dir-attr -> ((name word (word-is name "dir"))
212 (equals delimiter (and (= (end-offset name) (start-offset equals))
213 (word-is equals "=")))
214 (dir word (and (= (end-offset equals) (start-offset dir))
215 (or (word-is dir "rtl")
216 (word-is dir "ltr")))))
217 :name name :equals equals :dir dir))
218
219 (defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane)
220 (with-slots (dir) entity
221 (display-parse-tree dir syntax pane)))
222
223
224 ;;;;;;;;;;;;;;; href attribute
225
226 (defclass href-attr (html-attribute)
227 ((href :initarg :href)))
228
229 (add-html-rule (href-attr -> ((name word (word-is name "href"))
230 (equals delimiter (and (= (end-offset name) (start-offset equals))
231 (word-is equals "=")))
232 (href html-string))
233 :name name :equals equals :href href))
234
235 (defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane)
236 (with-slots (href) entity
237 (display-parse-tree href syntax pane)))
238
239
240 ;;;;;;;;;;;;;;; <html>-tag
241
242 (defclass <html>-attribute (html-nonterminal)
243 ((attribute :initarg :attribute)))
244
245 (defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
246 (with-slots (attribute) entity
247 (display-parse-tree attribute syntax pane)))
248
249 (add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
250 (add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))
251
252 (define-list <html>-attributes empty-<html>-attribute nonempty-<html>-attribute <html>-attribute)
253
254 (defclass <html> (html-tag)
255 ((start :initarg :start)
256 (name :initarg :name)
257 (attributes :initarg :attributes)
258 (end :initarg :end)))
259
260 (add-html-rule (<html> -> (tag-start
261 (word (and (= (end-offset tag-start) (start-offset word))
262 (word-is word "html")))
263 <html>-attributes
264 tag-end)
265 :start tag-start :name word :attributes <html>-attributes :end tag-end))
266
267 (defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane)
268 (with-slots (start name attributes end) entity
269 (display-parse-tree start syntax pane)
270 (display-parse-tree name syntax pane)
271 (display-parse-tree attributes syntax pane)
272 (display-parse-tree end syntax pane)))
273
274 (define-end-tag </html> "html")
275
276 ;;;;;;;;;;;;;;; title-item, title-items
277
278 (defclass title-item (html-nonterminal)
279 ((item :initarg :item)))
280
281 (add-html-rule (title-item -> (word) :item word))
282 (add-html-rule (title-item -> (delimiter) :item delimiter))
283
284 (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
285 (with-slots (item) entity
286 (display-parse-tree item syntax pane)))
287
288 (define-list title-items empty-title-items nonempty-title-items title-item)
289
290 ;;;;;;;;;;;;;;; title
291
292 (defclass title (html-nonterminal)
293 ((<title> :initarg :<title>)
294 (items :initarg :items)
295 (</title> :initarg :</title>)))
296
297 (add-html-rule (title -> (<title> title-items </title>)
298 :<title> <title> :items title-items :</title> </title>))
299
300 (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
301 (with-slots (<title> items </title>) entity
302 (display-parse-tree <title> syntax pane)
303 (with-text-face (pane :bold)
304 (display-parse-tree items syntax pane))
305 (display-parse-tree </title> syntax pane)))
306
307 ;;;;;;;;;;;;;;; inline-element, block-level-element
308
309 (defclass inline-element (html-nonterminal) ())
310 (defclass block-level-element (html-nonterminal) ())
311
312 ;;;;;;;;;;;;;;; inline-element-or-text
313
314 (defclass inline-element-or-text (html-nonterminal)
315 ((contents :initarg :contents)))
316
317 (add-html-rule (inline-element-or-text -> (inline-element) :contents inline-element))
318 (add-html-rule (inline-element-or-text -> (word) :contents word))
319 (add-html-rule (inline-element-or-text -> (delimiter) :contents delimiter))
320
321 (defmethod display-parse-tree ((entity inline-element-or-text) (syntax html-syntax) pane)
322 (with-slots (contents) entity
323 (display-parse-tree contents syntax pane)))
324
325 (define-list inline-things empty-inline-things nonempty-inline-things inline-element-or-text)
326
327 ;;;;;;;;;;;;;;; headings
328
329 (defclass heading (block-level-element)
330 ((start :initarg :start)
331 (contents :initarg :contents)
332 (end :initarg :end)))
333
334 (defmethod display-parse-tree ((entity heading) (syntax html-syntax) pane)
335 (with-slots (start contents end) entity
336 (display-parse-tree start syntax pane)
337 (display-parse-tree contents syntax pane)
338 (display-parse-tree end syntax pane)))
339
340 (defmacro define-heading (class-name tag-string start-tag-name end-tag-name)
341 `(progn
342 (define-tag-pair ,start-tag-name ,end-tag-name ,tag-string)
343
344 (defclass ,class-name (heading) ())
345
346 (add-html-rule
347 (,class-name -> (,start-tag-name inline-things ,end-tag-name)
348 :start ,start-tag-name :contents inline-things :end ,end-tag-name))))
349
350
351 (define-heading h1 "h1" <h1> </h1>)
352 (define-heading h2 "h2" <h2> </h2>)
353 (define-heading h3 "h3" <h3> </h3>)
354 (define-heading h4 "h4" <h4> </h4>)
355 (define-heading h5 "h5" <h5> </h5>)
356 (define-heading h6 "h6" <h6> </h6>)
357
358 ;;;;;;;;;;;;;;; <a>-tag
359
360 (defclass <a>-attribute (html-nonterminal)
361 ((attribute :initarg :attribute)))
362
363 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
364
365 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
366 (with-slots (attribute) entity
367 (display-parse-tree attribute syntax pane)))
368
369 (define-list <a>-attributes empty-<a>-attributes nonempty-<a>-attributes <a>-attribute)
370
371 (defclass <a> (html-tag)
372 ((start :initarg :start)
373 (name :initarg :name)
374 (attributes :initarg :attributes)
375 (end :initarg :end)))
376
377 (add-html-rule (<a> -> (tag-start
378 (word (and (= (end-offset tag-start) (start-offset word))
379 (word-is word "a")))
380 <a>-attributes
381 tag-end)
382 :start tag-start :name word :attributes <a>-attributes :end tag-end))
383
384 (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane)
385 (with-slots (start name attributes end) entity
386 (display-parse-tree start syntax pane)
387 (display-parse-tree name syntax pane)
388 (display-parse-tree attributes syntax pane)
389 (display-parse-tree end syntax pane)))
390
391 (define-end-tag </a> "a")
392
393 (defclass a (inline-element)
394 ((<a> :initarg :<a>)
395 (items :initarg :items)
396 (</a> :initarg :</a>)))
397
398 (add-html-rule (a -> (<a> body-items </a>)
399 :<a> <a> :items body-items :</a> </a>))
400
401 (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane)
402 (with-slots (<a> items </a>) entity
403 (display-parse-tree <a> syntax pane)
404 (with-text-face (pane :bold)
405 (display-parse-tree items syntax pane))
406 (display-parse-tree </a> syntax pane)))
407
408 ;;;;;;;;;;;;;;; body-item body-items
409
410 (defclass body-item (html-nonterminal)
411 ((item :initarg :item)))
412
413 (add-html-rule (body-item -> (word) :item word))
414 (add-html-rule (body-item -> (delimiter) :item delimiter))
415 (add-html-rule (body-item -> ((element block-level-element)) :item element))
416
417 (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
418 (with-slots (item) entity
419 (display-parse-tree item syntax pane)))
420
421 (define-list body-items empty-body-items nonempty-body-items body-item)
422
423 ;;;;;;;;;;;;;;; body
424
425 (defclass body (html-nonterminal)
426 ((<body> :initarg :<body>)
427 (items :initarg :items)
428 (</body> :initarg :</body>)))
429
430 (add-html-rule (body -> (<body> body-items </body>)
431 :<body> <body> :items body-items :</body> </body>))
432
433 (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
434 (with-slots (<body> items </body>) entity
435 (display-parse-tree <body> syntax pane)
436 (display-parse-tree items syntax pane)
437 (display-parse-tree </body> syntax pane)))
438
439 ;;;;;;;;;;;;;;; head
440
441 (defclass head (html-nonterminal)
442 ((<head> :initarg :<head>)
443 (title :initarg :title)
444 (</head> :initarg :</head>)))
445
446 (add-html-rule (head -> (<head> title </head>)
447 :<head> <head> :title title :</head> </head>))
448
449 (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
450 (with-slots (<head> title </head>) entity
451 (display-parse-tree <head> syntax pane)
452 (display-parse-tree title syntax pane)
453 (display-parse-tree </head> syntax pane)))
454
455 ;;;;;;;;;;;;;;; html
456
457 (defclass html (html-nonterminal)
458 ((<html> :initarg :<html>)
459 (head :initarg :head)
460 (body :initarg :body)
461 (</html> :initarg :</html>)))
462
463 (add-html-rule (html -> (<html> head body </html>)
464 :<html> <html> :head head :body body :</html> </html>))
465
466 (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
467 (with-slots (<html> head body </html>) entity
468 (display-parse-tree <html> syntax pane)
469 (display-parse-tree head syntax pane)
470 (display-parse-tree body syntax pane)
471 (display-parse-tree </html> syntax pane)))
472
473 ;;;;;;;;;;;;;;;
474
475 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
476 (declare (ignore args))
477 (with-slots (parser lexer buffer) syntax
478 (setf parser (make-instance 'parser
479 :grammar *html-grammar*
480 :target 'html))
481 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
482 (let ((m (clone-mark (low-mark buffer) :left))
483 (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
484 (setf (offset m) 0)
485 (setf (start-offset lexeme) m
486 (end-offset lexeme) 0)
487 (insert-lexeme lexer 0 lexeme))))
488
489 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
490 ;;;
491 ;;; update syntax
492
493
494 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
495 (with-slots (parser lexer valid-parse) syntax
496 (loop until (= valid-parse (nb-lexemes lexer))
497 while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
498 do (let ((current-token (lexeme lexer (1- valid-parse)))
499 (next-lexeme (lexeme lexer valid-parse)))
500 (setf (slot-value next-lexeme 'state)
501 (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
502 (incf valid-parse))))
503
504 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
505 (whitespacep object))
506
507 (defmethod update-syntax (buffer (syntax html-syntax))
508 (with-slots (lexer valid-parse) syntax
509 (let* ((low-mark (low-mark buffer))
510 (high-mark (high-mark buffer)))
511 (when (mark<= low-mark high-mark)
512 (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
513 (setf valid-parse first-invalid-position)
514 (update-lex lexer first-invalid-position high-mark))))))
515
516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
517 ;;;
518 ;;; display
519
520 (defvar *white-space-start* nil)
521
522 (defvar *cursor-positions* nil)
523 (defvar *current-line* 0)
524
525 (defun handle-whitespace (pane buffer start end)
526 (let ((space-width (space-width pane))
527 (tab-width (tab-width pane)))
528 (loop while (< start end)
529 do (ecase (buffer-object buffer start)
530 (#\Newline (terpri pane)
531 (setf (aref *cursor-positions* (incf *current-line*))
532 (multiple-value-bind (x y) (stream-cursor-position pane)
533 (declare (ignore x))
534 y)))
535 (#\Space (stream-increment-cursor-position
536 pane space-width 0))
537 (#\Tab (let ((x (stream-cursor-position pane)))
538 (stream-increment-cursor-position
539 pane (- tab-width (mod x tab-width)) 0))))
540 (incf start))))
541
542 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
543 (with-slots (top bot) pane
544 (when (and (end-offset entity) (mark> (end-offset entity) top))
545 (call-next-method))))
546
547 (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
548 (flet ((cache-test (t1 t2)
549 (and (eq t1 t2)
550 (eq (slot-value t1 'ink)
551 (medium-ink (sheet-medium pane)))
552 (eq (slot-value t1 'face)
553 (text-style-face (medium-text-style (sheet-medium pane)))))))
554 (updating-output (pane :unique-id entity
555 :id-test #'eq
556 :cache-value entity
557 :cache-test #'cache-test)
558 (with-slots (ink face) entity
559 (setf ink (medium-ink (sheet-medium pane))
560 face (text-style-face (medium-text-style (sheet-medium pane))))
561 (present (coerce (buffer-sequence (buffer syntax)
562 (start-offset entity)
563 (end-offset entity))
564 'string)
565 'string
566 :stream pane)))))
567
568 (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
569 (with-drawing-options (pane :ink +green+)
570 (call-next-method)))
571
572 (defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
573 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
574 (setf *white-space-start* (end-offset entity)))
575
576 (defgeneric display-parse-stack (symbol stack syntax pane))
577
578 (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
579 (let ((next (parse-stack-next stack)))
580 (unless (null next)
581 (display-parse-stack (parse-stack-symbol next) next syntax pane))
582 (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
583 do (display-parse-tree parse-tree syntax pane))))
584
585 (defun display-parse-state (state syntax pane)
586 (let ((top (parse-stack-top state)))
587 (if (not (null top))
588 (display-parse-stack (parse-stack-symbol top) top syntax pane)
589 (display-parse-tree (target-parse-tree state) syntax pane))))
590
591 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
592 (with-slots (top bot) pane
593 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
594 *current-line* 0
595 (aref *cursor-positions* 0) (stream-cursor-position pane))
596 (with-slots (lexer) syntax
597 (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
598 1.0)))
599 ;; find the last token before bot
600 (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
601 ;; go back to a token before bot
602 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
603 do (decf end-token-index))
604 ;; go forward to the last token before bot
605 (loop until (or (= end-token-index (nb-lexemes lexer))
606 (mark> (start-offset (lexeme lexer end-token-index)) bot))
607 do (incf end-token-index))
608 (let ((start-token-index end-token-index))
609 ;; go back to the first token after top, or until the previous token
610 ;; contains a valid parser state
611 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
612 (not (parse-state-empty-p
613 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
614 do (decf start-token-index))
615 (let ((*white-space-start* (offset top)))
616 ;; display the parse tree if any
617 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
618 (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
619 syntax
620 pane))
621 ;; display the lexemes
622 (with-drawing-options (pane :ink +red+)
623 (loop while (< start-token-index end-token-index)
624 do (let ((token (lexeme lexer start-token-index)))
625 (display-parse-tree token syntax pane))
626 (incf start-token-index))))))))
627 (let* ((cursor-line (number-of-lines-in-region top (point pane)))
628 (height (text-style-height (medium-text-style pane) pane))
629 (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
630 (cursor-column (column-number (point pane)))
631 (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
632 (updating-output (pane :unique-id -1)
633 (draw-rectangle* pane
634 (1- cursor-x) (- cursor-y (* 0.2 height))
635 (+ cursor-x 2) (+ cursor-y (* 0.8 height))
636 :ink (if current-p +red+ +blue+))))))
637

  ViewVC Help
Powered by ViewVC 1.1.5