aboutsummaryrefslogtreecommitdiff
path: root/gnu/installer/newt/welcome.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/installer/newt/welcome.scm')
-rw-r--r--gnu/installer/newt/welcome.scm122
1 files changed, 122 insertions, 0 deletions
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
new file mode 100644
index 0000000000..8ed9f68918
--- /dev/null
+++ b/gnu/installer/newt/welcome.scm
@@ -0,0 +1,122 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt welcome)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu installer newt utils)
+ #:use-module (guix build syscalls)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (run-welcome-page))
+
+;; Margin between screen border and newt root window.
+(define margin-left (make-parameter 3))
+(define margin-top (make-parameter 3))
+
+;; Expected width and height for the logo.
+(define logo-width (make-parameter 50))
+(define logo-height (make-parameter 23))
+
+(define (nearest-exact-integer x)
+ "Given a real number X, return the nearest exact integer, with ties going to
+the nearest exact even integer."
+ (inexact->exact (round x)))
+
+(define* (run-menu-page title logo
+ #:key
+ listbox-items
+ listbox-item->text)
+ "Run a page with the given TITLE, to ask the user to choose between
+LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text
+using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of
+the page. Contrary to other pages, we cannot resort to grid layouts, because
+we want this page to occupy all the screen space available."
+ (define (fill-listbox listbox items)
+ (map (lambda (item)
+ (let* ((text (listbox-item->text item))
+ (key (append-entry-to-listbox listbox text)))
+ (cons key item)))
+ items))
+
+ (let* ((windows
+ (make-window (margin-left)
+ (margin-top)
+ (- (screen-columns) (* 2 (margin-left)))
+ (- (screen-rows) (* 2 (margin-top)))
+ title))
+ (logo-textbox
+ (make-textbox (nearest-exact-integer
+ (- (/ (screen-columns) 2)
+ (+ (/ (logo-width) 2) (margin-left))))
+ (margin-top) (logo-width) (logo-height) 0))
+ (text (set-textbox-text logo-textbox
+ (read-all logo)))
+ (options-listbox
+ (make-listbox (margin-left)
+ (+ (logo-height) (margin-top))
+ (- (screen-rows) (+ (logo-height)
+ (* (margin-top) 4)))
+ (logior FLAG-BORDER FLAG-RETURNEXIT)))
+ (keys (fill-listbox options-listbox listbox-items))
+ (form (make-form)))
+ (set-listbox-width options-listbox (- (screen-columns)
+ (* (margin-left) 4)))
+ (add-components-to-form form logo-textbox options-listbox)
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (when (eq? exit-reason 'exit-component)
+ (cond
+ ((components=? argument options-listbox)
+ (let* ((entry (current-listbox-entry options-listbox))
+ (item (assoc-ref keys entry)))
+ (match item
+ ((text . proc)
+ (proc))))))))
+ (lambda ()
+ (destroy-form-and-pop form))))))
+
+(define (run-welcome-page logo)
+ "Run a welcome page with the given textual LOGO displayed at the center of
+the page. Ask the user to choose between manual installation, graphical
+installation and reboot."
+ (run-menu-page
+ (G_ "GNU GuixSD install")
+ logo
+ #:listbox-items
+ `((,(G_ "Install using the unguided shell based process")
+ .
+ ,(lambda ()
+ (clear-screen)
+ (newt-suspend)
+ (system* "bash" "-l")
+ (newt-resume)))
+ (,(G_ "Graphical install using a guided terminal based interface")
+ .
+ ,(const #t))
+ (,(G_ "Reboot")
+ .
+ ,(lambda ()
+ (newt-finish)
+ (reboot))))
+ #:listbox-item->text car))