src/lib/ps-html.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 (defvar *ps-html-empty-tag-aware-p* t)
   4 (defvar *ps-html-mode* :sgml "One of :sgml or :xml")
   5
   6 (defvar *html-empty-tags* '(:area :atop :audioscope :base :basefont :br :choose :col :frame
   7                             :hr :img :input :isindex :keygen :left :limittext :link :meta
   8                             :nextid :of :over :param :range :right :spacer :spot :tab :wbr))
   9
  10 (defun empty-tag-p (tag)
  11   (and *ps-html-empty-tag-aware-p*
  12        (member tag *html-empty-tags*)))
  13
  14 (defun concat-constant-strings (str-list)
  15   (reverse (reduce (lambda (optimized-list next-obj)
  16                      (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list)))
  17                          (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
  18                          (cons next-obj optimized-list)))
  19                    (cons () str-list))))
  20
  21 (defun process-html-forms-lhtml (forms)
  22   (let ((r ()))
  23     (labels ((process-attrs (attrs)
  24                (loop 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              (process-form% (tag attrs content)
  42                (push (format nil "<~A" tag) r)
  43                (process-attrs attrs)
  44                (if (or content (not (empty-tag-p tag)))
  45                    (progn (push ">" r)
  46                           (map nil #'process-form content)
  47                           (push (format nil "</~A>" tag) r))
  48                    (progn (when (eql *ps-html-mode* :xml)
  49                             (push "/" r))
  50                           (push ">" r))))
  51              (process-form (form)
  52                (cond ((keywordp form) (process-form (list form)))
  53                      ((atom form) (push form r))
  54                      ((and (consp form) (keywordp (car form)))
  55                       (process-form% (car form) () (cdr form)))
  56                      ((and (consp form) (consp (first form)) (keywordp (caar form)))
  57                       (process-form% (caar form) (cdar form) (cdr form)))
  58                      (t (push form r)))))
  59       (map nil #'process-form forms)
  60       (concat-constant-strings (reverse r)))))
  61
  62 (defun process-html-forms-cl-who (forms)
  63   (let ((r ()))
  64     (labels ((process-form (form)
  65                (cond ((keywordp form) (process-form (list form)))
  66                      ((atom form) (push form r))
  67                      ((and (consp form) (keywordp (car form)))
  68                       (push (format nil "<~A" (car form)) r)
  69                       (labels ((process-attributes (el-body)
  70                                  (when el-body
  71                                    (if (or (consp (car el-body)) (= 1 (length el-body)))
  72                                        el-body
  73                                        (progn (push (format nil " ~A=\"" (car el-body)) r)
  74                                               (push (cadr el-body) r)
  75                                               (push "\"" r)
  76                                               (process-attributes (cddr el-body)))))))
  77                         (let ((content (process-attributes (cdr form))))
  78                           (if (or content (not (empty-tag-p (car form))))
  79                               (progn (push ">" r)
  80                                      (when content (map nil #'process-form content))
  81                                      (push (format nil "</~A>" (car form)) r))
  82                               (progn (when (eql *ps-html-mode* :xml)
  83                                    (push "/" r))
  84                                  (push ">" r))))))
  85                      (t (push form r)))))
  86       (map nil #'process-form forms)
  87       (concat-constant-strings (reverse r)))))
  88
  89 (defmacro+ps ps-html (&rest html-forms)
  90   `(concat-string ,@(process-html-forms-lhtml html-forms)))
  91
  92 (defmacro+ps who-ps-html (&rest html-forms)
  93   `(concat-string ,@(process-html-forms-cl-who html-forms)))