(in-package :kira)

(defvar *style* 'content)
(defvar *rendition* '())
(defvar *render-function* 'render/html)

(defconstant +standard-page-regions+
  '(head
    title
    heading
    left
    right
    sidebar
    content))

(defelement :text (&rest args)
  `(:princ (text ,@args)))

(defun hidden-view-p (node &optional view)
  (typecase node
    ((or null keyword) nil)
    (node (and view (not (keywordp view))))
    (symbol t)))

(defelement :a html :safe (&attributes (&key href (rel t) &allow-other-keys &rest attributes) &body body)
  (unless href (setf href (pop body)))
  (multiple-value-bind (uri-to bindings)
      (when (and (eq rel t) (consp href) (eq (first href) :uri-to))
	(gensymize-list (rest href)))
    (when uri-to
      (setf href `(:uri-to ,@uri-to)
	    attributes `(:rel (:when (hidden-view-p ,@uri-to) "nofollow") ,@attributes)))
    (let ((a `(("a" :href ,href ,@(sans attributes :href)) ,@body)))
      (if bindings
	  `(:let ,bindings ,a)
	  a))))

(defelement :a* html (&attributes (&key (rel t) &allow-other-keys &rest attributes) &rest uri-to)
  (rebinding-lists (uri-to)
    `(html
      (("a" :href (:uri-to ,@uri-to)
	    ,@(when (eq rel t) `(:rel (:when (hidden-view-p ,@uri-to) "nofollow")))
	    ,@attributes)
       (render-title ,@uri-to)))))

(defelement :table html :safe (&attributes attributes &body body)
  `(("table"
     ,@(unless (getf attributes :cellpadding) '(:cellpadding 0))
     ,@(unless (getf attributes :cellspacing) '(:cellspacing 0))
     ,@(unless (getf attributes :border) '(:border 0))
     ,@attributes)
    ,@body))

(defelement :th/d html (&attributes attributes th &body td)
  `((:tr ,@attributes)
    (:th ,th)
    (:td ,@td)))

(defelement :script html (&attributes attributes &body body)
  `(("script"
     ,@(unless (getf attributes :type) '(:type "text/javascript"))
     ,@attributes)
    ,@body))

(defelement :li* html (&attributes attributes label &body body)
  `((:li ,@attributes)
    (:b ,label ":")
    " "
    ,@body))

(defun rendition-variable (name)
  (getf *rendition* name))

(defsetf rendition-variable (name) (value)
  `(setf (getf *rendition* ,name) ,value))

(defun region (name)
  (let ((stream (rendition-variable name)))
    (if (streamp stream)
	stream
	(setf (rendition-variable name)
	      (make-string-output-stream)))))

(defmethod region-around-form ((region t) form)
  form)

(defmethod region-around-form ((region (eql :sidebar)) form)
  `(let ((*style* 'sidebar)
	 (*n* 5)
	 (*link-list-n* 5))
     ,form))

(defmethod region-around-form ((region (eql :left)) form)
  (region-around-form :sidebar))

(defmethod region-around-form ((region (eql :right)) form)
  (region-around-form :sidebar))

(defmethod region-around-form ((region (eql :title)) form)
  `(let ((*allow-elements-p* nil))
     ,form))

(defmethod region-around-form ((region (eql :content)) form)
  `(let ((*paginatep* t))
     ,form))

(defmacro with-region-style ((name) &body body)
  (region-around-form name `(*ml ,@body)))

(defmacro with-region ((name) &body body)
  `(let ((*html-output* (region ',name)))
     (with-region-style (,name)
       ,@body)))

(defmacro standard-page (&body body)
  (with-sub-elements ((:title . title)) body
    (unless title
      (setf title '((render-title-from-query))))
    `(let (*prev*
	   *next*
	   (*rendition* (list :heading t)))
       (with-region (:title)
	 ,@title)
       (multiple-value-prog1
	   (with-region (:content)
	     ,.(loop for form in body
		     for name = (element-name form)
		     when (and (keywordp name) (member name +standard-page-regions+ :test #'string=))
		     collect `(with-region (,name) ,@(rest form))
		     else collect form))
	 (when (eq (rendition-variable :heading) t)
	   (setf (rendition-variable :heading)
		 (html-output ,@title)))
	 (render-standard-page)))))

(defun region-string (name)
  (whereas ((object (rendition-variable name)))
    (typecase object
      (string object)
      (stream (maybe-get-output-stream-string object)))))

(defelement :panel html (&attributes (&rest attributes &key case-preserving &allow-other-keys) &body body)
  (with-sub-elements ((:title . title) (:uri . uri)) body
    (when uri
      (setf title
	    (if title
		`((:a (:uri-to ,@uri) ,@title))
		`((render-link ,@uri)))))
    `((:div :class "panel" ,@(sans attributes :case-preserving))
      ,@(when title
          `(((:h4 ,@(when case-preserving
		      '(:style "text-transform: none")))
	    ,@title)))
      ((:div :class "content")
       ,@body))))

(defun render (object)
  (funcall *render-function* object))

(defun render/html (object)
  (render-in-style object *style*))

(defmethod render-in-style :around ((object t) (style t))
  (if (next-method-p)
      (call-next-method)
      (html (:p (render-link object)))))

(defmethod render-in-style ((object t) (style (eql 'content)))
  (render-in-style object 'html))

(defmethod render-in-style ((object t) (style (eql 'view)))
  (render-in-style object 'content))

(defun js-quote (string &optional stream)
  (with-output (stream *html-output*)
    (loop initially (write-char #\' stream)
          for char across string
          when (char= char #\')
          do (write-char #\\ stream)
          do (write-char char stream)
          finally (write-char #\' stream))))