src/lib/ps-html.lisp

   1 (in-package :parenscript)
   2
   3 (defvar *self-closing-tags-p* t)
   4
   5 (defun concat-constant-strings (str-list)
   6   (reverse (reduce (lambda (optimized-list next-obj)
   7                      (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list)))
   8                          (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
   9                          (cons next-obj optimized-list)))
  10                    (cons () str-list))))
  11
  12 (defun process-html-forms-lhtml (forms)
  13   (let ((r ()))
  14     (labels ((process-form (form)
  15                (cond ((keywordp form) (push (format nil "<~A />" form) r))
  16                      ((atom form) (push form r))
  17                      ((and (consp form) (keywordp (car form)))
  18                       (push (format nil "<~A>" (car form)) r)
  19                       (map nil #'process-form (cdr form))
  20                       (push (format nil "</~A>" (car form)) r))
  21                      ((and (consp form) (consp (first form)) (keywordp (caar form)))
  22                       (push (format nil "<~A" (caar form)) r)
  23                       (loop with attrs = (cdar form)
  24                          while attrs
  25                          for attr-name = (pop attrs)
  26                          for attr-test = (when (not (keywordp attr-name))
  27                                            (let ((test attr-name))
  28                                              (setf attr-name (pop attrs))
  29                                              test))
  30                          for attr-val = (pop attrs)
  31                          do
  32                          (if attr-test
  33                              (push `(if ,attr-test
  34                                         (concat-string ,(format nil " ~A=\"" attr-name) ,attr-val "\"")
  35                                         "")
  36                                    r)
  37                              (progn
  38                                (push (format nil " ~A=\"" attr-name) r)
  39                                (push attr-val r)
  40                                (push "\"" r))))
  41                       (if (or (cdr form) (not *self-closing-tags-p*))
  42                           (progn (push ">" r)
  43                                  (map nil #'process-form (cdr form))
  44                                  (push (format nil "</~A>" (caar form)) r))
  45                           (push "/>" r)))
  46                      (t (push form r)))))
  47       (map nil #'process-form forms)
  48       (concat-constant-strings (reverse r)))))
  49
  50 (defun process-html-forms-cl-who (forms)
  51   (let ((r ()))
  52     (labels ((process-form (form)
  53                (cond ((keywordp form) (push (format nil "<~A />" form) r))
  54                      ((atom form) (push form r))
  55                      ((and (consp form) (keywordp (car form)))
  56                       (push (format nil "<~A" (car form)) r)
  57                       (let (content)
  58                         (labels ((process-attributes (attrs)
  59                                    (cond ((null attrs) )
  60                                          ((= 1 (length attrs)) (setf content attrs))
  61                                          ((consp (car attrs))
  62                                           (push `(if ,(first attrs)
  63                                                      (concat-string ,(format nil " ~A=\"" (second attrs)) ,(third attrs) "\"")
  64                                                      "")
  65                                                 r)
  66                                           (process-attributes (cdddr attrs)))
  67                                          (t (push (format nil " ~A=\"" (first attrs)) r)
  68                                             (push (second attrs) r)
  69                                             (push "\"" r)
  70                                             (process-attributes (cddr attrs))))))
  71                           (process-attributes (cdr form))
  72                           (if (or content (not *self-closing-tags-p*))
  73                               (progn (push ">" r)
  74                                      (when content (map nil #'process-form content))
  75                                      (push (format nil "</~A>" (car form)) r))
  76                               (push "/>" r)))))
  77                      (t (push form r)))))
  78       (map nil #'process-form forms)
  79       (concat-constant-strings (reverse r)))))
  80
  81 (defmacro+ps ps-html (&rest html-forms)
  82   `(concat-string ,@(process-html-forms-lhtml html-forms)))
  83
  84 (defmacro+ps who-ps-html (&rest html-forms)
  85   `(concat-string ,@(process-html-forms-cl-who html-forms)))