(in-package :html)

(defconstant +xhtml-p+ nil)
(defconstant +element-escapes+ "<>&")
(defconstant +attribute-escapes+ "<>&\"")
(defvar *html-output* *standard-output*)
(defvar *empty-elements* nil)
(defvar *buffer* nil)
(defvar *collector* nil)
(defvar *environment* nil)
(defvar *ml* 'html)
(defconstant +ml-macro+ (gensym))

(defun current-ml (&optional (env *environment*))
  (if *buffer*
      *ml*
      (macro-value +ml-macro+ env 'html)))

(defun tag-name (tag)
  (if (consp tag)
      (car tag)
      tag))

(defun element-name (element)
  (when (consp element)
    (tag-name (car element))))

(defun html-element-p (element)
  (and (consp element) (keywordp (element-name element))))

(defun attributes (tag)
  (when (consp tag)
    (rest tag)))

(defun attribute (tag search-name &optional default)
  (loop for (name value) on (attributes tag) by #'cddr
	when (string-equal name search-name) return value
	finally (return default)))

(defun element-has-flag (name flag)
  (find flag (rest (get name 'element))))

(defun escape-char (char stream)
  (write-string
   (case char
     (#\& "&amp;")
     (#\< "&lt;")
     (#\> "&gt;")
     (#\" "&quot;")
     (t (format nil "&#~d;" (char-code char))))
   stream))

(defun escape (string &optional (escapes +attribute-escapes+) (stream *html-output*))
  (with-output (stream)
    (loop for char across string
	  do (if (find char escapes)
		 (escape-char char stream)
		 (write-char char stream)))))

(defun parse-element (form &aux (tag (first form)) (content (rest form)))
  (if (consp tag)
      (values (first tag) (rest tag) content)
      (values tag nil content)))

(defun expand-attribute (name value)
  (flet ((expand-attribute-name (name)
	   `(:progn " " ,name))
	 (expand-attribute-value (value)
	   (if (eq value t)
	       ""
	       `(:progn "=\"" ,value "\""))))
    (cond ((not value) "")
	  ((and (consp value) (eq (first value) :if))
	   (destructuring-bind (op test then else) value
	     `(,op ,test ,(expand-attribute name then) ,(expand-attribute name else))))
	  ((and (consp value) (case (first value) ((:when :unless :whereas) t)))
	   (destructuring-bind (op test &body body) value
	     `(,op ,test ,(expand-attribute name (if (rest body) `(:progn ,@body) (first body))))))
	  (t `(:progn ,(expand-attribute-name name) ,(expand-attribute-value value))))))

(defun process-html-element (form)
  (mapc
   #'process
   (multiple-value-bind (name attributes content) (parse-element form)
     `("<"
       ,name
       ,.(loop for (att-name att-value) on attributes by #'cddr
	       collect (expand-attribute att-name att-value))
       ,@(if (and (keywordp name)
                  (eq (current-ml) 'html)
                  (element-has-flag name :empty))
              (if +xhtml-p+
		  '(" />")
		  '(">"))
	     `(">"
	       ,@content
	       "</"
	       ,name
	       ">"))))))

(defun html-macroexpand-1 (form &optional (ml (current-ml)))
  (let (name info fn)
    (if (and (consp form)
	     (symbolp (setf name (element-name form)))
	     (setf info (get name 'element))
	     (setf fn (first info))
	     (or (member ml (rest info))
	         (not (subsetp '(html xml) (rest info)))))
        (values (funcall fn form) t)
        (values form nil))))

(defun html-macroexpand (form)
  (loop with expanded-p and any-expanded-p
        do (setf (values form expanded-p) (html-macroexpand-1 form))
	while expanded-p
        do (setf any-expanded-p t)
	finally (return (values form any-expanded-p))))

(defmethod process :around ((form t))
  (let (expanded-p html-expanded-p)
    (setf (values form expanded-p) (macroexpand form *environment*)
	  (values form html-expanded-p) (html-macroexpand form))
    (if (or expanded-p html-expanded-p)
	(process form)
	(call-next-method))))

(defmethod process ((form null))
  nil)

(defmethod process ((string string))
  (write-string string *buffer*))

(defmethod process ((char character))
  (write-char char *buffer*))

(defmethod process ((symbol symbol))
  (cond
    ((keywordp symbol)
     (write-string (string-downcase symbol) *buffer*))
    ((constantp symbol)
     (princ (symbol-value symbol) *buffer*))
    (t
     (funcall *collector* (html-macroexpand-1 `(:princ ,symbol))))))

(defmethod process ((form cons))
  (destructuring-bind (tag . body) form
    (cond
      ((eq tag :progn) (mapc #'process body))
      ((typep tag '(or keyword string cons)) (process-html-element form))
      (t (funcall *collector* form)))))

(defmethod process ((form t))
  (escape (princ-to-string form) +attribute-escapes+ *buffer*))

(defun ml-generation-code (forms *ml*)
  `(macrolet ((,+ml-macro+ () ',*ml*))
     ,@(collecting
         (let* ((*buffer* (make-string-output-stream))
                (*collector*
                 (lambda (form)
		   (whereas ((string (maybe-get-output-stream-string *buffer*)))
		     (collect `(write-string ,string *html-output*)))
		   (unless (eq form *buffer*)
		     (collect form)))))
           (mapc #'process forms)
           (funcall *collector* *buffer*)))))

(defmacro html (&body forms &environment *environment*)
  (ml-generation-code forms 'html))

(defmacro *ml (&body forms &environment *environment*)
  `(,(current-ml) ,@forms))

(defmacro xml (&body forms &environment *environment*)
  (ml-generation-code forms 'xml))

(defmacro html-output (&body forms)
  `(with-output-to-string (*html-output*)
     (html ,@forms)))

(defun parse-html-macro-lambda-list (args)
  (let* ((tail (member '&attributes args))
	 (attributes (second tail)))
    (values
     attributes
     (if attributes
	 (nconc (ldiff args tail) (cddr tail))
	 args))))

(define-method-macro defelement (name &qualifiers qualifiers lambda-list &body body)
  (with-unique-names (form)
    `(setf (get ',name 'element)
           (list*
	    (lambda (,form)
	      (with-element ,lambda-list ,form
		,@body))
	    ',qualifiers))))

(defelement :princ (object)
  (rebinding (object)
    `(when ,object
       (princ ,object *html-output*))))

(defelement :princ-safe (object &optional (escapes '+attribute-escapes+))
  (rebinding (object)
    `(when ,object
       (escape (if (stringp ,object) ,object (princ-to-string ,object)) ,escapes))))

(defelement :prin1 (object)
  `(prin1 ,object *html-output*))

(defelement :prin1-safe (object &optional (escapes '+attribute-escapes+))
  `(escape (prin1-to-string ,object) ,escapes))

(defelement :format (&rest args)
  (if (every #'constantp args)
      (apply #'format nil (mapcar #'eval args))
      `(format *html-output* ,@args)))

(defelement :if (test then else)
  `(if ,test
       (*ml ,then)
       (*ml ,else)))

(defelement :when (test &body then)
  `(when ,test
     (*ml ,@then)))

(defelement :unless (test &body then)
  `(unless ,test
     (*ml ,@then)))

(defelement :let (bindings &body body)
  `(let ,bindings
     (*ml ,@body)))

(defelement :whereas (bindings &body body)
  `(whereas ,bindings
     (*ml ,@body)))

(defelement :hidden-field html (name value &attributes attributes)
  `((:input :type "hidden" :name ,name :value ,value ,@attributes)))

(defelement :hidden-fields html (&attributes attributes &rest plist)
  `(:progn
     ,@(loop for (name value) on plist by #'cddr
	     collect `((:hidden-field ,@attributes) ,name ,value))))

(defmacro with-element (lambda-list element &body body)
  (multiple-value-bind (attribute-args args) (parse-html-macro-lambda-list lambda-list)
    (etypecase attribute-args
      (null
       `(destructuring-bind ,args (rest ,element)
	  ,@body))
      (symbol
       (with-unique-names (name content)
	 `(multiple-value-bind (,name ,attribute-args ,content) (parse-element ,element)
	    (destructuring-bind ,args ,content
	      ,@body))))
      (cons
       (with-unique-names (name attributes content)
	 `(multiple-value-bind (,name ,attributes ,content) (parse-element ,element)
	    (destructuring-bind ,args ,content
	      (destructuring-bind ,attribute-args ,attributes
		,@body))))))))

(defmacro with-sub-elements (elements body-var &body body)
  (with-unique-names (form)
    `(let* (,.(loop for (nil . matcher) in elements
                    collect (if (atom matcher)
                                matcher
                                (car matcher)))
	    (,body-var
	     (collecting
	       (dolist (,form ,body-var)
		 (cond
		   ,.(loop for (name . matcher) in elements collect
			   (let* ((rest-p (atom matcher))
				  (element (if rest-p matcher (car matcher))))
			     `((and (consp ,form) (eq (element-name ,form) ',name))
			       (setf ,element ,(if rest-p `(rest ,form) form)))))
		   (t (collect ,form)))))))
       ,@body)))