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.

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