bf38ed2dc6447dafefe473840ff1a8f3c2c73e85
[clinton/lisp-on-lines.git] / src / components / range-list.lisp
1 (in-package :mewa)
2
3
4 (defgeneric make-range-list-generator (instance &key query chunk-size &allow-other-keys)
5 (:documentation "Produced generator must obeys the following interface:
6 GENERATOR (:first|:last|:next|:previous|:current &optional offset) =>
7 (ITEMS LIST)
8 GENERATOR :offset &optional (offset integer) => (new-offset integer)
9 GENERATOR :chunk-size (size integer) => (new-chunk-size integer)
10 GENERATOR :chunks => (total-number-of-chunks integer)
11 GENERATOR (:have-previous-p|:have-next-p) => (v boolean)."))
12
13 (defmethod make-range-list-generator ((instance clsql:standard-db-object) &key query (chunk-size 20) (offset 0))
14 (let ((view-class (class-of instance))
15 (current-offset offset)
16 (last-select-size 0))
17 (labels ((guess-total-size ()
18 (car
19 (apply #'clsql:select
20 (clsql:sql-count (clsql:sql-expression :attribute '*))
21 :from (clsql:sql-expression :table (slot-value view-class 'clsql:view-table))
22 (append query '(:flatp t)))))
23 (select-items (offset size)
24 (apply #'clsql:select (class-name view-class)
25 (append query
26 `(:limit ,(+ size 1) :offset ,(* (- offset 1) size) :flatp t))))
27 (chunks ()
28 (multiple-value-bind (q rem)
29 (floor (guess-total-size) chunk-size)
30 (if (zerop rem) q (+ q 1)))))
31 (lambda (cmd &optional num)
32 (setf current-offset
33 (case cmd
34 (:first 1)
35 (:last (chunks))
36 (:next (+ 1 current-offset))
37 (:previous (max 1 (- current-offset 1)))
38 ((:current :offset) (if num (max 1 num) current-offset))
39 (otherwise current-offset)))
40 (ecase cmd
41 ((:first :last :next :previous :current)
42 (let ((items (select-items current-offset chunk-size)))
43 (setf last-select-size (length items))
44 (when (> last-select-size chunk-size)
45 (nbutlast items))
46 items))
47 (:chunks (chunks))
48 (:chunk-size (when num (setf chunk-size num))
49 chunk-size)
50 (:offset current-offset)
51 (:have-previous-p (> current-offset 1))
52 (:have-next-p (> last-select-size chunk-size)))))))
53
54 (defcomponent range-list (mewa::mewa-list-presentation)
55 ((offset :accessor range-list.offset
56 :initform 0
57 :backtrack t
58 :documentation "Which of the windows we're currently looking at.")
59 (window-size :accessor range-list.window-size :initform 20 :initarg :window-size)
60 (generator :reader range-list.generator)
61 (generator-args :reader range-list.generator-args :initarg generator-args :initform nil))
62 (:documentation "Component for showing the user a set of data one \"window\" at a time.
63
64 The data set is presented one \"window\" at a time with links to
65 the the first, previous, next and last window. Each window shows
66 at most WINDOW-SIZE elements of the data.
67 The GENERATOR is used to get a data to display every time.
68 It is produced by MAKE-RANGE-LIST-GENERATOR as
69 MAKE-RANGE-LIST-GENERATOR INSTANCE :chunk-size WINDOW-SIZE GENERATOR-ARGS"))
70
71 (defmethod range-list.generator :before ((self range-list))
72 (unless (slot-boundp self 'generator)
73 (create-generator self)))
74
75 (defmethod create-generator ((self range-list) &rest args)
76 (with-slots (instance generator generator-args window-size offset)
77 self
78 (when args
79 (setf generator-args args))
80 (setf generator
81 (apply 'make-range-list-generator instance :chunk-size window-size generator-args)
82 offset 0)
83 (funcall generator :offset offset)))
84
85 (defmethod range-list.have-previous-p ((self range-list))
86 "Returns true if we have a window before the current one."
87 (funcall (range-list.generator self) :have-previous-p))
88
89 (defmethod range-list.have-next-p ((self range-list))
90 "Returns true if we have a window after the current one."
91 (funcall (range-list.generator self) :have-next-p))
92
93 (defmethod range-list.fetch-items ((self range-list) op)
94 (prog2
95 (ecase op ((:first :last :current :next :previous) t))
96 (funcall (range-list.generator self) op)
97 (setf (range-list.offset self)
98 (funcall (range-list.generator self) :offset))))
99
100 (defaction scroll ((self range-list) op)
101 (funcall (range-list.generator self) :offset (range-list.offset self))
102 (setf (mewa::instances self)
103 (range-list.fetch-items self op)))
104
105 (defaction scroll-to-page ((self range-list) window-number)
106 (setf (range-list.offset self) window-number)
107 (scroll self :current))
108
109 (defmethod present ((self range-list))
110 (when (zerop (range-list.offset self))
111 (scroll self :current))
112 (<:table :class (css-class self)
113 (<:tr
114 (<:td (call-next-method)))
115 (<:tr
116 (<:td
117 (<:table :class "range-list-navigation"
118 (<:tr
119 (<:td
120 (<ucw:a :action (scroll self :first)
121 (<:tt (<:as-html "<<"))))
122 (<:td
123 (if (range-list.have-previous-p self)
124 (<ucw:a :action (scroll self :previous)
125 (<:tt (<:as-html "<")))
126 (<:tt (<:as-html "<"))))
127 (<:td
128 (if (range-list.have-next-p self)
129 (<ucw:a :action (scroll self :next)
130 (<:tt (<:as-html ">")))
131 (<:tt (<:as-html ">"))))
132 (<:td
133 (<ucw:a :action (scroll self :last)
134 (<:tt (<:as-html ">>"))))))))))