[closure-cvs] CVS closure/src/parse

[emarsden]

Update of /project/closure/cvsroot/closure/src/parse
In directory clnet:/tmp/cvs-serv3355/src/parse

Modified Files:
	pt.lisp 
Log Message:
Reimplement the LHTML parser. The previous version could not handle
forms like ((:a :href "/foo.html") "foo").


--- /project/closure/cvsroot/closure/src/parse/pt.lisp	2006/12/31 13:24:49	1.5
+++ /project/closure/cvsroot/closure/src/parse/pt.lisp	2007/01/03 16:07:25	1.6
@@ -148,7 +148,7 @@
       (setf (pt-parent k) res))
     res))
 
-(defun ppt (pt &optional (prefix "") (barp nil))
+(defun ppt (pt &optional (stream *standard-output*) (prefix "") (barp nil))
   (cond ((eq (pt-name pt) :pcdata)
          (let ((s (map 'string
 		    #'(lambda (x)
@@ -162,15 +162,16 @@
                (setq s (concatenate 'string (subseq s 0 (- 120 (length prefix))))
                      flag t))
            (write-string (format nil "~%~A| ~S ~A" prefix s
-                                 (if flag "..." "")))))
+                                 (if flag "..." "")) stream)))
         (t
-         (write-string (format nil "~%~A| ~A" prefix (pt-name pt)))
+         (write-string (format nil "~%~A| ~A" prefix (pt-name pt)) stream)
          (when (pt-children pt)
            (write-string (format nil "~%~A~A-~A." 
                                  prefix 
                                  (if barp "+" "`")
                                  (make-string (length (symbol-name (pt-name pt))) 
-                                             :initial-element #\- )))
+                                             :initial-element #\- ))
+                         stream)
            (let ((prefix1 (concatenate 'string 
                             prefix (if barp "|" " ")
                             (make-string (length (symbol-name (pt-name pt))) 
@@ -178,7 +179,7 @@
                             " ")))
              (do ((q (pt-children pt) (cdr q)))
                  ((null q))
-               (ppt (car q) prefix1 (if (cdr q) 't 'nil))))))))
+               (ppt (car q) stream prefix1 (if (cdr q) 't 'nil))))))))
 
 ;;; -------------------------------------------------------------------------------------------
 
@@ -218,27 +219,33 @@
   (cond ((null pt) nil)
         ((cons (pt-name pt) (pt-full-name-path (pt-parent pt))))))
 
-(defun lhtml->pt (tree)
-  (cond ((typep tree 'rod)
-         (sgml::make-pt :name :pcdata :attrs tree))
-        ((stringp tree)
-         (sgml::make-pt :name :pcdata :attrs (string-rod tree)))
-        ((sgml::pt-p tree) tree)
-        ((and (consp tree) (keywordp (car tree)))
-         (let ((attrs nil)
-               (gi (car tree)))
-           (do ((q (cdr tree) (cddr q)))
-               ((or (null q)
-                    (not (keywordp (car q))))
-		(sgml::make-pt :name gi
-			       :attrs (nreverse attrs)
-			       :children (mapcar #'lhtml->pt q)))
-             (push (car q) attrs)
-             (push (rod (cadr q)) attrs))))
-        (t
-         (error "~S does not look like LHTML." tree)) ))
+(defun walk-lhtml (lhtml tag-callback text-callback)
+  (if (stringp lhtml)
+      (funcall text-callback lhtml)
+      (destructuring-bind (tag &rest body)
+          (if (consp lhtml) lhtml (list lhtml))
+        (destructuring-bind (tag-name &rest attributes)
+            (if (consp tag) tag (list tag))
+          (funcall tag-callback tag-name attributes body)))))
+
+(defun lhtml->pt (lhtml)
+  (walk-lhtml lhtml
+              ;; tag callback
+              (lambda (tag-name attributes body)
+                (make-pt :name tag-name
+                         :attrs (loop :for (key value) :on attributes :by #'cddr
+                                      :collect key
+                                      :collect (etypecase value
+                                                 (string (runes:string-rod value))
+                                                 (sgml::rod value)))
+                         :children (mapcar #'lhtml->pt body)))
+              ;; text callback
+              (lambda (string)
+                (assert (stringp string))
+                (make-pt :name :pcdata :attrs (runes:string-rod string)))))
 
 (defun lhtml-reader (stream subchar arg)
+  (declare (ignore subchar arg))
   `(lhtml->pt
     ,(funcall (get-macro-character #\`) stream nil)))