src/components/range-list.lisp

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