Implemented who-ps-html, which is like the ps-html macro but taking CL-WHO like synta...

diff --git a/docs/reference.lisp b/docs/reference.lisp
index 0cd7a0c..5979eb9 100644 (file)
--- a/docs/reference.lisp
+++ b/docs/reference.lisp
@@ -1073,10 +1073,10 @@ a-variable  => aVariable
 ;;; compiler. The resulting expression is a JavaScript expression.
 
 (ps-html ((:a :href "foobar") "blorg"))
-=> '<a href=\"foobar\">blorg</a>'
+=> '<A HREF=\"foobar\">blorg</A>'
 
 (ps-html ((:a :href (generate-a-link)) "blorg"))
-=> '<a href=\"' + generateALink() + '\">blorg</a>'
+=> '<A HREF=\"' + generateALink() + '\">blorg</A>'
 
 ;;; We can recursively call the ParenScript compiler in an HTML
 ;;; expression.
@@ -1084,7 +1084,7 @@ a-variable  => aVariable
 (document.write
   (ps-html ((:a :href "#"
                 :onclick (lisp (ps-inline (transport)))) "link")))
-=> document.write('<a href=\"#\" onclick=\"' + 'javascript:transport()' + '\">link</a>')
+=> document.write('<A HREF=\"#\" ONCLICK=\"' + 'javascript:transport()' + '\">link</A>')
 
 ;;; Forms may be used in attribute lists to conditionally generate
 ;;; the next attribute. In this example the textarea is sometimes disabled.
@@ -1097,9 +1097,9 @@ a-variable  => aVariable
 => var disabled = null;
    var authorized = true;
    element.innerHTML =
-   '<textarea'
-   + (disabled || !authorized ? ' disabled=\"' + 'disabled' + '\"' : '')
-   + '>Edit me</textarea>';
+   '<TEXTAREA'
+   + (disabled || !authorized ? ' DISABLED=\"' + 'disabled' + '\"' : '')
+   + '>Edit me</TEXTAREA>';
 
 ;;;# Macrology
 ;;;t \index{macro}

