Commit | Line | Data |
---|---|---|
d0f3a672 MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | |
c73e554c | 3 | ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> |
d0f3a672 MO |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (gnu installer newt page) | |
29d8d919 | 21 | #:use-module (gnu installer utils) |
d0f3a672 MO |
22 | #:use-module (gnu installer newt utils) |
23 | #:use-module (guix i18n) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (ice-9 receive) | |
29d8d919 MO |
26 | #:use-module (srfi srfi-1) |
27 | #:use-module (srfi srfi-26) | |
d0f3a672 MO |
28 | #:use-module (newt) |
29 | #:export (draw-info-page | |
30 | draw-connecting-page | |
31 | run-input-page | |
32 | run-error-page | |
c73e554c | 33 | run-confirmation-page |
d0f3a672 | 34 | run-listbox-selection-page |
29d8d919 MO |
35 | run-scale-page |
36 | run-checkbox-tree-page | |
37 | run-file-textbox-page)) | |
d0f3a672 MO |
38 | |
39 | ;;; Commentary: | |
40 | ;;; | |
41 | ;;; Some helpers around guile-newt to draw or run generic pages. The | |
42 | ;;; difference between 'draw' and 'run' terms comes from newt library. A page | |
43 | ;;; is drawn when the form it contains does not expect any user | |
44 | ;;; interaction. In that case, it is necessary to call (newt-refresh) to force | |
45 | ;;; the page to be displayed. When a form is 'run', it is blocked waiting for | |
46 | ;;; any action from the user (press a button, input some text, ...). | |
47 | ;;; | |
48 | ;;; Code: | |
49 | ||
50 | (define (draw-info-page text title) | |
51 | "Draw an informative page with the given TEXT as content. Set the title of | |
52 | this page to TITLE." | |
53 | (let* ((text-box | |
54 | (make-reflowed-textbox -1 -1 text 40 | |
55 | #:flags FLAG-BORDER)) | |
56 | (grid (make-grid 1 1)) | |
57 | (form (make-form))) | |
58 | (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) | |
59 | (add-component-to-form form text-box) | |
60 | (make-wrapped-grid-window grid title) | |
61 | (draw-form form) | |
62 | ;; This call is imperative, otherwise the form won't be displayed. See the | |
63 | ;; explanation in the above commentary. | |
64 | (newt-refresh) | |
65 | form)) | |
66 | ||
67 | (define (draw-connecting-page service-name) | |
68 | "Draw a page to indicate a connection in in progress." | |
69 | (draw-info-page | |
70 | (format #f (G_ "Connecting to ~a, please wait.") service-name) | |
71 | (G_ "Connection in progress"))) | |
72 | ||
73 | (define* (run-input-page text title | |
74 | #:key | |
75 | (allow-empty-input? #f) | |
29d8d919 | 76 | (default-text #f) |
d0f3a672 MO |
77 | (input-field-width 40)) |
78 | "Run a page to prompt user for an input. The given TEXT will be displayed | |
79 | above the input field. The page title is set to TITLE. Unless | |
80 | allow-empty-input? is set to #t, an error page will be displayed if the user | |
81 | enters an empty input." | |
82 | (let* ((text-box | |
83 | (make-reflowed-textbox -1 -1 text | |
84 | input-field-width | |
85 | #:flags FLAG-BORDER)) | |
86 | (grid (make-grid 1 3)) | |
87 | (input-entry (make-entry -1 -1 20)) | |
ebb36dec | 88 | (ok-button (make-button -1 -1 (G_ "OK"))) |
d0f3a672 MO |
89 | (form (make-form))) |
90 | ||
29d8d919 MO |
91 | (when default-text |
92 | (set-entry-text input-entry default-text)) | |
93 | ||
d0f3a672 MO |
94 | (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) |
95 | (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry | |
96 | #:pad-top 1) | |
97 | (set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button | |
98 | #:pad-top 1) | |
99 | ||
100 | (add-components-to-form form text-box input-entry ok-button) | |
101 | (make-wrapped-grid-window grid title) | |
102 | (let ((error-page (lambda () | |
d700d131 | 103 | (run-error-page (G_ "Please enter a non empty input.") |
d0f3a672 MO |
104 | (G_ "Empty input"))))) |
105 | (let loop () | |
106 | (receive (exit-reason argument) | |
107 | (run-form form) | |
108 | (let ((input (entry-value input-entry))) | |
109 | (if (and (not allow-empty-input?) | |
110 | (eq? exit-reason 'exit-component) | |
111 | (string=? input "")) | |
112 | (begin | |
113 | ;; Display the error page. | |
114 | (error-page) | |
115 | ;; Set the focus back to the input input field. | |
116 | (set-current-component form input-entry) | |
117 | (loop)) | |
118 | (begin | |
119 | (destroy-form-and-pop form) | |
120 | input)))))))) | |
121 | ||
122 | (define (run-error-page text title) | |
123 | "Run a page to inform the user of an error. The page contains the given TEXT | |
124 | to explain the error and an \"OK\" button to acknowledge the error. The title | |
125 | of the page is set to TITLE." | |
126 | (let* ((text-box | |
127 | (make-reflowed-textbox -1 -1 text 40 | |
128 | #:flags FLAG-BORDER)) | |
129 | (grid (make-grid 1 2)) | |
ebb36dec | 130 | (ok-button (make-button -1 -1 "OK")) |
d0f3a672 MO |
131 | (form (make-form))) |
132 | ||
133 | (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) | |
134 | (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button | |
135 | #:pad-top 1) | |
136 | ||
137 | ;; Set the background color to red to indicate something went wrong. | |
138 | (newt-set-color COLORSET-ROOT "white" "red") | |
139 | (add-components-to-form form text-box ok-button) | |
140 | (make-wrapped-grid-window grid title) | |
141 | (run-form form) | |
142 | ;; Restore the background to its original color. | |
143 | (newt-set-color COLORSET-ROOT "white" "blue") | |
144 | (destroy-form-and-pop form))) | |
145 | ||
c73e554c LC |
146 | (define* (run-confirmation-page text title |
147 | #:key (exit-button-procedure (const #f))) | |
148 | "Run a page to inform the user of an error. The page contains the given TEXT | |
149 | to explain the error and an \"OK\" button to acknowledge the error. The title | |
150 | of the page is set to TITLE." | |
151 | (let* ((text-box | |
152 | (make-reflowed-textbox -1 -1 text 40 | |
153 | #:flags FLAG-BORDER)) | |
154 | (ok-button (make-button -1 -1 (G_ "Continue"))) | |
155 | (exit-button (make-button -1 -1 (G_ "Exit"))) | |
156 | (grid (vertically-stacked-grid | |
157 | GRID-ELEMENT-COMPONENT text-box | |
158 | GRID-ELEMENT-SUBGRID | |
159 | (horizontal-stacked-grid | |
160 | GRID-ELEMENT-COMPONENT ok-button | |
161 | GRID-ELEMENT-COMPONENT exit-button))) | |
162 | (form (make-form))) | |
163 | ||
164 | (add-form-to-grid grid form #t) | |
165 | (make-wrapped-grid-window grid title) | |
166 | ||
167 | (receive (exit-reason argument) | |
168 | (run-form form) | |
169 | (dynamic-wind | |
170 | (const #t) | |
171 | (lambda () | |
172 | (case exit-reason | |
173 | ((exit-component) | |
174 | (cond | |
175 | ((components=? argument ok-button) | |
176 | #t) | |
177 | ((components=? argument exit-button) | |
178 | (exit-button-procedure)))))) | |
179 | (lambda () | |
180 | (destroy-form-and-pop form)))))) | |
181 | ||
d0f3a672 MO |
182 | (define* (run-listbox-selection-page #:key |
183 | info-text | |
184 | title | |
185 | (info-textbox-width 50) | |
186 | listbox-items | |
187 | listbox-item->text | |
188 | (listbox-height 20) | |
189 | (listbox-default-item #f) | |
190 | (listbox-allow-multiple? #f) | |
191 | (sort-listbox-items? #t) | |
29d8d919 MO |
192 | (allow-delete? #f) |
193 | (skip-item-procedure? | |
194 | (const #f)) | |
d0f3a672 MO |
195 | button-text |
196 | (button-callback-procedure | |
197 | (const #t)) | |
29d8d919 MO |
198 | (button2-text #f) |
199 | (button2-callback-procedure | |
200 | (const #t)) | |
d0f3a672 | 201 | (listbox-callback-procedure |
29d8d919 MO |
202 | identity) |
203 | (hotkey-callback-procedure | |
d0f3a672 MO |
204 | (const #t))) |
205 | "Run a page asking the user to select an item in a listbox. The page | |
206 | contains, stacked vertically from the top to the bottom, an informative text | |
207 | set to INFO-TEXT, a listbox and a button. The listbox will be filled with | |
208 | LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT | |
209 | on every item. The selected item from LISTBOX-ITEMS is returned. The button | |
210 | text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called | |
211 | when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an | |
212 | item from the listbox is selected (by pressing the <ENTER> key). | |
213 | ||
214 | INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be | |
215 | displayed. LISTBOX-HEIGHT is the height of the listbox. | |
216 | ||
217 | If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in | |
218 | LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of | |
219 | the listbox is selected. | |
220 | ||
221 | If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can | |
222 | be selected (using the <SPACE> key). It that case, a list containing the | |
223 | selected items will be returned. | |
224 | ||
225 | If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using | |
29d8d919 MO |
226 | 'string<=' procedure (after being converted to text). |
227 | ||
228 | If ALLOW-DELETE? is #t, the form will return if the <DELETE> key is pressed, | |
b83e4a93 | 229 | otherwise nothing will happen. |
29d8d919 MO |
230 | |
231 | Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the | |
232 | current listbox item as argument. If it returns #t, skip the element and jump | |
233 | to the next/previous one depending on the previous item, otherwise do | |
234 | nothing." | |
d0f3a672 MO |
235 | |
236 | (define (fill-listbox listbox items) | |
237 | "Append the given ITEMS to LISTBOX, once they have been converted to text | |
238 | with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by | |
239 | newt. Save this key by returning an association list under the form: | |
240 | ||
241 | ((NEWT-LISTBOX-KEY . ITEM) ...) | |
242 | ||
243 | where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when | |
244 | ITEM was inserted into LISTBOX." | |
245 | (map (lambda (item) | |
246 | (let* ((text (listbox-item->text item)) | |
247 | (key (append-entry-to-listbox listbox text))) | |
248 | (cons key item))) | |
249 | items)) | |
250 | ||
251 | (define (sort-listbox-items listbox-items) | |
252 | "Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text | |
253 | corresponding to each item in the list." | |
254 | (let* ((items (map (lambda (item) | |
255 | (cons item (listbox-item->text item))) | |
256 | listbox-items)) | |
257 | (sorted-items | |
258 | (sort items (lambda (a b) | |
259 | (let ((text-a (cdr a)) | |
260 | (text-b (cdr b))) | |
261 | (string<= text-a text-b)))))) | |
262 | (map car sorted-items))) | |
263 | ||
29d8d919 MO |
264 | ;; Store the last selected listbox item's key. |
265 | (define last-listbox-key (make-parameter #f)) | |
266 | ||
267 | (define (previous-key keys key) | |
268 | (let ((index (list-index (cut eq? key <>) keys))) | |
269 | (and index | |
270 | (> index 0) | |
271 | (list-ref keys (- index 1))))) | |
272 | ||
273 | (define (next-key keys key) | |
274 | (let ((index (list-index (cut eq? key <>) keys))) | |
275 | (and index | |
276 | (< index (- (length keys) 1)) | |
277 | (list-ref keys (+ index 1))))) | |
278 | ||
d0f3a672 MO |
279 | (define (set-default-item listbox listbox-keys default-item) |
280 | "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the | |
281 | association list returned by the FILL-LISTBOX procedure. It is used because | |
282 | the current listbox item has to be selected by key." | |
283 | (for-each (match-lambda | |
284 | ((key . item) | |
285 | (when (equal? item default-item) | |
286 | (set-current-listbox-entry-by-key listbox key)))) | |
287 | listbox-keys)) | |
288 | ||
289 | (let* ((listbox (make-listbox | |
290 | -1 -1 | |
291 | listbox-height | |
292 | (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT | |
293 | (if listbox-allow-multiple? | |
294 | FLAG-MULTIPLE | |
295 | 0)))) | |
296 | (form (make-form)) | |
297 | (info-textbox | |
298 | (make-reflowed-textbox -1 -1 info-text | |
299 | info-textbox-width | |
300 | #:flags FLAG-BORDER)) | |
301 | (button (make-button -1 -1 button-text)) | |
29d8d919 MO |
302 | (button2 (and button2-text |
303 | (make-button -1 -1 button2-text))) | |
d0f3a672 MO |
304 | (grid (vertically-stacked-grid |
305 | GRID-ELEMENT-COMPONENT info-textbox | |
306 | GRID-ELEMENT-COMPONENT listbox | |
29d8d919 MO |
307 | GRID-ELEMENT-SUBGRID |
308 | (apply | |
309 | horizontal-stacked-grid | |
310 | GRID-ELEMENT-COMPONENT button | |
311 | `(,@(if button2 | |
312 | (list GRID-ELEMENT-COMPONENT button2) | |
313 | '()))))) | |
d0f3a672 MO |
314 | (sorted-items (if sort-listbox-items? |
315 | (sort-listbox-items listbox-items) | |
316 | listbox-items)) | |
317 | (keys (fill-listbox listbox sorted-items))) | |
318 | ||
29d8d919 MO |
319 | ;; On every listbox element change, check if we need to skip it. If yes, |
320 | ;; depending on the 'last-listbox-key', jump forward or backward. If no, | |
321 | ;; do nothing. | |
322 | (add-component-callback | |
323 | listbox | |
324 | (lambda (component) | |
325 | (let* ((current-key (current-listbox-entry listbox)) | |
326 | (listbox-keys (map car keys)) | |
327 | (last-key (last-listbox-key)) | |
328 | (item (assoc-ref keys current-key)) | |
329 | (prev-key (previous-key listbox-keys current-key)) | |
330 | (next-key (next-key listbox-keys current-key))) | |
331 | ;; Update last-listbox-key before a potential call to | |
332 | ;; set-current-listbox-entry-by-key, because it will immediately | |
333 | ;; cause this callback to be called for the new entry. | |
334 | (last-listbox-key current-key) | |
335 | (when (skip-item-procedure? item) | |
336 | (when (eq? prev-key last-key) | |
337 | (if next-key | |
338 | (set-current-listbox-entry-by-key listbox next-key) | |
339 | (set-current-listbox-entry-by-key listbox prev-key))) | |
340 | (when (eq? next-key last-key) | |
341 | (if prev-key | |
342 | (set-current-listbox-entry-by-key listbox prev-key) | |
343 | (set-current-listbox-entry-by-key listbox next-key))))))) | |
344 | ||
d0f3a672 MO |
345 | (when listbox-default-item |
346 | (set-default-item listbox keys listbox-default-item)) | |
347 | ||
29d8d919 MO |
348 | (when allow-delete? |
349 | (form-add-hotkey form KEY-DELETE)) | |
350 | ||
d0f3a672 MO |
351 | (add-form-to-grid grid form #t) |
352 | (make-wrapped-grid-window grid title) | |
353 | ||
354 | (receive (exit-reason argument) | |
355 | (run-form form) | |
356 | (dynamic-wind | |
357 | (const #t) | |
358 | (lambda () | |
29d8d919 MO |
359 | (case exit-reason |
360 | ((exit-component) | |
361 | (cond | |
362 | ((components=? argument button) | |
363 | (button-callback-procedure)) | |
364 | ((and button2 | |
365 | (components=? argument button2)) | |
366 | (button2-callback-procedure)) | |
367 | ((components=? argument listbox) | |
368 | (if listbox-allow-multiple? | |
369 | (let* ((entries (listbox-selection listbox)) | |
370 | (items (map (lambda (entry) | |
371 | (assoc-ref keys entry)) | |
372 | entries))) | |
373 | (listbox-callback-procedure items)) | |
374 | (let* ((entry (current-listbox-entry listbox)) | |
375 | (item (assoc-ref keys entry))) | |
376 | (listbox-callback-procedure item)))))) | |
377 | ((exit-hotkey) | |
378 | (let* ((entry (current-listbox-entry listbox)) | |
379 | (item (assoc-ref keys entry))) | |
380 | (hotkey-callback-procedure argument item))))) | |
d0f3a672 MO |
381 | (lambda () |
382 | (destroy-form-and-pop form)))))) | |
383 | ||
384 | (define* (run-scale-page #:key | |
385 | title | |
386 | info-text | |
387 | (info-textbox-width 50) | |
388 | (scale-width 40) | |
389 | (scale-full-value 100) | |
390 | scale-update-proc | |
391 | (max-scale-update 5)) | |
392 | "Run a page with a progress bar (called 'scale' in newt). The given | |
393 | INFO-TEXT is displayed in a textbox above the scale. The width of the textbox | |
394 | is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to | |
395 | SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of | |
396 | the scale. | |
397 | ||
398 | The procedure SCALE-UPDATE-PROC shall return a new scale | |
399 | value. SCALE-UPDATE-PROC will be called until the returned value is superior | |
400 | or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An | |
401 | error is raised if the MAX-SCALE-UPDATE limit is reached." | |
402 | (let* ((info-textbox | |
403 | (make-reflowed-textbox -1 -1 info-text | |
404 | info-textbox-width | |
405 | #:flags FLAG-BORDER)) | |
406 | (scale (make-scale -1 -1 scale-width scale-full-value)) | |
407 | (grid (vertically-stacked-grid | |
408 | GRID-ELEMENT-COMPONENT info-textbox | |
409 | GRID-ELEMENT-COMPONENT scale)) | |
410 | (form (make-form))) | |
411 | ||
412 | (add-form-to-grid grid form #t) | |
413 | (make-wrapped-grid-window grid title) | |
414 | ||
415 | (draw-form form) | |
416 | ;; This call is imperative, otherwise the form won't be displayed. See the | |
417 | ;; explanation in the above commentary. | |
418 | (newt-refresh) | |
419 | ||
420 | (dynamic-wind | |
421 | (const #t) | |
422 | (lambda () | |
423 | (let loop ((i max-scale-update) | |
424 | (last-value 0)) | |
425 | (let ((value (scale-update-proc last-value))) | |
426 | (set-scale-value scale value) | |
427 | ;; Same as above. | |
428 | (newt-refresh) | |
429 | (unless (>= value scale-full-value) | |
430 | (if (> i 0) | |
431 | (loop (- i 1) value) | |
432 | (error "Max scale updates reached.")))))) | |
433 | (lambda () | |
434 | (destroy-form-and-pop form))))) | |
29d8d919 MO |
435 | |
436 | (define* (run-checkbox-tree-page #:key | |
437 | info-text | |
438 | title | |
439 | items | |
440 | item->text | |
441 | (info-textbox-width 50) | |
442 | (checkbox-tree-height 10) | |
443 | (ok-button-callback-procedure | |
444 | (const #t)) | |
7d812901 | 445 | (exit-button-callback-procedure |
29d8d919 MO |
446 | (const #t))) |
447 | "Run a page allowing the user to select one or multiple items among ITEMS in | |
448 | a checkbox list. The page contains vertically stacked from the top to the | |
449 | bottom, an informative text set to INFO-TEXT, the checkbox list and two | |
7d812901 | 450 | buttons, 'Ok' and 'Exit'. The page title's is set to TITLE. ITEMS are |
29d8d919 MO |
451 | converted to text using ITEM->TEXT before being displayed in the checkbox |
452 | list. | |
453 | ||
454 | INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be | |
455 | displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list. | |
456 | ||
457 | OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed. | |
7d812901 | 458 | EXIT-BUTTON-CALLBACK-PROCEDURE is called when the 'Exit' button is |
29d8d919 MO |
459 | pressed. |
460 | ||
461 | This procedure returns the list of checked items in the checkbox list among | |
462 | ITEMS when 'Ok' is pressed." | |
463 | (define (fill-checkbox-tree checkbox-tree items) | |
464 | (map | |
465 | (lambda (item) | |
466 | (let* ((item-text (item->text item)) | |
467 | (key (add-entry-to-checkboxtree checkbox-tree item-text 0))) | |
468 | (cons key item))) | |
469 | items)) | |
470 | ||
471 | (let* ((checkbox-tree | |
472 | (make-checkboxtree -1 -1 | |
473 | checkbox-tree-height | |
474 | FLAG-BORDER)) | |
475 | (info-textbox | |
476 | (make-reflowed-textbox -1 -1 info-text | |
477 | info-textbox-width | |
478 | #:flags FLAG-BORDER)) | |
ebb36dec | 479 | (ok-button (make-button -1 -1 (G_ "OK"))) |
7d812901 | 480 | (exit-button (make-button -1 -1 (G_ "Exit"))) |
29d8d919 MO |
481 | (grid (vertically-stacked-grid |
482 | GRID-ELEMENT-COMPONENT info-textbox | |
483 | GRID-ELEMENT-COMPONENT checkbox-tree | |
484 | GRID-ELEMENT-SUBGRID | |
485 | (horizontal-stacked-grid | |
486 | GRID-ELEMENT-COMPONENT ok-button | |
7d812901 | 487 | GRID-ELEMENT-COMPONENT exit-button))) |
29d8d919 MO |
488 | (keys (fill-checkbox-tree checkbox-tree items)) |
489 | (form (make-form))) | |
490 | ||
491 | (add-form-to-grid grid form #t) | |
492 | (make-wrapped-grid-window grid title) | |
493 | ||
494 | (receive (exit-reason argument) | |
495 | (run-form form) | |
496 | (dynamic-wind | |
497 | (const #t) | |
498 | (lambda () | |
499 | (case exit-reason | |
500 | ((exit-component) | |
501 | (cond | |
502 | ((components=? argument ok-button) | |
503 | (let* ((entries (current-checkbox-selection checkbox-tree)) | |
504 | (current-items (map (lambda (entry) | |
505 | (assoc-ref keys entry)) | |
506 | entries))) | |
507 | (ok-button-callback-procedure) | |
508 | current-items)) | |
7d812901 MO |
509 | ((components=? argument exit-button) |
510 | (exit-button-callback-procedure)))))) | |
29d8d919 MO |
511 | (lambda () |
512 | (destroy-form-and-pop form)))))) | |
513 | ||
514 | (define* (run-file-textbox-page #:key | |
515 | info-text | |
516 | title | |
517 | file | |
518 | (info-textbox-width 50) | |
519 | (file-textbox-width 50) | |
520 | (file-textbox-height 30) | |
3d0f6a05 | 521 | (exit-button? #t) |
29d8d919 MO |
522 | (ok-button-callback-procedure |
523 | (const #t)) | |
7d812901 | 524 | (exit-button-callback-procedure |
29d8d919 MO |
525 | (const #t))) |
526 | (let* ((info-textbox | |
527 | (make-reflowed-textbox -1 -1 info-text | |
528 | info-textbox-width | |
529 | #:flags FLAG-BORDER)) | |
530 | (file-text (read-all file)) | |
531 | (file-textbox | |
532 | (make-textbox -1 -1 | |
533 | file-textbox-width | |
534 | file-textbox-height | |
535 | (logior FLAG-SCROLL FLAG-BORDER))) | |
ebb36dec | 536 | (ok-button (make-button -1 -1 (G_ "OK"))) |
7d812901 | 537 | (exit-button (make-button -1 -1 (G_ "Exit"))) |
29d8d919 MO |
538 | (grid (vertically-stacked-grid |
539 | GRID-ELEMENT-COMPONENT info-textbox | |
540 | GRID-ELEMENT-COMPONENT file-textbox | |
541 | GRID-ELEMENT-SUBGRID | |
3d0f6a05 MO |
542 | (apply |
543 | horizontal-stacked-grid | |
29d8d919 | 544 | GRID-ELEMENT-COMPONENT ok-button |
3d0f6a05 MO |
545 | `(,@(if exit-button? |
546 | (list GRID-ELEMENT-COMPONENT exit-button) | |
547 | '()))))) | |
29d8d919 MO |
548 | (form (make-form))) |
549 | ||
550 | (set-textbox-text file-textbox file-text) | |
551 | (add-form-to-grid grid form #t) | |
552 | (make-wrapped-grid-window grid title) | |
553 | ||
554 | (receive (exit-reason argument) | |
555 | (run-form form) | |
556 | (dynamic-wind | |
557 | (const #t) | |
558 | (lambda () | |
559 | (case exit-reason | |
560 | ((exit-component) | |
561 | (cond | |
562 | ((components=? argument ok-button) | |
563 | (ok-button-callback-procedure)) | |
3d0f6a05 MO |
564 | ((and exit-button? |
565 | (components=? argument exit-button)) | |
7d812901 | 566 | (exit-button-callback-procedure)))))) |
29d8d919 MO |
567 | (lambda () |
568 | (destroy-form-and-pop form)))))) |