-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathreport-column.ss
169 lines (142 loc) · 6.33 KB
/
report-column.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
#lang scheme/base
(require "base.ss")
(require srfi/13
(prefix-in sql- (snooze-in sql/sql-struct))
(unlib-in symbol))
; Structure types --------------------------------
; (struct symbol string xml boolean (listof (U symbol string)))
(define snooze-report-column%
(class/cells object/cells% ()
; (cell symbol)
;
; A unique (page-wide) identifier for the column.
; Used for HTML IDs and sort callbacks.
(init-cell id #:accessor #:mutator)
; (cell string)
;
; The printed name of the column in string format.
(init-cell string-name #:accessor #:mutator)
; (cell (U xml #f))
;
; The printed name of the column in xml format:
; the default value of #f causes the default accessor
; to return (xml ,(get-string-name)).
(init-cell xml-name #f #:mutator)
; (cell (listof (U symbol string)))
;
; A list of CSS classes to apply to head cells in this column.
(init-cell classes '(ui-widget-header) #:accessor #:mutator)
; (cell boolean)
;
; Should this column be displayed in the HTML version of the report?
(init-cell display-in-html? #t #:accessor #:mutator)
; (cell boolean)
;
; Should this column be displayed in the CSV version of the report?
(init-cell display-in-csv? #t #:accessor #:mutator)
; (cell (listof order))
;
; A sample SQL order statement to use when the report
; is sorted by this column in ascending order.
;
; The reverse order is automatically generated by default
; by reversing each component in the sample.
(init-cell order null #:mutator)
; Constructor --------------------------------
; Methods ------------------------------------
; (U 'asc 'desc) -> (listof order)
(define/public (get-order dir)
(if (eq? dir 'asc)
(web-cell-ref order-cell)
(reverse-order (web-cell-ref order-cell))))
; -> boolean
(define/public (get-sortable?)
(and (pair? (get-order 'asc)) #t))
; -> symbol
(define/public (get-sort-id)
(and (pair? (get-order 'asc))
(symbol-append (get-id) '-sort)))
; -> xml
(define/public (get-xml-name)
(or (web-cell-ref xml-name-cell)
(xml ,(get-string-name))))
; seed -> xml
(define/public (render-col-tag seed)
(xml (col (@ [classes ,(format-classes (get-classes))]))))
; seed (U 'asc 'desc #f) -> xml
(define/public (render-head seed sort-dir)
(let* ([id (get-id)] ; symbol
[classes (get-classes)] ; (listof (U symbol string))
[sortable? (get-sortable?)] ; boolean
[sort-id (and sortable? (get-sort-id))] ; (U symbol #f)
[title (and sortable? ; (U string #f)
(case sort-dir
[(asc) "Click to sort by this column; currently in ascending order."]
[(desc) "Click to sort by this column; currently in descending order."]
[else "Click to sort by this column."]))])
(xml (th (@ [class ,(if sortable?
(case sort-dir
[(asc) (format-classes (list* 'sort 'asc 'ui-state-active classes))]
[(desc) (format-classes (list* 'sort 'desc 'ui-state-active classes))]
[(#f) (format-classes (list* 'sort 'ui-state-default classes))])
(format-classes (list* 'not-sortable 'ui-state-default classes)))])
,(if sortable?
(xml (a (@ ,(opt-xml-attr sort-id id sort-id)
[title ,title])
; optional sorting arrows
,(opt-xml sortable?
(span (@ [class ,(case sort-dir
[(asc) "sort-icon ui-icon ui-icon-triangle-1-n"]
[(desc) "sort-icon ui-icon ui-icon-triangle-1-s"]
[(#f) "sort-icon ui-icon ui-icon-carat-2-n-s"])])))
,(get-xml-name)))
(xml (span (@ [class 'not-sortable])
,(get-xml-name))))))))
(define/public (render-head/csv)
(csv:cell (get-string-name)))))
; Procedures -------------------------------------
; symbol
; string
; (U (listof order) #f)
; [#:xml-name xml]
; [#:classes (listof (U symbol string))]
; [#:display-in-html? boolean]
; [#:display-in-csv? boolean]
; ->
; column
(define (make-column id
string-name
[order #f]
#:xml-name [xml-name (xml ,string-name)]
#:classes [classes null]
#:display-in-html? [display-in-html? #t]
#:display-in-csv? [display-in-csv? #t])
(new snooze-report-column%
[id id]
[string-name string-name]
[xml-name xml-name]
[classes classes]
[display-in-html? display-in-html?]
[display-in-csv? display-in-csv?]
[order (or order null)]))
; Helpers ----------------------------------------
; (listof (U string symbol)) -> string
(define (format-classes classes)
(string-join (map (cut format "~a" <>) classes) " "))
; (listof order) -> (listof order)
(define (reverse-order order)
(for/list ([order (in-list order)])
(sql-make-order (sql-order-expression order)
(if (eq? (sql-order-direction order) 'asc)
'desc
'asc))))
; Provide statements -----------------------------
(provide/contract
[snooze-report-column% class?]
[make-column (->* (symbol? string?)
((or/c (listof sql-order?) false/c)
#:xml-name xml?
#:classes (listof (or/c symbol? string?))
#:display-in-html? boolean?
#:display-in-csv? boolean?)
(is-a?/c snooze-report-column%))])