(in-package :kira)

(defvar *paginatep* nil)
(defvar *prev* nil)
(defvar *next* nil)

(defclass collection (odb::collection-wrapper)
  ((descending :accessor descending :initarg :descending)
   (start :accessor start :initarg :start))
  (:default-initargs
   :descending nil
   :start +unspecific+))

(defconstant +collection-initargs+
  (loop for (key value) in (class-default-initargs (find-class 'collection))
        collect key collect (funcall value)))

(defmacro defcollection (name lambda-list &body body)
  (with-unique-names (args)
    `(progn
       (defmethod ,name
	   (,@lambda-list
	    &rest ,args
	    ,@(unless (member '&key lambda-list) '(&key))
	    ,@(unless (member '&allow-other-keys lambda-list) '(&allow-other-keys)))
	 (flet ((cached-collection (node slot &rest initargs)
		  (%cached-collection node slot initargs ,args)))
	   ,@body))
       ,(unless (ignore-errors (get-setf-method (list name)))
	  `(defsetf ,name (&rest args) (collection)
	     `(setf (collection (,',name ,@args :%force t))
		    (collection ,collection)))))))

(defun %cached-collection (node slot initargs extra-args)
  (let ((collection (slot-value node slot)))
    (when (or collection (getf extra-args :%force))
      (typecase collection
	(collection collection)
	(t (let* ((initargs+
		   (loop for (k v) on +collection-initargs+ by #'cddr
			 for v+ = (getf extra-args k +unspecific+)
			 unless (eq v+ +unspecific+)
			 collect k and collect v+))
		  (collection
		   (apply #'make-instance
			  'collection
			  :collection collection
			  (append initargs+ initargs))))
	     (prog1 collection
	       (unless initargs+
		 (setf (slot-value node slot)
		       collection)))))))))

(defun cursor-over-btree (fn btree descending start n paginatep)
  (multiple-value-bind (forward backward)
      (if descending
	  (values #'cursor-prev #'cursor-next)
	  (values #'cursor-next #'cursor-prev))
    (with-cursor (cursor btree)
      (let (key value present-p)
	(if n
	    (let (prev next start-present-p)
	      (unless (eq start +unspecific+)
		(setf (values key value start-present-p)
		      (cursor-set cursor start :from-end descending :prime (not paginatep)))
		(when paginatep
		  (setf (values key value present-p) (funcall backward cursor))
		  (when present-p (setf prev (prin1-to-string key))))
		(unless start-present-p
		  (return-from cursor-over-btree (values prev nil))))
	      (loop repeat n
		    do (setf (values key value present-p) (funcall forward cursor))
		    while present-p do (funcall fn key value))
	      (when paginatep
		(when present-p (setf (values key value present-p) (funcall forward cursor)))
		(when present-p (setf next (prin1-to-string key)))
		(values prev next)))
	    (prog1 nil
	      (unless (eq start +unspecific+)
		(setf (values key value present-p) (cursor-set cursor start :from-end descending :prime t))
		(unless present-p (return-from cursor-over-btree)))
	      (loop do (setf (values key value present-p) (funcall forward cursor))
		    while present-p do (funcall fn key value))))))))

(defun map-btree (fn btree &key (descending +unspecific+) (start +unspecific+) n (paginatep *paginatep*))
  (when (typep btree 'collection)
    (when (eq descending +unspecific+)
      (setf descending (descending btree)))
    (when (eq start +unspecific+)
      (setf start (start btree)))
    (setf btree (collection btree)))
  (when (eq descending +unspecific+)
    (setf descending nil))
  (if (and n paginatep)
      (let ((previous-page-p nil))
	(whereas ((^descending (request-query-value "descending")))
	  (setf descending (string->type ^descending t)))
	(whereas ((^start (request-query-value "start")))
	  (setf start (string->type ^start t)))
	(whereas ((^previous-page-p (request-query-value "previous-page-p")))
	  (setf previous-page-p (string->type ^previous-page-p t)))
	(if previous-page-p
	    (let ((keys '())
		  (values '()))
	      (setf (values *next* *prev*)
		    (cursor-over-btree (lambda (key value)
					 (push key keys)
					 (push value values))
				       btree
				       (not descending)
				       start
				       n
				       t))
	      (mapc fn keys values))
	    (setf (values *prev* *next*)
		  (cursor-over-btree fn btree descending start n t))))
      (cursor-over-btree fn btree descending start n nil)))

(defun map-collection (fn &rest args)
  (apply #'map-btree
	 (lambda (key value)
	   (declare (ignore key))
	   (funcall fn value))
	 args))

(defmacro do-btree ((key value &rest args) &body body)
  (let ((decls '()))
    (unless key
      (setf key (gensym "KEY"))
      (push `(declare (ignore ,key)) decls))
    (unless value
      (setf value (gensym "VALUE"))
      (push `(declare (ignore ,value)) decls))
    `(block nil
       (map-btree (lambda (,key ,value)
		    ,@decls
		    (*ml ,@body))
		  ,@args)
       nil)))

(defmacro do-collection (args &body body)
  `(do-btree (nil ,@args)
     ,@body))

(defun fetch (&rest args)
  (let ((*paginatep* nil))
    (collecting (apply #'map-collection #'collect args))))

(defun function-call (f &rest args)
  (cond ((keywordp f)
	 (list* f args))
	((and (consp f) (eq (first f) 'quote))
	 (list* (second f) args))
	(t
	 `(funcall ,f ,@args))))

(defun tag/attributes (tag attributes)
  (if (consp tag)
      (append tag attributes)
      (list* tag attributes)))

(defelement :collection
  (collection
   &attributes attributes
   &rest args
   &key (f ''render) tag item-tag (n '*n*)
   &allow-other-keys)
  (with-unique-names (object)
    (let* ((step (function-call f object))
           (loop
	    `(do-collection (,object ,collection :n ,n ,@(sans args :n :f :tag :item-tag))
	       ,(if item-tag
		    (list item-tag step)
		    step))))
      (if (or tag attributes)
	  (list (tag/attributes (or tag :div) attributes) loop)
	  loop))))

(defelement :list html
    (collection
     &rest args
     &attributes attributes
     &key (f ''render) (n '*link-list-n*) (tag :ul) (item-tag :li) (style ''li)
     &allow-other-keys)
  (with-unique-names (object)
    `(:let ((*style* ,style))
       (,(tag/attributes tag attributes)
	(do-collection (,object ,collection :n ,n ,@(sans args :n :f :tag :item-tag :style))
	  (,item-tag ,(function-call f object)))))))

(defelement :links html
    (collection
     &rest args
     &key (f ''render-link) (n 10) (separator ", ") tag
     &allow-other-keys)
  (with-unique-names (object firstp)
    `(let ((,firstp t))
       (do-collection (,object ,collection :n ,n ,@(sans args :n :f :separator :tag))
	 (if ,firstp
	     (setf ,firstp nil)
	     (html ,separator))
	 ,(if tag
	      (list tag (function-call f object))
	      (function-call f object))))))

(defelement :grid html
    (collection
     &attributes attributes
     &rest args
     &key (f ''render) (n '*n*)
     &allow-other-keys)
  (with-unique-names (object)
    `(:let ((*style* 'cell))
       (:div " ")
       ((:div
	 ,@(unless (getf attributes :class) '(:class "grid"))
	 ,@attributes)
	(do-collection (,object ,collection :n ,n ,@(sans args :n :f))
	  ((:div :class "cell")
	   ,(function-call f object))))
       ((:div :class "clear")))))

(defmethod render-in-style ((object t) (style (eql 'li)))
  (render-link object))

(defmethod render-in-style ((object t) (style (eql 'cell)))
  (html
   ((:ul :class "lines")
    (:li (render-image object))
    (render-in-style object 'caption))))

(defmethod render-in-style ((object t) (style (eql 'caption)))
  (html (:li (render-title object))))

(defmethod render-in-style ((object t) (style (eql 'sidebar)))
  (html ((:div :class "cell") (render-in-style object 'cell))))