installer: Add new pages.

* gnu/installer/newt/page.scm (run-scale-page): New exported procedure,
(run-checkbox-tree-page): ditto,
(run-file-textbox-page): ditto.
This commit is contained in:
Mathieu Othacehe 2018-12-05 14:47:49 +09:00 committed by Ludovic Courtès
parent b4658c258e
commit 29d8d9196b
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 231 additions and 19 deletions

View File

@ -17,17 +17,22 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt page) (define-module (gnu installer newt page)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils) #:use-module (gnu installer newt utils)
#:use-module (guix i18n) #:use-module (guix i18n)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (newt) #:use-module (newt)
#:export (draw-info-page #:export (draw-info-page
draw-connecting-page draw-connecting-page
run-input-page run-input-page
run-error-page run-error-page
run-listbox-selection-page run-listbox-selection-page
run-scale-page)) run-scale-page
run-checkbox-tree-page
run-file-textbox-page))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -66,6 +71,7 @@ this page to TITLE."
(define* (run-input-page text title (define* (run-input-page text title
#:key #:key
(allow-empty-input? #f) (allow-empty-input? #f)
(default-text #f)
(input-field-width 40)) (input-field-width 40))
"Run a page to prompt user for an input. The given TEXT will be displayed "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 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"))) (ok-button (make-button -1 -1 (G_ "Ok")))
(form (make-form))) (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 0 GRID-ELEMENT-COMPONENT text-box)
(set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
#:pad-top 1) #:pad-top 1)
@ -142,10 +151,18 @@ of the page is set to TITLE."
(listbox-default-item #f) (listbox-default-item #f)
(listbox-allow-multiple? #f) (listbox-allow-multiple? #f)
(sort-listbox-items? #t) (sort-listbox-items? #t)
(allow-delete? #f)
(skip-item-procedure?
(const #f))
button-text button-text
(button-callback-procedure (button-callback-procedure
(const #t)) (const #t))
(button2-text #f)
(button2-callback-procedure
(const #t))
(listbox-callback-procedure (listbox-callback-procedure
identity)
(hotkey-callback-procedure
(const #t))) (const #t)))
"Run a page asking the user to select an item in a listbox. The page "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 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. selected items will be returned.
If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using 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) (define (fill-listbox listbox items)
"Append the given ITEMS to LISTBOX, once they have been converted to text "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)))))) (string<= text-a text-b))))))
(map car sorted-items))) (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) (define (set-default-item listbox listbox-keys default-item)
"Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the "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 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 info-textbox-width
#:flags FLAG-BORDER)) #:flags FLAG-BORDER))
(button (make-button -1 -1 button-text)) (button (make-button -1 -1 button-text))
(button2 (and button2-text
(make-button -1 -1 button2-text)))
(grid (vertically-stacked-grid (grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT listbox 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? (sorted-items (if sort-listbox-items?
(sort-listbox-items listbox-items) (sort-listbox-items listbox-items)
listbox-items)) listbox-items))
(keys (fill-listbox listbox sorted-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 (when listbox-default-item
(set-default-item listbox keys 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) (add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title) (make-wrapped-grid-window grid title)
@ -241,22 +318,28 @@ the current listbox item has to be selected by key."
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()
(when (eq? exit-reason 'exit-component) (case exit-reason
(cond ((exit-component)
((components=? argument button) (cond
(button-callback-procedure)) ((components=? argument button)
((components=? argument listbox) (button-callback-procedure))
(if listbox-allow-multiple? ((and button2
(let* ((entries (listbox-selection listbox)) (components=? argument button2))
(items (map (lambda (entry) (button2-callback-procedure))
(assoc-ref keys entry)) ((components=? argument listbox)
entries))) (if listbox-allow-multiple?
(listbox-callback-procedure items) (let* ((entries (listbox-selection listbox))
items) (items (map (lambda (entry)
(let* ((entry (current-listbox-entry listbox)) (assoc-ref keys entry))
(item (assoc-ref keys entry))) entries)))
(listbox-callback-procedure item) (listbox-callback-procedure items))
item)))))) (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 () (lambda ()
(destroy-form-and-pop form)))))) (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.")))))) (error "Max scale updates reached."))))))
(lambda () (lambda ()
(destroy-form-and-pop form))))) (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))))))