output.lisp

(in-package #:hextml)

(defvar *hextml-stream*)

(defmacro output-html ((stream-var &optional (stream-form stream-var))
		       &body forms)
  (let ((code (let ((operations (html-output-toplevel stream-var forms)))
		(if (cdr operations)
		    `(prog1 nil ,@operations)
		    (car operations)))))
    (if (eq stream-var stream-form)
	code
	`(let ((,stream-var ,stream-form))
	  (declare (ignorable ,stream-var))
	  ,code))))

(defmacro with-html-output-optimizer (&body body)
  `(with-optimizer (collect retrieve
		     #'(lambda (thing accumulator)
			 (if (typep thing '(or string character))
			     (princ thing accumulator)))
		     #'identity)
    ,@body))

(defun html-output-toplevel (stream forms)
  (loop for operation in (html-output-children stream forms)
	collect (if (stringp operation)
		    `(write-string ,operation ,stream)
		    operation)))

(defun html-output-children (stream children)
  (with-html-output-optimizer
    (dolist (child children)
      (if (or (stringp child)
	      (numberp child)
	      (and (keywordp child)
		   (error "Keywords no longer supported in html-output.")))
	  (collect (princ-to-string child))
	  (if (html-node-form-p child)
	      (mapcar #'collect (html-output-node stream child))
	      (if (tag-form-p child)
		  (error "no tag support for output-html at this time.")
		  (collect (html-output stream child))))))
    (retrieve)))

(defun html-output (stream form)
  (let ((form (let ((*hextml-stream* stream))
		(hextml-macroexpand-1 form))))
    (cond ((or (atom form)
	       (not (listp (cdr form))))
	   form)
	  ((noprocess-form-p form)
	   (second form))
	  ((or (html-node-form-p form)
	       (tag-form-p form))
	   `(prog1 nil ,@(html-output-toplevel stream (list form))))
	  (t (mapcar (fmask #'html-output ? (stream ?))
		     form)))))

(defun html-output-node (stream form)
  (with-html-output-optimizer
    (multiple-value-bind (type attributes children) (destructure-html-node-form form)
      (collect (format nil "<~A" type))
      (doalist (attribute value attributes)
	(etypecase attribute
	  (string (if (and (consp value)
			   (eq (first value) 'boolean))
		      (collect `(if ,(second value)
				 (write-string ,(format nil " ~A=\"~A\""
							attribute attribute)
				  ,stream)))
		      (progn
			(collect (format nil " ~A=\"" attribute))
			(if (or (stringp value)
				(numberp value)
				(and (keywordp value)
				     (error "Keywords no longer supported ~
                                                      in html-output-node")))
			    (collect (princ-to-string value))
			    (if (eq value t)
				(collect attribute)
				(if (and (consp value) (eq (car value) 'progn))
				    (mapc #'collect (cdr value))
				    (collect value))))
			(collect "\""))))
	  ((eql quote) (mapcar #'collect (html-output-children stream (list value))))))
      (if children
	  (progn (collect ">")
		 (mapcar #'collect (html-output-children stream children))
		 (collect (format nil "</~A>" type)))
	  (collect " />")))
    (retrieve)))