html-syntax.lisp 26.1 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 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
(defclass html-start-tag (html-tag)
  ((start :initarg :start)
   (name :initarg :name)
   (attributes :initform nil :initarg :attributes)
   (end :initarg :end)))

(defmethod display-parse-tree ((entity html-start-tag) (syntax html-syntax) pane)
  (with-slots (start name attributes end) entity
    (display-parse-tree start syntax pane)
    (display-parse-tree name syntax pane)
    (unless (null attributes)
      (display-parse-tree attributes syntax pane))
    (display-parse-tree end syntax pane)))

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

(defmethod display-parse-tree ((entity html-end-tag) (syntax html-syntax) pane)
  (with-slots (start name attributes end) entity
    (display-parse-tree start syntax pane)
    (display-parse-tree name syntax pane)
    (display-parse-tree end syntax pane)))

75 76 77 78
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer

79
(defclass html-lexeme (html-token)
80 81
  ((state :initarg :state)))

82
(defclass start-lexeme (html-lexeme) ())
83 84
(defclass start-tag-start (html-lexeme) ())
(defclass end-tag-start (html-lexeme) ())
85 86 87
(defclass tag-end (html-lexeme) ())
(defclass word (html-lexeme) ())
(defclass delimiter (html-lexeme) ())
88

Robert Strandh's avatar
Robert Strandh committed
89 90
(defclass html-lexer (incremental-lexer) ())     

