[climacs-cvs] CVS update: climacs/html-syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Mon Apr 4 06:20:53 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv17330
Modified Files:
html-syntax.lisp
Log Message:
<html> tag now accepts LANG and DIR attributes.
Date: Mon Apr 4 08:20:52 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.20 climacs/html-syntax.lisp:1.21
--- climacs/html-syntax.lisp:1.20 Sun Mar 20 09:25:21 2005
+++ climacs/html-syntax.lisp Mon Apr 4 08:20:52 2005
@@ -82,6 +82,9 @@
(defparameter *html-grammar* (grammar))
+(defmacro add-html-rule (rule)
+ `(add-rule (grammar-rule ,rule) *html-grammar*))
+
(defun word-is (word string)
(string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
string))
@@ -90,30 +93,27 @@
`(progn
(defclass ,name (html-tag) ())
- (add-rule (grammar-rule
- (,name -> (tag-start
- (word (and (= (end-offset tag-start) (start-offset word))
- (word-is word ,string)))
- (tag-end (= (end-offset word) (start-offset tag-end))))))
- *html-grammar*)))
+ (add-html-rule
+ (,name -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word ,string)))
+ (tag-end (= (end-offset word) (start-offset tag-end))))))))
(defmacro define-end-tag (name string)
`(progn
(defclass ,name (html-tag) ())
- (add-rule (grammar-rule
- (,name -> (tag-start
- (slash (= (end-offset tag-start) (start-offset slash)))
- (word (and (= (end-offset slash) (start-offset word))
- (word-is word ,string)))
- (tag-end (= (end-offset word) (start-offset tag-end))))))
- *html-grammar*)))
+ (add-html-rule
+ (,name -> (tag-start
+ (slash (= (end-offset tag-start) (start-offset slash)))
+ (word (and (= (end-offset slash) (start-offset word))
+ (word-is word ,string)))
+ (tag-end (= (end-offset word) (start-offset tag-end))))))))
(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 <html> </html> "html")
(define-tag-pair <head> </head> "head")
(define-tag-pair <title> </title> "title")
(define-tag-pair <body> </body> "body")
@@ -133,14 +133,12 @@
((items :initarg :items)
(item :initarg :item)))
- (add-rule (grammar-rule (,name -> ()
- (make-instance ',empty-name)))
- *html-grammar*)
-
- (add-rule (grammar-rule (,name -> (,name ,item-name)
- (make-instance ',nonempty-name
- :items ,name :item ,item-name)))
- *html-grammar*)
+ (add-html-rule (,name -> ()
+ (make-instance ',empty-name)))
+
+ (add-html-rule (,name -> (,name ,item-name)
+ (make-instance ',nonempty-name
+ :items ,name :item ,item-name)))
(defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
(declare (ignore pane))
@@ -151,13 +149,95 @@
(display-parse-tree items syntax pane)
(display-parse-tree item syntax pane)))))
+;;;;;;;;;;;;;;; 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)))
+
+;;;;;;;;;;;;;;; lang attribute
+
+(defclass lang-attr (html-attribute)
+ ((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
+
+(defclass dir-attr (html-attribute)
+ ((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)))
+
+
+;;;;;;;;;;;;;;; <html>-tag
+
+(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 empty-<html>-attribute nonempty-<html>-attribute <html>-attribute)
+
+(defclass <html> (html-tag)
+ ((start :initarg :start)
+ (name :initarg :name)
+ (attributes :initarg :attributes)
+ (end :initarg :end)))
+
+(add-html-rule (<html> -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word "html")))
+ <html>-attributes
+ tag-end)
+ :start tag-start :name word :attributes <html>-attributes :end tag-end))
+
+(defmethod display-parse-tree ((entity <html>) (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 attributes syntax pane)
+ (display-parse-tree end syntax pane)))
+
+(define-end-tag </html> "html")
+
;;;;;;;;;;;;;;; title-item, title-items
(defclass title-item (html-nonterminal)
((item :initarg :item)))
-(add-rule (grammar-rule (title-item -> (word) :item word)) *html-grammar*)
-(add-rule (grammar-rule (title-item -> (delimiter) :item delimiter)) *html-grammar*)
+(add-html-rule (title-item -> (word) :item word))
+(add-html-rule (title-item -> (delimiter) :item delimiter))
(defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
(with-slots (item) entity
@@ -172,9 +252,8 @@
(items :initarg :items)
(</title> :initarg :</title>)))
-(add-rule (grammar-rule (title -> (<title> title-items </title>)
- :<title> <title> :items title-items :</title> </title>))
- *html-grammar*)
+(add-html-rule (title -> (<title> title-items </title>)
+ :<title> <title> :items title-items :</title> </title>))
(defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
(with-slots (<title> items </title>) entity
@@ -188,9 +267,9 @@
(defclass body-item (html-nonterminal)
((item :initarg :item)))
-(add-rule (grammar-rule (body-item -> (word) :item word)) *html-grammar*)
-(add-rule (grammar-rule (body-item -> (delimiter) :item delimiter)) *html-grammar*)
-(add-rule (grammar-rule (body-item -> (a) :item a)) *html-grammar*)
+(add-html-rule (body-item -> (word) :item word))
+(add-html-rule (body-item -> (delimiter) :item delimiter))
+(add-html-rule (body-item -> (a) :item a))
(defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
(with-slots (item) entity
@@ -205,9 +284,8 @@
(items :initarg :items)
(</body> :initarg :</body>)))
-(add-rule (grammar-rule (body -> (<body> body-items </body>)
- :<body> <body> :items body-items :</body> </body>))
- *html-grammar*)
+(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
@@ -220,8 +298,8 @@
(defclass a-tag-item (html-nonterminal)
((item :initarg :item)))
-(add-rule (grammar-rule (a-tag-item -> (word) :item word)) *html-grammar*)
-(add-rule (grammar-rule (a-tag-item -> (delimiter) :item delimiter)) *html-grammar*)
+(add-html-rule (a-tag-item -> (word) :item word))
+(add-html-rule (a-tag-item -> (delimiter) :item delimiter))
(defmethod display-parse-tree ((entity a-tag-item) (syntax html-syntax) pane)
(with-slots (item) entity
@@ -235,13 +313,12 @@
(items :initarg :items)
(end :initarg :end)))
-(add-rule (grammar-rule (<a> -> (tag-start
+(add-html-rule (<a> -> (tag-start
(word (and (= (end-offset tag-start) (start-offset word))
(word-is word "a")))
a-tag-items
tag-end)
- :start tag-start :name word :items a-tag-items :end tag-end))
- *html-grammar*)
+ :start tag-start :name word :items a-tag-items :end tag-end))
(defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane)
(with-slots (start name items end) entity
@@ -257,9 +334,8 @@
(items :initarg :items)
(</a> :initarg :</a>)))
-(add-rule (grammar-rule (a -> (<a> body-items </a>)
- :<a> <a> :items body-items :</a> </a>))
- *html-grammar*)
+(add-html-rule (a -> (<a> body-items </a>)
+ :<a> <a> :items body-items :</a> </a>))
(defmethod display-parse-tree ((entity a) (syntax html-syntax) pane)
(with-slots (<a> items </a>) entity
@@ -274,9 +350,8 @@
(title :initarg :title)
(</head> :initarg :</head>)))
-(add-rule (grammar-rule (head -> (<head> title </head>)
- :<head> <head> :title title :</head> </head>))
- *html-grammar*)
+(add-html-rule (head -> (<head> title </head>)
+ :<head> <head> :title title :</head> </head>))
(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
(with-slots (<head> title </head>) entity
@@ -292,9 +367,8 @@
(body :initarg :body)
(</html> :initarg :</html>)))
-(add-rule (grammar-rule (html -> (<html> head body </html>)
- :<html> <html> :head head :body body :</html> </html>))
- *html-grammar*)
+(add-html-rule (html -> (<html> head body </html>)
+ :<html> <html> :head head :body body :</html> </html>))
(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
(with-slots (<html> head body </html>) entity
More information about the Climacs-cvs
mailing list