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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide annotations)
Mon Apr 4 11:49:05 2005 UTC (9 years ago) by rstrandh
Branch: MAIN
Changes since 1.21: +58 -17 lines
Defined a "string" syntactic entity where the contents are shown in
italics.

Defined an HREF attribute that takes a string as an argument

Fixed the <a> tag to take a list of attributes, just like <html> now
does.  The only possible attribute for the <a> tag at the moment is
HREF.
1 rstrandh 1.16 ;;; -*- Mode: Lisp; Package: CLIMACS-HTML-SYNTAX -*-
2 rstrandh 1.1
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 rstrandh 1.6 (in-package :climacs-html-syntax)
24 rstrandh 1.1
25     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26     ;;;
27     ;;; grammar classes
28    
29 rstrandh 1.17 (defclass html-parse-tree (parse-tree)
30 rstrandh 1.14 ((badness :initform 0 :initarg :badness :reader badness)))
31 rstrandh 1.1
32 rstrandh 1.17 (defmethod parse-tree-better ((t1 html-parse-tree) (t2 html-parse-tree))
33 rstrandh 1.1 (and (eq (class-of t1) (class-of t2))
34     (< (badness t1) (badness t2))))
35    
36 rstrandh 1.17 (defclass html-nonterminal (html-parse-tree) ())
37 rstrandh 1.6
38 rstrandh 1.17 (defclass html-token (html-parse-tree)
39 rstrandh 1.9 ((ink) (face)))
40 rstrandh 1.4
41 rstrandh 1.9 (defclass html-tag (html-token) ())
42 rstrandh 1.4
43 rstrandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
44     ;;;
45     ;;; lexer
46    
47 rstrandh 1.17 (defclass html-lexeme (html-token)
48 rstrandh 1.4 ((state :initarg :state)))
49    
50 rstrandh 1.17 (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 rstrandh 1.4
57 rstrandh 1.15 (defclass html-lexer (incremental-lexer) ())
58    
59 rstrandh 1.14 (defmethod next-lexeme ((lexer html-lexer) scan)
60 rstrandh 1.11 (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 rstrandh 1.13
74 rstrandh 1.4 (define-syntax html-syntax ("HTML" (basic-syntax))
75 rstrandh 1.13 ((lexer :reader lexer)
76 rstrandh 1.4 (valid-parse :initform 1)
77     (parser)))
78 rstrandh 1.1
79     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80     ;;;
81     ;;; parser
82    
83 rstrandh 1.20 (defparameter *html-grammar* (grammar))
84 rstrandh 1.18
85 rstrandh 1.21 (defmacro add-html-rule (rule)
86     `(add-rule (grammar-rule ,rule) *html-grammar*))
87    
88 rstrandh 1.18 (defun word-is (word string)
89 rstrandh 1.19 (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
90 rstrandh 1.18 string))
91 rstrandh 1.1
92 rstrandh 1.17 (defmacro define-start-tag (name string)
93     `(progn
94     (defclass ,name (html-tag) ())
95    
96 rstrandh 1.21 (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 rstrandh 1.17
102     (defmacro define-end-tag (name string)
103     `(progn
104     (defclass ,name (html-tag) ())
105    
106 rstrandh 1.21 (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 rstrandh 1.17
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 <h1> </h1> "h1")
121     (define-tag-pair <h2> </h2> "h2")
122     (define-tag-pair <h3> </h3> "h3")
123     (define-tag-pair <p> </p> "p")
124     (define-tag-pair <ul> </ul> "ul")
125     (define-tag-pair <li> </li> "li")
126    
127     (defmacro define-list (name empty-name nonempty-name item-name)
128     `(progn
129     (defclass ,name (html-nonterminal) ())
130     (defclass ,empty-name (,name) ())
131    
132     (defclass ,nonempty-name (,name)
133     ((items :initarg :items)
134     (item :initarg :item)))
135    
136 rstrandh 1.21 (add-html-rule (,name -> ()
137     (make-instance ',empty-name)))
138    
139     (add-html-rule (,name -> (,name ,item-name)
140     (make-instance ',nonempty-name
141     :items ,name :item ,item-name)))
142 rstrandh 1.17
143     (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
144     (declare (ignore pane))
145     nil)
146    
147     (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
148     (with-slots (items item) entity
149     (display-parse-tree items syntax pane)
150     (display-parse-tree item syntax pane)))))
151    
152 rstrandh 1.22 ;;;;;;;;;;;;;;; string
153    
154     (defclass string-lexeme (html-lexeme) ())
155    
156     (add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\""))))))
157    
158     (defclass html-string (html-token)
159     ((start :initarg :start)
160     (lexemes :initarg :lexemes)
161     (end :initarg :end)))
162    
163     (define-list string-lexemes empty-string-lexeme nonempty-string-lexeme string-lexeme)
164    
165     (add-html-rule (html-string -> ((start delimiter (word-is start "\""))
166     string-lexemes
167     (end delimiter (word-is end "\"")))
168     :start start :lexemes string-lexemes :end end))
169    
170     (defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane)
171     (with-slots (start lexemes end) entity
172     (display-parse-tree start syntax pane)
173     (with-text-face (pane :italic)
174     (display-parse-tree lexemes syntax pane))
175     (display-parse-tree end syntax pane)))
176    
177 rstrandh 1.21 ;;;;;;;;;;;;;;; attributes
178    
179     (defclass html-attribute (html-nonterminal)
180     ((name :initarg :name)
181     (equals :initarg :equals)))
182    
183     (defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane)
184     (with-slots (name equals) entity
185     (display-parse-tree name syntax pane)
186     (display-parse-tree equals syntax pane)))
187    
188     ;;;;;;;;;;;;;;; lang attribute
189    
190     (defclass lang-attr (html-attribute)
191     ((lang :initarg :lang)))
192    
193     (add-html-rule (lang-attr -> ((name word (word-is name "lang"))
194     (equals delimiter (and (= (end-offset name) (start-offset equals))
195     (word-is equals "=")))
196     (lang word (and (= (end-offset equals) (start-offset lang))
197     (= (- (end-offset lang) (start-offset lang))
198     2))))
199     :name name :equals equals :lang lang))
200    
201     (defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane)
202     (with-slots (lang) entity
203     (display-parse-tree lang syntax pane)))
204    
205     ;;;;;;;;;;;;;;; dir attribute
206    
207     (defclass dir-attr (html-attribute)
208     ((dir :initarg :dir)))
209    
210     (add-html-rule (dir-attr -> ((name word (word-is name "dir"))
211     (equals delimiter (and (= (end-offset name) (start-offset equals))
212     (word-is equals "=")))
213     (dir word (and (= (end-offset equals) (start-offset dir))
214     (or (word-is dir "rtl")
215     (word-is dir "ltr")))))
216     :name name :equals equals :dir dir))
217    
218     (defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane)
219     (with-slots (dir) entity
220     (display-parse-tree dir syntax pane)))
221    
222    
223 rstrandh 1.22 ;;;;;;;;;;;;;;; href attribute
224    
225     (defclass href-attr (html-attribute)
226     ((href :initarg :href)))
227    
228     (add-html-rule (href-attr -> ((name word (word-is name "href"))
229     (equals delimiter (and (= (end-offset name) (start-offset equals))
230     (word-is equals "=")))
231     (href html-string))
232     :name name :equals equals :href href))
233    
234     (defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane)
235     (with-slots (href) entity
236     (display-parse-tree href syntax pane)))
237    
238    
239 rstrandh 1.21 ;;;;;;;;;;;;;;; <html>-tag
240    
241     (defclass <html>-attribute (html-nonterminal)
242     ((attribute :initarg :attribute)))
243    
244     (defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
245     (with-slots (attribute) entity
246     (display-parse-tree attribute syntax pane)))
247    
248     (add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
249     (add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))
250    
251     (define-list <html>-attributes empty-<html>-attribute nonempty-<html>-attribute <html>-attribute)
252    
253     (defclass <html> (html-tag)
254     ((start :initarg :start)
255     (name :initarg :name)
256     (attributes :initarg :attributes)
257     (end :initarg :end)))
258    
259     (add-html-rule (<html> -> (tag-start
260     (word (and (= (end-offset tag-start) (start-offset word))
261     (word-is word "html")))
262     <html>-attributes
263     tag-end)
264     :start tag-start :name word :attributes <html>-attributes :end tag-end))
265    
266     (defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane)
267     (with-slots (start name attributes end) entity
268     (display-parse-tree start syntax pane)
269     (display-parse-tree name syntax pane)
270     (display-parse-tree attributes syntax pane)
271     (display-parse-tree end syntax pane)))
272    
273     (define-end-tag </html> "html")
274    
275 rstrandh 1.17 ;;;;;;;;;;;;;;; title-item, title-items
276    
277 rstrandh 1.16 (defclass title-item (html-nonterminal)
278     ((item :initarg :item)))
279    
280 rstrandh 1.21 (add-html-rule (title-item -> (word) :item word))
281     (add-html-rule (title-item -> (delimiter) :item delimiter))
282 rstrandh 1.16
283     (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
284     (with-slots (item) entity
285     (display-parse-tree item syntax pane)))
286    
287 rstrandh 1.17 (define-list title-items empty-title-items nonempty-title-items title-item)
288 rstrandh 1.16
289     ;;;;;;;;;;;;;;; title
290    
291     (defclass title (html-nonterminal)
292     ((<title> :initarg :<title>)
293     (items :initarg :items)
294     (</title> :initarg :</title>)))
295    
296 rstrandh 1.21 (add-html-rule (title -> (<title> title-items </title>)
297     :<title> <title> :items title-items :</title> </title>))
298 rstrandh 1.16
299     (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
300     (with-slots (<title> items </title>) entity
301     (display-parse-tree <title> syntax pane)
302     (with-text-face (pane :bold)
303     (display-parse-tree items syntax pane))
304     (display-parse-tree </title> syntax pane)))
305    
306 rstrandh 1.17 ;;;;;;;;;;;;;;; body-item body-items
307 rstrandh 1.16
308     (defclass body-item (html-nonterminal)
309     ((item :initarg :item)))
310    
311 rstrandh 1.21 (add-html-rule (body-item -> (word) :item word))
312     (add-html-rule (body-item -> (delimiter) :item delimiter))
313     (add-html-rule (body-item -> (a) :item a))
314 rstrandh 1.16
315     (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
316     (with-slots (item) entity
317     (display-parse-tree item syntax pane)))
318    
319 rstrandh 1.17 (define-list body-items empty-body-items nonempty-body-items body-item)
320 rstrandh 1.16
321     ;;;;;;;;;;;;;;; body
322    
323     (defclass body (html-nonterminal)
324     ((<body> :initarg :<body>)
325     (items :initarg :items)
326     (</body> :initarg :</body>)))
327    
328 rstrandh 1.21 (add-html-rule (body -> (<body> body-items </body>)
329     :<body> <body> :items body-items :</body> </body>))
330 rstrandh 1.16
331     (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
332     (with-slots (<body> items </body>) entity
333     (display-parse-tree <body> syntax pane)
334     (display-parse-tree items syntax pane)
335     (display-parse-tree </body> syntax pane)))
336    
337 rstrandh 1.18 ;;;;;;;;;;;;;;; <a>-tag
338    
339 rstrandh 1.22 (defclass <a>-attribute (html-nonterminal)
340     ((attribute :initarg :attribute)))
341 rstrandh 1.18
342 rstrandh 1.22 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
343 rstrandh 1.18
344 rstrandh 1.22 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
345     (with-slots (attribute) entity
346     (display-parse-tree attribute syntax pane)))
347 rstrandh 1.18
348 rstrandh 1.22 (define-list <a>-attributes empty-<a>-attributes nonempty-<a>-attributes <a>-attribute)
349 rstrandh 1.18
350     (defclass <a> (html-tag)
351     ((start :initarg :start)
352     (name :initarg :name)
353 rstrandh 1.22 (attributes :initarg :attributes)
354 rstrandh 1.18 (end :initarg :end)))
355    
356 rstrandh 1.21 (add-html-rule (<a> -> (tag-start
357 rstrandh 1.22 (word (and (= (end-offset tag-start) (start-offset word))
358     (word-is word "a")))
359     <a>-attributes
360     tag-end)
361     :start tag-start :name word :attributes <a>-attributes :end tag-end))
362 rstrandh 1.18
363     (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane)
364 rstrandh 1.22 (with-slots (start name attributes end) entity
365 rstrandh 1.18 (display-parse-tree start syntax pane)
366     (display-parse-tree name syntax pane)
367 rstrandh 1.22 (display-parse-tree attributes syntax pane)
368 rstrandh 1.18 (display-parse-tree end syntax pane)))
369    
370     (define-end-tag </a> "a")
371    
372     (defclass a (html-nonterminal)
373     ((<a> :initarg :<a>)
374     (items :initarg :items)
375     (</a> :initarg :</a>)))
376    
377 rstrandh 1.21 (add-html-rule (a -> (<a> body-items </a>)
378     :<a> <a> :items body-items :</a> </a>))
379 rstrandh 1.18
380     (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane)
381     (with-slots (<a> items </a>) entity
382     (display-parse-tree <a> syntax pane)
383 rstrandh 1.22 (with-text-face (pane :bold)
384     (display-parse-tree items syntax pane))
385 rstrandh 1.18 (display-parse-tree </a> syntax pane)))
386    
387     ;;;;;;;;;;;;;;; head
388    
389     (defclass head (html-nonterminal)
390     ((<head> :initarg :<head>)
391     (title :initarg :title)
392     (</head> :initarg :</head>)))
393    
394 rstrandh 1.21 (add-html-rule (head -> (<head> title </head>)
395     :<head> <head> :title title :</head> </head>))
396 rstrandh 1.20
397 rstrandh 1.18 (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
398     (with-slots (<head> title </head>) entity
399     (display-parse-tree <head> syntax pane)
400     (display-parse-tree title syntax pane)
401     (display-parse-tree </head> syntax pane)))
402    
403     ;;;;;;;;;;;;;;; html
404    
405     (defclass html (html-nonterminal)
406     ((<html> :initarg :<html>)
407     (head :initarg :head)
408     (body :initarg :body)
409     (</html> :initarg :</html>)))
410 rstrandh 1.20
411 rstrandh 1.21 (add-html-rule (html -> (<html> head body </html>)
412     :<html> <html> :head head :body body :</html> </html>))
413 rstrandh 1.18
414     (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
415     (with-slots (<html> head body </html>) entity
416     (display-parse-tree <html> syntax pane)
417     (display-parse-tree head syntax pane)
418     (display-parse-tree body syntax pane)
419     (display-parse-tree </html> syntax pane)))
420    
421     ;;;;;;;;;;;;;;;
422    
423 rstrandh 1.1 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
424     (declare (ignore args))
425 rstrandh 1.13 (with-slots (parser lexer buffer) syntax
426 rstrandh 1.1 (setf parser (make-instance 'parser
427     :grammar *html-grammar*
428     :target 'html))
429 rstrandh 1.13 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
430 rstrandh 1.19 (let ((m (clone-mark (low-mark buffer) :left))
431     (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
432 abakic 1.12 (setf (offset m) 0)
433 rstrandh 1.19 (setf (start-offset lexeme) m
434     (end-offset lexeme) 0)
435     (insert-lexeme lexer 0 lexeme))))
436 rstrandh 1.4
437 rstrandh 1.6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
438     ;;;
439     ;;; update syntax
440    
441 rstrandh 1.13
442 rstrandh 1.4 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
443 rstrandh 1.13 (with-slots (parser lexer valid-parse) syntax
444     (loop until (= valid-parse (nb-lexemes lexer))
445     while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
446     do (let ((current-token (lexeme lexer (1- valid-parse)))
447     (next-lexeme (lexeme lexer valid-parse)))
448 rstrandh 1.11 (setf (slot-value next-lexeme 'state)
449     (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
450 rstrandh 1.4 (incf valid-parse))))
451 rstrandh 1.1
452 rstrandh 1.13 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
453 rstrandh 1.11 (whitespacep object))
454    
455 rstrandh 1.1 (defmethod update-syntax (buffer (syntax html-syntax))
456 rstrandh 1.13 (with-slots (lexer valid-parse) syntax
457 rstrandh 1.11 (let* ((low-mark (low-mark buffer))
458 rstrandh 1.17 (high-mark (high-mark buffer)))
459     (when (mark<= low-mark high-mark)
460     (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
461     (setf valid-parse first-invalid-position)
462     (update-lex lexer first-invalid-position high-mark))))))
463 rstrandh 1.6
464     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
465     ;;;
466     ;;; display
467    
468 rstrandh 1.9 (defvar *white-space-start* nil)
469    
470     (defvar *cursor-positions* nil)
471     (defvar *current-line* 0)
472    
473 rstrandh 1.7 (defun handle-whitespace (pane buffer start end)
474     (let ((space-width (space-width pane))
475     (tab-width (tab-width pane)))
476     (loop while (< start end)
477     do (ecase (buffer-object buffer start)
478 rstrandh 1.9 (#\Newline (terpri pane)
479     (setf (aref *cursor-positions* (incf *current-line*))
480     (multiple-value-bind (x y) (stream-cursor-position pane)
481 rstrandh 1.10 (declare (ignore x))
482 rstrandh 1.9 y)))
483 rstrandh 1.7 (#\Space (stream-increment-cursor-position
484     pane space-width 0))
485     (#\Tab (let ((x (stream-cursor-position pane)))
486     (stream-increment-cursor-position
487     pane (- tab-width (mod x tab-width)) 0))))
488     (incf start))))
489 rstrandh 1.6
490 rstrandh 1.17 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
491 rstrandh 1.8 (with-slots (top bot) pane
492 rstrandh 1.17 (when (and (end-offset entity) (mark> (end-offset entity) top))
493 rstrandh 1.8 (call-next-method))))
494    
495     (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
496 rstrandh 1.9 (flet ((cache-test (t1 t2)
497     (and (eq t1 t2)
498     (eq (slot-value t1 'ink)
499     (medium-ink (sheet-medium pane)))
500     (eq (slot-value t1 'face)
501     (text-style-face (medium-text-style (sheet-medium pane)))))))
502     (updating-output (pane :unique-id entity
503     :id-test #'eq
504     :cache-value entity
505     :cache-test #'cache-test)
506     (with-slots (ink face) entity
507     (setf ink (medium-ink (sheet-medium pane))
508     face (text-style-face (medium-text-style (sheet-medium pane))))
509 rstrandh 1.19 (present (coerce (buffer-sequence (buffer syntax)
510     (start-offset entity)
511     (end-offset entity))
512 rstrandh 1.9 'string)
513     'string
514     :stream pane)))))
515    
516     (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
517     (with-drawing-options (pane :ink +green+)
518     (call-next-method)))
519    
520     (defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
521     (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
522     (setf *white-space-start* (end-offset entity)))
523 rstrandh 1.10
524 rstrandh 1.8 (defgeneric display-parse-stack (symbol stack syntax pane))
525    
526     (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
527     (let ((next (parse-stack-next stack)))
528     (unless (null next)
529     (display-parse-stack (parse-stack-symbol next) next syntax pane))
530     (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
531     do (display-parse-tree parse-tree syntax pane))))
532    
533     (defun display-parse-state (state syntax pane)
534     (let ((top (parse-stack-top state)))
535     (if (not (null top))
536     (display-parse-stack (parse-stack-symbol top) top syntax pane)
537     (display-parse-tree (target-parse-tree state) syntax pane))))
538    
539 rstrandh 1.7 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
540     (with-slots (top bot) pane
541 rstrandh 1.9 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
542     *current-line* 0
543     (aref *cursor-positions* 0) (stream-cursor-position pane))
544 rstrandh 1.13 (with-slots (lexer) syntax
545     (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
546 rstrandh 1.7 1.0)))
547     ;; find the last token before bot
548     (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
549     ;; go back to a token before bot
550 rstrandh 1.13 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
551 rstrandh 1.7 do (decf end-token-index))
552 rstrandh 1.8 ;; go forward to the last token before bot
553 rstrandh 1.13 (loop until (or (= end-token-index (nb-lexemes lexer))
554     (mark> (start-offset (lexeme lexer end-token-index)) bot))
555 rstrandh 1.7 do (incf end-token-index))
556     (let ((start-token-index end-token-index))
557 rstrandh 1.8 ;; go back to the first token after top, or until the previous token
558     ;; contains a valid parser state
559 rstrandh 1.13 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
560 rstrandh 1.9 (not (parse-state-empty-p
561 rstrandh 1.13 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
562 rstrandh 1.7 do (decf start-token-index))
563 rstrandh 1.9 (let ((*white-space-start* (offset top)))
564     ;; display the parse tree if any
565 rstrandh 1.13 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
566     (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
567 rstrandh 1.9 syntax
568     pane))
569 rstrandh 1.11 ;; display the lexemes
570 rstrandh 1.9 (with-drawing-options (pane :ink +red+)
571     (loop while (< start-token-index end-token-index)
572 rstrandh 1.13 do (let ((token (lexeme lexer start-token-index)))
573 rstrandh 1.9 (display-parse-tree token syntax pane))
574     (incf start-token-index))))))))
575     (let* ((cursor-line (number-of-lines-in-region top (point pane)))
576     (height (text-style-height (medium-text-style pane) pane))
577     (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
578     (cursor-column (column-number (point pane)))
579     (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
580     (updating-output (pane :unique-id -1)
581     (draw-rectangle* pane
582     (1- cursor-x) (- cursor-y (* 0.2 height))
583     (+ cursor-x 2) (+ cursor-y (* 0.8 height))
584     :ink (if current-p +red+ +blue+))))))
585 rstrandh 1.7

  ViewVC Help
Powered by ViewVC 1.1.5