91
(defmethod next-lexeme ((lexer html-lexer) scan)
92 93 94
  (flet ((fo () (forward-object scan)))
    (let ((object (object-after scan)))
      (case object
95 96 97 98 99
	(#\< (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))))
100 101 102 103 104 105 106 107
	(#\> (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))))))))
108

109 110 111 112
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser

113
(defparameter *html-grammar* (grammar))
114

115 116 117
(defmacro add-html-rule (rule &key predict-test)
  `(add-rule (grammar-rule ,rule :predict-test ,predict-test)
	     *html-grammar*))
118

119
(defun word-is (word string)
120
  (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
121
		string))
122

123 124
(defmacro define-start-tag (name string)
  `(progn
125
     (defclass ,name (html-start-tag) ())
126

127
     (add-html-rule
128 129
      (,name -> (start-tag-start
		 (word (and (= (end-offset start-tag-start) (start-offset word))
130
			    (word-is word ,string)))
131 132
		 (tag-end (= (end-offset word) (start-offset tag-end))))
	     :start start-tag-start :name word :end tag-end))))
133 134 135

(defmacro define-end-tag (name string)
  `(progn
136
     (defclass ,name (html-end-tag) ())
137

138
     (add-html-rule
139 140
      (,name -> (end-tag-start
		 (word (and (= (end-offset end-tag-start) (start-offset word))
141
			    (word-is word ,string)))
142 143 144 145
		 (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)))))
146 147 148 149 150 151 152 153 154

(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")

155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
(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
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200
				:items ,name :item ,item-name)))
       
       (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
	 (declare (ignore pane))
	 nil)
       
       (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
	 (with-slots (items item) entity
	   (display-parse-tree items syntax pane)
	   (display-parse-tree item syntax pane))))))

(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)))
201 202 203 204 205 206 207 208 209
       
       (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
	 (declare (ignore pane))
	 nil)
       
       (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
	 (with-slots (items item) entity
	   (display-parse-tree items syntax pane)
	   (display-parse-tree item syntax pane))))))
210

211 212 213 214 215 216 217 218 219 220 221
;;;;;;;;;;;;;;; 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)))

222
(define-list string-lexemes string-lexeme)
223 224 225 226 227 228 229 230 231 232 233 234 235

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

(defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane)
  (with-slots (start lexemes end) entity
     (display-parse-tree start syntax pane)
     (with-text-face (pane :italic)
       (display-parse-tree lexemes syntax pane))
     (display-parse-tree end syntax pane)))

236 237 238 239 240 241 242 243 244 245 246
;;;;;;;;;;;;;;; attributes

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

(defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane)
  (with-slots (name equals) entity
     (display-parse-tree name syntax pane)
     (display-parse-tree equals syntax pane)))

247 248 249 250 251 252 253
(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)
254

255 256
;;;;;;;;;;;;;;; lang attribute

257
(defclass lang-attr (i18n-attribute)
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
  ((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))

(defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane)
  (with-slots (lang) entity
     (display-parse-tree lang syntax pane)))

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

274
(defclass dir-attr (i18n-attribute)
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
  ((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))

(defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane)
  (with-slots (dir) entity
     (display-parse-tree dir syntax pane)))


290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
;;;;;;;;;;;;;;; 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))

(defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane)
  (with-slots (href) entity
     (display-parse-tree href syntax pane)))


306
;;;;;;;;;;;;;;; title
307

308 309 310
(defclass title-item (html-nonterminal)
  ((item :initarg :item)))

311 312
(add-html-rule (title-item -> (word) :item word))
(add-html-rule (title-item -> (delimiter) :item delimiter))
313 314 315 316 317

(defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
  (with-slots (item) entity
     (display-parse-tree item syntax pane)))

318
(define-list title-items title-item)
319 320 321 322 323 324

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

325 326
(add-html-rule (title -> (<title> title-items </title>)
		      :<title> <title> :items title-items :</title> </title>))
327 328 329 330 331 332 333 334

(defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
  (with-slots (<title> items </title>) entity
     (display-parse-tree <title> syntax pane)
     (with-text-face (pane :bold)
       (display-parse-tree items syntax pane))
     (display-parse-tree </title> syntax pane)))

335 336 337 338 339
;;;;;;;;;;;;;;; inline-element, block-level-element

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

340 341 342 343 344
;;;;;;;;;;;;;;; %inline

(defclass $inline (html-nonterminal)
  ((contents :initarg :contents)))
     
345 346 347
(add-html-rule ($inline -> (inline-element) :contents inline-element)
	       :predict-test (lambda (token)
			       (typep token 'start-tag-start)))
348 349 350 351 352 353 354 355 356 357
(add-html-rule ($inline -> (word) :contents word))
(add-html-rule ($inline -> (delimiter) :contents delimiter))

(defmethod display-parse-tree ((entity $inline) (syntax html-syntax) pane)
  (with-slots (contents) entity
     (display-parse-tree contents syntax pane)))

(define-list $inlines $inline)

;;;;;;;;;;;;;;; %flow
358

359
(defclass $flow (html-nonterminal)
Robert Strandh's avatar
Robert Strandh committed
360
  ((contents :initarg :contents)))
361
     
362
(add-html-rule ($flow -> ($inline) :contents $inline))
363 364 365
(add-html-rule ($flow -> (block-level-element) :contents block-level-element)
	       :predict-test (lambda (token)
			       (typep token 'start-tag-start)))
366

367
(defmethod display-parse-tree ((entity $flow) (syntax html-syntax) pane)
368 369 370
  (with-slots (contents) entity
     (display-parse-tree contents syntax pane)))

371
(define-list $flows $flow)
Robert Strandh's avatar
Robert Strandh committed
372 373 374 375 376 377 378 379 380 381 382

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

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

(defmethod display-parse-tree ((entity heading) (syntax html-syntax) pane)
  (with-slots (start contents end) entity
     (display-parse-tree start syntax pane)
383 384
     (with-text-face (pane :bold)
       (display-parse-tree contents syntax pane))
Robert Strandh's avatar
Robert Strandh committed
385 386 387 388 389 390 391 392 393
     (display-parse-tree end syntax pane)))
	      
(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
394 395
      (,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
396 397 398 399 400 401 402 403 404


(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>)

405
;;;;;;;;;;;;;;; a element
406

407 408
(defclass <a>-attribute (html-nonterminal)
  ((attribute :initarg :attribute)))
409

410
(add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
411

412 413 414
(defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
  (with-slots (attribute) entity
     (display-parse-tree attribute syntax pane)))
415

416
(define-list <a>-attributes <a>-attribute)
417

418
(defclass <a> (html-start-tag) ())
419

420 421
(add-html-rule (<a> -> (start-tag-start
			(word (and (= (end-offset start-tag-start) (start-offset word))
422 423 424
				   (word-is word "a")))
			<a>-attributes
			tag-end)
425
		    :start start-tag-start :name word :attributes <a>-attributes :end tag-end))
426 427 428

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

429
(defclass a-element (inline-element)
430 431 432 433
  ((<a> :initarg :<a>)
   (items :initarg :items)
   (</a> :initarg :</a>)))

434 435
(add-html-rule (a-element -> (<a> $inlines </a>)
			  :<a> <a> :items $inlines :</a> </a>))
436

437
(defmethod display-parse-tree ((entity a-element) (syntax html-syntax) pane)
438 439
  (with-slots (<a> items </a>) entity
     (display-parse-tree <a> syntax pane)
440 441
     (with-text-face (pane :bold)
       (display-parse-tree items syntax pane))
442 443
     (display-parse-tree </a> syntax pane)))

444 445 446 447 448 449 450 451 452 453 454 455 456
;;;;;;;;;;;;;;; br element

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

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

(defmethod display-parse-tree ((entity br-element) (syntax html-syntax) pane)
  (with-slots (<br>) entity
     (display-parse-tree <br> syntax pane)))

457 458
;;;;;;;;;;;;;;; p element

459
(defclass <p> (html-start-tag) ())
460

461 462
(add-html-rule (<p> -> (start-tag-start
			(word (and (= (end-offset start-tag-start) (start-offset word))
463 464 465
				   (word-is word "p")))
			common-attributes
			tag-end)
466
		    :start start-tag-start :name word :attributes common-attributes :end tag-end))
467 468 469 470 471 472 473 474

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

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

475 476
(add-html-rule (p-element -> (<p> $inlines </p>)
			  :<p> <p> :contents $inlines :</p> </p>))
477 478 479 480 481 482 483

(defmethod display-parse-tree ((entity p-element) (syntax html-syntax) pane)
  (with-slots (<p> contents </p>) entity
    (display-parse-tree <p> syntax pane)
    (display-parse-tree contents syntax pane)
    (display-parse-tree </p> syntax pane)))

484 485
;;;;;;;;;;;;;;; li element

486
(defclass <li> (html-start-tag) ())
487

488 489
(add-html-rule (<li> -> (start-tag-start
			 (word (and (= (end-offset start-tag-start) (start-offset word))
490 491 492
				    (word-is word "li")))
			 common-attributes
			 tag-end)
493
		     :start start-tag-start
494 495 496 497 498 499 500 501 502 503 504
		     :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>)))

505 506 507 508
(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))
509 510 511 512 513

(defmethod display-parse-tree ((entity li-element) (syntax html-syntax) pane)
  (with-slots (<li> items </li>) entity
     (display-parse-tree <li> syntax pane)
     (display-parse-tree items syntax pane)     
514 515
     (when </li>
       (display-parse-tree </li> syntax pane))))
516 517 518

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

519
(defclass <ul> (html-start-tag) ())
520

521 522
(add-html-rule (<ul> -> (start-tag-start
			 (word (and (= (end-offset start-tag-start) (start-offset word))
523 524 525
				    (word-is word "ul")))
			 common-attributes
			 tag-end)
526
		     :start start-tag-start
527 528 529 530 531 532
		     :name word
		     :attributes common-attributes
		     :end tag-end))

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

533
(define-nonempty-list li-elements li-element)
534 535 536 537 538 539 540 541 542 543 544 545 546 547 548

(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>))

(defmethod display-parse-tree ((entity ul-element) (syntax html-syntax) pane)
  (with-slots (<ul> items </ul>) entity
     (display-parse-tree <ul> syntax pane)
     (display-parse-tree items syntax pane)     
     (display-parse-tree </ul> syntax pane)))

549 550 551 552 553 554 555 556 557 558 559 560 561
;;;;;;;;;;;;;;; hr element

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

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

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

(defmethod display-parse-tree ((entity hr-element) (syntax html-syntax) pane)
  (with-slots (<hr>) entity
     (display-parse-tree <hr> syntax pane)))

562
;;;;;;;;;;;;;;; body element
Robert Strandh's avatar
Robert Strandh committed
563 564 565 566 567 568 569 570 571 572

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

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

(defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
  (with-slots (item) entity
     (display-parse-tree item syntax pane)))

573
(define-list body-items body-item)
Robert Strandh's avatar
Robert Strandh committed
574 575 576 577 578 579 580 581 582 583 584 585 586 587 588

(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>))

(defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
  (with-slots (<body> items </body>) entity
     (display-parse-tree <body> syntax pane)
     (display-parse-tree items syntax pane)     
     (display-parse-tree </body> syntax pane)))

589 590 591 592 593 594 595
;;;;;;;;;;;;;;; head

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

596 597
(add-html-rule (head -> (<head> title </head>)
		     :<head> <head> :title title :</head> </head>))
598

599 600 601 602 603 604 605 606
(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
  (with-slots (<head> title </head>) entity
     (display-parse-tree <head> syntax pane)
     (display-parse-tree title syntax pane)     
     (display-parse-tree </head> syntax pane)))

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

607 608 609 610 611 612 613 614 615 616 617 618
(defclass <html>-attribute (html-nonterminal)
  ((attribute :initarg :attribute)))

(defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
  (with-slots (attribute) entity
     (display-parse-tree attribute syntax pane)))

(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)

619
(defclass <html> (html-start-tag) ())
620

621 622
(add-html-rule (<html> -> (start-tag-start
			   (word (and (= (end-offset start-tag-start) (start-offset word))
623 624 625
				      (word-is word "html")))
			   <html>-attributes
			   tag-end)
626
		       :start start-tag-start :name word :attributes <html>-attributes :end tag-end))
627 628 629

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

630 631 632 633 634 635
(defclass html (html-nonterminal)
  ((<html> :initarg :<html>)
   (head :initarg :head)
   (body :initarg :body)
   (</html> :initarg :</html>)))

636 637
(add-html-rule (html -> (<html> head body </html>)
		     :<html> <html> :head head :body body :</html> </html>))
638

639 640 641 642 643 644 645 646 647
(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
  (with-slots (<html> head body </html>) entity
     (display-parse-tree <html> syntax pane)
     (display-parse-tree head syntax pane)     
     (display-parse-tree body syntax pane)     
     (display-parse-tree </html> syntax pane)))

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

648 649
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
  (declare (ignore args))
650
  (with-slots (parser lexer buffer) syntax
651 652 653
     (setf parser (make-instance 'parser
		     :grammar *html-grammar*
		     :target 'html))
654
     (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
655 656
     (let ((m (clone-mark (low-mark buffer) :left))
	   (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
657
       (setf (offset m) 0)
658 659 660
       (setf (start-offset lexeme) m
	     (end-offset lexeme) 0)
       (insert-lexeme lexer 0 lexeme))))
661

662 663 664 665
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; update syntax

666

667
(defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
668 669 670 671 672
  (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)))
673 674
		(setf (slot-value next-lexeme 'state)
		      (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
675
	      (incf valid-parse))))
676

677
(defmethod inter-lexeme-object-p ((lexer html-lexer) object)
678
  (whitespacep (syntax (buffer lexer)) object))
679

680
(defmethod update-syntax (buffer (syntax html-syntax))
681
  (with-slots (lexer valid-parse) syntax
682
     (let* ((low-mark (low-mark buffer))
683 684 685 686 687
	    (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))))))
688

689 690 691 692
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; display

693 694 695 696 697
(defvar *white-space-start* nil)

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

698 699 700 701 702
(defun handle-whitespace (pane buffer start end)
  (let ((space-width (space-width pane))
	(tab-width (tab-width pane)))
    (loop while (< start end)
	  do (ecase (buffer-object buffer start)
703 704 705
	       (#\Newline (terpri pane)
			  (setf (aref *cursor-positions* (incf *current-line*))
				(multiple-value-bind (x y) (stream-cursor-position pane)
706
				  (declare (ignore x))
707
				  y)))
708 709 710 711 712 713 714
	       (#\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))))		    

715
(defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
716
  (with-slots (top bot) pane
717
     (when (and (end-offset entity) (mark> (end-offset entity) top))
718 719
       (call-next-method))))

720
(defmethod display-parse-tree ((entity html-lexeme) (syntax html-syntax) pane)
721
  (flet ((cache-test (t1 t2)
722 723 724 725 726 727
	   (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)))
728 729 730 731 732 733 734
    (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))))
735 736 737
	 (present (coerce (buffer-sequence (buffer syntax)
					   (start-offset entity)
					   (end-offset entity))
738 739 740 741 742
			  'string)
		  'string
		  :stream pane)))))

(defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
743
  (with-drawing-options (pane :ink +green4+)
744 745
    (call-next-method)))

746
(defmethod display-parse-tree :before ((entity html-lexeme) (syntax html-syntax) pane)
747 748
  (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
  (setf *white-space-start* (end-offset entity)))
749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764

(defgeneric display-parse-stack (symbol stack syntax pane))

(defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
  (let ((next (parse-stack-next stack)))
    (unless (null next)
      (display-parse-stack (parse-stack-symbol next) next syntax pane))
    (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
	  do (display-parse-tree parse-tree syntax pane))))  

(defun display-parse-state (state syntax pane)
  (let ((top (parse-stack-top state)))
    (if (not (null top))
	(display-parse-stack (parse-stack-symbol top) top syntax pane)
	(display-parse-tree (target-parse-tree state) syntax pane))))

765 766
(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
  (with-slots (top bot) pane
767 768 769
     (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
	   *current-line* 0
	   (aref *cursor-positions* 0) (stream-cursor-position pane))
770 771
     (with-slots (lexer) syntax
	(let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
772 773 774 775
				       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
776
	    (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
777
		  do (decf end-token-index))
778
	    ;; go forward to the last token before bot
779 780
	    (loop until (or (= end-token-index (nb-lexemes lexer))
			    (mark> (start-offset (lexeme lexer end-token-index)) bot))
781 782
		  do (incf end-token-index))
	    (let ((start-token-index end-token-index))
783 784
	      ;; go back to the first token after top, or until the previous token
	      ;; contains a valid parser state
785
	      (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
786
			      (not (parse-state-empty-p 
787
				    (slot-value (lexeme lexer (1- start-token-index)) 'state))))
788
		    do (decf start-token-index))
789 790
	      (let ((*white-space-start* (offset top)))
		;; display the parse tree if any
791 792
		(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)
793 794
				       syntax
				       pane))
795
		;; display the lexemes
796 797
		(with-drawing-options (pane :ink +red+)
		  (loop while (< start-token-index end-token-index)
798
			do (let ((token (lexeme lexer start-token-index)))
799 800
			     (display-parse-tree token syntax pane))
			   (incf start-token-index))))))))
801
     (when (region-visible-p pane) (display-region pane syntax))
802
     (display-cursor pane syntax current-p)))
803