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