diff options
Diffstat (limited to 'gnu/installer/newt')
| -rw-r--r-- | gnu/installer/newt/page.scm | 250 |
1 files changed, 231 insertions, 19 deletions
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index bcede3e333..10849b81eb 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -17,17 +17,22 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu installer newt page) + #:use-module (gnu installer utils) #:use-module (gnu installer newt utils) #:use-module (guix i18n) #:use-module (ice-9 match) #:use-module (ice-9 receive) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (newt) #:export (draw-info-page draw-connecting-page run-input-page run-error-page run-listbox-selection-page - run-scale-page)) + run-scale-page + run-checkbox-tree-page + run-file-textbox-page)) ;;; Commentary: ;;; @@ -66,6 +71,7 @@ this page to TITLE." (define* (run-input-page text title #:key (allow-empty-input? #f) + (default-text #f) (input-field-width 40)) "Run a page to prompt user for an input. The given TEXT will be displayed above the input field. The page title is set to TITLE. Unless @@ -80,6 +86,9 @@ enters an empty input." (ok-button (make-button -1 -1 (G_ "Ok"))) (form (make-form))) + (when default-text + (set-entry-text input-entry default-text)) + (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry #:pad-top 1) @@ -142,10 +151,18 @@ of the page is set to TITLE." (listbox-default-item #f) (listbox-allow-multiple? #f) (sort-listbox-items? #t) + (allow-delete? #f) + (skip-item-procedure? + (const #f)) button-text (button-callback-procedure (const #t)) + (button2-text #f) + (button2-callback-procedure + (const #t)) (listbox-callback-procedure + identity) + (hotkey-callback-procedure (const #t))) "Run a page asking the user to select an item in a listbox. The page contains, stacked vertically from the top to the bottom, an informative text @@ -168,7 +185,15 @@ be selected (using the <SPACE> key). It that case, a list containing the selected items will be returned. If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using -'string<=' procedure (after being converted to text)." +'string<=' procedure (after being converted to text). + +If ALLOW-DELETE? is #t, the form will return if the <DELETE> key is pressed, +otherwise nothing will happend. + +Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the +current listbox item as argument. If it returns #t, skip the element and jump +to the next/previous one depending on the previous item, otherwise do +nothing." (define (fill-listbox listbox items) "Append the given ITEMS to LISTBOX, once they have been converted to text @@ -198,6 +223,21 @@ corresponding to each item in the list." (string<= text-a text-b)))))) (map car sorted-items))) + ;; Store the last selected listbox item's key. + (define last-listbox-key (make-parameter #f)) + + (define (previous-key keys key) + (let ((index (list-index (cut eq? key <>) keys))) + (and index + (> index 0) + (list-ref keys (- index 1))))) + + (define (next-key keys key) + (let ((index (list-index (cut eq? key <>) keys))) + (and index + (< index (- (length keys) 1)) + (list-ref keys (+ index 1))))) + (define (set-default-item listbox listbox-keys default-item) "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the association list returned by the FILL-LISTBOX procedure. It is used because @@ -221,18 +261,55 @@ the current listbox item has to be selected by key." info-textbox-width #:flags FLAG-BORDER)) (button (make-button -1 -1 button-text)) + (button2 (and button2-text + (make-button -1 -1 button2-text))) (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox GRID-ELEMENT-COMPONENT listbox - GRID-ELEMENT-COMPONENT button)) + GRID-ELEMENT-SUBGRID + (apply + horizontal-stacked-grid + GRID-ELEMENT-COMPONENT button + `(,@(if button2 + (list GRID-ELEMENT-COMPONENT button2) + '()))))) (sorted-items (if sort-listbox-items? (sort-listbox-items listbox-items) listbox-items)) (keys (fill-listbox listbox sorted-items))) + ;; On every listbox element change, check if we need to skip it. If yes, + ;; depending on the 'last-listbox-key', jump forward or backward. If no, + ;; do nothing. + (add-component-callback + listbox + (lambda (component) + (let* ((current-key (current-listbox-entry listbox)) + (listbox-keys (map car keys)) + (last-key (last-listbox-key)) + (item (assoc-ref keys current-key)) + (prev-key (previous-key listbox-keys current-key)) + (next-key (next-key listbox-keys current-key))) + ;; Update last-listbox-key before a potential call to + ;; set-current-listbox-entry-by-key, because it will immediately + ;; cause this callback to be called for the new entry. + (last-listbox-key current-key) + (when (skip-item-procedure? item) + (when (eq? prev-key last-key) + (if next-key + (set-current-listbox-entry-by-key listbox next-key) + (set-current-listbox-entry-by-key listbox prev-key))) + (when (eq? next-key last-key) + (if prev-key + (set-current-listbox-entry-by-key listbox prev-key) + (set-current-listbox-entry-by-key listbox next-key))))))) + (when listbox-default-item (set-default-item listbox keys listbox-default-item)) + (when allow-delete? + (form-add-hotkey form KEY-DELETE)) + (add-form-to-grid grid form #t) (make-wrapped-grid-window grid title) @@ -241,22 +318,28 @@ the current listbox item has to be selected by key." (dynamic-wind (const #t) (lambda () - (when (eq? exit-reason 'exit-component) - (cond - ((components=? argument button) - (button-callback-procedure)) - ((components=? argument listbox) - (if listbox-allow-multiple? - (let* ((entries (listbox-selection listbox)) - (items (map (lambda (entry) - (assoc-ref keys entry)) - entries))) - (listbox-callback-procedure items) - items) - (let* ((entry (current-listbox-entry listbox)) - (item (assoc-ref keys entry))) - (listbox-callback-procedure item) - item)))))) + (case exit-reason + ((exit-component) + (cond + ((components=? argument button) + (button-callback-procedure)) + ((and button2 + (components=? argument button2)) + (button2-callback-procedure)) + ((components=? argument listbox) + (if listbox-allow-multiple? + (let* ((entries (listbox-selection listbox)) + (items (map (lambda (entry) + (assoc-ref keys entry)) + entries))) + (listbox-callback-procedure items)) + (let* ((entry (current-listbox-entry listbox)) + (item (assoc-ref keys entry))) + (listbox-callback-procedure item)))))) + ((exit-hotkey) + (let* ((entry (current-listbox-entry listbox)) + (item (assoc-ref keys entry))) + (hotkey-callback-procedure argument item))))) (lambda () (destroy-form-and-pop form)))))) @@ -311,3 +394,132 @@ error is raised if the MAX-SCALE-UPDATE limit is reached." (error "Max scale updates reached.")))))) (lambda () (destroy-form-and-pop form))))) + +(define* (run-checkbox-tree-page #:key + info-text + title + items + item->text + (info-textbox-width 50) + (checkbox-tree-height 10) + (ok-button-callback-procedure + (const #t)) + (cancel-button-callback-procedure + (const #t))) + "Run a page allowing the user to select one or multiple items among ITEMS in +a checkbox list. The page contains vertically stacked from the top to the +bottom, an informative text set to INFO-TEXT, the checkbox list and two +buttons, 'Ok' and 'Cancel'. The page title's is set to TITLE. ITEMS are +converted to text using ITEM->TEXT before being displayed in the checkbox +list. + +INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be +displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list. + +OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed. +CANCEL-BUTTON-CALLBACK-PROCEDURE is called when the 'Cancel' button is +pressed. + +This procedure returns the list of checked items in the checkbox list among +ITEMS when 'Ok' is pressed." + (define (fill-checkbox-tree checkbox-tree items) + (map + (lambda (item) + (let* ((item-text (item->text item)) + (key (add-entry-to-checkboxtree checkbox-tree item-text 0))) + (cons key item))) + items)) + + (let* ((checkbox-tree + (make-checkboxtree -1 -1 + checkbox-tree-height + FLAG-BORDER)) + (info-textbox + (make-reflowed-textbox -1 -1 info-text + info-textbox-width + #:flags FLAG-BORDER)) + (ok-button (make-button -1 -1 (G_ "Ok"))) + (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (grid (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT checkbox-tree + GRID-ELEMENT-SUBGRID + (horizontal-stacked-grid + GRID-ELEMENT-COMPONENT ok-button + GRID-ELEMENT-COMPONENT cancel-button))) + (keys (fill-checkbox-tree checkbox-tree items)) + (form (make-form))) + + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid title) + + (receive (exit-reason argument) + (run-form form) + (dynamic-wind + (const #t) + (lambda () + (case exit-reason + ((exit-component) + (cond + ((components=? argument ok-button) + (let* ((entries (current-checkbox-selection checkbox-tree)) + (current-items (map (lambda (entry) + (assoc-ref keys entry)) + entries))) + (ok-button-callback-procedure) + current-items)) + ((components=? argument cancel-button) + (cancel-button-callback-procedure)))))) + (lambda () + (destroy-form-and-pop form)))))) + +(define* (run-file-textbox-page #:key + info-text + title + file + (info-textbox-width 50) + (file-textbox-width 50) + (file-textbox-height 30) + (ok-button-callback-procedure + (const #t)) + (cancel-button-callback-procedure + (const #t))) + (let* ((info-textbox + (make-reflowed-textbox -1 -1 info-text + info-textbox-width + #:flags FLAG-BORDER)) + (file-text (read-all file)) + (file-textbox + (make-textbox -1 -1 + file-textbox-width + file-textbox-height + (logior FLAG-SCROLL FLAG-BORDER))) + (ok-button (make-button -1 -1 (G_ "Ok"))) + (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (grid (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT file-textbox + GRID-ELEMENT-SUBGRID + (horizontal-stacked-grid + GRID-ELEMENT-COMPONENT ok-button + GRID-ELEMENT-COMPONENT cancel-button))) + (form (make-form))) + + (set-textbox-text file-textbox file-text) + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid title) + + (receive (exit-reason argument) + (run-form form) + (dynamic-wind + (const #t) + (lambda () + (case exit-reason + ((exit-component) + (cond + ((components=? argument ok-button) + (ok-button-callback-procedure)) + ((components=? argument cancel-button) + (cancel-button-callback-procedure)))))) + (lambda () + (destroy-form-and-pop form)))))) |