;;;; Walk along the tree and expand all the macros in the specified list

(in-package :cl-who)

(defparameter *macro-to-expand* nil
  "List of macro that macroexpand-tree should expand ")

(defparameter *stream* nil
  "Dynamic variable that is binded to the html stream inside cl-who syntax
macro.")

(defun macroexpand-tree (tree)
  "Recursively expands all macro from *macro-to-expand* list in TREE."
  (apply-to-tree
   (lambda (subtree)
     (macroexpand-tree (macroexpand-1 subtree)))
   (lambda (subtree)
     (and (consp subtree)
	  (member (first subtree) *macro-to-expand*
		  :test #'eq)))
   tree))

(defmacro def-syntax-macro (name attrs &body body)
  "Syntactic sugar for defining a macro and adding its name to
*macro-to-expand*."
  `(progn
    (defmacro ,name ,attrs ,@body)
    (pushnew ',name *macro-to-expand*)))

(def-syntax-macro esc (form &rest rest)
  "Defines macroexpansion for ESC special form."
  (declare (ignore rest))
  (let ((result (gensym)))
    `(let ((,result ,form))
       (when ,form (write-string (escape-string ,result) *stream*)))))

(def-syntax-macro str (form &rest rest)
  "Defines macroexpansion for STR special form."  
  (declare (ignore rest))
  (let ((result (gensym)))
    `(let ((,result ,form))
       (when ,result (princ ,result *stream*)))))

(def-syntax-macro fmt (form &rest rest)
  "Defines macroexpansion for FMT special form."
  `(format *stream* ,form ,@rest))

(def-syntax-macro htm (&rest rest)
  "Defines macroexpasion for HTM special form."
  (tree-to-commands rest '*stream*))

(defun tree-to-template (tree)
  "Transforms an HTML tree into an intermediate format - mainly a
flattened list of strings. Utility function used by TREE-TO-COMMANDS."
  (loop for element in tree
        nconc (cond ((or (keywordp element)
                         (and (listp element)
                              (keywordp (first element)))
                         (and (listp element)
                              (listp (first element))
                              (keywordp (first (first element)))))
                     ;; normal tag
                     (process-tag element #'tree-to-template))
                    (t
                     (if *indent*
                       (list +newline+ (n-spaces *indent*) element)
                       (list element))))))

(defun tree-to-commands-aux (tree stream)
  (declare (optimize speed space))
  "Transforms the intermediate representation of an HTML tree into
Lisp code to print the HTML to STREAM. Utility function used by
TREE-TO-COMMANDS."
  (let ((in-string t)
        collector
        string-collector)
    (flet ((emit-string-collector ()
             "Generate a WRITE-STRING statement for what is currently
in STRING-COLLECTOR."
             (list 'write-string
                   (string-list-to-string (nreverse string-collector))
                   stream))
           (tree-to-commands-aux-internal (tree)
             "Same as TREE-TO-COMMANDS-AUX but with closed-over STREAM
for REPLACE-HTM."
             (tree-to-commands-aux tree stream)))
      (unless (listp tree)
        (return-from tree-to-commands-aux tree))
      (loop for element in tree
            do (cond ((and in-string (stringp element))
                       ;; this element is a string and the last one
                       ;; also was (or this is the first element) -
                       ;; collect into STRING-COLLECTOR
                       (push element string-collector))
                     ((stringp element)
                       ;; the last one wasn't a string so we start
                       ;; with an empty STRING-COLLECTOR
                       (setq string-collector (list element)
                             in-string t))
                     (string-collector
                       ;; not a string but STRING-COLLECTOR isn't
                       ;; empty so we have to emit the collected
                       ;; strings first
                       (push (emit-string-collector) collector)
                       (setq in-string nil
                             string-collector '())
                       ;; collect this element but walk down the
                       ;; subtree first
                       (push element collector))
                     (t
                       ;; not a string and empty STRING-COLLECTOR
                       (push element collector)))
            finally (return (if string-collector
                              ;; finally empty STRING-COLLECTOR if
                              ;; there's something in it
                              (nreverse (cons (emit-string-collector)
                                              collector))
                              (nreverse collector)))))))

(defun tree-to-commands (tree stream &optional prologue)
  (declare (optimize speed space))
  "Transforms an HTML tree into code to print the HTML to STREAM."
  ;; use TREE-TO-TEMPLATE, then TREE-TO-COMMANDS-AUX, and finally
  ;; replace the special symbols ESC, STR, FMT, and HTM
  (tree-to-commands-aux
   (if prologue
       (list* 'progn prologue +newline+
	      (tree-to-template (macroexpand-tree tree)))
       (cons 'progn (tree-to-template (macroexpand-tree tree))))
   stream))

(defmacro with-html-output ((var &optional stream
                                 &key prologue
                                      ((:indent *indent*) *indent*))
                            &body body)
  "Transform the enclosed BODY consisting of HTML as s-expressions
into Lisp code to write the corresponding HTML as strings to VAR -
which should either hold a stream or which'll be bound to STREAM if
supplied."
  (when (and *indent*
             (not (integerp *indent*)))
    (setq *indent* 0))
  (when (eq prologue t)
    (setq prologue *prologue*))
  `(let ((,var ,(or stream var))
	 (*stream* ,(or stream var)))
    ,(tree-to-commands body var prologue)))