gnu/installer/newt/page.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu installer newt page)
  21   #:use-module (gnu installer utils)
  22   #:use-module (gnu installer newt utils)
  23   #:use-module (guix i18n)
  24   #:use-module (ice-9 i18n)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 receive)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (newt)
  30   #:export (draw-info-page
  31             draw-connecting-page
  32             run-input-page
  33             run-error-page
  34             run-confirmation-page
  35             run-listbox-selection-page
  36             run-scale-page
  37             run-checkbox-tree-page
  38             run-file-textbox-page))
  39
  40 ;;; Commentary:
  41 ;;;
  42 ;;; Some helpers around guile-newt to draw or run generic pages. The
  43 ;;; difference between 'draw' and 'run' terms comes from newt library. A page
  44 ;;; is drawn when the form it contains does not expect any user
  45 ;;; interaction. In that case, it is necessary to call (newt-refresh) to force
  46 ;;; the page to be displayed. When a form is 'run', it is blocked waiting for
  47 ;;; any action from the user (press a button, input some text, ...).
  48 ;;;
  49 ;;; Code:
  50
  51 (define (draw-info-page text title)
  52   "Draw an informative page with the given TEXT as content.  Set the title of
  53 this page to TITLE."
  54   (let* ((text-box
  55           (make-reflowed-textbox -1 -1 text 40
  56                                  #:flags FLAG-BORDER))
  57          (grid (make-grid 1 1))
  58          (form (make-form)))
  59     (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
  60     (add-component-to-form form text-box)
  61     (make-wrapped-grid-window grid title)
  62     (draw-form form)
  63     ;; This call is imperative, otherwise the form won't be displayed. See the
  64     ;; explanation in the above commentary.
  65     (newt-refresh)
  66     form))
  67
  68 (define (draw-connecting-page service-name)
  69   "Draw a page to indicate a connection in in progress."
  70   (draw-info-page
  71    (format #f (G_ "Connecting to ~a, please wait.") service-name)
  72    (G_ "Connection in progress")))
  73
  74 (define* (run-input-page text title
  75                          #:key
  76                          (allow-empty-input? #f)
  77                          (default-text #f)
  78                          (input-field-width 40)
  79                          (input-flags 0))
  80   "Run a page to prompt user for an input. The given TEXT will be displayed
  81 above the input field. The page title is set to TITLE. Unless
  82 allow-empty-input? is set to #t, an error page will be displayed if the user
  83 enters an empty input.  INPUT-FLAGS is a bitwise-or'd set of flags for the
  84 input box, such as FLAG-PASSWORD."
  85   (let* ((text-box
  86           (make-reflowed-textbox -1 -1 text
  87                                  input-field-width
  88                                  #:flags FLAG-BORDER))
  89          (grid (make-grid 1 3))
  90          (input-entry (make-entry -1 -1 20
  91                                   #:flags input-flags))
  92          (ok-button (make-button -1 -1 (G_ "OK")))
  93          (form (make-form)))
  94
  95     (when default-text
  96       (set-entry-text input-entry default-text))
  97
  98     (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
  99     (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
 100                     #:pad-top 1)
 101     (set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button
 102                     #:pad-top 1)
 103
 104     (add-components-to-form form text-box input-entry ok-button)
 105     (make-wrapped-grid-window grid title)
 106     (let ((error-page (lambda ()
 107                         (run-error-page (G_ "Please enter a non empty input.")
 108                                         (G_ "Empty input")))))
 109       (let loop ()
 110         (receive (exit-reason argument)
 111             (run-form form)
 112           (let ((input (entry-value input-entry)))
 113             (if (and (not allow-empty-input?)
 114                      (eq? exit-reason 'exit-component)
 115                      (string=? input ""))
 116                 (begin
 117                   ;; Display the error page.
 118                   (error-page)
 119                   ;; Set the focus back to the input input field.
 120                   (set-current-component form input-entry)
 121                   (loop))
 122                 (begin
 123                   (destroy-form-and-pop form)
 124                   input))))))))
 125
 126 (define (run-error-page text title)
 127   "Run a page to inform the user of an error. The page contains the given TEXT
 128 to explain the error and an \"OK\" button to acknowledge the error. The title
 129 of the page is set to TITLE."
 130   (let* ((text-box
 131           (make-reflowed-textbox -1 -1 text 40
 132                                  #:flags FLAG-BORDER))
 133          (grid (make-grid 1 2))
 134          (ok-button (make-button -1 -1 "OK"))
 135          (form (make-form)))
 136
 137     (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
 138     (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button
 139                     #:pad-top 1)
 140
 141     ;; Set the background color to red to indicate something went wrong.
 142     (newt-set-color COLORSET-ROOT "white" "red")
 143     (add-components-to-form form text-box ok-button)
 144     (make-wrapped-grid-window grid title)
 145     (run-form form)
 146     ;; Restore the background to its original color.
 147     (newt-set-color COLORSET-ROOT "white" "blue")
 148     (destroy-form-and-pop form)))
 149
 150 (define* (run-confirmation-page text title
 151                                 #:key (exit-button-procedure (const #f)))
 152   "Run a page to inform the user of an error. The page contains the given TEXT
 153 to explain the error and an \"OK\" button to acknowledge the error. The title
 154 of the page is set to TITLE."
 155   (let* ((text-box
 156           (make-reflowed-textbox -1 -1 text 40
 157                                  #:flags FLAG-BORDER))
 158          (ok-button (make-button -1 -1 (G_ "Continue")))
 159          (exit-button (make-button -1 -1 (G_ "Exit")))
 160          (grid (vertically-stacked-grid
 161                 GRID-ELEMENT-COMPONENT text-box
 162                 GRID-ELEMENT-SUBGRID
 163                 (horizontal-stacked-grid
 164                  GRID-ELEMENT-COMPONENT ok-button
 165                  GRID-ELEMENT-COMPONENT exit-button)))
 166          (form (make-form)))
 167
 168     (add-form-to-grid grid form #t)
 169     (make-wrapped-grid-window grid title)
 170
 171     (receive (exit-reason argument)
 172         (run-form form)
 173       (dynamic-wind
 174         (const #t)
 175         (lambda ()
 176           (case exit-reason
 177             ((exit-component)
 178              (cond
 179               ((components=? argument ok-button)
 180                #t)
 181               ((components=? argument exit-button)
 182                (exit-button-procedure))))))
 183         (lambda ()
 184           (destroy-form-and-pop form))))))
 185
 186 (define* (run-listbox-selection-page #:key
 187                                      info-text
 188                                      title
 189                                      (info-textbox-width 50)
 190                                      listbox-items
 191                                      listbox-item->text
 192                                      (listbox-height 20)
 193                                      (listbox-default-item #f)
 194                                      (listbox-allow-multiple? #f)
 195                                      (sort-listbox-items? #t)
 196                                      (allow-delete? #f)
 197                                      (skip-item-procedure?
 198                                       (const #f))
 199                                      button-text
 200                                      (button-callback-procedure
 201                                       (const #t))
 202                                      (button2-text #f)
 203                                      (button2-callback-procedure
 204                                       (const #t))
 205                                      (listbox-callback-procedure
 206                                       identity)
 207                                      (hotkey-callback-procedure
 208                                       (const #t)))
 209   "Run a page asking the user to select an item in a listbox. The page
 210 contains, stacked vertically from the top to the bottom, an informative text
 211 set to INFO-TEXT, a listbox and a button. The listbox will be filled with
 212 LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
 213 on every item. The selected item from LISTBOX-ITEMS is returned. The button
 214 text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
 215 when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
 216 item from the listbox is selected (by pressing the <ENTER> key).
 217
 218 INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
 219 displayed. LISTBOX-HEIGHT is the height of the listbox.
 220
 221 If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
 222 LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
 223 the listbox is selected.
 224
 225 If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
 226 be selected (using the <SPACE> key). It that case, a list containing the
 227 selected items will be returned.
 228
 229 If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
 230 'string-locale<?' procedure (after being converted to text).
 231
 232 If ALLOW-DELETE? is #t, the form will return if the <DELETE> key is pressed,
 233 otherwise nothing will happen.
 234
 235 Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the
 236 current listbox item as argument. If it returns #t, skip the element and jump
 237 to the next/previous one depending on the previous item, otherwise do
 238 nothing."
 239
 240   (define (fill-listbox listbox items)
 241     "Append the given ITEMS to LISTBOX, once they have been converted to text
 242 with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
 243 newt. Save this key by returning an association list under the form:
 244
 245         ((NEWT-LISTBOX-KEY . ITEM) ...)
 246
 247 where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
 248 ITEM was inserted into LISTBOX."
 249     (map (lambda (item)
 250            (let* ((text (listbox-item->text item))
 251                   (key (append-entry-to-listbox listbox text)))
 252              (cons key item)))
 253          items))
 254
 255   (define (sort-listbox-items listbox-items)
 256     "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
 257 corresponding to each item in the list."
 258     (let* ((items (map (lambda (item)
 259                          (cons item (listbox-item->text item)))
 260                        listbox-items))
 261            (sorted-items
 262             (sort items (lambda (a b)
 263                           (let ((text-a (cdr a))
 264                                 (text-b (cdr b)))
 265                             (string-locale<? text-a text-b))))))
 266       (map car sorted-items)))
 267
 268   ;; Store the last selected listbox item's key.
 269   (define last-listbox-key (make-parameter #f))
 270
 271   (define (previous-key keys key)
 272     (let ((index (list-index (cut eq? key <>) keys)))
 273       (and index
 274            (> index 0)
 275            (list-ref keys (- index 1)))))
 276
 277   (define (next-key keys key)
 278     (let ((index (list-index (cut eq? key <>) keys)))
 279       (and index
 280            (< index (- (length keys) 1))
 281            (list-ref keys (+ index 1)))))
 282
 283   (define (set-default-item listbox listbox-keys default-item)
 284     "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
 285 association list returned by the FILL-LISTBOX procedure. It is used because
 286 the current listbox item has to be selected by key."
 287     (for-each (match-lambda
 288                 ((key . item)
 289                  (when (equal? item default-item)
 290                    (set-current-listbox-entry-by-key listbox key))))
 291               listbox-keys))
 292
 293   (let* ((listbox (make-listbox
 294                    -1 -1
 295                    listbox-height
 296                    (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
 297                            (if listbox-allow-multiple?
 298                                FLAG-MULTIPLE
 299                                0))))
 300          (form (make-form))
 301          (info-textbox
 302           (make-reflowed-textbox -1 -1 info-text
 303                                  info-textbox-width
 304                                  #:flags FLAG-BORDER))
 305          (button (make-button -1 -1 button-text))
 306          (button2 (and button2-text
 307                        (make-button -1 -1 button2-text)))
 308          (grid (vertically-stacked-grid
 309                 GRID-ELEMENT-COMPONENT info-textbox
 310                 GRID-ELEMENT-COMPONENT listbox
 311                 GRID-ELEMENT-SUBGRID
 312                 (apply
 313                  horizontal-stacked-grid
 314                  GRID-ELEMENT-COMPONENT button
 315                  `(,@(if button2
 316                          (list GRID-ELEMENT-COMPONENT button2)
 317                          '())))))
 318          (sorted-items (if sort-listbox-items?
 319                            (sort-listbox-items listbox-items)
 320                            listbox-items))
 321          (keys (fill-listbox listbox sorted-items)))
 322
 323     ;; On every listbox element change, check if we need to skip it. If yes,
 324     ;; depending on the 'last-listbox-key', jump forward or backward. If no,
 325     ;; do nothing.
 326     (add-component-callback
 327      listbox
 328      (lambda (component)
 329        (let* ((current-key (current-listbox-entry listbox))
 330               (listbox-keys (map car keys))
 331               (last-key (last-listbox-key))
 332               (item (assoc-ref keys current-key))
 333               (prev-key (previous-key listbox-keys current-key))
 334               (next-key (next-key listbox-keys current-key)))
 335          ;; Update last-listbox-key before a potential call to
 336          ;; set-current-listbox-entry-by-key, because it will immediately
 337          ;; cause this callback to be called for the new entry.
 338          (last-listbox-key current-key)
 339          (when (skip-item-procedure? item)
 340            (when (eq? prev-key last-key)
 341              (if next-key
 342                  (set-current-listbox-entry-by-key listbox next-key)
 343                  (set-current-listbox-entry-by-key listbox prev-key)))
 344            (when (eq? next-key last-key)
 345              (if prev-key
 346                  (set-current-listbox-entry-by-key listbox prev-key)
 347                  (set-current-listbox-entry-by-key listbox next-key)))))))
 348
 349     (when listbox-default-item
 350       (set-default-item listbox keys listbox-default-item))
 351
 352     (when allow-delete?
 353       (form-add-hotkey form KEY-DELETE))
 354
 355     (add-form-to-grid grid form #t)
 356     (make-wrapped-grid-window grid title)
 357
 358     (receive (exit-reason argument)
 359         (run-form form)
 360       (dynamic-wind
 361         (const #t)
 362         (lambda ()
 363           (case exit-reason
 364             ((exit-component)
 365              (cond
 366               ((components=? argument button)
 367                (button-callback-procedure))
 368               ((and button2
 369                     (components=? argument button2))
 370                (button2-callback-procedure))
 371               ((components=? argument listbox)
 372                (if listbox-allow-multiple?
 373                    (let* ((entries (listbox-selection listbox))
 374                           (items (map (lambda (entry)
 375                                         (assoc-ref keys entry))
 376                                       entries)))
 377                      (listbox-callback-procedure items))
 378                    (let* ((entry (current-listbox-entry listbox))
 379                           (item (assoc-ref keys entry)))
 380                      (listbox-callback-procedure item))))))
 381             ((exit-hotkey)
 382              (let* ((entry (current-listbox-entry listbox))
 383                     (item (assoc-ref keys entry)))
 384                (hotkey-callback-procedure argument item)))))
 385         (lambda ()
 386           (destroy-form-and-pop form))))))
 387
 388 (define* (run-scale-page #:key
 389                          title
 390                          info-text
 391                          (info-textbox-width 50)
 392                          (scale-width 40)
 393                          (scale-full-value 100)
 394                          scale-update-proc
 395                          (max-scale-update 5))
 396   "Run a page with a progress bar (called 'scale' in newt). The given
 397 INFO-TEXT is displayed in a textbox above the scale. The width of the textbox
 398 is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to
 399 SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of
 400 the scale.
 401
 402 The procedure SCALE-UPDATE-PROC shall return a new scale
 403 value. SCALE-UPDATE-PROC will be called until the returned value is superior
 404 or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An
 405 error is raised if the MAX-SCALE-UPDATE limit is reached."
 406   (let* ((info-textbox
 407           (make-reflowed-textbox -1 -1 info-text
 408                                  info-textbox-width
 409                                  #:flags FLAG-BORDER))
 410          (scale (make-scale -1 -1 scale-width scale-full-value))
 411          (grid (vertically-stacked-grid
 412                 GRID-ELEMENT-COMPONENT info-textbox
 413                 GRID-ELEMENT-COMPONENT scale))
 414          (form (make-form)))
 415
 416     (add-form-to-grid grid form #t)
 417     (make-wrapped-grid-window grid title)
 418
 419     (draw-form form)
 420     ;; This call is imperative, otherwise the form won't be displayed. See the
 421     ;; explanation in the above commentary.
 422     (newt-refresh)
 423
 424     (dynamic-wind
 425       (const #t)
 426       (lambda ()
 427         (let loop ((i max-scale-update)
 428                    (last-value 0))
 429           (let ((value (scale-update-proc last-value)))
 430             (set-scale-value scale value)
 431             ;; Same as above.
 432             (newt-refresh)
 433             (unless (>= value scale-full-value)
 434               (if (> i 0)
 435                   (loop (- i 1) value)
 436                   (error "Max scale updates reached."))))))
 437       (lambda ()
 438         (destroy-form-and-pop form)))))
 439
 440 (define %none-selected
 441   (circular-list #f))
 442
 443 (define* (run-checkbox-tree-page #:key
 444                                  info-text
 445                                  title
 446                                  items
 447                                  (selection %none-selected)
 448                                  item->text
 449                                  (info-textbox-width 50)
 450                                  (checkbox-tree-height 10)
 451                                  (ok-button-callback-procedure
 452                                   (const #t))
 453                                  (exit-button-callback-procedure
 454                                   (const #t)))
 455   "Run a page allowing the user to select one or multiple items among ITEMS in
 456 a checkbox list. The page contains vertically stacked from the top to the
 457 bottom, an informative text set to INFO-TEXT, the checkbox list and two
 458 buttons, 'Ok' and 'Exit'. The page title's is set to TITLE. ITEMS are
 459 converted to text using ITEM->TEXT before being displayed in the checkbox
 460 list.  SELECTION is a list of Booleans of the same length as ITEMS that
 461 specifies which items are initially checked.
 462
 463 INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
 464 displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list.
 465
 466 OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed.
 467 EXIT-BUTTON-CALLBACK-PROCEDURE is called when the 'Exit' button is
 468 pressed.
 469
 470 This procedure returns the list of checked items in the checkbox list among
 471 ITEMS when 'Ok' is pressed."
 472   (define (fill-checkbox-tree checkbox-tree items)
 473     (map (lambda (item selected?)
 474            (let* ((item-text (item->text item))
 475                   (key (add-entry-to-checkboxtree checkbox-tree item-text
 476                                                   (if selected?
 477                                                       FLAG-SELECTED
 478                                                       0))))
 479              (cons key item)))
 480          items
 481          selection))
 482
 483   (let* ((checkbox-tree
 484           (make-checkboxtree -1 -1
 485                              checkbox-tree-height
 486                              FLAG-BORDER))
 487          (info-textbox
 488           (make-reflowed-textbox -1 -1 info-text
 489                                  info-textbox-width
 490                                  #:flags FLAG-BORDER))
 491          (ok-button (make-button -1 -1 (G_ "OK")))
 492          (exit-button (make-button -1 -1 (G_ "Exit")))
 493          (grid (vertically-stacked-grid
 494                 GRID-ELEMENT-COMPONENT info-textbox
 495                 GRID-ELEMENT-COMPONENT checkbox-tree
 496                 GRID-ELEMENT-SUBGRID
 497                 (horizontal-stacked-grid
 498                  GRID-ELEMENT-COMPONENT ok-button
 499                  GRID-ELEMENT-COMPONENT exit-button)))
 500          (keys (fill-checkbox-tree checkbox-tree items))
 501          (form (make-form)))
 502
 503     (add-form-to-grid grid form #t)
 504     (make-wrapped-grid-window grid title)
 505
 506     (receive (exit-reason argument)
 507         (run-form form)
 508       (dynamic-wind
 509         (const #t)
 510         (lambda ()
 511           (case exit-reason
 512             ((exit-component)
 513              (cond
 514               ((components=? argument ok-button)
 515                (let* ((entries (current-checkbox-selection checkbox-tree))
 516                       (current-items (map (lambda (entry)
 517                                             (assoc-ref keys entry))
 518                                           entries)))
 519                  (ok-button-callback-procedure)
 520                  current-items))
 521               ((components=? argument exit-button)
 522                (exit-button-callback-procedure))))))
 523         (lambda ()
 524           (destroy-form-and-pop form))))))
 525
 526 (define* (run-file-textbox-page #:key
 527                                 info-text
 528                                 title
 529                                 file
 530                                 (info-textbox-width 50)
 531                                 (file-textbox-width 50)
 532                                 (file-textbox-height 30)
 533                                 (exit-button? #t)
 534                                 (ok-button-callback-procedure
 535                                  (const #t))
 536                                 (exit-button-callback-procedure
 537                                  (const #t)))
 538   (let* ((info-textbox
 539           (make-reflowed-textbox -1 -1 info-text
 540                                  info-textbox-width
 541                                  #:flags FLAG-BORDER))
 542          (file-text (read-all file))
 543          (file-textbox
 544           (make-textbox -1 -1
 545                         file-textbox-width
 546                         file-textbox-height
 547                         (logior FLAG-SCROLL FLAG-BORDER)))
 548          (ok-button (make-button -1 -1 (G_ "OK")))
 549          (exit-button (make-button -1 -1 (G_ "Exit")))
 550          (grid (vertically-stacked-grid
 551                 GRID-ELEMENT-COMPONENT info-textbox
 552                 GRID-ELEMENT-COMPONENT file-textbox
 553                 GRID-ELEMENT-SUBGRID
 554                 (apply
 555                  horizontal-stacked-grid
 556                  GRID-ELEMENT-COMPONENT ok-button
 557                  `(,@(if exit-button?
 558                          (list GRID-ELEMENT-COMPONENT exit-button)
 559                          '())))))
 560          (form (make-form)))
 561
 562     (set-textbox-text file-textbox file-text)
 563     (add-form-to-grid grid form #t)
 564     (make-wrapped-grid-window grid title)
 565
 566     (receive (exit-reason argument)
 567         (run-form form)
 568       (dynamic-wind
 569         (const #t)
 570         (lambda ()
 571           (case exit-reason
 572             ((exit-component)
 573              (cond
 574               ((components=? argument ok-button)
 575                (ok-button-callback-procedure))
 576               ((and exit-button?
 577                     (components=? argument exit-button))
 578                (exit-button-callback-procedure))))))
 579         (lambda ()
 580           (destroy-form-and-pop form))))))