guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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.
install-doc-overhaul
Mathieu Othacehe 4 years ago
committed by Ludovic Courtès
parent
b4658c258e
commit
29d8d9196b
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
1 changed files with 231 additions and 19 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 250
      gnu/installer/newt/page.scm

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

Write Preview
Loading…
Cancel
Save