X-Git-Url: http://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/30a9b64a7426644f155c5b8c1cc3e956893c82eb..0734b390e374e8c06cd58b7f321a40ad5c8c7e9d:/src/lib/ps-html.lisp diff --git a/src/lib/ps-html.lisp b/src/lib/ps-html.lisp dissimilarity index 99% index b28127b..39214c1 100644 --- a/src/lib/ps-html.lisp +++ b/src/lib/ps-html.lisp @@ -1,76 +1,93 @@ -;;; Macros for generating HTML from ParenScript code. - -(in-package :parenscript) - -(defun optimize-string-list (list) - (let (res - cur) - (dolist (node list) - (when (numberp node) - (setf node (format nil "~A" node))) - (cond ((null cur) (setf cur node)) - ((and (stringp cur) - (stringp node)) - (setf cur (concatenate 'string cur node))) - (t (push cur res) - (setf cur node)))) - (push cur res) - (nreverse res))) - -(defun process-html-forms (forms) - (let (res) - (labels ((handle-form (form) - (cond ((keywordp form) - (push (format nil "<~A/>" - (string-downcase (symbol-name form))) res)) - - ((atom form) - (push form res)) - - ((and (consp form) - (keywordp (first form))) - (let ((node-name (string-downcase (symbol-name (first form))))) - (push (format nil "<~A>" node-name) res) - (map nil #'handle-form (cdr form)) - (push (format nil "" node-name) res))) - - ((and (consp form) - (consp (first form)) - (keywordp (caar form))) - (let ((node-name (string-downcase (symbol-name (caar form))))) - (push (format nil "<~A" node-name) res) - - (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 - (+ ,(format nil " ~A=\"" (string-downcase (symbol-name attr-name))) - ,attr-val - "\"") - "") - res) - (progn - (push (format nil " ~A=\"" (string-downcase (symbol-name attr-name))) - res) - (push attr-val res) - (push "\"" res)))) - (push ">" res) - (map nil #'handle-form (cdr form)) - (push (format nil "" node-name) res))) - - ((consp form) - (push form res))))) - (map nil #'handle-form forms)) - (cons '+ (optimize-string-list (nreverse res))))) - -(define-ps-special-form ps-html (expecting &rest forms) - (declare (ignore expecting)) - (compile-parenscript-form (process-html-forms forms))) - +(in-package "PARENSCRIPT") + +(defvar *html-empty-tag-aware-p* t) +(defvar *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 *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) + (loop 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))))) + (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 "" tag) r)) + (progn (when (eql *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 "" (car form)) r)) + (progn (when (eql *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)))