guix/guix
3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

installer: Add new pages.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

250
gnu/installer/newt/page.scm
View file

@ -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))))))