| 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 | (do (attr-test attr-name attr-val) |
| 25 | ((not attrs)) |
| 26 | (setf attr-name (pop attrs) |
| 27 | attr-test (when (not (keywordp attr-name)) |
| 28 | (let ((test attr-name)) |
| 29 | (setf attr-name (pop attrs)) |
| 30 | test)) |
| 31 | attr-val (pop attrs)) |
| 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))) |