gnu/installer/newt/page.scm

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