diff --git a/src/lib/ps-html.lisp b/src/lib/ps-html.lisp
dissimilarity index 98%
index f24682a..d2d96cc 100644 (file)
--- a/src/lib/ps-html.lisp
+++ b/src/lib/ps-html.lisp
@@ -1,60 +1,79 @@
-(in-package :parenscript)
-
-(defun process-html-forms (forms) ; this needs a rewrite
-  (let ((res ()))
-    (labels ((handle-form (form)
-               (cond ((keywordp form)
-                      (push (format nil "<~A/>"
-                                    (string-downcase (symbol-name form))) res))
-
-                     ((atom form)
-                      (push form res))
-
-                     ((and (consp form)
-                           (keywordp (first form)))
-                      (let ((node-name (string-downcase (symbol-name (first form)))))
-                        (push (format nil "<~A>" node-name) res)
-                        (map nil #'handle-form (cdr form))
-                        (push (format nil "</~A>" node-name) res)))
-
-                     ((and (consp form)
-                           (consp (first form))
-                           (keywordp (caar form)))
-                      (let ((node-name (string-downcase (symbol-name (caar form)))))
-                        (push (format nil "<~A" node-name) res)
-
-                        (loop with attrs = (cdar form)
-                              while attrs
-                              for attr-name = (pop attrs)
-                              for attr-test = (when (not (keywordp attr-name))
-                                                (let ((test attr-name))
-                                                  (setf attr-name (pop attrs))
-                                                  test))
-                              for attr-val = (pop attrs)
-                              do
-                              (if attr-test
-                                  (push `(if ,attr-test
-                                          (+ ,(format nil " ~A=\"" (string-downcase (symbol-name attr-name)))
-                                           ,attr-val
-                                           "\"")
-                                          "")
-                                        res)
-                                  (progn 
-                                    (push (format nil " ~A=\"" (string-downcase (symbol-name attr-name)))
-                                          res)
-                                    (push attr-val res)
-                                    (push "\"" res))))
-                        (push ">" res)
-                        (map nil #'handle-form (cdr form))
-                        (push (format nil "</~A>" node-name) res)))
-
-                     ((consp form)
-                      (push form res)))))
-      (map nil #'handle-form forms)
-      (concat-constant-strings (reverse res)))))
-
-(defpsmacro ps-html (&rest html-forms)
-  (cons '+ (process-html-forms html-forms)))
-
-(defmacro ps-html (&rest html-forms)
-  `(format nil "~@{~A~}" ,@(process-html-forms html-forms)))
+(in-package :parenscript)
+
+(defun concat-constant-strings (str-list)
+  (reverse (reduce (lambda (optimized-list next-obj)
+                     (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list)))
+                         (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
+                         (cons next-obj optimized-list)))
+                   (cons () str-list))))
+
+(defun process-html-forms-lhtml (forms)
+  (let ((r ()))
+    (labels ((process-form (form)
+               (cond ((keywordp form) (push (format nil "<~A />" form) r))
+                     ((atom form) (push form r))
+                     ((and (consp form) (keywordp (car form)))
+                      (push (format nil "<~A>" (car form)) r)
+                      (map nil #'process-form (cdr form))
+                      (push (format nil "</~A>" (car form)) r))
+                     ((and (consp form) (consp (first form)) (keywordp (caar form)))
+                      (push (format nil "<~A" (caar form)) r)
+                      (loop with attrs = (cdar form)
+                         while attrs
+                         for attr-name = (pop attrs)
+                         for attr-test = (when (not (keywordp attr-name))
+                                           (let ((test attr-name))
+                                             (setf attr-name (pop attrs))
+                                             test))
+                         for attr-val = (pop attrs)
+                         do
+                         (if attr-test
+                             (push `(if ,attr-test
+                                        (concat-string ,(format nil " ~A=\"" attr-name) ,attr-val "\"")
+                                        "")
+                                   r)
+                             (progn
+                               (push (format nil " ~A=\"" attr-name) r)
+                               (push attr-val r)
+                               (push "\"" r))))
+                      (push ">" r)
+                      (map nil #'process-form (cdr form))
+                      (push (format nil "</~A>" (caar form)) r))
+                     (t (push form r)))))
+      (map nil #'process-form forms)
+      (concat-constant-strings (reverse r)))))
+
+(defun process-html-forms-cl-who (forms)
+  (let ((r ()))
+    (labels ((process-form (form)
+               (cond ((keywordp form) (push (format nil "<~A />" form) r))
+                     ((atom form) (push form r))
+                     ((and (consp form) (keywordp (car form)))
+                      (push (format nil "<~A" (car form)) r)
+                      (let (content)
+                        (labels ((process-attributes (attrs)
+                                   (cond ((= 1 (length attrs)) (setf content (car attrs)))
+                                         ((consp (car attrs))
+                                          (push `(if ,(first attrs)
+                                                     (concat-string ,(format nil " ~A=\"" (second attrs)) ,(third attrs) "\"")
+                                                     "")
+                                                r)
+                                          (process-attributes (cdddr attrs)))
+                                         (t (push (format nil " ~A=\"" (first attrs)) r)
+                                            (push (second attrs) r)
+                                            (push "\"" r)
+                                            (process-attributes (cddr attrs))))))
+                          (process-attributes (cdr form))
+                          (push ">" r)
+                          (when content
+                            (map nil #'process-form content))))
+                      (push (format nil "</~A>" (car form)) r))
+                     (t (push form r)))))
+      (map nil #'process-form forms)
+      (concat-constant-strings (reverse r)))))
+
+(defmacro+ps ps-html (&rest html-forms)
+  `(concat-string ,@(process-html-forms-lhtml html-forms)))
+
+(defmacro+ps who-ps-html (&rest html-forms)
+  `(concat-string ,@(process-html-forms-cl-who html-forms)))

diff --git a/src/lib/ps-macro-lib.lisp b/src/lib/ps-macro-lib.lisp
index 51ea696..83dba18 100644 (file)
--- a/src/lib/ps-macro-lib.lisp
+++ b/src/lib/ps-macro-lib.lisp
@@ -77,3 +77,10 @@
 (defpsmacro concatenate (result-type &rest sequences)
   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
   (cons '+ sequences))
+
+(defmacro concat-string (&rest things)
+  `(format nil "~@{~A~}" ,@things))
+
+(defpsmacro concat-string (&rest things)
+  (cons '+ things))
+

diff --git a/src/package.lisp b/src/package.lisp
index 4eedcbd..4992492 100644 (file)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -143,6 +143,7 @@
 
       ;; html generator for javascript
       #:ps-html
+      #:who-ps-html
 
       ;; utils
       #:do-set-timeout

diff --git a/src/utils.lisp b/src/utils.lisp
index f253f0e..d3b6ccc 100644 (file)
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -25,13 +25,6 @@
       (when keep-separators (push (string (char string i)) res))
       (setf last (1+ i)))))
 
-(defun concat-constant-strings (list)
-  (reverse (reduce (lambda (optimized-list next-obj)
-                     (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list)))
-                         (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
-                         (cons next-obj optimized-list)))
-                   (cons () list))))
-
 (defparameter *special-chars*
   '((#\! . "Bang")
     (#\? . "What")

diff --git a/t/ps-tests.lisp b/t/ps-tests.lisp
index 73c4e4c..4477531 100644 (file)
--- a/t/ps-tests.lisp
+++ b/t/ps-tests.lisp
@@ -415,7 +415,7 @@ x = 2 + sideEffect() + x + 5;")
                      :onclick (lisp (ps-inline (transport))))
                  img))
        img))
-  "document.write(LINKORNOT == 1 ? '<a href=\"#\" onclick=\"' + 'javascript:transport()' + '\">' + img + '</a>' : img)")
+  "document.write(LINKORNOT == 1 ? '<A HREF=\"#\" ONCLICK=\"' + 'javascript:transport()' + '\">' + img + '</A>' : img)")
 
 (test-ps-js negate-number-literal ;; ok, this was broken and fixed before, but no one bothered to add the test!
   (- 1)

diff --git a/t/reference-tests.lisp b/t/reference-tests.lisp
index ec31e30..99b3706 100644 (file)
--- a/t/reference-tests.lisp
+++ b/t/reference-tests.lisp
@@ -579,17 +579,17 @@ for (var k in obj) {
 
 (test-ps-js the-html-generator-1
   (ps-html ((:a :href "foobar") "blorg"))
-  "'<a href=\"foobar\">blorg</a>'")
+  "'<A HREF=\"foobar\">blorg</A>'")
 
 (test-ps-js the-html-generator-2
   (ps-html ((:a :href (generate-a-link)) "blorg"))
-  "'<a href=\"' + generateALink() + '\">blorg</a>'")
+  "'<A HREF=\"' + generateALink() + '\">blorg</A>'")
 
 (test-ps-js the-html-generator-3
   (document.write
   (ps-html ((:a :href "#"
                 :onclick (lisp (ps-inline (transport)))) "link")))
-  "document.write('<a href=\"#\" onclick=\"' + 'javascript:transport()' + '\">link</a>')")
+  "document.write('<A HREF=\"#\" ONCLICK=\"' + 'javascript:transport()' + '\">link</A>')")
 
 (test-ps-js the-html-generator-4
   (let* ((disabled nil)
@@ -600,7 +600,7 @@ for (var k in obj) {
   "var disabled = null;
 var authorized = true;
 element.innerHTML =
-'<textarea'
-+ (disabled || !authorized ? ' disabled=\"' + 'disabled' + '\"' : '')
-+ '>Edit me</textarea>';")
+'<TEXTAREA'
++ (disabled || !authorized ? ' DISABLED=\"' + 'disabled' + '\"' : '')
++ '>Edit me</TEXTAREA>';")