Changed process-html-forms-lhtml loop in lib/ps-html.lisp from 'loop'

[clinton/parenscript.git] / src / lib / ps-html.lisp

(in-package "PARENSCRIPT")

(defvar *ps-html-empty-tag-aware-p* t)
(defvar *ps-html-mode* :sgml "One of :sgml or :xml")

(defvar *html-empty-tags* '(:area :atop :audioscope :base :basefont :br :choose :col :frame
                            :hr :img :input :isindex :keygen :left :limittext :link :meta
                            :nextid :of :over :param :range :right :spacer :spot :tab :wbr))

(defun empty-tag-p (tag)
  (and *ps-html-empty-tag-aware-p*
       (member tag *html-empty-tags*)))

(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-attrs (attrs)
               (do (attr-test attr-name attr-val)
                   ((not attrs))
                 (setf attr-name (pop attrs)
                       attr-test (when (not (keywordp attr-name))
                                   (let ((test attr-name))
                                     (setf attr-name (pop attrs))
                                     test))
                       attr-val (pop attrs))
                 (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)))))
             (process-form% (tag attrs content)
               (push (format nil "<~A" tag) r)
               (process-attrs attrs)
               (if (or content (not (empty-tag-p tag)))
                   (progn (push ">" r)
                          (map nil #'process-form content)
                          (push (format nil "</~A>" tag) r))
                   (progn (when (eql *ps-html-mode* :xml)
                            (push "/" r))
                          (push ">" r))))
             (process-form (form)
               (cond ((keywordp form) (process-form (list form)))
                     ((atom form) (push form r))
                     ((and (consp form) (keywordp (car form)))
                      (process-form% (car form) () (cdr form)))
                     ((and (consp form) (consp (first form)) (keywordp (caar form)))
                      (process-form% (caar form) (cdar form) (cdr form)))
                     (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) (process-form (list form)))
                     ((atom form) (push form r))
                     ((and (consp form) (keywordp (car form)))
                      (push (format nil "<~A" (car form)) r)
                      (labels ((process-attributes (el-body)
                                 (when el-body
                                   (if (or (consp (car el-body)) (= 1 (length el-body)))
                                       el-body
                                       (progn (push (format nil " ~A=\"" (car el-body)) r)
                                              (push (cadr el-body) r)
                                              (push "\"" r)
                                              (process-attributes (cddr el-body)))))))
                        (let ((content (process-attributes (cdr form))))
                          (if (or content (not (empty-tag-p (car form))))
                              (progn (push ">" r)
                                     (when content (map nil #'process-form content))
                                     (push (format nil "</~A>" (car form)) r))
                              (progn (when (eql *ps-html-mode* :xml)
                                   (push "/" r))
                                 (push ">" 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)))