;;; sxml-pagination.scm
;
; Copyright (c) 2004-2008 Peter Bex (Peter.Bex@xs4all.nl)
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of Peter Bex nor the names of any contributors may
;    be used to endorse or promote products derived from this software
;    without specific prior written permission.
; 
; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
; SUCH DAMAGE.

(module sxml-pagination
  (page-var page-size base-uri determine-page page-count first-entry
   last-entry pagination-rules)

(import chicken scheme extras data-structures)

(require-extension sxml-transforms srfi-1 srfi-13 uri-common)

;; Variable fetching and link generation should be done differently
(define page-size (make-parameter 20))
(define page-var (make-parameter 'page))
(define base-uri (make-parameter (uri-reference "")))

;; Always returns a good page
(define (determine-page len)
  (let ((page (inexact->exact
               (or (string->number
                    (or (alist-ref (page-var) (uri-query (base-uri))) "1"))
                   1))))
    (cond
     ((< page 1) 1)
     ((<= len (* (page-size) (sub1 page))) (page-count len))
     (else page))))

(define (page-count len)
  (inexact->exact (ceiling (/ len (page-size)))))

(define (first-entry nentries . rest)
  (* (page-size) (sub1 (determine-page nentries))))

(define (last-entry nentries . rest)
  (sub1 (min (+ (first-entry nentries (page-size)) (page-size))
	     nentries)))

;; Utils
(define (slice list first last)
  (take (drop list first) (- last first -1)))

(define (expand-entries code entries size)
  (pre-post-order
   code
   `((entries . ,(lambda (tag code)
		   (map (lambda (entry)
			  (pre-post-order
			   code
			   `((entry . ,(lambda (tag)
					 (if (promise? entry)
					     (force entry)
					     entry)))
			     (*default* . ,(lambda code code))
			     (*text* . ,(lambda (text string) string)))))
			entries)))
     (pagination-links . ,(lambda (tag)
			    `(pagination-info ,size)))
     (current-page . ,(lambda (tag)
			(determine-page size)))
     (page-count . ,(lambda (tag)
		      (page-count size)))
     (last-entry . ,(lambda (tag)
		      (last-entry size)))
     (first-entry . ,(lambda (tag)
		       (first-entry size)))
     (*text* . ,(lambda (text string) string))
     (*default* . ,(lambda code code)))))

;; This is a long mofo.  I don't really see a way to make it shorter, though
(define (page-navigation nentries)
  (if (<= nentries (page-size))
      '()
      (let ((pages (page-count nentries))
	    (pagenr (determine-page nentries)))
	`(ol (@ (class "page-navigation"))
	     (li (@ (class "first"))
		 ,(if (> pagenr 1)
		      `(page-link 1 "<<")
		      "<<"))
	     (li (@ (class "prev"))
		 ,(if (> pagenr 1)
		      `(page-link ,(sub1 pagenr) "<")
		      "<"))
	     ,(map (lambda (nr)
		     (if (= nr pagenr)
			 `(li ,nr)
			 `(li (page-link ,nr ,nr))))
		   (iota pages 1))
	     (li (@ (class "next"))
		 ,(if (< pagenr pages)
		      `(page-link ,(add1 pagenr) ">")
		      ">"))
	     (li (@ (class "last"))
		 ,(if (< pagenr pages)
		      `(page-link ,pages ">>")
		      ">>"))))))

(define (make-uri-string pg)
  (uri->string (update-uri (base-uri)
                           query: (alist-update! (page-var)
                                                 (number->string pg)
                                                 (uri-query (base-uri))))))

(define pagination-rules
  `((paginate-list *macro* .
     ,(lambda (tag code entries)
	(let* ((size (length entries))
	       (start (first-entry size))
	       (end (last-entry size))
	       (page-entries (if (= size 0)
				 '()
				 (slice entries start end))))
	  `(paginate ,code ,page-entries ,size))))
    (paginate *macro* .
     ,(lambda (tag code entries size)
	(let* ((pages (page-count size)))
	  (expand-entries code entries size))))
    (pagination-info *macro* .
     ,(lambda (tag size)
	(page-navigation size)))
    (page-link *macro* .
     ,(lambda (tag pg txt . rest)
	`(a (@ (href ,(make-uri-string pg))) ,txt)))
    ,@alist-conv-rules))
)