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

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations)
Thu Apr 7 05:02:33 2005 UTC (9 years ago) by rstrandh
Branch: MAIN
Changes since 1.22: +25 -3 lines
Introduced the concept of inline element and block-level element.

Reorganized the attributes into core attributes, i18n attributes and
scripting events according to the HTML standard.
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 rstrandh 1.23 (defclass core-attribute (html-attribute) ())
189     (defclass i18n-attribute (html-attribute) ())
190     (defclass scripting-event (html-attribute) ())
191    
192 rstrandh 1.21 ;;;;;;;;;;;;;;; lang attribute
193    
194 rstrandh 1.23 (defclass lang-attr (i18n-attribute)
195 rstrandh 1.21 ((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 rstrandh 1.23 (defclass dir-attr (i18n-attribute)
212 rstrandh 1.21 ((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 rstrandh 1.22 ;;;;;;;;;;;;;;; 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 rstrandh 1.21 ;;;;;;;;;;;;;;; <html>-tag
244    
245     (defclass <html>-attribute (html-nonterminal)
246     ((attribute :initarg :attribute)))
247    
248     (defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
249     (with-slots (attribute) entity
250     (display-parse-tree attribute syntax pane)))
251    
252     (add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
253     (add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))
254    
255     (define-list <html>-attributes empty-<html>-attribute nonempty-<html>-attribute <html>-attribute)
256    
257     (defclass <html> (html-tag)
258     ((start :initarg :start)
259     (name :initarg :name)
260     (attributes :initarg :attributes)
261     (end :initarg :end)))
262    
263     (add-html-rule (<html> -> (tag-start
264     (word (and (= (end-offset tag-start) (start-offset word))
265     (word-is word "html")))
266     <html>-attributes
267     tag-end)
268     :start tag-start :name word :attributes <html>-attributes :end tag-end))
269    
270     (defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane)
271     (with-slots (start name attributes end) entity
272     (display-parse-tree start syntax pane)
273     (display-parse-tree name syntax pane)
274     (display-parse-tree attributes syntax pane)
275     (display-parse-tree end syntax pane)))
276    
277     (define-end-tag </html> "html")
278    
279 rstrandh 1.17 ;;;;;;;;;;;;;;; title-item, title-items
280    
281 rstrandh 1.16 (defclass title-item (html-nonterminal)
282     ((item :initarg :item)))
283    
284 rstrandh 1.21 (add-html-rule (title-item -> (word) :item word))
285     (add-html-rule (title-item -> (delimiter) :item delimiter))
286 rstrandh 1.16
287     (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
288     (with-slots (item) entity
289     (display-parse-tree item syntax pane)))
290    
291 rstrandh 1.17 (define-list title-items empty-title-items nonempty-title-items title-item)
292 rstrandh 1.16
293     ;;;;;;;;;;;;;;; title
294    
295     (defclass title (html-nonterminal)
296     ((<title> :initarg :<title>)
297     (items :initarg :items)
298     (</title> :initarg :</title>)))
299    
300 rstrandh 1.21 (add-html-rule (title -> (<title> title-items </title>)
301     :<title> <title> :items title-items :</title> </title>))
302 rstrandh 1.16
303     (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
304     (with-slots (<title> items </title>) entity
305     (display-parse-tree <title> syntax pane)
306     (with-text-face (pane :bold)
307     (display-parse-tree items syntax pane))
308     (display-parse-tree </title> syntax pane)))
309    
310 rstrandh 1.17 ;;;;;;;;;;;;;;; body-item body-items
311 rstrandh 1.16
312     (defclass body-item (html-nonterminal)
313     ((item :initarg :item)))
314    
315 rstrandh 1.21 (add-html-rule (body-item -> (word) :item word))
316     (add-html-rule (body-item -> (delimiter) :item delimiter))
317     (add-html-rule (body-item -> (a) :item a))
318 rstrandh 1.16
319     (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
320     (with-slots (item) entity
321     (display-parse-tree item syntax pane)))
322    
323 rstrandh 1.17 (define-list body-items empty-body-items nonempty-body-items body-item)
324 rstrandh 1.16
325     ;;;;;;;;;;;;;;; body
326    
327     (defclass body (html-nonterminal)
328     ((<body> :initarg :<body>)
329     (items :initarg :items)
330     (</body> :initarg :</body>)))
331    
332 rstrandh 1.21 (add-html-rule (body -> (<body> body-items </body>)
333     :<body> <body> :items body-items :</body> </body>))
334 rstrandh 1.16
335     (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
336     (with-slots (<body> items </body>) entity
337     (display-parse-tree <body> syntax pane)
338     (display-parse-tree items syntax pane)
339     (display-parse-tree </body> syntax pane)))
340    
341 rstrandh 1.23 ;;;;;;;;;;;;;;; inline-element, block-level-element
342    
343     (defclass inline-element (html-nonterminal) ())
344     (defclass block-level-element (html-nonterminal) ())
345    
346     ;;;;;;;;;;;;;;; inline-element-or-text
347    
348     (defclass inline-element-or-text (html-nonterminal)
349     ((contents :initarg contents)))
350    
351     (add-html-rule (inline-element-or-text -> (inline-element) :contents inline-element))
352     (add-html-rule (inline-element-or-text -> (word) :contents word))
353     (add-html-rule (inline-element-or-text -> (delimiter) :contents delimiter))
354    
355     (defmethod display-parse-tree ((entity inline-element-or-text) (syntax html-syntax) pane)
356     (with-slots (contents) entity
357     (display-parse-tree contents syntax pane)))
358    
359 rstrandh 1.18 ;;;;;;;;;;;;;;; <a>-tag
360    
361 rstrandh 1.22 (defclass <a>-attribute (html-nonterminal)
362     ((attribute :initarg :attribute)))
363 rstrandh 1.18
364 rstrandh 1.22 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
365 rstrandh 1.18
366 rstrandh 1.22 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
367     (with-slots (attribute) entity
368     (display-parse-tree attribute syntax pane)))
369 rstrandh 1.18
370 rstrandh 1.22 (define-list <a>-attributes empty-<a>-attributes nonempty-<a>-attributes <a>-attribute)
371 rstrandh 1.18
372     (defclass <a> (html-tag)
373     ((start :initarg :start)
374     (name :initarg :name)
375 rstrandh 1.22 (attributes :initarg :attributes)
376 rstrandh 1.18 (end :initarg :end)))
377    
378 rstrandh 1.21 (add-html-rule (<a> -> (tag-start
379 rstrandh 1.22 (word (and (= (end-offset tag-start) (start-offset word))
380     (word-is word "a")))
381     <a>-attributes
382     tag-end)
383     :start tag-start :name word :attributes <a>-attributes :end tag-end))
384 rstrandh 1.18
385     (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane)
386 rstrandh 1.22 (with-slots (start name attributes end) entity
387 rstrandh 1.18 (display-parse-tree start syntax pane)
388     (display-parse-tree name syntax pane)
389 rstrandh 1.22 (display-parse-tree attributes syntax pane)
390 rstrandh 1.18 (display-parse-tree end syntax pane)))
391    
392     (define-end-tag </a> "a")
393    
394 rstrandh 1.23 (defclass a (inline-element)
395 rstrandh 1.18 ((<a> :initarg :<a>)
396     (items :initarg :items)
397     (</a> :initarg :</a>)))
398    
399 rstrandh 1.21 (add-html-rule (a -> (<a> body-items </a>)
400     :<a> <a> :items body-items :</a> </a>))
401 rstrandh 1.18
402     (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane)
403     (with-slots (<a> items </a>) entity
404     (display-parse-tree <a> syntax pane)
405 rstrandh 1.22 (with-text-face (pane :bold)
406     (display-parse-tree items syntax pane))
407 rstrandh 1.18 (display-parse-tree </a> syntax pane)))
408    
409     ;;;;;;;;;;;;;;; head
410    
411     (defclass head (html-nonterminal)
412     ((<head> :initarg :<head>)
413     (title :initarg :title)
414     (</head> :initarg :</head>)))
415    
416 rstrandh 1.21 (add-html-rule (head -> (<head> title </head>)
417     :<head> <head> :title title :</head> </head>))
418 rstrandh 1.20
419 rstrandh 1.18 (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
420     (with-slots (<head> title </head>) entity
421     (display-parse-tree <head> syntax pane)
422     (display-parse-tree title syntax pane)
423     (display-parse-tree </head> syntax pane)))
424    
425     ;;;;;;;;;;;;;;; html
426    
427     (defclass html (html-nonterminal)
428     ((<html> :initarg :<html>)
429     (head :initarg :head)
430     (body :initarg :body)
431     (</html> :initarg :</html>)))
432 rstrandh 1.20
433 rstrandh 1.21 (add-html-rule (html -> (<html> head body </html>)
434     :<html> <html> :head head :body body :</html> </html>))
435 rstrandh 1.18
436     (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
437     (with-slots (<html> head body </html>) entity
438     (display-parse-tree <html> syntax pane)
439     (display-parse-tree head syntax pane)
440     (display-parse-tree body syntax pane)
441     (display-parse-tree </html> syntax pane)))
442    
443     ;;;;;;;;;;;;;;;
444    
445 rstrandh 1.1 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
446     (declare (ignore args))
447 rstrandh 1.13 (with-slots (parser lexer buffer) syntax
448 rstrandh 1.1 (setf parser (make-instance 'parser
449     :grammar *html-grammar*
450     :target 'html))
451 rstrandh 1.13 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
452 rstrandh 1.19 (let ((m (clone-mark (low-mark buffer) :left))
453     (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
454 abakic 1.12 (setf (offset m) 0)
455 rstrandh 1.19 (setf (start-offset lexeme) m
456     (end-offset lexeme) 0)
457     (insert-lexeme lexer 0 lexeme))))
458 rstrandh 1.4
459 rstrandh 1.6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
460     ;;;
461     ;;; update syntax
462    
463 rstrandh 1.13
464 rstrandh 1.4 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
465 rstrandh 1.13 (with-slots (parser lexer valid-parse) syntax
466     (loop until (= valid-parse (nb-lexemes lexer))
467     while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
468     do (let ((current-token (lexeme lexer (1- valid-parse)))
469     (next-lexeme (lexeme lexer valid-parse)))
470 rstrandh 1.11 (setf (slot-value next-lexeme 'state)
471     (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
472 rstrandh 1.4 (incf valid-parse))))
473 rstrandh 1.1
474 rstrandh 1.13 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
475 rstrandh 1.11 (whitespacep object))
476    
477 rstrandh 1.1 (defmethod update-syntax (buffer (syntax html-syntax))
478 rstrandh 1.13 (with-slots (lexer valid-parse) syntax
479 rstrandh 1.11 (let* ((low-mark (low-mark buffer))
480 rstrandh 1.17 (high-mark (high-mark buffer)))
481     (when (mark<= low-mark high-mark)
482     (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
483     (setf valid-parse first-invalid-position)
484     (update-lex lexer first-invalid-position high-mark))))))
485 rstrandh 1.6
486     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
487     ;;;
488     ;;; display
489    
490 rstrandh 1.9 (defvar *white-space-start* nil)
491    
492     (defvar *cursor-positions* nil)
493     (defvar *current-line* 0)
494    
495 rstrandh 1.7 (defun handle-whitespace (pane buffer start end)
496     (let ((space-width (space-width pane))
497     (tab-width (tab-width pane)))
498     (loop while (< start end)
499     do (ecase (buffer-object buffer start)
500 rstrandh 1.9 (#\Newline (terpri pane)
501     (setf (aref *cursor-positions* (incf *current-line*))
502     (multiple-value-bind (x y) (stream-cursor-position pane)
503 rstrandh 1.10 (declare (ignore x))
504 rstrandh 1.9 y)))
505 rstrandh 1.7 (#\Space (stream-increment-cursor-position
506     pane space-width 0))
507     (#\Tab (let ((x (stream-cursor-position pane)))
508     (stream-increment-cursor-position
509     pane (- tab-width (mod x tab-width)) 0))))
510     (incf start))))
511 rstrandh 1.6
512 rstrandh 1.17 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
513 rstrandh 1.8 (with-slots (top bot) pane
514 rstrandh 1.17 (when (and (end-offset entity) (mark> (end-offset entity) top))
515 rstrandh 1.8 (call-next-method))))
516    
517     (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
518 rstrandh 1.9 (flet ((cache-test (t1 t2)
519     (and (eq t1 t2)
520     (eq (slot-value t1 'ink)
521     (medium-ink (sheet-medium pane)))
522     (eq (slot-value t1 'face)
523     (text-style-face (medium-text-style (sheet-medium pane)))))))
524     (updating-output (pane :unique-id entity
525     :id-test #'eq
526     :cache-value entity
527     :cache-test #'cache-test)
528     (with-slots (ink face) entity
529     (setf ink (medium-ink (sheet-medium pane))
530     face (text-style-face (medium-text-style (sheet-medium pane))))
531 rstrandh 1.19 (present (coerce (buffer-sequence (buffer syntax)
532     (start-offset entity)
533     (end-offset entity))
534 rstrandh 1.9 'string)
535     'string
536     :stream pane)))))
537    
538     (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
539     (with-drawing-options (pane :ink +green+)
540     (call-next-method)))
541    
542     (defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
543     (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
544     (setf *white-space-start* (end-offset entity)))
545 rstrandh 1.10
546 rstrandh 1.8 (defgeneric display-parse-stack (symbol stack syntax pane))
547    
548     (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
549     (let ((next (parse-stack-next stack)))
550     (unless (null next)
551     (display-parse-stack (parse-stack-symbol next) next syntax pane))
552     (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
553     do (display-parse-tree parse-tree syntax pane))))
554    
555     (defun display-parse-state (state syntax pane)
556     (let ((top (parse-stack-top state)))
557     (if (not (null top))
558     (display-parse-stack (parse-stack-symbol top) top syntax pane)
559     (display-parse-tree (target-parse-tree state) syntax pane))))
560    
561 rstrandh 1.7 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
562     (with-slots (top bot) pane
563 rstrandh 1.9 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
564     *current-line* 0
565     (aref *cursor-positions* 0) (stream-cursor-position pane))
566 rstrandh 1.13 (with-slots (lexer) syntax
567     (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
568 rstrandh 1.7 1.0)))
569     ;; find the last token before bot
570     (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
571     ;; go back to a token before bot
572 rstrandh 1.13 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
573 rstrandh 1.7 do (decf end-token-index))
574 rstrandh 1.8 ;; go forward to the last token before bot
575 rstrandh 1.13 (loop until (or (= end-token-index (nb-lexemes lexer))
576     (mark> (start-offset (lexeme lexer end-token-index)) bot))
577 rstrandh 1.7 do (incf end-token-index))
578     (let ((start-token-index end-token-index))
579 rstrandh 1.8 ;; go back to the first token after top, or until the previous token
580     ;; contains a valid parser state
581 rstrandh 1.13 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
582 rstrandh 1.9 (not (parse-state-empty-p
583 rstrandh 1.13 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
584 rstrandh 1.7 do (decf start-token-index))
585 rstrandh 1.9 (let ((*white-space-start* (offset top)))
586     ;; display the parse tree if any
587 rstrandh 1.13 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
588     (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
589 rstrandh 1.9 syntax
590     pane))
591 rstrandh 1.11 ;; display the lexemes
592 rstrandh 1.9 (with-drawing-options (pane :ink +red+)
593     (loop while (< start-token-index end-token-index)
594 rstrandh 1.13 do (let ((token (lexeme lexer start-token-index)))
595 rstrandh 1.9 (display-parse-tree token syntax pane))
596     (incf start-token-index))))))))
597     (let* ((cursor-line (number-of-lines-in-region top (point pane)))
598     (height (text-style-height (medium-text-style pane) pane))
599     (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
600     (cursor-column (column-number (point pane)))
601     (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
602     (updating-output (pane :unique-id -1)
603     (draw-rectangle* pane
604     (1- cursor-x) (- cursor-y (* 0.2 height))
605     (+ cursor-x 2) (+ cursor-y (* 0.8 height))
606     :ink (if current-p +red+ +blue+))))))
607 rstrandh 1.7

  ViewVC Help
Powered by ViewVC 1.1.5