[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: installer: Fix flickering and general slowness.
|
From: |
Danny Milosavljevic |
|
Subject: |
01/01: installer: Fix flickering and general slowness. |
|
Date: |
Sun, 9 Jul 2017 08:15:32 -0400 (EDT) |
dannym pushed a commit to branch wip-installer-2
in repository guix.
commit 50d856828caaa7ee143bda764c4df7387af3d7e7
Author: Danny Milosavljevic <address@hidden>
Date: Sun Jul 9 13:22:59 2017 +0200
installer: Fix flickering and general slowness.
* gurses/buttons.scm (buttons-window): New variable. Export it.
(buttons-refresh): New variable. Export it.
(draw-button): Modify to not refresh.
(buttons-fetch-by-key): Modify to accept label.
(buttons-post): Modify to accept label.
(buttons-selected-symbol): Modify to accept label.
(buttons-select-by-symbol): Modify to accept label.
(buttons-mouse-handler): Modify to accept label.
* gurses/form.scm (form-refresh): New variable.
(form-update-cursor): Update docstring.
(make-form): Make popups panels.
(form-redraw-labels): New variable.
(form-post): Use it here.
* gurses/menu.scm (menu-redraw): Use "erase".
(menu-post): Enable keypad keys.
(menu-refresh): Don't call (doupdate) or (update-panels) here.
* gnu/system/installer/utils.scm (slurp**): New variable. Export it.
(deep-visit-windows): New variable. Export it.
(create-vbox): New variable. Export it.
(boxed-window-decoration-refresh): New variable. Export it.
(make-boxed-window): Use it here.
(refresh*): Disable.
(make-window-port): Modify to update screen as soon as possible.
(create-vbox-i): New variable.
* gnu/system/installer/page.scm (page-getch): New variable. Export it.
(page-focused-window): New variable. Export it.
(refresh-screen): New variable. Export it.
(<page>): Rename "refresh" to "refresher".
(make-page): Implicitly create a boxed window around the page.
(page-leave): Delete all the windows we don't need anymore.
* gnu/system/installer/configure.scm (configure-page-activate-item): Modify
event handler result.
(configure-page-init): Delete boxed-window creation (moved to page base).
Don't refresh entire screen. Use create-vbox.
Move text refreshing to...
(configure-page-refresh): ... here. Don't refresh entire screen.
* gnu/system/installer/dialog.scm (dialog-page-init): Delete
boxed-window creation (moved to page base). Use create-vbox.
Don't refresh entire screen. Move text refreshing to...
(dialog-page-refresh): ... here.
* gnu/system/installer/disks.scm (disk-page-init): Delete boxed-window
creation (moved to page base). Don't refresh entire screen.
Use create-vbox. Move text refreshing to...
(disk-page-refresh): ... here. Use "erase". Don't refresh entire screen.
* gnu/system/installer/filesystems.scm (filesystem-page-init): Delete
boxed-window creation (moved to page base). Use create-vbox.
Don't refresh entire screen. Move text refreshing to...
(filesystem-page-refresh): ... here. Use "erase". Don't refreh entire
screen.
* gnu/system/installer/format.scm (format-page-init): Delete one
boxed-window
creation (moved to page base). Don't refresh entire screen. Move text
refreshing to...
(format-page-refresh): ... here. Use "erase". Don't refresh entire screen.
(format-page-activate-item): Use "config-window" boxed-window.
* gnu/system/installer/guixsd-installer.scm (main-options): Use slurp**.
* gnu/system/installer/hostname.scm (host-name-init): Delete boxed-window
creation (moved to page base). Use create-vbox.
(host-name-refresh): Use "erase".
* gnu/system/installer/install.scm (install-page-init): Delete boxed-window
creation (moved to page base). Don't refresh entire screen.
(install-page-refresh): Don't refresh entire screen.
* gnu/system/installer/key-map.scm (key-map-page-init): Don't refresh
entire screen. Use create-vbox. Move text refreshing to...
(key-map-page-refresh): ...here.
* gnu/system/installer/locale.scm (locale-description): Rename to...
(locale-descriptionx): ...this.
(locale-description): New variable.
(locale-page-init): Delete boxed-window creation (moved to page base).
Don't refresh entire screen. Move text window refreshing to...
(locale-page-refresh): ... here. Use "erase".
* gnu/system/installer/mount-point.scm (mount-point-page-init): Delete
boxed-window creation (moved to page base). Use create-vbox.
Don't refresh entire screen. Move text window refreshing to...
(mount-point-page-refresh): ...here.
* gnu/system/installer/network.scm (network-page-init): Delete
boxed-window creation (moved to page base). Don't refresh entire screen.
Moved text-window refreshing to...
(network-page-refresh): ... here.
* geändert: gnu/system/installer/passphrase.scm
(passphase-refresh): Use "erase". Don't refresh entire screen.
(passphrase-init): Delete boxed-window creation. Use create-vbox.
Don't refresh entire screen.
* gnu/system/installer/ping.scm (ping-page-activate-item): Don't refresh
entire screen.
(ping-page-init): Delete boxed-window creation. Use create-vbox.
Don't refresh entire screen.
(ping-page-refresh): ...here. Use "erase". Don't refresh entire screen.
* gnu/system/installer/role.scm (role-page-init): Delete boxed-window
creation. Use create-vbox. Move text-window refreshing to....
(role-page-refresh): ...here. Don't refresh entire screen. Use "erase".
* gnu/system/installer/time-zone.scm (time-zone-page-init): Delete
boxed-window creation. Use create-vbox. Moved text-window refreshing
to...
(time-zone-page-refresh): ... here. Don't refresh entire screen.
Use "erase".
* gnu/system/installer/user-edit.scm (user-edit-page-init): Delete
boxed-window creation. Use create-vbox. Moved text-window refreshing to...
(user-edit-page-refresh): ... here. Don't refresh entire screen.
Use "erase".
* gnu/system/installer/users.scm (header-format): New variable.
(users-page-init): Delete boxed-window creation. Use create-vbox.
Don't refresh entire screen.
(users-page-refresh): Refresh text-window. Use "erase".
* gnu/system/installer/wireless.scm (wireless-page-init):
Delete boxed-window creation. Use create-vbox. Don't refresh entire
screen.
(wireless-page-refresh): Refresh text-window. Use "erase". Don't
refresh entire screen. Don't refresh menu twice.
---
gnu/system/installer/configure.scm | 52 +++++----------
gnu/system/installer/dialog.scm | 52 +++++----------
gnu/system/installer/disks.scm | 92 ++++++++++----------------
gnu/system/installer/filesystems.scm | 89 +++++++++----------------
gnu/system/installer/format.scm | 75 +++++++++------------
gnu/system/installer/guixsd-installer.scm | 106 +++++++++++++-----------------
gnu/system/installer/hostname.scm | 55 +++++-----------
gnu/system/installer/install.scm | 35 ++++------
gnu/system/installer/key-map.scm | 51 ++++----------
gnu/system/installer/locale.scm | 72 +++++++-------------
gnu/system/installer/mount-point.scm | 102 +++++++++++-----------------
gnu/system/installer/network.scm | 85 ++++++++----------------
gnu/system/installer/page.scm | 91 +++++++++++++++++++++----
gnu/system/installer/passphrase.scm | 56 +++++-----------
gnu/system/installer/ping.scm | 45 +++----------
gnu/system/installer/role.scm | 57 ++++------------
gnu/system/installer/time-zone.scm | 51 ++++----------
gnu/system/installer/user-edit.scm | 61 +++++------------
gnu/system/installer/users.scm | 81 ++++++++---------------
gnu/system/installer/utils.scm | 92 ++++++++++++++++++--------
gnu/system/installer/wireless.scm | 57 +++++-----------
gurses/buttons.scm | 36 ++++++++--
gurses/form.scm | 50 +++++++++-----
gurses/menu.scm | 21 ++----
24 files changed, 629 insertions(+), 935 deletions(-)
diff --git a/gnu/system/installer/configure.scm
b/gnu/system/installer/configure.scm
index 0949b39..e7a828d 100644
--- a/gnu/system/installer/configure.scm
+++ b/gnu/system/installer/configure.scm
@@ -91,17 +91,18 @@
(close-port cfg-port))
;; Close the menu and return
- (page-leave))
+ (page-leave)
+ 'handled)
(_ 'ignored)))
(define (configure-page-refresh page)
(when (not (page-initialised? page))
(configure-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page))))
-
+ (let ((text-window (page-datum page 'text-window)))
+ (addstr* text-window
+ (gettext
+ "The following configuration has been generated for you. If you
are satisfied with it you may save it and continue. Otherwise go back and
change some options."))))
(define (generate-guix-config p width)
(let ((grub-mount-point
@@ -190,51 +191,34 @@
'())))
(name-service-switch %mdns-host-lookup-nss)) p #:width width)))
-
(define (configure-page-init p)
(let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
(text-window (derwin
- (inner pr)
- 3 (getmaxx (inner pr))
+ s
+ 3 (getmaxx s)
0 0
- #:panel #f))
+ #:panel #t))
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
+ (bwin (derwin s
+ 3 (getmaxx s)
+ (- (getmaxy s) 3) 0
+ #:panel #t))
(buttons (make-buttons my-buttons 1))
-
(config-window (make-boxed-window
- (inner pr)
- (- (getmaxy (inner pr))
+ s
+ (- (getmaxy s)
(getmaxy bwin)
(getmaxy text-window))
- (getmaxx (inner pr))
+ (getmaxx s)
(getmaxy text-window)
0)))
- (addstr* text-window
- (gettext
- "The following configuration has been generated for you. If you
are satisfied with it you may save it and continue. Otherwise go back and
change some options."))
-
(let ((p (make-window-port (inner config-window))))
(generate-guix-config p (getmaxx (inner config-window)))
(force-output p))
(push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
(page-set-datum! p 'navigation buttons)
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* text-window)
-
- (refresh* (outer config-window))
-
- (refresh* bwin)))
+ (page-set-datum! p 'text-window text-window)
+ (buttons-post buttons bwin)))
diff --git a/gnu/system/installer/dialog.scm b/gnu/system/installer/dialog.scm
index 5f152df..427b97f 100644
--- a/gnu/system/installer/dialog.scm
+++ b/gnu/system/installer/dialog.scm
@@ -21,6 +21,7 @@
#:use-module (gnu system installer utils)
#:use-module (gurses buttons)
#:use-module (ncurses curses)
+ #:use-module (ice-9 match)
#:export (make-dialog))
@@ -69,41 +70,20 @@
(when (not (page-initialised? page))
(dialog-page-init page)
(page-set-initialised! page #t))
- (refresh* (page-datum page 'text-window)))
+ (let ((text-window (page-datum page 'text-window))
+ (m (page-datum page 'message))
+ (justify (page-datum page 'justify)))
+ (erase text-window)
+ (if justify
+ (addstr* text-window (gettext m))
+ (addstr text-window (gettext m)))))
(define (dialog-page-init p)
- (let* ((s (page-surface p))
- (frame (make-boxed-window #f
- (- (getmaxy s) 5) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (button-window (derwin (inner frame)
- 3 (getmaxx (inner frame))
- (- (getmaxy (inner frame)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (text-window (derwin (inner frame)
- (- (getmaxy (inner frame)) (getmaxy
button-window))
- (getmaxx (inner frame))
- 0 0 #:panel #f)))
-
- (let ((m (page-datum p 'message))
- (justify (page-datum p 'justify)))
- (if justify
- (addstr* text-window (gettext m))
- (addstr text-window (gettext m))))
-
- (push-cursor (page-cursor-visibility p))
- (page-set-wwin! p frame)
- (page-set-datum! p 'text-window text-window)
- (page-set-datum! p 'navigation buttons)
- (buttons-post buttons button-window)
- (buttons-select buttons 0)
- (refresh* (outer frame))
- (refresh* (inner frame))
- (refresh* text-window)
- (refresh* button-window)))
-
-
-
+ (match (create-vbox (page-surface p) (- (getmaxy (page-surface p)) 3) 3)
+ ((text-window button-window)
+ (let ((buttons (make-buttons my-buttons 1)))
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)
+ (buttons-select buttons 0)))))
diff --git a/gnu/system/installer/disks.scm b/gnu/system/installer/disks.scm
index c1cd20f..aa4499f 100644
--- a/gnu/system/installer/disks.scm
+++ b/gnu/system/installer/disks.scm
@@ -30,7 +30,8 @@
(include "i18n.scm")
-(define my-buttons `((continue ,(M_ "_Continue") #t)))
+(define my-buttons
+ `((continue ,(M_ "_Continue") #t)))
(define (make-disk-page parent title)
(make-page (page-surface parent)
@@ -43,20 +44,15 @@
(when (not (page-initialised? page))
(disk-page-init page)
(page-set-initialised! page #t))
-
- (let ((win (page-datum page 'text-window))
- (menu (page-datum page 'menu)))
- (clear win)
- (addstr win
- (justify* (gettext "Select a disk to partition (or repartition),
or choose \"Continue\" to leave the disk(s) unchanged.")
- (getmaxx win)))
-
+ (let ((text-window (page-datum page 'text-window))
+ (menu (page-datum page 'menu)))
+ (erase text-window)
+ (addstr text-window (justify* (gettext "Select a disk to partition (or
repartition), or choose \"Continue\" to leave the disk(s) unchanged.")
+ (getmaxx text-window)))
(menu-set-items! menu (volumes))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
(menu-redraw menu)
- (menu-refresh menu)))
+ (menu-refresh menu)
+ (buttons-refresh (page-datum page 'navigation))))
(define (disk-page-activate-item page item)
(match item
@@ -71,51 +67,29 @@
(_ 'ignored)))
(define (truncate-string ss w)
- (if (> (string-length ss) w)
- (string-append
- (string-take ss (- w 3)) "...")
- ss))
+ (if (> (string-length ss) w)
+ (string-append (string-take ss (- w 3)) "...")
+ ss))
(define (disk-page-init p)
- (let* ((s (page-surface p))
- (frame (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (button-window (derwin (inner frame)
- 3 (getmaxx (inner frame))
- (- (getmaxy (inner frame)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (text-window (derwin (inner frame)
- 4
- (getmaxx (inner frame))
- 0 0 #:panel #f))
-
- (menu-window (derwin (inner frame)
- (- (getmaxy (inner frame)) 3 (getmaxy text-window))
- (getmaxx (inner frame))
- (getmaxy text-window) 0 #:panel #f))
- (menu (make-menu (volumes)
- #:disp-proc
- (lambda (d row)
- (let ((w 23))
- (format #f (ngettext "~28a ~? ~6a (~a
partition)"
- "~28a ~? ~6a (~a
partitions)"
- (length (disk-partitions
d)))
- (disk-name d)
- (format #f "~~~aa" (1+ w))
- (list (truncate-string (disk-vendor d)
w))
- (number->size (disk-size d))
- (length (disk-partitions d))))))))
-
- (push-cursor (page-cursor-visibility p))
- (page-set-datum! p 'text-window text-window)
- (page-set-wwin! p frame)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (menu-post menu menu-window)
- (buttons-post buttons button-window)
- (refresh* (outer frame))
- (refresh* button-window)))
+ (match (create-vbox (page-surface p) 4 (- (getmaxy (page-surface p)) 4 3) 3)
+ ((text-window menu-window button-window)
+ (let* ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu (volumes)
+ #:disp-proc
+ (lambda (d row)
+ (let ((w 23))
+ (format #f (ngettext "~28a ~? ~6a (~a partition)"
+ "~28a ~? ~6a (~a partitions)"
+ (length (disk-partitions d)))
+ (disk-name d)
+ (format #f "~~~aa" (1+ w))
+ (list (truncate-string (disk-vendor d) w))
+ (number->size (disk-size d))
+ (length (disk-partitions d))))))))
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (menu-post menu menu-window)
+ (buttons-post buttons button-window)))))
diff --git a/gnu/system/installer/filesystems.scm
b/gnu/system/installer/filesystems.scm
index bdccf2b..df79dd1 100644
--- a/gnu/system/installer/filesystems.scm
+++ b/gnu/system/installer/filesystems.scm
@@ -133,8 +133,9 @@
0
#:activator filesystem-page-activate-item))
-(define my-buttons `((continue ,(M_ "_Continue") #t)
- (cancel ,(M_ "Canc_el") #t)))
+(define my-buttons
+ `((continue ,(M_ "_Continue") #t)
+ (cancel ,(M_ "Canc_el") #t)))
(define menu-format "~30a ~7a ~16a ~a")
@@ -143,24 +144,21 @@
(filesystem-page-init page)
(page-set-initialised! page #t))
- (let ((text-win (page-datum page 'text-window))
+ (let ((text-window (page-datum page 'text-window))
(menu (page-datum page 'menu)))
- (clear text-win)
- (addstr text-win
+ (erase text-window)
+ (addstr text-window
(gettext "Select a partition to change its mount point or filesystem."))
- (addstr text-win "
+ (addstr text-window "
")
(let ((header (format #f menu-format (gettext "Device") (gettext "Size")
(gettext "Filesystem") (gettext "Mountpoint"))))
- (addstr text-win header)
- (addstr text-win "
+ (addstr text-window header)
+ (addstr text-window "
")
- (hline text-win (acs-hline) (string-length header))
+ (hline text-window (acs-hline) (string-length header))
)
(menu-set-items! menu (partition-volume-pairs))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
(menu-redraw menu)
(menu-refresh menu)))
@@ -205,50 +203,25 @@
(_ 'ignored)))
(define (filesystem-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
- (text-window (derwin (inner pr) 3 (getmaxx (inner pr))
- 0 0 #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (mwin (derwin (inner pr)
- (- (getmaxy (inner pr)) 3 (getmaxy text-window))
- (- (getmaxx (inner pr)) 0)
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu
- (partition-volume-pairs)
- #:disp-proc
- (lambda (d row)
- (let* ((part (car d))
- (name (partition-name part))
- (fs-spec
- (assoc-ref mount-points name)))
-
- (format #f menu-format
- name
- (number->size (partition-size part))
- (if fs-spec (file-system-spec-type fs-spec) "")
- (if fs-spec
+ (match (create-vbox (page-surface p) 3 (- (getmaxy (page-surface p)) 3 3) 3)
+ ((text-window mwin bwin)
+ (let ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu (partition-volume-pairs)
+ #:disp-proc
+ (lambda (d row)
+ (let* ((part (car d))
+ (name (partition-name part))
+ (fs-spec
+ (assoc-ref mount-points name)))
+ (format #f menu-format
+ name
+ (number->size (partition-size part))
+ (if fs-spec (file-system-spec-type fs-spec) "")
+ (if fs-spec
(file-system-spec-mount-point fs-spec)
"")))))))
-
- (push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (page-set-datum! p 'text-window text-window)
- (menu-post menu mwin)
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* bwin)))
-
-
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (page-set-datum! p 'text-window text-window)
+ (menu-post menu mwin)
+ (buttons-post buttons bwin)))))
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index 71584af..12a30e9 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -79,7 +79,7 @@ match those uuids read from the respective partitions"
(page-leave)
'cancelled)
('format
- (let ((window-port (make-window-port config-window)))
+ (let ((window-port (make-window-port (inner config-window))))
(for-each
(lambda (x)
(match x
@@ -126,40 +126,10 @@ match those uuids read from the respective partitions"
(when (not (page-initialised? page))
(format-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page))))
-
-
-(define (format-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
- (text-window (derwin
- (inner pr)
- 3 (getmaxx (inner pr))
- 0 0
- #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
-
- (config-window (make-boxed-window
- (inner pr)
- (- (getmaxy (inner pr))
- (getmaxy bwin)
- (getmaxy text-window))
- (getmaxx (inner pr))
- (getmaxy text-window)
- 0)))
+ (let ((text-window (page-datum page 'text-window))
+ (config-window (page-datum page 'config-window)))
+ (erase text-window)
(render-stexi
text-window
(texi-fragment->stexi
@@ -167,17 +137,34 @@ match those uuids read from the respective partitions"
(G_ "The partitions ~s will be formatted. @strong{Any existing
data on these partitions will be destroyed if you continue!!}")
(map (lambda (x) (car x))
mount-points)))
- #:markup-table installer-texinfo-markup)
+ #:markup-table installer-texinfo-markup))
+ ; TODO refresh inner config-window
+ )
+(define (format-page-init p)
+ (let* ((s (page-surface p))
+ (text-window (derwin
+ s
+ 3 (getmaxx s)
+ 0 0
+ #:panel #t))
+
+ (bwin (derwin s
+ 3 (getmaxx s)
+ (- (getmaxy s) 3) 0
+ #:panel #t))
+ (buttons (make-buttons my-buttons 1))
+ (config-window (make-boxed-window
+ s
+ (- (getmaxy s)
+ (getmaxy bwin)
+ (getmaxy text-window))
+ (getmaxx s)
+ (getmaxy text-window)
+ 0)))
(push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
(page-set-datum! p 'navigation buttons)
- (page-set-datum! p 'config-window (inner config-window))
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* text-window)
-
- (refresh* (outer config-window))
-
- (refresh* bwin)))
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'config-window config-window)
+ (buttons-post buttons bwin)))
diff --git a/gnu/system/installer/guixsd-installer.scm
b/gnu/system/installer/guixsd-installer.scm
index 2ec54d0..6d81c9d 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -19,6 +19,7 @@
(define-module (gnu system installer guixsd-installer))
(use-modules (ncurses curses)
+ (ncurses panel)
(gurses menu)
(gnu system installer utils)
(gnu system installer misc)
@@ -116,9 +117,9 @@
page
(or
(getenv "TZDIR")
- (parameterize ((current-error-port
(%make-void-port "w")))
- (string-append (car (slurp* "guix" "build"
"tzdata"))
- "/share/zoneinfo")))))))
+ (string-append (car (slurp** (page-surface
page)
+ "guix" "build"
"tzdata"))
+ "/share/zoneinfo"))))))
(hostname . ,(make-task hostname-menu-title
'()
@@ -219,74 +220,35 @@
(('menu-item-activated x)
(do-task (car x) page)
(page-uniquify)
- ((page-refresh (car stack)) (car stack))
+ (page-refresh (car stack))
'handled)
(_ #f)))
(define (main-page-init page)
- (let* ((frame (make-boxed-window (page-surface page) (lines) (cols) 0 0
- #:title (page-title page)))
- (background (inner frame))
-
-
- (text-window (derwin background 4 (getmaxx background)
- 0 0 #:panel #f))
-
- (win (derwin background (- (getmaxy background) (getmaxy text-window)
3)
- (- (getmaxx background) 2) (getmaxy text-window) 1
#:panel #f))
-
- (main-menu (make-menu main-options
- #:disp-proc (lambda (datum row)
- (gettext (task-title (cdr
datum)))))))
-
-
- (page-set-wwin! page frame)
- (page-set-datum! page 'menu main-menu)
- (page-set-datum! page 'text-window text-window)
- (page-set-datum! page 'background background)
- (menu-post main-menu win)
-
+ (match (create-vbox (page-surface page) 4 (- (getmaxy (page-surface page))
4))
+ ((text-window win)
+ (let ((main-menu (make-menu main-options
+ #:disp-proc (lambda (datum row)
+ (gettext (task-title (cdr datum)))))))
+ (page-set-datum! page 'menu main-menu)
+ (page-set-datum! page 'text-window text-window)
+ (menu-post main-menu win)))
(push-cursor (page-cursor-visibility page))))
-
(define (main-page-refresh page)
(when (not (page-initialised? page))
(main-page-init page)
(page-set-initialised! page #t))
-
(let ((text-window (page-datum page 'text-window))
- (menu (page-datum page 'menu))
- (background (page-datum page 'background)))
-
- (clear background)
-
+ (menu (page-datum page 'menu)))
+ (erase text-window)
(addstr*
text-window
(format
#f
(gettext
"To start the complete installation process, choose ~s. Alternatively,
you may run each step individually for a slower, more controlled experience.")
- (gettext installation-menu-title)))
-
-
- ;; Do the key action labels
- (let ((ypos (1- (getmaxy background)))
- (str0 (gettext "Get a Shell <F1>"))
- (str1 (gettext "Language <F9>"))
- (str2 (gettext "Keyboard <F10>")))
-
- (addstr background str0 #:y ypos #:x 0)
- (addstr background str1 #:y ypos #:x
- (truncate (/ (- (getmaxx background)
- (string-length str1)) 2)))
- (addstr background str2 #:y ypos #:x
- (- (getmaxx background) (string-length str2))))
-
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-redraw menu)
- (menu-refresh menu)))
+ (gettext installation-menu-title)))))
(define-public (guixsd-installer)
@@ -304,6 +266,21 @@
(system* "dmesg" "--console-off")
(initscr)))
+ ;; Do the key action labels
+ (let ((ypos (1- (getmaxy stdscr)))
+ (str0 (gettext "Get a Shell <F1>"))
+ (str1 (gettext "Language <F9>"))
+ (str2 (gettext "Keyboard <F10>")))
+
+ (addstr stdscr str0 #:y ypos #:x 0)
+ (addstr stdscr str1 #:y ypos #:x
+ (truncate (/ (- (getmaxx stdscr)
+ (string-length str1)) 2)))
+ (addstr stdscr str2 #:y ypos #:x
+ (- (getmaxx stdscr)
+ (string-length str2))))
+
+
;; Set up timeout for getch so that we can update status displays.
(timeout! stdscr 500) ; 500 ms
@@ -325,10 +302,12 @@
(let ((page (make-page
stdscr (gettext "GuixSD Installer")
main-page-refresh 0
- #:activator main-page-activate-item)))
+ #:activator main-page-activate-item
+ #:height-subtraction 1)))
(page-enter page)
(page-push #f)
- (let loop ((ch (getch stdscr)))
+ (refresh-screen)
+ (let loop ((ch (page-getch (page-top))))
(let ((current-page (page-top)))
(if (eqv? ch KEY_MOUSE)
(match (or (getmouse) '())
@@ -340,8 +319,14 @@
device-id
x y z
button-state)))
- (when (eq? ret 'cancelled)
- (page-ppop))))
+ (match ret
+ ('cancelled
+ (page-ppop))
+ (#f #f)
+ ('ignored #f)
+ (_ ; Refresh just in case.
+ (page-refresh (page-top))
+ (refresh-screen)))))
(_ #f))
(if ch ; not timeout
(let* ((current-page (page-top))
@@ -351,8 +336,9 @@
(base-page-key-handler current-page ch))))
(if ch ; not timeout
(let ((current-page (page-top))) ; Not necessarily the same.
- ((page-refresh current-page) current-page))))
- (loop (getch stdscr)))
+ (page-refresh current-page)
+ (refresh-screen))))
+ (loop (page-getch (page-top))))
(endwin)))
(lambda (key . args)
diff --git a/gnu/system/installer/hostname.scm
b/gnu/system/installer/hostname.scm
index 6372fe7..dbe72e8 100644
--- a/gnu/system/installer/hostname.scm
+++ b/gnu/system/installer/hostname.scm
@@ -24,6 +24,7 @@
#:use-module (gurses form)
#:use-module (gurses buttons)
#:use-module (ncurses curses)
+ #:use-module (ncurses panel)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@@ -60,19 +61,15 @@
(when (not (page-initialised? page))
(host-name-init page)
(page-set-initialised! page #t))
-
(let ((form (page-datum page 'form))
(text-window (page-datum page 'text-window)))
- (clear text-window)
+ (erase text-window)
(addstr*
text-window
(format
#f
(G_ "Enter the host name for the new system. Only letters, digits and
hyphens are allowed. The first character may not be a hyphen. A maximum of ~a
characters are allowed.")
- max-length))
- (refresh* text-window)
- (refresh* (outer (page-wwin page)))
- (refresh* (form-window form))))
+ max-length))))
(define (host-name-activate-item page item)
(let ((form (page-datum page 'form))
@@ -91,38 +88,16 @@
(define my-buttons `((cancel ,(M_ "Cancel") #f)))
(define (host-name-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window
- #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
- (text-window (derwin (inner pr) 5 (getmaxx (inner pr))
- 0 0 #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
-
- (nav (make-buttons my-buttons 1))
-
- (fw (derwin (inner pr)
- 2
- (getmaxx (inner pr))
- (getmaxy text-window) 0 #:panel #f))
-
-
- (form (make-form my-fields)))
-
- (page-set-datum! p 'navigation nav)
- (page-set-datum! p 'text-window text-window)
- (page-set-datum! p 'form form)
- (push-cursor (page-cursor-visibility p))
-
- (form-post form fw)
- (buttons-post nav bwin)
- (page-set-wwin! p pr)
- (refresh* (outer pr))))
+ (match (create-vbox (page-surface p) 5 (- (getmaxy (page-surface p)) 5 3) 3)
+ ((text-window fw bwin)
+ (let ((nav (make-buttons my-buttons 1))
+ (form (make-form my-fields)))
+ (page-set-datum! p 'navigation nav)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'form form)
+ (page-set-datum! p 'fw fw)
+ (push-cursor (page-cursor-visibility p))
+
+ (form-post form fw)
+ (buttons-post nav bwin)))))
diff --git a/gnu/system/installer/install.scm b/gnu/system/installer/install.scm
index 201bdfc..8a4f580 100644
--- a/gnu/system/installer/install.scm
+++ b/gnu/system/installer/install.scm
@@ -147,36 +147,29 @@
(define (install-page-refresh page)
(when (not (page-initialised? page))
(install-page-init page)
- (page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page))))
+ (page-set-initialised! page #t)))
(define (install-page-init p)
(let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
(text-window (derwin
- (inner pr)
- 3 (getmaxx (inner pr))
+ s
+ 3 (getmaxx s)
0 0
- #:panel #f))
+ #:panel #t))
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
+ (bwin (derwin s
+ 3 (getmaxx s)
+ (- (getmaxy s) 3) 0
+ #:panel #t))
(buttons (make-buttons my-buttons 1))
(config-window (make-boxed-window
- (inner pr)
- (- (getmaxy (inner pr))
+ s
+ (- (getmaxy s)
(getmaxy bwin)
(getmaxy text-window))
- (getmaxx (inner pr))
+ (getmaxx s)
(getmaxy text-window)
0))
)
@@ -186,11 +179,7 @@
"Choose \"Continue\" to start installing the system."))
(push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
(page-set-datum! p 'navigation buttons)
(page-set-datum! p 'config-window (inner config-window))
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* text-window)
- (refresh* bwin)))
+ (buttons-post buttons bwin)))
diff --git a/gnu/system/installer/key-map.scm b/gnu/system/installer/key-map.scm
index 8c80ff1..69dde11 100644
--- a/gnu/system/installer/key-map.scm
+++ b/gnu/system/installer/key-map.scm
@@ -65,50 +65,23 @@
(when (not (page-initialised? page))
(key-map-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-refresh (page-datum page 'menu)))
+ ;auto (menu-refresh (page-datum page 'menu))
+ )
(define (key-map-page-init p)
- (let* ((s (page-surface p))
- (frame (make-boxed-window #f
- (- (getmaxy s) 5) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (button-window (derwin (inner frame)
- 3 (getmaxx (inner frame))
- (- (getmaxy (inner frame)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (text-window (derwin (inner frame)
- 4
- (getmaxx (inner frame))
- 0 0 #:panel #f))
-
- (menu-window (derwin (inner frame)
- (- (getmaxy (inner frame)) 3 (getmaxy
text-window))
- (getmaxx (inner frame))
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu
+ (match (create-vbox (page-surface p) 4 (- (getmaxy (page-surface p)) 3 4) 3)
+ ((text-window menu-window button-window)
+ (let ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu
(let ((dir (page-datum p 'directory)))
(filter (lambda (name)
(and (not (string=? name "./"))
(not (string=? name "include/"))))
(scandir-with-slashes dir))))))
+ (menu-post menu menu-window)
- (menu-post menu menu-window)
-
- (addstr* text-window
- (gettext "Select an item most closely matching your keyboard
layout:" ))
- (push-cursor (page-cursor-visibility p))
- (page-set-wwin! p frame)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (buttons-post buttons button-window)
- (refresh* (outer frame))
- (refresh* (inner frame))
- (refresh* text-window)
- (refresh* button-window)))
+ (addstr* text-window (gettext "Select an item most closely matching your
keyboard layout:" ))
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)))))
diff --git a/gnu/system/installer/locale.scm b/gnu/system/installer/locale.scm
index 80d6c87..d1f0256 100644
--- a/gnu/system/installer/locale.scm
+++ b/gnu/system/installer/locale.scm
@@ -25,6 +25,7 @@
#:use-module (gurses buttons)
#:use-module (ncurses curses)
#:use-module (ice-9 format)
+ #:use-module (ice-9 poe)
#:use-module (ice-9 match)
#:export (make-locale-page))
@@ -40,22 +41,16 @@
#:activator locale-page-activate-item))
(define (locale-page-refresh page)
- (when (not (page-initialised? page))
- (locale-page-init page)
- (page-set-initialised! page #t))
+ (when (not (page-initialised? page))
+ (locale-page-init page)
+ (page-set-initialised! page #t))
- (let ((win (page-datum page 'text-window))
- (menu (page-datum page 'menu)))
- (clear win)
- (addstr win
- (justify* (gettext "The following languages are available.")
- (getmaxx win)))
-
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-redraw menu)
- (menu-refresh menu)))
+ (let ((text-window (page-datum page 'text-window))
+ (menu (page-datum page 'menu)))
+ (clear text-window)
+ (addstr text-window
+ (justify* (gettext "The following languages are available.")
+ (getmaxx text-window)))))
(define (locale-page-activate-item page item)
(match item
@@ -69,7 +64,7 @@
(_
'ignored)))
-(define (locale-description locale)
+(define (locale-descriptionx locale)
"Return a string describing LOCALE"
(define loc #f)
(define lc-all "LC_ALL")
@@ -88,41 +83,22 @@
(setenv lc-all loc)
(unsetenv lc-all)))))
-(define (locale-page-init p)
- (let* ((s (page-surface p))
- (frame (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (button-window (derwin (inner frame)
- 3 (getmaxx (inner frame))
- (- (getmaxy (inner frame)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (text-window (derwin (inner frame)
- 4
- (getmaxx (inner frame))
- 0 0 #:panel #f))
+(define locale-description
+ (pure-funcq locale-descriptionx))
- (menu-window (derwin (inner frame)
- (- (getmaxy (inner frame)) 3 (getmaxy text-window))
- (getmaxx (inner frame))
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu %default-locale-definitions
+(define (locale-page-init p)
+ (match (create-vbox (page-surface p) 4 (- (getmaxy (page-surface p)) 4 3) 3)
+ ((text-window menu-window button-window)
+ (let ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu %default-locale-definitions
#:disp-proc (lambda (d row)
(format #f "~60a ~10a"
(locale-description
(locale-definition-name d))
(locale-definition-name d))))))
-
- (push-cursor (page-cursor-visibility p))
- (page-set-datum! p 'text-window text-window)
- (page-set-wwin! p frame)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (menu-post menu menu-window)
- (buttons-post buttons button-window)
- (refresh* (outer frame))
- (refresh* button-window)))
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (menu-post menu menu-window)
+ (buttons-post buttons button-window)))))
diff --git a/gnu/system/installer/mount-point.scm
b/gnu/system/installer/mount-point.scm
index c6ee4a4..3235edf 100644
--- a/gnu/system/installer/mount-point.scm
+++ b/gnu/system/installer/mount-point.scm
@@ -46,9 +46,16 @@
(when (not (page-initialised? page))
(mount-point-page-init page)
(page-set-initialised! page #t))
- (let ((form (page-datum page 'form)))
- (refresh* (outer (page-wwin page)))
- (refresh* (form-window form))))
+
+ (let ((dev (page-datum page 'device))
+ (text-window (page-datum page 'text-window)))
+ (erase text-window)
+ (addstr*
+ text-window
+ (format #f
+ (gettext
+ "The device ~s is currently configured as follows. You may
change the configuration here if desired.")
+ dev))))
(define (mount-point-page-activate-item page item)
(let ((form (page-datum page 'form))
@@ -81,33 +88,10 @@
(cancel ,(M_ "Cancel") #f)))
(define (mount-point-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window
- #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
- (text-window (derwin (inner pr) 3 (getmaxx (inner pr))
- 0 0 #:panel #t))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #t))
-
- (nav (make-buttons my-buttons 1))
-
- (fw (derwin (inner pr)
- (-
- (getmaxy (inner pr))
- (getmaxy text-window)
- (getmaxy bwin))
- (getmaxx (inner pr))
- (getmaxy text-window) 0 #:panel #f))
-
-
- (form (make-form
+ (match (create-vbox (page-surface p) 3 (- (getmaxy (page-surface p)) 3 3) 3)
+ ((text-window fw bwin)
+ (let ((nav (make-buttons my-buttons 1))
+ (form (make-form
(my-fields)
(lambda (f)
(let ((field (get-current-field f)))
@@ -126,38 +110,28 @@
(form-set-value! f 'label "")
(form-set-value! f 'mount-point ""))))))))))
- (page-set-datum! p 'navigation nav)
- (let ((dev (page-datum p 'device)))
- (addstr*
- text-window
- (format #f
- (gettext
- "The device ~s is currently configured as follows. You may
change the configuration here if desired.")
- dev))
-
- (form-post form fw))
-
- (let* ((dev (page-datum p 'device))
- (fss (assoc-ref mount-points dev)))
-
- (form-set-value! form 'label
- (if fss
- (file-system-spec-label fss)
- (string-append host-name
- "-")))
- (when fss
- (form-set-value! form 'mount-point
- (file-system-spec-mount-point fss))
- (form-set-value! form 'fs-type
- (symbol->string
- (file-system-spec-type fss)))))
-
- (form-set-current-field form 0)
-
- (push-cursor (page-cursor-visibility p))
- (buttons-post nav bwin)
- (page-set-datum! p 'form form)
-
- (page-set-wwin! p pr)
- (refresh* (outer pr))))
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'navigation nav)
+ (form-post form fw)
+
+ (let* ((dev (page-datum p 'device))
+ (fss (assoc-ref mount-points dev)))
+
+ (form-set-value! form 'label
+ (if fss
+ (file-system-spec-label fss)
+ (string-append host-name
+ "-")))
+ (when fss
+ (form-set-value! form 'mount-point
+ (file-system-spec-mount-point fss))
+ (form-set-value! form 'fs-type
+ (symbol->string
+ (file-system-spec-type fss)))))
+
+ (form-set-current-field form 0)
+
+ (push-cursor (page-cursor-visibility p))
+ (buttons-post nav bwin)
+ (page-set-datum! p 'form form)))))
diff --git a/gnu/system/installer/network.scm b/gnu/system/installer/network.scm
index 3379734..31d8114 100644
--- a/gnu/system/installer/network.scm
+++ b/gnu/system/installer/network.scm
@@ -132,10 +132,10 @@
(when (not (page-initialised? page))
(network-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-refresh (page-datum page 'menu)))
+ (let ((text-window (page-datum page 'text-window)))
+ (erase text-window)
+ (addstr* text-window (format #f
+ (gettext "To install GuixSD a connection to one of ~s must be available.
The following network devices exist on the system. Select one to configure or
\"Continue\" to proceeed.") %default-substitute-urls))))
(define (if-flags ifce)
(network-interface-flags
@@ -144,35 +144,16 @@
(define (network-page-init p)
(define prev-flags (map-in-order if-flags (interfaces)))
- (let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (text-window (derwin
- (inner pr)
- 5 (getmaxx (inner pr))
- 0 0
- #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (mwin (derwin (inner pr)
- (- (getmaxy (inner pr)) (getmaxy text-window) 3)
- (- (getmaxx (inner pr)) 0)
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu
- (filter (lambda (i) (memq
+ (match (create-vbox (page-surface p) 5 (- (getmaxy (page-surface p)) 5 3) 3)
+ ((text-window mwin bwin)
+ (let ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu
+ (filter (lambda (i) (memq
(assq-ref i 'class)
'(ethernet wireless)))
(interfaces))
- #:disp-proc
- (lambda (datum row)
+ #:disp-proc
+ (lambda (datum row)
(format #f "~55a (~a) (status: ~a)"
(name->description (assq-ref datum 'name))
(assq-ref datum 'class)
@@ -180,29 +161,21 @@
(gettext "Running")
(gettext "Down")))))))
- (addstr* text-window (format #f
- (gettext
- "To install GuixSD a connection to one of
~s must be available. The following network devices exist on the system.
Select one to configure or \"Continue\" to proceeed.")
%default-substitute-urls))
-
-
- ;; Raise sigalarm every second to refresh the menu
- (sigaction SIGALRM (lambda (_)
- (let ((flags
- (map-in-order
- if-flags
- (interfaces))))
-
- (when (not (equal? prev-flags flags))
- (set! prev-flags flags)
- (menu-redraw menu)))))
- (setitimer ITIMER_REAL 1 0 1 0)
-
- (push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (menu-post menu mwin)
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* text-window)
- (refresh* bwin)))
+ ;; Raise sigalarm every second to refresh the menu
+ (sigaction SIGALRM (lambda (_)
+ (let ((flags
+ (map-in-order
+ if-flags
+ (interfaces))))
+
+ (when (not (equal? prev-flags flags))
+ (set! prev-flags flags)
+ (menu-redraw menu)))))
+ (setitimer ITIMER_REAL 1 0 1 0)
+
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (page-set-datum! p 'text-window text-window)
+ (menu-post menu mwin)
+ (buttons-post buttons bwin)))))
diff --git a/gnu/system/installer/page.scm b/gnu/system/installer/page.scm
index 478f114..2f75fdb 100644
--- a/gnu/system/installer/page.scm
+++ b/gnu/system/installer/page.scm
@@ -34,23 +34,27 @@
#:export (page-mouse-handler)
#:export (page-default-key-handler)
#:export (page-default-mouse-handler)
+ #:export (page-getch)
+ #:export (page-focused-window)
+ #:export (refresh-screen)
#:use-module (gurses buttons)
#:use-module (gurses menu)
#:use-module (gurses form)
#:use-module (ncurses curses)
+ #:use-module (ncurses panel)
#:use-module (gnu system installer utils)
#:use-module (gnu system installer levelled-stack)
#:use-module (srfi srfi-9)
#:use-module (ice-9 match))
(define-record-type <page>
- (make-page' surface title inited refresh cursor-visibility key-handler
mouse-handler data)
+ (make-page' surface title inited refresher cursor-visibility key-handler
mouse-handler data)
page?
(title page-title)
(surface page-surface)
(inited page-initialised? page-set-initialised!)
- (refresh page-refresh)
+ (refresher page-refresher)
(cursor-visibility page-cursor-visibility)
(key-handler page-key-handler)
(mouse-handler page-mouse-handler)
@@ -152,7 +156,6 @@ If a form is used it's assumed that the menu is not used
and vice versa."
(if nav
(buttons-selected-symbol nav)
'default)))))
-
((and menu (menu-active menu) (std-menu-key-handler menu ch))
'handled)
@@ -189,16 +192,23 @@ If a form is used it's assumed that the menu is not used
and vice versa."
(else
'ignored))))
-(define* (make-page surface title refresh cursor-visibility
+(define* (make-page s title refresh cursor-visibility
#:optional
(key-handler page-default-key-handler)
(mouse-handler page-default-mouse-handler)
#:key
- activator)
- (let ((result (make-page' surface title #f refresh cursor-visibility
key-handler mouse-handler '())))
- (if activator
- (page-set-datum! result 'activator activator))
- result))
+ activator
+ (height-subtraction 0))
+ (let* ((frame (make-boxed-window s
+ (- (getmaxy s) height-subtraction) (-
(getmaxx s) 0)
+ 0 0
+ #:title title))
+ (xsurface (inner frame)))
+ (let* ((result (make-page' xsurface title #f refresh cursor-visibility
key-handler mouse-handler '())))
+ (page-set-wwin! result frame)
+ (if activator
+ (page-set-datum! result 'activator activator))
+ result)))
(define (page-set-datum! page key value)
(page-set-data! page (acons key value (page-data page))))
@@ -208,9 +218,68 @@ If a form is used it's assumed that the menu is not used
and vice versa."
(define (page-leave)
(pop-cursor)
- (page-pop))
+ (let* ((frame (page-wwin (page-top)))
+ (window (outer frame)))
+ (hide-panel window)
+ ;(hide-panel (page-surface (page-top)))
+ (deep-visit-windows delwin window)
+ ;(redrawwin stdscr)
+ (update-panels)
+ (doupdate)
+ (page-pop)
+ ;(deep-visit-windows touchwin (outer (page-wwin (page-top)))) ; FIXME
+ ))
+
+(define (page-refresh p)
+ (let ((focused-window (or (page-focused-window p) (page-surface p))))
+ (match (getyx focused-window)
+ ((y x)
+ (erase (page-surface p))
+ ((page-refresher p) p)
+ (let ((form (page-datum p 'form))
+ (buttons (page-datum p 'navigation))
+ (menu (page-datum p 'menu)))
+ (boxed-window-decoration-refresh (page-wwin p) (page-title p))
+ (if menu
+ (begin
+ (menu-redraw menu)
+ (menu-refresh menu)))
+ (if buttons
+ (buttons-refresh buttons))
+ (if form
+ (form-refresh form))
+ (move focused-window y x))))))
(define (page-enter p)
(page-push p)
- ((page-refresh p) p))
+ ;(erase (page-surface p))
+ (page-refresh p))
+
+(define (page-focused-window p)
+ (let* ((menu (page-datum p 'menu))
+ (form (page-datum p 'form))
+ (buttons (page-datum p 'navigation)))
+ (cond
+ ((and menu (menu-active menu))
+ (menu-window menu))
+ ((and form (form-enabled? form))
+ (form-window form))
+ (buttons
+ (buttons-window buttons))
+ (else ; shouldn't happen.
+ #f))))
+
+(define (page-getch p)
+ (let ((window (page-focused-window p)))
+ (keypad! window #t)
+ (timeout! window 500) ; ms
+ (getch window)))
+(define (refresh-screen)
+ (let* ((page (page-top))
+ (window (page-focused-window page)))
+ (match (getyx window)
+ ((y x)
+ (update-panels)
+ (doupdate)
+ (move window y x)))))
diff --git a/gnu/system/installer/passphrase.scm
b/gnu/system/installer/passphrase.scm
index 48ba14f..95365ec 100644
--- a/gnu/system/installer/passphrase.scm
+++ b/gnu/system/installer/passphrase.scm
@@ -26,6 +26,7 @@
#:use-module (gurses buttons)
#:use-module (ncurses curses)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
#:export (make-passphrase-page))
@@ -55,17 +56,12 @@
(let ((form (page-datum page 'form))
(access-point (page-datum page 'access-point))
(text-window (page-datum page 'text-window)))
-
- (clear text-window)
+ (erase text-window)
(addstr*
text-window
(gettext
(format #f "Enter the passphrase for the network ~a."
- (assq-ref access-point 'essid))))
-
- (refresh* text-window)
- (refresh* (outer (page-wwin page)))
- (refresh* (form-window form))))
+ (assq-ref access-point 'essid))))))
(define (passphrase-mouse-handler page device-id x y z button-state)
'ignored)
@@ -107,37 +103,15 @@
(define my-buttons `((cancel ,(M_ "Cancel") #f)))
(define (passphrase-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window
- #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
- (text-window (derwin (inner pr) 5 (getmaxx (inner pr))
- 0 0 #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
-
- (nav (make-buttons my-buttons 1))
-
- (fw (derwin (inner pr)
- 2
- (getmaxx (inner pr))
- (getmaxy text-window) 0 #:panel #f))
-
-
- (form (make-form my-fields)))
-
- (push-cursor (page-cursor-visibility p))
- (page-set-datum! p 'navigation nav)
- (page-set-datum! p 'text-window text-window)
- (page-set-datum! p 'form form)
-
- (form-post form fw)
- (buttons-post nav bwin)
- (page-set-wwin! p pr)
- (refresh* (outer pr))))
+ (match (create-vbox (page-surface p) 5 (- (getmaxy (page-surface p)) 5 3) 3)
+ ((text-window fw bwin)
+ (let ((nav (make-buttons my-buttons 1))
+ (form (make-form my-fields)))
+
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'navigation nav)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'form form)
+
+ (form-post form fw)
+ (buttons-post nav bwin)))))
diff --git a/gnu/system/installer/ping.scm b/gnu/system/installer/ping.scm
index ab78520..e0ee196 100644
--- a/gnu/system/installer/ping.scm
+++ b/gnu/system/installer/ping.scm
@@ -73,7 +73,6 @@
(car %default-substitute-urls)))))
(addstr test-window (G_ "Test successful. Network is working."))
(addstr test-window (G_ "Test failed. No servers reached.")))
- (refresh* test-window)
'handled))
(_
'ignored))))
@@ -84,40 +83,16 @@
(page-set-initialised! page #t))
(let ((text-window (page-datum page 'text-window)))
+ (erase text-window)
(addstr* text-window
- (G_ "Choose \"Test\" to check network connectivity."))
-
- (refresh* text-window)
- (refresh* (page-datum page 'test-window))))
+ (G_ "Choose \"Test\" to check network connectivity."))))
(define (ping-page-init p)
- (let* ((s (page-surface p))
- (frame (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (button-window (derwin (inner frame)
- 3 (getmaxx (inner frame))
- (- (getmaxy (inner frame)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (text-window (derwin (inner frame)
- 4
- (getmaxx (inner frame))
- 0 0 #:panel #f))
-
- (test-window (derwin (inner frame)
- (- (getmaxy (inner frame)) (getmaxy text-window)
(getmaxy button-window))
- (getmaxx (inner frame))
- (getmaxy text-window) 0 #:panel #f))
- )
-
- (box test-window 0 0)
- (page-set-wwin! p frame)
- (page-set-datum! p 'test-window test-window)
- (page-set-datum! p 'text-window text-window)
- (page-set-datum! p 'navigation buttons)
- (buttons-post buttons button-window)
- (refresh* text-window)
- (refresh* button-window)))
+ (match (create-vbox (page-surface p) 4 (- (getmaxy (page-surface p)) 4 3) 3)
+ ((text-window test-window button-window)
+ (let ((buttons (make-buttons my-buttons 1)))
+ (box test-window 0 0)
+ (page-set-datum! p 'test-window test-window)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)))))
diff --git a/gnu/system/installer/role.scm b/gnu/system/installer/role.scm
index d3d2e54..50a7551 100644
--- a/gnu/system/installer/role.scm
+++ b/gnu/system/installer/role.scm
@@ -1,3 +1,4 @@
+
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 John Darrington <address@hidden>
;;;
@@ -70,11 +71,9 @@
(when (not (page-initialised? page))
(role-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-refresh (page-datum page 'menu)))
-
+ (let ((text-window (page-datum page 'text-window)))
+ (erase text-window)
+ (addstr* text-window (format #f (gettext "Select from the list below
the role which most closely matches the purpose of the system to be
installed.")))))
(define roles `(,(make-role (M_ "Headless server")
`(tcpdump)
@@ -97,43 +96,15 @@
`(desktop))))
(define (role-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (text-window (derwin
- (inner pr)
- 5 (getmaxx (inner pr))
- 0 0
- #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (mwin (derwin (inner pr)
- (- (getmaxy (inner pr)) (getmaxy text-window) 3)
- (- (getmaxx (inner pr)) 0)
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu roles
+ (match (create-vbox (page-surface p) 5 (- (getmaxy (page-surface p)) 5 3) 3)
+ ((text-window mwin bwin)
+ (let* ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu roles
#:disp-proc (lambda (datum row)
(gettext (role-description datum))))))
-
- (addstr* text-window (format #f
- (gettext
- "Select from the list below the role which most closely matches
the purpose of the system to be installed.")))
-
- (push-cursor (page-cursor-visibility p))
-
- (page-set-wwin! p pr)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (menu-post menu mwin)
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* text-window)
- (refresh* bwin)))
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (page-set-datum! p 'text-window text-window)
+ (menu-post menu mwin)
+ (buttons-post buttons bwin)))))
diff --git a/gnu/system/installer/time-zone.scm
b/gnu/system/installer/time-zone.scm
index 396dcfb..24f0d5a 100644
--- a/gnu/system/installer/time-zone.scm
+++ b/gnu/system/installer/time-zone.scm
@@ -75,34 +75,14 @@
(when (not (page-initialised? page))
(time-zone-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-refresh (page-datum page 'menu)))
+ (let ((text-window (page-datum page 'text-window)))
+ (addstr* text-window (gettext "Select the default time zone for the
system:" ))))
(define (time-zone-page-init p)
- (let* ((s (page-surface p))
- (frame (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (button-window (derwin (inner frame)
- 3 (getmaxx (inner frame))
- (- (getmaxy (inner frame)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (text-window (derwin (inner frame)
- 4
- (getmaxx (inner frame))
- 0 0 #:panel #f))
-
- (menu-window (derwin (inner frame)
- (- (getmaxy (inner frame)) 3 (getmaxy
text-window))
- (getmaxx (inner frame))
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu
+ (match (create-vbox (page-surface p) 4 (- (getmaxy (page-surface p)) 4 3) 3)
+ ((text-window menu-window button-window)
+ (let ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu
(let* ((dir (page-datum p 'directory))
(all-names (scandir-with-slashes dir))
(useful-names (filter (lambda (name)
@@ -112,18 +92,11 @@
all-names)))
(sort useful-names string<)))))
- (menu-post menu menu-window)
-
- (addstr* text-window
- (gettext "Select the default time zone for the system:" ))
+ (menu-post menu menu-window)
- (push-cursor (page-cursor-visibility p))
+ (push-cursor (page-cursor-visibility p))
- (page-set-wwin! p frame)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (buttons-post buttons button-window)
- (refresh* (outer frame))
- (refresh* (inner frame))
- (refresh* text-window)
- (refresh* button-window)))
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)))))
diff --git a/gnu/system/installer/user-edit.scm
b/gnu/system/installer/user-edit.scm
index e72387b..a95b3bd 100644
--- a/gnu/system/installer/user-edit.scm
+++ b/gnu/system/installer/user-edit.scm
@@ -46,14 +46,18 @@
(page-set-datum! page 'parent parent)
page))
-
(define (user-edit-refresh page)
(when (not (page-initialised? page))
(user-edit-page-init page)
(page-set-initialised! page #t))
- (let ((form (page-datum page 'form)))
- (refresh* (outer (page-wwin page)))
- (refresh* (form-window form))))
+ (let ((acc (page-datum page 'account))
+ (text-window (page-datum page 'text-window)))
+ (erase text-window)
+ (addstr*
+ text-window
+ (if acc
+ (format #f (M_ "This user account currently has the following
details. You may change any details here as required."))
+ (format #f (M_ "Enter the details of the new user below."))))))
(define (user-edit-page-activate-item page item)
(let ((form (page-datum page 'form))
@@ -83,36 +87,15 @@
(_
'ignored))))
-(define my-buttons `((save ,(M_ "Save") #f)
- (cancel ,(M_ "Cancel") #f)))
+(define my-buttons
+ `((save ,(M_ "Save") #f)
+ (cancel ,(M_ "Cancel") #f)))
(define (user-edit-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window
- #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
-
- (text-window (derwin (inner pr) 3 (getmaxx (inner pr))
- 0 0 #:panel #t))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #t))
-
- (nav (make-buttons my-buttons 1))
-
- (fw (derwin (inner pr)
- (-
- (getmaxy (inner pr))
- (getmaxy text-window)
- (getmaxy bwin))
- (getmaxx (inner pr))
- (getmaxy text-window) 0 #:panel #f))
-
- (form (make-form (my-fields)
+ (match (create-vbox (page-surface p) 3 (- (getmaxy (page-surface p)) 3 3) 3)
+ ((text-window fw bwin)
+ (let* ((nav (make-buttons my-buttons 1))
+ (form (make-form (my-fields)
(lambda (frm)
;; Infer the most likely desired values of the
;; name and home fields from the other field values
@@ -135,15 +118,10 @@
"/home/"
(form-get-value
frm 'name))))))))))
- (page-set-datum! p 'navigation nav)
+ (page-set-datum! p 'navigation nav)
+ (page-set-datum! p 'text-window text-window)
(let ((acc (page-datum p 'account)))
- (addstr*
- text-window
- (if acc
- (format #f (M_ "This user account currently has the following details.
You may change any details here as required."))
- (format #f (M_ "Enter the details of the new user below."))))
-
(form-post form fw)
(when acc
@@ -153,7 +131,4 @@
(push-cursor (page-cursor-visibility p))
(buttons-post nav bwin)
- (page-set-datum! p 'form form)
-
- (page-set-wwin! p pr)
- (refresh* (outer pr))))
+ (page-set-datum! p 'form form)))))
diff --git a/gnu/system/installer/users.scm b/gnu/system/installer/users.scm
index b1041bd..b2961fe 100644
--- a/gnu/system/installer/users.scm
+++ b/gnu/system/installer/users.scm
@@ -35,7 +35,7 @@
(include "i18n.scm")
-(define (make-users-page parent title)
+(define (make-users-page parent title)
(make-page (page-surface parent)
title
users-page-refresh
@@ -70,53 +70,18 @@
(_
'ignored))))
+
+(define header-format "~16a ~40a")
+
(define (users-page-refresh page)
(when (not (page-initialised? page))
(users-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-refresh (page-datum page 'menu)))
-
-
-
-(define (users-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (text-window (derwin
- (inner pr)
- 3 (getmaxx (inner pr))
- 0 0
- #:panel #f))
-
- (header-window (derwin
- (inner pr)
- 2 (getmaxx (inner pr))
- 4 0 #:panel #f))
-
- (mwin (derwin (inner pr)
- (- (getmaxy (inner pr)) (getmaxy text-window) 3)
- (- (getmaxx (inner pr)) 0)
- 6 0 #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
-
- (header-format "~16a ~40a")
- (menu (make-menu users
- #:disp-proc (lambda (x r)
- (format #f header-format
- (user-account-name x)
- (user-account-comment x))))))
-
+ (let ((text-window (page-datum page 'text-window))
+ (header-window (page-datum page 'header-window))
+ (header (format #f header-format (gettext "Username")
+ (gettext "Real name"))))
+ (erase text-window)
(addstr*
text-window
(if (null? users)
@@ -125,20 +90,26 @@
(format #f (M_
"The following user accounts are currently configured.
You can edit the account details here and add or remove them as desired."))))
- (let ((header (format #f header-format (gettext "Username")
- (gettext "Real name"))))
- (addstr header-window header)
- (addstr header-window "
+ (erase header-window)
+ (addstr header-window header)
+ (addstr header-window "
")
- (hline header-window (acs-hline) (string-length header)))
+ (hline header-window (acs-hline) (string-length header))))
+
+(define (users-page-init p)
+ (match (create-vbox (page-surface p) 3 2 (- (getmaxy (page-surface p)) 3 2
3) 3)
+ ((text-window header-window mwin bwin)
+ (let* ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu users
+ #:disp-proc (lambda (x r)
+ (format #f header-format
+ (user-account-name x)
+ (user-account-comment x))))))
(push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
(page-set-datum! p 'menu menu)
(page-set-datum! p 'navigation buttons)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'header-window header-window)
(menu-post menu mwin)
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* header-window)
- (refresh* text-window)
- (refresh* bwin)))
+ (buttons-post buttons bwin)))))
diff --git a/gnu/system/installer/utils.scm b/gnu/system/installer/utils.scm
index bafd98c..832d934 100644
--- a/gnu/system/installer/utils.scm
+++ b/gnu/system/installer/utils.scm
@@ -21,6 +21,7 @@
justify*
addstr*
slurp*
+ slurp**
key-value-slurp*
quit-key?
@@ -33,6 +34,7 @@
make-boxed-window
inner
outer
+ deep-visit-windows
open-input-pipe-with-fallback*
@@ -41,8 +43,10 @@
window-pipe
pipe-cmd
refresh*
-
+
scandir-with-slashes
+ create-vbox
+ boxed-window-decoration-refresh
select-key?))
@@ -58,11 +62,7 @@
(ncurses curses))
(define (refresh* win)
- (if (panel? win)
- (begin
- (update-panels)
- (doupdate))
- (refresh win)))
+ #f)
(define (make-window-port win)
"Return a port which writes to the curses window WIN"
@@ -76,7 +76,9 @@
(vector
(lambda (c) (addch win c))
(lambda (s) (addstr win s))
- (lambda () (refresh* win))
+ (lambda () (refresh* win)
+ (update-panels)
+ (doupdate))
#f
#f)
"w"))
@@ -168,6 +170,17 @@ This version assumes some external entity puts in the
carriage returns."
result
#f)))
+(define (slurp** surface program . args)
+ (addstr surface "Please wait..." #:x 20 #:y 13)
+ (refresh* surface)
+ ;; This probably doesn't work because the window port is a soft port.
+ ;; pipe-cmd has a weird workaround for that.
+ (parameterize ((current-error-port (make-window-port surface)))
+ (let ((result (apply slurp* program args)))
+ (force-output (current-error-port))
+ (close-port (current-error-port))
+ result)))
+
(define (key-value-slurp* program . args)
"Slurp CMD, which is expected to give an output of key-value pairs -
each pair terminated with a newline and the key/value delimited with ="
@@ -254,31 +267,35 @@ Ignore blank lines."
(error "~s is not a window" outside))
outside)))
+(define* (boxed-window-decoration-refresh pr title)
+ (let ((win (outer pr)))
+ ;(erase win) ; FIXME Why does this nuke the label in an unrelated window?
WTF.
+ (color-set! win 0)
+ (box win (acs-vline) (acs-hline))
+ (if title
+ (begin
+ ;(move win 2 1)
+ ;(hline win (acs-hline) (- (getmaxx win) 2))
+ (color-set! win livery-title)
+ (move win 1 1)
+ (clrtoeol win) ; kills one char too much at the end.
+ (addstr win title #:y 1 #:x (round (/ (- (getmaxx win) (string-length
title)) 2)))))
+ (color-set! win 0)))
(define* (make-boxed-window orig height width starty startx #:key (title #f))
"Create a window with a frame around it, and optionally a TITLE. Returns a
pair whose car is the inner window and whose cdr is the frame."
(let* ((win (if orig
- (derwin orig height width starty startx #:panel #f)
- (newwin height width starty startx #:panel #f)))
- (ystart (if title 3 1))
- (sw (derwin win (- (getmaxy win) ystart 1)
- (- (getmaxx win) 2)
- ystart 1 #:panel #f)))
- (clear win)
- (box win (acs-vline) (acs-hline))
-
- (if title
- (begin
- (move win 2 1)
- (hline win (acs-hline) (- (getmaxx win) 2))
- (color-set! win livery-title)
- (addstr win title #:y 1
- #:x (round (/ (- (getmaxx win) (string-length title)) 2)))))
-
- (refresh* sw)
- ;; Return the inner and outer windows
- (cons sw win)))
+ (derwin orig height width starty startx #:panel #t)
+ (newwin height width starty startx #:panel #t)))
+ (ystart (if title 2 1)))
+ (let ((sw (derwin win (- (getmaxy win) ystart 1)
+ (- (getmaxx win) 2)
+ ystart 1 #:panel #t)))
+ (boxed-window-decoration-refresh (cons sw win) title)
+ ;(refresh* sw)
+ ;; Return the inner and outer windows
+ (cons sw win))))
(define (find-mount-device in mp)
@@ -329,3 +346,24 @@ mounts return the device on which the path IN would be
mounted."
('directory (string-append name "/"))
(_ name)))
(scandir dir)))
+
+(define (deep-visit-windows proc window)
+ (let ((panels (panels-map identity)))
+ (for-each
+ (lambda (subwindow)
+ (if (eq? (getparent subwindow) window)
+ (deep-visit-windows proc subwindow)))
+ panels))
+ (proc window))
+
+(define (create-vbox-i parent-window item-heights y)
+ (if (null? item-heights)
+ '()
+ (let ((item-height (car item-heights))
+ (maxx (getmaxx parent-window)))
+ (cons (derwin parent-window item-height maxx y 0 #:panel #t)
+ (create-vbox-i parent-window (cdr item-heights)
+ (+ y item-height))))))
+
+(define (create-vbox parent-window . item-heights)
+ (create-vbox-i parent-window item-heights 0))
diff --git a/gnu/system/installer/wireless.scm
b/gnu/system/installer/wireless.scm
index c9fa53c..9cb2a88 100644
--- a/gnu/system/installer/wireless.scm
+++ b/gnu/system/installer/wireless.scm
@@ -77,36 +77,17 @@
(when (not (page-initialised? page))
(wireless-page-init page)
(page-set-initialised! page #t))
- (touchwin (outer (page-wwin page)))
- (refresh* (outer (page-wwin page)))
- (refresh* (inner (page-wwin page)))
- (menu-refresh (page-datum page 'menu)))
-
+ (let ((text-window (page-datum page 'text-window)))
+ (erase text-window)
+ (addstr* text-window (format #f
+ (gettext
+ "Select an access point to connect.")))))
(define (wireless-page-init p)
- (let* ((s (page-surface p))
- (pr (make-boxed-window #f
- (- (getmaxy s) 4) (- (getmaxx s) 2)
- 2 1
- #:title (page-title p)))
- (text-window (derwin
- (inner pr)
- 5 (getmaxx (inner pr))
- 0 0
- #:panel #f))
-
- (bwin (derwin (inner pr)
- 3 (getmaxx (inner pr))
- (- (getmaxy (inner pr)) 3) 0
- #:panel #f))
- (buttons (make-buttons my-buttons 1))
-
- (mwin (derwin (inner pr)
- (- (getmaxy (inner pr)) (getmaxy text-window) 3)
- (- (getmaxx (inner pr)) 0)
- (getmaxy text-window) 0 #:panel #f))
-
- (menu (make-menu
+ (match (create-vbox (page-surface p) 5 (- (getmaxy (page-surface p)) 5 3) 3)
+ ((text-window mwin bwin)
+ (let* ((buttons (make-buttons my-buttons 1))
+ (menu (make-menu
;; Present a menu of available Access points in decreasing
;; order of signal strength
(sort
@@ -123,20 +104,12 @@
(and=> (assq-ref d 'encryption)
symbol->string)
(M_ "clear")))))))
-
- (addstr* text-window (format #f
- (gettext
- "Select an access point to connect.")))
-
- (push-cursor (page-cursor-visibility p))
- (page-set-wwin! p pr)
- (page-set-datum! p 'menu menu)
- (page-set-datum! p 'navigation buttons)
- (menu-post menu mwin)
- (buttons-post buttons bwin)
- (refresh* (outer pr))
- (refresh* text-window)
- (refresh* bwin)))
+ (push-cursor (page-cursor-visibility p))
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (page-set-datum! p 'text-window text-window)
+ (menu-post menu mwin)
+ (buttons-post buttons bwin)))))
diff --git a/gurses/buttons.scm b/gurses/buttons.scm
index dae43b9..c3aad7a 100644
--- a/gurses/buttons.scm
+++ b/gurses/buttons.scm
@@ -31,6 +31,8 @@
#:export (buttons-n-buttons)
#:export (buttons-key-matches-symbol?)
#:export (buttons-mouse-handler)
+ #:export (buttons-window)
+ #:export (buttons-refresh)
#:use-module (ncurses curses)
#:use-module (ice-9 match)
@@ -62,7 +64,8 @@
(define (draw-button b color)
(color-set! b color)
(box b 0 0)
- (refresh b))
+ ;(refresh b)
+ )
(define (buttons-unselect-all buttons)
(let* ((arry (buttons-array buttons))
@@ -80,7 +83,7 @@
key
(loop (1+ idx)
(match (array-ref (buttons-array buttons) idx)
- ((ch win sym)
+ ((ch win sym label)
(if (eq? ch c) sym #f)))))))
(define (buttons-select buttons which)
@@ -150,11 +153,13 @@
(width (+ (length label) 2))
(w (derwin win 3 width 0
(round (- (* (1+ i) (/ (getmaxx win) (1+ n)))
- (/ width 2))) #:panel #f)))
+ (/ width 2))) #:panel #t)))
+ (keypad! w #t)
(buttons-set-bwindows! buttons (cons w (buttons-bwindows
buttons)))
(box w 0 0)
(addchstr w label #:y 1 #:x 1)
- (loop (cdr bl) (1+ i) (acons mark (list w key) alist)))))))))
+ (loop (cdr bl) (1+ i) (acons mark (list w key label) alist)))
+ ))))))
@@ -174,7 +179,7 @@
(if (= current -1)
#f
(match (array-ref arry current)
- ((ch win sym)
+ ((ch win sym label)
sym)))))
(define (buttons-select-by-symbol buttons sym)
@@ -183,7 +188,7 @@
(let loop ((i 0))
(if (< i len)
(match (array-ref arry i)
- ((ch win xsym)
+ ((ch win xsym label)
(if (eq? xsym sym)
(buttons-set-selected! buttons i)
(loop (1+ i)))))))))
@@ -195,7 +200,7 @@
(let loop ((i 0))
(if (< i len)
(match (array-ref arry i)
- ((ch win sym)
+ ((ch win sym label)
(match (mouse-trafo win g-y g-x #f)
((y x)
(buttons-select buttons i)
@@ -205,3 +210,20 @@
'ignored)))))
'ignored)))
'ignored))
+
+(define (buttons-window buttons)
+ (car (buttons-bwindows buttons)))
+
+(define (buttons-refresh buttons)
+ (let ((selected-index (buttons-selected buttons))
+ (selected-color (buttons-active-color buttons)))
+ (for-each (lambda (index button a)
+ (draw-button button (if (= index selected-index)
+ selected-color
+ 0))
+ (match a
+ ((ch win sym label)
+ (addchstr button label #:y 1 #:x 1))))
+ (iota (length (buttons-bwindows buttons)))
+ (reverse (buttons-bwindows buttons))
+ (array->list (buttons-array buttons)))))
diff --git a/gurses/form.scm b/gurses/form.scm
index 618d1c6..581e1b8 100644
--- a/gurses/form.scm
+++ b/gurses/form.scm
@@ -32,6 +32,7 @@
#:export (form-set-current-field)
#:export (get-current-field)
#:export (std-form-mouse-handler)
+ #:export (form-refresh)
#:use-module (ncurses curses)
#:use-module (ncurses panel)
@@ -69,7 +70,7 @@
(callback form-callback))
(define (form-update-cursor form)
- "Updates the cursor for FIELD in FORM"
+ "Updates the cursor for the current field in FORM"
(let ((field (array-ref (form-items form) (form-current-item form))))
(move (form-window form) (form-current-item form)
(+ (field-cursor-position field)
@@ -146,7 +147,8 @@ label eq? to N"
(make-field
symbol label width menu
(let ((p (newwin (length things)
- width 0 0 #:panel #f)))
+ width 0 0 #:panel #t)))
+ (hide-panel p)
(menu-post menu p)
p)
"" 0 #f)))
@@ -346,23 +348,26 @@ Set the field value to the newly selected value."
'handled)
'ignored))
-(define (form-post form win)
- (form-set-window! form win)
- (let ((xpos
- ;; Print the labels and return the length of the longest
- (let loop ((fields (form-items form))
- (pos 0)
- (maxlen 0))
- (if (not (array-in-bounds? fields pos))
- (+ maxlen 2)
- (let ((f (array-ref fields pos)))
- ;; Print the label
- (addstr win (format #f "~a:" (field-label f)) #:y pos #:x 0)
- (loop fields (1+ pos) (max maxlen
- (string-length (field-label
f)))))))))
+(define (form-redraw-labels form)
+ (let* ((win (form-window form))
+ (xpos
+ ;; Print the labels and return the length of the longest
+ (let loop ((fields (form-items form)) (pos 0) (maxlen 0))
+ (if (not (array-in-bounds? fields pos))
+ (+ maxlen 2)
+ (let ((f (array-ref fields pos)))
+ ;; Print the label
+ (addstr win (format #f "~a:" (field-label f)) #:y pos #:x 0)
+ (loop fields (1+ pos) (max maxlen
+ (string-length (field-label f)))))))))
(form-set-tabpos! form xpos)
+ xpos))
+(define (form-post form win)
+ (keypad! win #t)
+ (form-set-window! form win)
+ (let ((xpos (form-redraw-labels form)))
(let loop ((fields (form-items form))
(pos 0))
(when (array-in-bounds? fields pos)
@@ -370,7 +375,7 @@ Set the field value to the newly selected value."
(p (field-popup f)))
(when p
(ensure-panel! win)
- (mvwin p
+ (move-panel p
(+ (getbegy win) pos)
(+ (form-tabpos form) (getbegx win))))
(loop fields (1+ pos)))))
@@ -385,6 +390,17 @@ Set the field value to the newly selected value."
(form-update-cursor form))
+(define (form-refresh form) ; TODO redraw labels
+ (erase (form-window form))
+ (form-redraw-labels form)
+ (let loop ((fields (form-items form))
+ (pos 0))
+ (if (array-in-bounds? fields pos)
+ (begin
+ (redraw-field form (array-ref fields pos) pos)
+ (loop fields (1+ pos)))))
+ (form-update-cursor form))
+
(define (get-current-field form)
(array-ref (form-items form) (form-current-item form)))
diff --git a/gurses/menu.scm b/gurses/menu.scm
index c8ff2f5..98377fe 100644
--- a/gurses/menu.scm
+++ b/gurses/menu.scm
@@ -119,7 +119,7 @@
(define (menu-redraw menu)
(define win (menu-window menu))
- (clear win)
+ (erase win)
(let populate ((row (menu-top-item menu))
(data (list-tail (menu-items menu) (menu-top-item menu) )))
(if (and
@@ -132,6 +132,7 @@
(populate (1+ row) (cdr data))))))
(define (menu-post menu win)
+ (keypad! win #t)
(menu-set-window! menu win)
(menu-redraw menu))
@@ -141,16 +142,8 @@
(attr (if (menu-active menu) (menu-active-attr menu) A_DIM)))
(bkgd win (color 0 (normal #\space)))
- (chgat win -1 attr colour #:y
- (- (menu-current-item menu) (menu-top-item menu))
- #:x 0)
- (if (panel? win)
- (begin
- (update-panels)
- (doupdate))
- (refresh win))))
-
-
+ (chgat win -1 attr colour
+ #:y (- (menu-current-item menu) (menu-top-item menu)) #:x 0)))
@@ -158,7 +151,7 @@
"Handle some often-used menu keys.
Note that it's the caller's responsibility to check whether the menu is
active."
- (if (menu-active menu)
+ (if #t ; FIXME (menu-active menu)
(cond
((eq? ch KEY_NPAGE)
(menu-down menu #:step (getmaxy (menu-window menu)))
@@ -176,8 +169,8 @@ active."
(menu-goto-end menu)
'handled)
- ((or (eq? ch KEY_DOWN)
- (eq? ch #\so))
+ ((or (eqv? ch KEY_DOWN)
+ (eqv? ch #\so))
(menu-down menu)
'handled)