Coverage report: /home/ati/workspace/perec/query/scroll.lisp

Kind	Covered	All	%
expression	50	112	44.6
branch	11	14	78.6

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

2

;;;

3

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

;;; ---------------------------------------------------------------------------

10

11

(defclass* scroll ()

12

())

13

14

(defgeneric elements (scroll)

15

(:documentation "Return the elements on the current page"))

16

17

(defgeneric page (scroll))

18

(defgeneric (setf page) (page scroll)

19

(:method :around (page (scroll scroll))

20

(declare (cl:type integer page))

21

;; TODO: why isn't it an error?

22

(when (< page 0)

23

(setf page 0))

24

(unless (= page (page scroll))

25

(call-next-method page scroll))))

26

27

(defgeneric page-size (scroll))

28

(defgeneric (setf page-size) (page-size scroll))

29

30

(defgeneric first-page! (scroll)

31

(:method ((scroll scroll))

32

(setf (page scroll) 0)))

33

34

(defgeneric next-page! (scroll)

35

(:method ((scroll scroll))

36

(incf (page scroll)))

37

(:documentation "Should return the current page number or nil if there are no more pages."))

38

39

(defgeneric previous-page! (scroll)

40

(:method ((scroll scroll))

41

(decf (page scroll))))

42

43

(defgeneric revive-scroll! (scroll)

44

(:method ((scroll scroll))

45

(values))

46

(:documentation "Revives the cache objects of the scroll in the current transaction."))

47

48

;;; ---------------------------------------------------------------------------

49

50

(defclass* fixed-size-scroll (scroll)

51

())

52

53

(defgeneric page-count (fixed-size-scroll))

54

55

(defgeneric element-count (fixed-size-scroll))

56

57

(defgeneric last-page! (scroll)

58

(:method ((scroll fixed-size-scroll))

59

(setf (page scroll) (1- (page-count scroll)))))

60

61

(defmethod next-page! :around ((scroll fixed-size-scroll))

62

(if (< (page scroll) (1- (page-count scroll)))

63

(call-next-method)

64

nil))

65

66

(defmethod (setf page) :around (page (scroll fixed-size-scroll))

67

(declare (cl:type integer page))

68

(bind ((page-count (page-count scroll)))

69

(when (>= page page-count)

70

(setf page (1- page-count)))

71

(when (/= page (page scroll))

72

(call-next-method page scroll))))

73

74

(defmethod revive-scroll! :after ((scroll fixed-size-scroll))

75

(when (>= (page scroll) (page-count scroll))

76

(last-page! scroll)))

77

78

;;; ---------------------------------------------------------------------------

79

80

(defclass* simple-scroll (fixed-size-scroll)

81

((elements #() :type vector)

82

(page 0 :accessor page :type integer)

83

(page-size 10 :accessor page-size :type integer))

84

(:documentation "Provides the fixed-size-scroll interface for a vector of elements."))

85

86

(defmethod initialize-instance :around ((scroll simple-scroll)

87

&rest args

88

&key page page-size elements

89

&allow-other-keys)

90

(remf-keywords args :elements)

91

(setf elements (coerce elements 'vector))

92

(apply #'call-next-method scroll :elements elements args)

93

;; send them through the standard setters for sanity checks

94

(when page-size

95

(setf (page-size scroll) page-size))

96

(when page

97

(setf (page scroll) page)))

98

99

(defmethod element-count ((scroll simple-scroll))

100

(length (elements-of scroll)))

101

102

(defmethod page-count ((scroll simple-scroll))

103

(values (ceiling (/ (element-count scroll) (page-size scroll)))))

104

105

(defmethod elements ((scroll simple-scroll))

106

(bind ((page-size (page-size scroll))

107

(page (page scroll))

108

(start-offset (* page page-size))

109

(end-offset (min (* (1+ page) page-size)

110

(element-count scroll))))

111

112

(make-array (- end-offset start-offset)

113

:displaced-to (elements-of scroll)

114

:displaced-index-offset start-offset)))