source: project/release/4/sxml-fu/sxml-pagination.scm @ 15356

Last change on this file since 15356 was 15356, checked in by sjamaan, 11 years ago

Change explicit default/text rules to alist-conv-rules, for readability

File size: 5.1 KB
Line 
1;;; sxml-pagination.scm
2;
3; Copyright (c) 2004-2008 Peter Bex (Peter.Bex@xs4all.nl)
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions
8; are met:
9; 1. Redistributions of source code must retain the above copyright
10;    notice, this list of conditions and the following disclaimer.
11; 2. Redistributions in binary form must reproduce the above copyright
12;    notice, this list of conditions and the following disclaimer in the
13;    documentation and/or other materials provided with the distribution.
14; 3. Neither the name of Peter Bex nor the names of any contributors may
15;    be used to endorse or promote products derived from this software
16;    without specific prior written permission.
17;
18; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
19; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
22; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
27; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
28; SUCH DAMAGE.
29
30(module sxml-pagination
31  (page-var page-size base-uri determine-page page-count first-entry
32   last-entry pagination-rules)
33
34(import chicken scheme extras data-structures)
35
36(require-extension sxml-transforms srfi-1 srfi-13 uri-common)
37
38;; Variable fetching and link generation should be done differently
39(define page-size (make-parameter 20))
40(define page-var (make-parameter 'page))
41(define base-uri (make-parameter (uri-reference "")))
42
43;; Always returns a good page
44(define (determine-page len)
45  (let ((page (inexact->exact
46               (or (string->number
47                    (or (alist-ref (page-var) (uri-query (base-uri))) "1"))
48                   1))))
49    (cond
50     ((< page 1) 1)
51     ((<= len (* (page-size) (sub1 page))) (page-count len))
52     (else page))))
53
54(define (page-count len)
55  (inexact->exact (ceiling (/ len (page-size)))))
56
57(define (first-entry nentries . rest)
58  (* (page-size) (sub1 (determine-page nentries))))
59
60(define (last-entry nentries . rest)
61  (sub1 (min (+ (first-entry nentries (page-size)) (page-size))
62             nentries)))
63
64;; Utils
65(define (slice list first last)
66  (take (drop list first) (- last first -1)))
67
68(define (expand-entries code entries size)
69  (pre-post-order
70   code
71   `((entries . ,(lambda (tag code)
72                   (map (lambda (entry)
73                          (pre-post-order
74                           code
75                           `((entry . ,(lambda (tag)
76                                         (if (promise? entry)
77                                             (force entry)
78                                             entry)))
79                             (*default* . ,(lambda code code))
80                             (*text* . ,(lambda (text string) string)))))
81                        entries)))
82     (pagination-links . ,(lambda (tag)
83                            `(pagination-info ,size)))
84     (current-page . ,(lambda (tag)
85                        (determine-page size)))
86     (page-count . ,(lambda (tag)
87                      (page-count size)))
88     (last-entry . ,(lambda (tag)
89                      (last-entry size)))
90     (first-entry . ,(lambda (tag)
91                       (first-entry size)))
92     (*text* . ,(lambda (text string) string))
93     (*default* . ,(lambda code code)))))
94
95;; This is a long mofo.  I don't really see a way to make it shorter, though
96(define (page-navigation nentries)
97  (if (<= nentries (page-size))
98      '()
99      (let ((pages (page-count nentries))
100            (pagenr (determine-page nentries)))
101        `(ol (@ (class "page-navigation"))
102             (li (@ (class "first"))
103                 ,(if (> pagenr 1)
104                      `(page-link 1 "<<")
105                      "<<"))
106             (li (@ (class "prev"))
107                 ,(if (> pagenr 1)
108                      `(page-link ,(sub1 pagenr) "<")
109                      "<"))
110             ,(map (lambda (nr)
111                     (if (= nr pagenr)
112                         `(li ,nr)
113                         `(li (page-link ,nr ,nr))))
114                   (iota pages 1))
115             (li (@ (class "next"))
116                 ,(if (< pagenr pages)
117                      `(page-link ,(add1 pagenr) ">")
118                      ">"))
119             (li (@ (class "last"))
120                 ,(if (< pagenr pages)
121                      `(page-link ,pages ">>")
122                      ">>"))))))
123
124(define (make-uri-string pg)
125  (uri->string (update-uri (base-uri)
126                           query: (alist-update! (page-var)
127                                                 (number->string pg)
128                                                 (uri-query (base-uri))))))
129
130(define pagination-rules
131  `((paginate-list *macro* .
132     ,(lambda (tag code entries)
133        (let* ((size (length entries))
134               (start (first-entry size))
135               (end (last-entry size))
136               (page-entries (if (= size 0)
137                                 '()
138                                 (slice entries start end))))
139          `(paginate ,code ,page-entries ,size))))
140    (paginate *macro* .
141     ,(lambda (tag code entries size)
142        (let* ((pages (page-count size)))
143          (expand-entries code entries size))))
144    (pagination-info *macro* .
145     ,(lambda (tag size)
146        (page-navigation size)))
147    (page-link *macro* .
148     ,(lambda (tag pg txt . rest)
149        `(a (@ (href ,(make-uri-string pg))) ,txt)))
150    ,@alist-conv-rules))
151)
Note: See TracBrowser for help on using the repository browser.