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
Ludovic Courtès
parent
b4658c258e
commit
29d8d9196b
|
|
@ -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))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue