html-syntax.lisp 29.3 KB
Newer Older
1
;;; -*- Mode: Lisp; Package: CLIMACS-HTML-SYNTAX -*-
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22

;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh@labri.fr)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; Syntax for analysing HTML

23
(in-package :climacs-html-syntax)
24

25
(define-syntax html-syntax (fundamental-syntax)
26 27
  ((lexer :reader lexer)
   (valid-parse :initform 1)
28 29 30
   (parser))
  (:name "HTML")
  (:pathname-types "html" "htm"))
31

32 33 34 35
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; grammar classes

36
(defclass html-parse-tree (parse-tree)
37
  ((badness :initform 0 :initarg :badness :reader badness)))
38

39
(defmethod parse-tree-better ((t1 html-parse-tree) (t2 html-parse-tree))
40 41 42
  (and (eq (class-of t1) (class-of t2))
       (< (badness t1) (badness t2))))

43
(defclass html-nonterminal (html-parse-tree) ())
44

45
(defclass html-token (html-parse-tree)
46 47 48 49
  ((ink) (face)))

(defclass html-tag (html-token) ())

50 51 52 53 54 55
(defclass html-start-tag (html-tag)
  ((start :initarg :start)
   (name :initarg :name)
   (attributes :initform nil :initarg :attributes)
   (end :initarg :end)))

56 57 58 59
(defgeneric display-parse-tree (parse-symbol pane drei syntax))

