-
Notifications
You must be signed in to change notification settings - Fork 1
/
xml-worksheet.ss
213 lines (196 loc) · 12.2 KB
/
xml-worksheet.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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
#lang scheme/base
(require "base.ss")
(require "formula-render.ss"
"ref.ss"
"struct.ss"
"xml-cache.ss"
"xml-internal.ss")
; cache worksheet -> xml
(define (worksheet-xml cache sheet)
(xml ,standalone-header-xml
(worksheet (@ [xmlns ,spreadsheetml-namespace]
[xmlns:r ,workbook-namespace])
,(sheet-views-xml cache sheet)
,(cols-xml cache sheet)
,(sheet-data-xml cache sheet)
,(sheet-protection-xml cache sheet)
,(auto-filter-xml cache sheet)
,(cf+validation-xml cache sheet)
,(print-options-xml cache sheet)
,(print-settings-xml cache sheet))))
; cache worksheet -> xml
(define (cols-xml cache sheet)
(let ([cols (reverse (for/fold ([accum null])
([x (in-range (range-width (worksheet-data sheet)))])
(let ([width (cache-col-width-ref cache sheet x)]
[hidden (if (cache-col-visibility-ref cache sheet x) #f "true")])
(if (or width hidden)
(cons (xml (col (@ [min ,(add1 x)]
[max ,(add1 x)]
,(opt-xml-attr hidden)
,(opt-xml-attr width customWidth "true")
,(opt-xml-attr width))))
accum)
accum))))])
(if (null? cols)
(xml)
(xml (cols ,@cols)))))
; cache worksheet -> xml
(define (sheet-views-xml cache sheet)
(let ([split (worksheet-split sheet)])
(opt-xml split
,(let*-values ([(split-x split-y) (if (range? (split-position split))
(call-with-values (cut cache-address-ref cache (split-position split))
(lambda (sheet x y)
(values x y)))
(values (car (split-position split))
(cdr (split-position split))))]
[(scroll-pos) (if (range? (split-scroll-position split))
(call-with-values (cut cache-address-ref cache (split-position split))
(lambda (sheet x y)
(xy->ref x y)))
(xy->ref (car (split-position split))
(cdr (split-position split))))]
[(frozen?) (split-frozen? split)])
; The workbookViewId attribute is required but we don't actually need to set up a view in workbook.xml.
(xml (sheetViews (sheetView (@ [workbookViewId 0])
(pane (@ [xSplit ,split-x]
[ySplit ,split-y]
[topLeftCell ,scroll-pos]
[activePane "bottomRight"]
[state ,(if frozen? "frozenSplit" "split")])))))))))
; cache worksheet -> xml
(define (sheet-data-xml cache sheet)
(xml (sheetData ,@(for/list ([y (in-range (range-height (worksheet-data sheet)))])
(let ([cells (for/list ([x (in-range (range-width (worksheet-data sheet)))])
(let-values ([(cell s) (cache-value-ref cache sheet x y)])
(opt-xml s
,(let ([r (xy->ref x y)])
(if cell
(match (cell-value cell)
[#t (xml (c (@ [r ,r] [s ,s] [t "b"]) (v 1)))]
[#f (xml (c (@ [r ,r] [s ,s])))]
[(? number? n) (xml (c (@ [r ,r] [s ,s]) (v ,(exact->inexact n))))]
[(? string? str) (xml (c (@ [r ,r] [s ,s] [t "inlineStr"]) (is (t ,str))))]
[(? symbol? sym) (xml (c (@ [r ,r] [s ,s] [t "inlineStr"]) (is (t ,sym))))]
[(? bytes? byt) (xml (c (@ [r ,r] [s ,s] [t "inlineStr"]) (is (t ,byt))))]
[(? formula? f) (let ([f-str (expression->string cache sheet cell x y (formula-expr f))])
(if (formula-array? f)
(xml (c (@ [r ,r] [s ,s])
(f (@ [t "array"] [aca "true"] [ref ,r]) ,f-str)))
(xml (c (@ [r ,r] [s ,s])
(f ,f-str)))))])
(xml (c (@ [r ,r] [s ,s]))))))))])
(opt-xml (not (andmap xml-empty? cells))
,(let ([ht (cache-row-height-ref cache sheet y)]
[hidden (if (cache-row-visibility-ref cache sheet y) #f 1)])
(xml (row (@ [r ,(y->row y)]
,(opt-xml-attr hidden)
,(opt-xml-attr ht customHeight 1)
,(opt-xml-attr ht))
,@cells)))))))))
; cache worksheet -> xml
(define (sheet-protection-xml cache sheet)
(xml (sheetProtection (@ [autoFilter ,(if (worksheet-auto-filter-lock? sheet) "true" "false")]
[deleteColumns ,(if (worksheet-delete-columns-lock? sheet) "true" "false")]
[deleteRows ,(if (worksheet-delete-rows-lock? sheet) "true" "false")]
[formatCells ,(if (worksheet-format-cells-lock? sheet) "true" "false")]
[formatColumns ,(if (worksheet-format-columns-lock? sheet) "true" "false")]
[formatRows ,(if (worksheet-format-rows-lock? sheet) "true" "false")]
[insertColumns ,(if (worksheet-insert-columns-lock? sheet) "true" "false")]
[insertHyperlinks ,(if (worksheet-insert-hyperlinks-lock? sheet) "true" "false")]
[insertRows ,(if (worksheet-insert-rows-lock? sheet) "true" "false")]
[objects ,(if (worksheet-objects-lock? sheet) "true" "false")]
[pivotTables ,(if (worksheet-pivot-tables-lock? sheet) "true" "false")]
[scenarios ,(if (worksheet-scenarios-lock? sheet) "true" "false")]
[selectLockedCells ,(if (worksheet-locked-cell-selection-lock? sheet) "true" "false")]
[selectUnlockedCells ,(if (worksheet-unlocked-cell-selection-lock? sheet) "true" "false")]
[sheet ,(if (worksheet-sheet-lock? sheet) "true" "false")]
[sort ,(if (worksheet-sort-lock? sheet) "true" "false")]))))
; cache worksheet -> xml
(define (auto-filter-xml cache sheet)
(let ([filter (worksheet-auto-filter sheet)])
(opt-xml filter
,(let ([x (auto-filter-x filter)]
[y (auto-filter-y filter)]
[w (auto-filter-width filter)]
[h (auto-filter-height filter)])
(xml (autoFilter (@ [ref ,(format "~a:~a"
(xy->ref x y)
(xy->ref (sub1 (+ x w))
(sub1 (+ y h))))])))))))
; cache worksheet -> xml
(define (cf+validation-xml cache sheet)
; (box (listof xml))
(define cf-accum (box null))
(define validation-accum (box null))
(range-for-each
; range
(worksheet-data sheet)
; compose/range : range #f natural natural -> #f
(lambda (range _ x y) #f)
; compose/part : part #f -> #f
(lambda (part _) #f)
; consume! : range #f natural natural -> void
(lambda (range _ x0 y0)
(unless (null? (range-conditional-formats range))
(set-box! cf-accum (cons (conditional-format-xml cache sheet range x0 y0) (unbox cf-accum))))
(when (range-validation-rule range)
(set-box! validation-accum (cons (validation-rule-xml cache sheet range x0 y0) (unbox validation-accum)))))
; accum0 : #f
#f)
(xml ,@(reverse (unbox cf-accum))
,(opt-xml (pair? (unbox validation-accum))
(dataValidations (@ [count ,(length (unbox validation-accum))])
,@(reverse (unbox validation-accum))))))
; cache worksheet -> xml
(define (print-settings-xml cache sheet)
(match (worksheet-print-settings sheet)
[(struct print-settings (fitToWidth fitToHeight orientation headers footers _ _))
(xml (pageSetup (@ [paperSize 0] ; A4
,(opt-xml-attr fitToWidth)
,(opt-xml-attr fitToHeight)
,(opt-xml-attr orientation)
[horizontalDpi 4294967292] ; 2^32 - 4 ; goodness knows why
[verticalDpi 4294967292])) ; 2^32 - 4 ; goodness knows why
(headerFooter (oddHeader ,headers)
(oddFooter ,footers)))]
[#f (xml)]))
; cache worksheet -> xml
(define (print-options-xml cache sheet)
(match (worksheet-print-settings sheet)
[(struct print-settings (fitToWidth fitToHeight orientation headers footers horizontalCentered verticalCentered))
(opt-xml (or horizontalCentered verticalCentered)
(printOptions (@ ,(opt-xml-attr horizontalCentered horizontalCentered "true")
,(opt-xml-attr verticalCentered verticalCentered "true"))))]
[#f (xml)]))
; cache worksheet range natural natural -> xml
(define (conditional-format-xml cache sheet range x0 y0)
(xml (conditionalFormatting
(@ [sqref ,(range-address range x0 y0)])
,@(for/list ([cf (in-list (range-conditional-formats range))])
(match cf
[(struct conditional-format (formula style priority))
(xml (cfRule (@ [type "expression"]
[dxfId ,(cache-diff-style-ref cache style)]
[priority ,priority])
(formula ,(expression->string cache sheet range x0 y0 (formula-expr formula)))))])))))
; cache worksheet range natural natural -> xml
(define (validation-rule-xml cache sheet range x0 y0)
(match (range-validation-rule range)
[(struct validation-rule (formula errorStyle errorTitle error promptTitle prompt))
(xml (dataValidation
(@ [sqref ,(range-address range x0 y0)]
[type "custom"]
[allowBlank "1"]
[showInputMessage ,(if (or promptTitle prompt) "1" "0")]
[showErrorMessage ,(if (or errorTitle error) "1" "0")]
,(opt-xml-attr errorStyle)
,(opt-xml-attr errorTitle)
,(opt-xml-attr error)
,(opt-xml-attr promptTitle)
,(opt-xml-attr prompt))
(formula1 ,(expression->string cache sheet range x0 y0 (formula-expr formula)))))]))
; Provide statements -----------------------------
(provide/contract
[worksheet-xml (-> cache? worksheet? xml?)])