(defmethod display-parse-tree ((entity html-start-tag) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
60
  (with-slots (start name attributes end) entity
61 62
    (display-parse-tree start pane drei syntax)
    (display-parse-tree name pane drei syntax)
63
    (unless (null attributes)
64 65
      (display-parse-tree attributes pane drei syntax))
    (display-parse-tree end pane drei syntax)))
66 67 68 69 70 71

(defclass html-end-tag (html-tag)
  ((start :initarg :start)
   (name :initarg :name)
   (end :initarg :end)))

72 73
(defmethod display-parse-tree ((entity html-end-tag) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
74
  (with-slots (start name attributes end) entity
75 76 77
    (display-parse-tree start pane drei syntax)
    (display-parse-tree name pane drei syntax)
    (display-parse-tree end pane drei syntax)))
78

79 80 81 82
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer

83
(defclass html-lexeme (html-token)
84 85
  ((state :initarg :state)))

86
(defclass start-lexeme (html-lexeme) ())
87 88
(defclass start-tag-start (html-lexeme) ())
(defclass end-tag-start (html-lexeme) ())
89 90 91
(defclass tag-end (html-lexeme) ())
(defclass word (html-lexeme) ())
(defclass delimiter (html-lexeme) ())
92

Robert Strandh's avatar
Robert Strandh committed
93 94
(defclass html-lexer (incremental-lexer) ())     

95
(defmethod next-lexeme ((lexer html-lexer) scan)
96 97 98
  (flet ((fo () (forward-object scan)))
    (let ((object (object-after scan)))
      (case object
99 100 101 102 103
	(#\< (fo) (cond ((or (end-of-buffer-p scan)
			     (not (eql (object-after scan) #\/)))
			 (make-instance 'start-tag-start))
			(t (fo)
			   (make-instance 'end-tag-start))))
104 105 106 107 108 109 110 111
	(#\> (fo) (make-instance 'tag-end))
	(t (cond ((alphanumericp object)
		  (loop until (end-of-buffer-p scan)
			while (alphanumericp (object-after scan))
			do (fo))
		  (make-instance 'word))
		 (t
		  (fo) (make-instance 'delimiter))))))))
112

113 114 115 116
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser

117
(defparameter *html-grammar* (grammar))
118

119 120 121
(defmacro add-html-rule (rule &key predict-test)
  `(add-rule (grammar-rule ,rule :predict-test ,predict-test)
	     *html-grammar*))
122

123
(defun word-is (word string)
124
  (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
125
		string))
126

127 128
(defmacro define-start-tag (name string)
  `(progn
129
     (defclass ,name (html-start-tag) ())
130

131
     (add-html-rule
132 133
      (,name -> (start-tag-start
		 (word (and (= (end-offset start-tag-start) (start-offset word))
134
			    (word-is word ,string)))
135 136
		 (tag-end (= (end-offset word) (start-offset tag-end))))
	     :start start-tag-start :name word :end tag-end))))
137 138 139

(defmacro define-end-tag (name string)
  `(progn
140
     (defclass ,name (html-end-tag) ())
141

142
     (add-html-rule
143 144
      (,name -> (end-tag-start
		 (word (and (= (end-offset end-tag-start) (start-offset word))
145
			    (word-is word ,string)))
146 147 148 149
		 (tag-end (= (end-offset word) (start-offset tag-end))))
	     :start end-tag-start :name word :end tag-end)
      :predict-test (lambda (token)
		      (typep token 'end-tag-start)))))
150 151 152 153 154 155 156 157 158

(defmacro define-tag-pair (start-name end-name string)
  `(progn (define-start-tag ,start-name ,string)
	  (define-end-tag ,end-name ,string)))

(define-tag-pair <head> </head> "head")
(define-tag-pair <title> </title> "title")
(define-tag-pair <body> </body> "body")

159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
(defmacro define-list (name item-name)
  (let ((empty-name (gensym))
	(nonempty-name (gensym)))
    `(progn
       (defclass ,name (html-nonterminal) ())
       (defclass ,empty-name (,name) ())
       
       (defclass ,nonempty-name (,name)
	 ((items :initarg :items)
	  (item :initarg :item)))
       
       (add-html-rule (,name -> ()
			     (make-instance ',empty-name)))
       
       (add-html-rule (,name -> (,name ,item-name)
			     (make-instance ',nonempty-name
175 176
				:items ,name :item ,item-name)))
       
177 178
       (defmethod display-parse-tree ((entity ,empty-name) (pane clim-stream-pane)
                                      (drei drei) (syntax html-syntax))
179 180 181
	 (declare (ignore pane))
	 nil)
       
182 183
       (defmethod display-parse-tree ((entity ,nonempty-name) (pane clim-stream-pane)
                                      (drei drei) (syntax html-syntax))
184
	 (with-slots (items item) entity
185 186
	   (display-parse-tree items pane drei syntax)
	   (display-parse-tree item pane drei syntax))))))
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206

(defmacro define-nonempty-list (name item-name)
  (let ((empty-name (gensym))
	(nonempty-name (gensym)))
    `(progn
       (defclass ,name (html-nonterminal) ())
       (defclass ,empty-name (,name) ())
       
       (defclass ,nonempty-name (,name)
	 ((items :initarg :items)
	  (item :initarg :item)))
       
       (add-html-rule (,name -> (,item-name)
			     (make-instance ',nonempty-name
				:items (make-instance ',empty-name)
				:item ,item-name)))
       
       (add-html-rule (,name -> (,name ,item-name)
			     (make-instance ',nonempty-name
				:items ,name :item ,item-name)))
207
       
208 209
       (defmethod display-parse-tree ((entity ,empty-name) (pane clim-stream-pane)
                                      (drei drei) (syntax html-syntax))
210 211 212
	 (declare (ignore pane))
	 nil)
       
213 214
       (defmethod display-parse-tree ((entity ,nonempty-name) (pane clim-stream-pane)
                                      (drei drei) (syntax html-syntax))
215
	 (with-slots (items item) entity
216 217
	   (display-parse-tree items pane drei syntax)
	   (display-parse-tree item pane drei syntax))))))
218

219 220 221 222 223 224 225 226 227 228 229
;;;;;;;;;;;;;;; string

(defclass string-lexeme (html-lexeme) ())

(add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\""))))))

(defclass html-string (html-token)
  ((start :initarg :start)
   (lexemes :initarg :lexemes)
   (end :initarg :end)))

230
(define-list string-lexemes string-lexeme)
231 232 233 234 235 236

(add-html-rule (html-string -> ((start delimiter (word-is start "\""))
				string-lexemes
				(end delimiter (word-is end "\"")))
			    :start start :lexemes string-lexemes :end end))

237 238
(defmethod display-parse-tree ((entity html-string) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
239
  (with-slots (start lexemes end) entity
240
     (display-parse-tree start pane drei syntax)
241
     (with-text-face (pane :italic)
242 243
       (display-parse-tree lexemes pane drei syntax))
     (display-parse-tree end pane drei syntax)))
244

245 246 247 248 249 250
;;;;;;;;;;;;;;; attributes

(defclass html-attribute (html-nonterminal)
  ((name :initarg :name)
   (equals :initarg :equals)))

251 252
(defmethod display-parse-tree :before ((entity html-attribute) (pane clim-stream-pane)
                                       (drei drei) (syntax html-syntax))
253
  (with-slots (name equals) entity
254 255
     (display-parse-tree name pane drei syntax)
     (display-parse-tree equals pane drei syntax)))
256

257 258 259 260 261 262 263
(defclass common-attribute (html-attribute) ())

(defclass core-attribute (common-attribute) ())
(defclass i18n-attribute (common-attribute) ())
(defclass scripting-event (common-attribute) ())

(define-list common-attributes common-attribute)
264

265 266
;;;;;;;;;;;;;;; lang attribute

267
(defclass lang-attr (i18n-attribute)
268 269 270 271 272 273 274 275 276 277
  ((lang :initarg :lang)))

(add-html-rule (lang-attr -> ((name word (word-is name "lang"))
			      (equals delimiter (and (= (end-offset name) (start-offset equals))
						     (word-is equals "=")))
			      (lang word (and (= (end-offset equals) (start-offset lang))
					      (= (- (end-offset lang) (start-offset lang))
						 2))))
			  :name name :equals equals :lang lang))

278 279
(defmethod display-parse-tree ((entity lang-attr) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
280
  (with-slots (lang) entity
281
     (display-parse-tree lang pane drei syntax)))
282 283 284

;;;;;;;;;;;;;;; dir attribute

285
(defclass dir-attr (i18n-attribute)
286 287 288 289 290 291 292 293 294 295
  ((dir :initarg :dir)))

(add-html-rule (dir-attr -> ((name word (word-is name "dir"))
			     (equals delimiter (and (= (end-offset name) (start-offset equals))
						    (word-is equals "=")))
			     (dir word (and (= (end-offset equals) (start-offset dir))
					    (or (word-is dir "rtl")
						(word-is dir "ltr")))))
			 :name name :equals equals :dir dir))

296 297
(defmethod display-parse-tree ((entity dir-attr) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
298
  (with-slots (dir) entity
299
     (display-parse-tree dir pane drei syntax)))
300 301


302 303 304 305 306 307 308 309 310 311 312
;;;;;;;;;;;;;;; href attribute

(defclass href-attr (html-attribute)
  ((href :initarg :href)))

(add-html-rule (href-attr -> ((name word (word-is name "href"))
			      (equals delimiter (and (= (end-offset name) (start-offset equals))
						     (word-is equals "=")))
			      (href html-string))
			  :name name :equals equals :href href))

313 314
(defmethod display-parse-tree ((entity href-attr) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
315
  (with-slots (href) entity
316
     (display-parse-tree href pane drei syntax)))
317 318


319
;;;;;;;;;;;;;;; title
320

321 322 323
(defclass title-item (html-nonterminal)
  ((item :initarg :item)))

324 325
(add-html-rule (title-item -> (word) :item word))
(add-html-rule (title-item -> (delimiter) :item delimiter))
326

327 328
(defmethod display-parse-tree ((entity title-item) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
329
  (with-slots (item) entity
330
     (display-parse-tree item pane drei syntax)))
331

332
(define-list title-items title-item)
333 334 335 336 337 338

(defclass title (html-nonterminal)
  ((<title> :initarg :<title>)
   (items :initarg :items)
   (</title> :initarg :</title>)))

339 340
(add-html-rule (title -> (<title> title-items </title>)
		      :<title> <title> :items title-items :</title> </title>))
341

342 343
(defmethod display-parse-tree ((entity title) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
344
  (with-slots (<title> items </title>) entity
345
     (display-parse-tree <title> pane drei syntax)
346
     (with-text-face (pane :bold)
347 348
       (display-parse-tree items pane drei syntax))
     (display-parse-tree </title> pane drei syntax)))
349

350 351 352 353 354
;;;;;;;;;;;;;;; inline-element, block-level-element

(defclass inline-element (html-nonterminal) ())
(defclass block-level-element (html-nonterminal) ())

355 356 357 358 359
;;;;;;;;;;;;;;; %inline

(defclass $inline (html-nonterminal)
  ((contents :initarg :contents)))
     
360 361 362
(add-html-rule ($inline -> (inline-element) :contents inline-element)
	       :predict-test (lambda (token)
			       (typep token 'start-tag-start)))
363 364 365
(add-html-rule ($inline -> (word) :contents word))
(add-html-rule ($inline -> (delimiter) :contents delimiter))

366 367
(defmethod display-parse-tree ((entity $inline) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
368
  (with-slots (contents) entity
369
     (display-parse-tree contents pane drei syntax)))
370 371 372 373

(define-list $inlines $inline)

;;;;;;;;;;;;;;; %flow
374

375
(defclass $flow (html-nonterminal)
Robert Strandh's avatar
Robert Strandh committed
376
  ((contents :initarg :contents)))
377
     
378
(add-html-rule ($flow -> ($inline) :contents $inline))
379 380 381
(add-html-rule ($flow -> (block-level-element) :contents block-level-element)
	       :predict-test (lambda (token)
			       (typep token 'start-tag-start)))
382

383 384
(defmethod display-parse-tree ((entity $flow) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
385
  (with-slots (contents) entity
386
     (display-parse-tree contents pane drei syntax)))
387

388
(define-list $flows $flow)
Robert Strandh's avatar
Robert Strandh committed
389 390 391 392 393 394 395 396

;;;;;;;;;;;;;;; headings

(defclass heading (block-level-element)
  ((start :initarg :start)
   (contents :initarg :contents)
   (end :initarg :end)))

397 398
(defmethod display-parse-tree ((entity heading) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
Robert Strandh's avatar
Robert Strandh committed
399
  (with-slots (start contents end) entity
400
     (display-parse-tree start pane drei syntax)
401
     (with-text-face (pane :bold)
402 403
       (display-parse-tree contents pane drei syntax))
     (display-parse-tree end pane drei syntax)))
Robert Strandh's avatar
Robert Strandh committed
404 405 406 407 408 409 410 411
	      
(defmacro define-heading (class-name tag-string start-tag-name end-tag-name)
  `(progn
     (define-tag-pair ,start-tag-name ,end-tag-name ,tag-string)

     (defclass ,class-name (heading) ())

     (add-html-rule
412 413
      (,class-name -> (,start-tag-name $inlines ,end-tag-name)
		   :start ,start-tag-name :contents $inlines :end ,end-tag-name))))
Robert Strandh's avatar
Robert Strandh committed
414 415 416 417 418 419 420 421 422


(define-heading h1 "h1" <h1> </h1>)
(define-heading h2 "h2" <h2> </h2>)
(define-heading h3 "h3" <h3> </h3>)
(define-heading h4 "h4" <h4> </h4>)
(define-heading h5 "h5" <h5> </h5>)
(define-heading h6 "h6" <h6> </h6>)

423
;;;;;;;;;;;;;;; a element
424

425 426
(defclass <a>-attribute (html-nonterminal)
  ((attribute :initarg :attribute)))
427

428
(add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
429

430 431
(defmethod display-parse-tree ((entity <a>-attribute) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
432
  (with-slots (attribute) entity
433
     (display-parse-tree attribute pane drei syntax)))
434

435
(define-list <a>-attributes <a>-attribute)
436

437
(defclass <a> (html-start-tag) ())
438

439 440
(add-html-rule (<a> -> (start-tag-start
			(word (and (= (end-offset start-tag-start) (start-offset word))
441 442 443
				   (word-is word "a")))
			<a>-attributes
			tag-end)
444
		    :start start-tag-start :name word :attributes <a>-attributes :end tag-end))
445 446 447

(define-end-tag </a> "a")

448
(defclass a-element (inline-element)
449 450 451 452
  ((<a> :initarg :<a>)
   (items :initarg :items)
   (</a> :initarg :</a>)))

453 454
(add-html-rule (a-element -> (<a> $inlines </a>)
			  :<a> <a> :items $inlines :</a> </a>))
455

456 457
(defmethod display-parse-tree ((entity a-element) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
458
  (with-slots (<a> items </a>) entity
459
     (display-parse-tree <a> pane drei syntax)
460
     (with-text-face (pane :bold)
461 462
       (display-parse-tree items pane drei syntax))
     (display-parse-tree </a> pane drei syntax)))
463

464 465 466 467 468 469 470 471 472
;;;;;;;;;;;;;;; br element

(defclass br-element (inline-element)
  ((<br> :initarg :<br>)))
     
(define-start-tag <br> "br")

(add-html-rule (br-element -> (<br>) :<br> <br>))

473 474
(defmethod display-parse-tree ((entity br-element) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
475
  (with-slots (<br>) entity
476
     (display-parse-tree <br> pane drei syntax)))
477

478 479
;;;;;;;;;;;;;;; p element

480
(defclass <p> (html-start-tag) ())
481

482 483
(add-html-rule (<p> -> (start-tag-start
			(word (and (= (end-offset start-tag-start) (start-offset word))
484 485 486
				   (word-is word "p")))
			common-attributes
			tag-end)
487
		    :start start-tag-start :name word :attributes common-attributes :end tag-end))
488 489 490 491 492 493 494 495

(define-end-tag </p> "p")

(defclass p-element (block-level-element)
  ((<p> :initarg :<p>)
   (contents :initarg :contents)
   (</p> :initarg :</p>)))

496 497
(add-html-rule (p-element -> (<p> $inlines </p>)
			  :<p> <p> :contents $inlines :</p> </p>))
498

499 500
(defmethod display-parse-tree ((entity p-element) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
501
  (with-slots (<p> contents </p>) entity
502 503 504
    (display-parse-tree <p> pane drei syntax)
    (display-parse-tree contents pane drei syntax)
    (display-parse-tree </p> pane drei syntax)))
505

506 507
;;;;;;;;;;;;;;; li element

508
(defclass <li> (html-start-tag) ())
509

510 511
(add-html-rule (<li> -> (start-tag-start
			 (word (and (= (end-offset start-tag-start) (start-offset word))
512 513 514
				    (word-is word "li")))
			 common-attributes
			 tag-end)
515
		     :start start-tag-start
516 517 518 519 520 521 522 523 524 525 526
		     :name word
		     :attributes common-attributes
		     :end tag-end))

(define-end-tag </li> "li")

(defclass li-element (html-nonterminal)
  ((<li> :initarg :<li>)
   (items :initarg :items)
   (</li> :initarg :</li>)))

527 528 529 530
(add-html-rule (li-element -> (<li> $flows </li>)
			   :<li> <li> :items $flows :</li> </li>))
(add-html-rule (li-element -> (<li> $flows)
			   :<li> <li> :items $flows :</li> nil))
531

532 533
(defmethod display-parse-tree ((entity li-element) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
534
  (with-slots (<li> items </li>) entity
535 536
     (display-parse-tree <li> pane drei syntax)
     (display-parse-tree items pane drei syntax)     
537
     (when </li>
538
       (display-parse-tree </li> pane drei syntax))))
539 540 541

;;;;;;;;;;;;;;; ul element

542
(defclass <ul> (html-start-tag) ())
543

544 545
(add-html-rule (<ul> -> (start-tag-start
			 (word (and (= (end-offset start-tag-start) (start-offset word))
546 547 548
				    (word-is word "ul")))
			 common-attributes
			 tag-end)
549
		     :start start-tag-start
550 551 552 553 554 555
		     :name word
		     :attributes common-attributes
		     :end tag-end))

(define-end-tag </ul> "ul")

556
(define-nonempty-list li-elements li-element)
557 558 559 560 561 562 563 564 565

(defclass ul-element (block-level-element)
  ((<ul> :initarg :<ul>)
   (items :initarg :items)
   (</ul> :initarg :</ul>)))

(add-html-rule (ul-element -> (<ul> li-elements </ul>)
			   :<ul> <ul> :items li-elements :</ul> </ul>))

566 567
(defmethod display-parse-tree ((entity ul-element) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
568
  (with-slots (<ul> items </ul>) entity
569 570 571
     (display-parse-tree <ul> pane drei syntax)
     (display-parse-tree items pane drei syntax)     
     (display-parse-tree </ul> pane drei syntax)))
572

573 574 575 576 577 578 579 580 581
;;;;;;;;;;;;;;; hr element

(defclass hr-element (block-level-element)
  ((<hr> :initarg :<hr>)))

(define-start-tag <hr> "hr")

(add-html-rule (hr-element -> (<hr>) :<hr> <hr>))

582 583
(defmethod display-parse-tree ((entity hr-element) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
584
  (with-slots (<hr>) entity
585
     (display-parse-tree <hr> pane drei syntax)))
586

587
;;;;;;;;;;;;;;; body element
Robert Strandh's avatar
Robert Strandh committed
588 589 590 591 592 593

(defclass body-item (html-nonterminal)
  ((item :initarg :item)))

(add-html-rule (body-item -> ((element block-level-element)) :item element))

594 595
(defmethod display-parse-tree ((entity body-item) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
Robert Strandh's avatar
Robert Strandh committed
596
  (with-slots (item) entity
597
     (display-parse-tree item pane drei syntax)))
Robert Strandh's avatar
Robert Strandh committed
598

599
(define-list body-items body-item)
Robert Strandh's avatar
Robert Strandh committed
600 601 602 603 604 605 606 607 608

(defclass body (html-nonterminal)
  ((<body> :initarg :<body>)
   (items :initarg :items)
   (</body> :initarg :</body>)))

(add-html-rule (body -> (<body> body-items </body>)
		     :<body> <body> :items body-items :</body> </body>))

609 610
(defmethod display-parse-tree ((entity body) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
Robert Strandh's avatar
Robert Strandh committed
611
  (with-slots (<body> items </body>) entity
612 613 614
     (display-parse-tree <body> pane drei syntax)
     (display-parse-tree items pane drei syntax)     
     (display-parse-tree </body> pane drei syntax)))
Robert Strandh's avatar
Robert Strandh committed
615

616 617 618 619 620 621 622
;;;;;;;;;;;;;;; head

(defclass head (html-nonterminal)
  ((<head> :initarg :<head>)
   (title :initarg :title)
   (</head> :initarg :</head>)))

623 624
(add-html-rule (head -> (<head> title </head>)
		     :<head> <head> :title title :</head> </head>))
625

626 627
(defmethod display-parse-tree ((entity head) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
628
  (with-slots (<head> title </head>) entity
629 630 631
     (display-parse-tree <head> pane drei syntax)
     (display-parse-tree title pane drei syntax)     
     (display-parse-tree </head> pane drei syntax)))
632 633 634

;;;;;;;;;;;;;;; html

635 636 637
(defclass <html>-attribute (html-nonterminal)
  ((attribute :initarg :attribute)))

638 639
(defmethod display-parse-tree ((entity <html>-attribute) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
640
  (with-slots (attribute) entity
641
     (display-parse-tree attribute pane drei syntax)))
642 643 644 645 646 647

(add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
(add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))

(define-list <html>-attributes <html>-attribute)

648
(defclass <html> (html-start-tag) ())
649

650 651
(add-html-rule (<html> -> (start-tag-start
			   (word (and (= (end-offset start-tag-start) (start-offset word))
652 653 654
				      (word-is word "html")))
			   <html>-attributes
			   tag-end)
655
		       :start start-tag-start :name word :attributes <html>-attributes :end tag-end))
656 657 658

(define-end-tag </html> "html")

659 660 661 662 663 664
(defclass html (html-nonterminal)
  ((<html> :initarg :<html>)
   (head :initarg :head)
   (body :initarg :body)
   (</html> :initarg :</html>)))

665 666
(add-html-rule (html -> (<html> head body </html>)
		     :<html> <html> :head head :body body :</html> </html>))
667

668 669
(defmethod display-parse-tree ((entity html) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
670
  (with-slots (<html> head body </html>) entity
671 672 673 674
     (display-parse-tree <html> pane drei syntax)
     (display-parse-tree head pane drei syntax)
     (display-parse-tree body pane drei syntax)
     (display-parse-tree </html> pane drei syntax)))
675 676 677

;;;;;;;;;;;;;;;

678 679
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
  (declare (ignore args))
680
  (with-slots (parser lexer buffer) syntax
681 682 683
     (setf parser (make-instance 'parser
		     :grammar *html-grammar*
		     :target 'html))
684
     (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
685 686
     (let ((m (clone-mark (low-mark buffer) :left))
	   (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
687
       (setf (offset m) 0)
688 689 690
       (setf (start-offset lexeme) m
	     (end-offset lexeme) 0)
       (insert-lexeme lexer 0 lexeme))))
691

692 693 694 695
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; update syntax

696

697
(defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
698 699 700 701 702
  (with-slots (parser lexer valid-parse) syntax
     (loop until (= valid-parse (nb-lexemes lexer))
	   while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
	   do (let ((current-token (lexeme lexer (1- valid-parse)))
		    (next-lexeme (lexeme lexer valid-parse)))
703 704
		(setf (slot-value next-lexeme 'state)
		      (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
705
	      (incf valid-parse))))
706

707
(defmethod inter-lexeme-object-p ((lexer html-lexer) object)
708
  (whitespacep (syntax (buffer lexer)) object))
709

710
(defmethod update-syntax (buffer (syntax html-syntax))
711
  (with-slots (lexer valid-parse) syntax
712
     (let* ((low-mark (low-mark buffer))
713 714 715 716 717
	    (high-mark (high-mark buffer)))
       (when (mark<= low-mark high-mark)
	 (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
	   (setf valid-parse first-invalid-position)
	   (update-lex lexer first-invalid-position high-mark))))))
718

719 720 721 722
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; display

723 724 725 726 727
(defvar *white-space-start* nil)

(defvar *cursor-positions* nil)
(defvar *current-line* 0)

728 729
(defun handle-whitespace (pane buffer start end)
  (let ((space-width (space-width pane))
730 731 732 733 734 735 736 737 738 739 740 741 742 743 744
        (tab-width (tab-width pane)))
    (with-sheet-medium (medium pane)
      (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
        (loop while (< start end)
           do (case (buffer-object buffer start)
                (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
                           (terpri pane)
                           (stream-increment-cursor-position
                            pane (first (aref cursor-positions 0)) 0))
                ((#\Page #\Return #\Space) (stream-increment-cursor-position
                                            pane space-width 0))
                (#\Tab (let ((x (stream-cursor-position pane)))
                         (stream-increment-cursor-position
                          pane (- tab-width (mod x tab-width)) 0))))
           (incf start))))))		    
745

746 747 748
(defmethod display-parse-tree :around ((entity html-parse-tree) (pane clim-stream-pane)
                                       (drei drei) (syntax html-syntax))
  (with-slots (top bot) drei
749
     (when (and (end-offset entity) (mark> (end-offset entity) top))
750 751
       (call-next-method))))

752 753
(defmethod display-parse-tree ((entity html-lexeme) (pane clim-stream-pane)
                               (drei drei) (syntax html-syntax))
754
  (flet ((cache-test (t1 t2)
755 756 757 758 759 760
	   (let ((result (and (eq t1 t2)
			      (eq (slot-value t1 'ink)
				  (medium-ink (sheet-medium pane)))
			      (eq (slot-value t1 'face)
				  (text-style-face (medium-text-style (sheet-medium pane)))))))
	     result)))
761 762 763 764 765 766 767
    (updating-output (pane :unique-id entity
			   :id-test #'eq
			   :cache-value entity
			   :cache-test #'cache-test)
      (with-slots (ink face) entity
	 (setf ink (medium-ink (sheet-medium pane))
	       face (text-style-face (medium-text-style (sheet-medium pane))))
768 769 770
	 (present (coerce (buffer-sequence (buffer syntax)
					   (start-offset entity)
					   (end-offset entity))
771 772 773 774
			  'string)
		  'string
		  :stream pane)))))

775 776
(defmethod display-parse-tree :around ((entity html-tag) (pane clim-stream-pane)
                                       (drei drei) (syntax html-syntax))
777
  (with-drawing-options (pane :ink +green4+)
778 779
    (call-next-method)))

780 781 782
(defmethod display-parse-tree :before ((entity html-lexeme) (pane clim-stream-pane)
                                       (drei drei) (syntax html-syntax))
  (handle-whitespace pane (buffer drei) *white-space-start* (start-offset entity))
783
  (setf *white-space-start* (end-offset entity)))
784

785
(defgeneric display-parse-stack (symbol stack pane drei syntax))
786

787 788
(defmethod display-parse-stack (symbol stack (pane clim-stream-pane)
                                (drei drei) (syntax html-syntax))
789 790
  (let ((next (parse-stack-next stack)))
    (unless (null next)
791
      (display-parse-stack (parse-stack-symbol next) next pane drei syntax))
792
    (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
793
	  do (display-parse-tree parse-tree pane drei syntax))))  
794

795
(defun display-parse-state (state pane drei syntax)
796 797
  (let ((top (parse-stack-top state)))
    (if (not (null top))
798 799
	(display-parse-stack (parse-stack-symbol top) top pane drei syntax)
	(display-parse-tree (target-parse-tree state) pane drei syntax))))
800

801
(defmethod display-drei-contents ((pane clim-stream-pane) (drei drei) (syntax html-syntax))
802
  (with-slots (top bot) drei
803 804 805 806 807 808 809 810
    (with-accessors ((cursor-positions cursor-positions)) syntax
      (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
                                         :initial-element nil)
            *current-line* 0
            (aref cursor-positions 0) (multiple-value-list
                                       (stream-cursor-position pane))))
    (setf *white-space-start* (offset top))
    (with-slots (lexer) syntax
811
      (let ((average-token-size (max (float (/ (size (buffer drei)) (nb-lexemes lexer)))
812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831
                                     1.0)))
        ;; find the last token before bot
        (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
          ;; go back to a token before bot
          (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
             do (decf end-token-index))
          ;; go forward to the last token before bot
          (loop until (or (= end-token-index (nb-lexemes lexer))
                          (mark> (start-offset (lexeme lexer end-token-index)) bot))
             do (incf end-token-index))
          (let ((start-token-index end-token-index))
            ;; go back to the first token after top, or until the previous token
            ;; contains a valid parser state
            (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
                            (not (parse-state-empty-p 
                                  (slot-value (lexeme lexer (1- start-token-index)) 'state))))
               do (decf start-token-index))
            ;; display the parse tree if any
            (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
              (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
832
                                   pane drei syntax))
833 834 835 836
            ;; display the lexemes
            (with-drawing-options (pane :ink +red+)
              (loop while (< start-token-index end-token-index)
                 do (let ((token (lexeme lexer start-token-index)))
837
                      (display-parse-tree token pane drei syntax))
838
                 (incf start-token-index)))))))))