[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/03: installer: Introduce color palette.
|
From: |
Danny Milosavljevic |
|
Subject: |
02/03: installer: Introduce color palette. |
|
Date: |
Sun, 9 Jul 2017 14:57:54 -0400 (EDT) |
dannym pushed a commit to branch wip-installer-2
in repository guix.
commit 66981ab5a9fc92157ac8768dc122d3665d19a071
Author: Danny Milosavljevic <address@hidden>
Date: Sun Jul 9 20:35:30 2017 +0200
installer: Introduce color palette.
* gurses/colors.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/system/installer/utils.scm (register-color-palette!): Move to
(gurses colors).
(boxed-window-decoration-refresh): Use (gurses colors).
* gurses/buttons.scm (<buttons>): Remove active-color.
(make-buttons'): Remove active-color.
(make-buttons): Remove color.
(draw-button): Use (gurses colors).
(buttons-unselect-all): Use symbolic color names.
(buttons-select): Use symbolic color names.
(buttons-refresh): Use symbolic color names.
* gnu/system/installer/configure.scm (configure-page-init): Fix up
make-buttons.
* gnu/system/installer/dialog.scm (dialog-page-init): Fix up
make-buttons.
* gnu/system/installer/disks.scm (disk-page-init): Fix up
make-buttons.
* gnu/system/installer/filesystems.scm (filesystem-page-init): Fix up
make-buttons.
* gnu/system/installer/format.scm (format-page-init): Fix up make-buttons.
* gnu/system/installer/guixsd-installer.scm: Import (gurses colors).
* gnu/system/installer/hostname.scm (host-name-init): Fix up make-buttons.
* gnu/system/installer/install.scm (install-page-init): Fix up make-buttons.
* gnu/system/installer/key-map.scm (key-map-page-init): Fix up make-buttons.
* gnu/system/installer/locale.scm (locale-page-init): Fix up make-buttons.
* gnu/system/installer/misc.scm (livery-title): Delete variable.
(strong-colour): Delete variable.
(installer-texinfo-markup): Fix color.
* gnu/system/installer/mount-point.scm (mount-point-page-init): Fix up
make-buttons.
* gnu/system/installer/network.scm (network-page-init): Fix up make-buttons.
* gnu/system/installer/passphrase.scm (passphrase-init): Fix up
make-buttons.
* gnu/system/installer/ping.scm (ping-page-init): Fix up make-buttons.
* gnu/system/installer/role.scm (role-page-init): Fix up make-buttons.
* gnu/system/installer/time-zone.scm (time-zone-page-init): Fix up
make-buttons.
* gnu/system/installer/user-edit.scm (user-edit-page-init): Fix up
make-buttons.
* gnu/system/installer/users.scm (users-page-init): Fix up make-buttons.
* gnu/system/installer/wireless.scm (wireless-page-init): Fix up
make-buttons.
---
Makefile.am | 1 +
gnu/system/installer/configure.scm | 2 +-
gnu/system/installer/dialog.scm | 2 +-
gnu/system/installer/disks.scm | 2 +-
gnu/system/installer/filesystems.scm | 2 +-
gnu/system/installer/format.scm | 2 +-
gnu/system/installer/guixsd-installer.scm | 27 +++++++++++++------------
gnu/system/installer/hostname.scm | 2 +-
gnu/system/installer/install.scm | 2 +-
gnu/system/installer/key-map.scm | 10 +++++-----
gnu/system/installer/locale.scm | 2 +-
gnu/system/installer/misc.scm | 8 ++------
gnu/system/installer/mount-point.scm | 2 +-
gnu/system/installer/network.scm | 2 +-
gnu/system/installer/passphrase.scm | 2 +-
gnu/system/installer/ping.scm | 2 +-
gnu/system/installer/role.scm | 2 +-
gnu/system/installer/time-zone.scm | 2 +-
gnu/system/installer/user-edit.scm | 2 +-
gnu/system/installer/users.scm | 2 +-
gnu/system/installer/utils.scm | 14 +++++--------
gnu/system/installer/wireless.scm | 2 +-
gurses/buttons.scm | 25 +++++++++++------------
gurses/colors.scm | 33 +++++++++++++++++++++++++++++++
24 files changed, 89 insertions(+), 63 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 0fa5849..d52256c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -182,6 +182,7 @@ MODULES = \
if HAVE_GUILE_NCURSES
MODULES += \
+ gurses/colors.scm \
gurses/buttons.scm \
gurses/form.scm \
gurses/menu.scm \
diff --git a/gnu/system/installer/configure.scm
b/gnu/system/installer/configure.scm
index e7a828d..fd4f6ec 100644
--- a/gnu/system/installer/configure.scm
+++ b/gnu/system/installer/configure.scm
@@ -203,7 +203,7 @@
3 (getmaxx s)
(- (getmaxy s) 3) 0
#:panel #t))
- (buttons (make-buttons my-buttons 1))
+ (buttons (make-buttons my-buttons))
(config-window (make-boxed-window
s
diff --git a/gnu/system/installer/dialog.scm b/gnu/system/installer/dialog.scm
index 427b97f..55c7566 100644
--- a/gnu/system/installer/dialog.scm
+++ b/gnu/system/installer/dialog.scm
@@ -81,7 +81,7 @@
(define (dialog-page-init p)
(match (create-vbox (page-surface p) (- (getmaxy (page-surface p)) 3) 3)
((text-window button-window)
- (let ((buttons (make-buttons my-buttons 1)))
+ (let ((buttons (make-buttons my-buttons)))
(push-cursor (page-cursor-visibility p))
(page-set-datum! p 'text-window text-window)
(page-set-datum! p 'navigation buttons)
diff --git a/gnu/system/installer/disks.scm b/gnu/system/installer/disks.scm
index a684358..a97b853 100644
--- a/gnu/system/installer/disks.scm
+++ b/gnu/system/installer/disks.scm
@@ -70,7 +70,7 @@
(define (disk-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))
+ (let* ((buttons (make-buttons my-buttons))
(menu (make-menu (volumes)
#:disp-proc
(lambda (d row)
diff --git a/gnu/system/installer/filesystems.scm
b/gnu/system/installer/filesystems.scm
index df79dd1..365b9b7 100644
--- a/gnu/system/installer/filesystems.scm
+++ b/gnu/system/installer/filesystems.scm
@@ -205,7 +205,7 @@
(define (filesystem-page-init p)
(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))
+ (let ((buttons (make-buttons my-buttons))
(menu (make-menu (partition-volume-pairs)
#:disp-proc
(lambda (d row)
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index ff5a743..d1bfc95 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -153,7 +153,7 @@ match those uuids read from the respective partitions"
3 (getmaxx s)
(- (getmaxy s) 3) 0
#:panel #t))
- (buttons (make-buttons my-buttons 1))
+ (buttons (make-buttons my-buttons))
(config-window (make-boxed-window
s
diff --git a/gnu/system/installer/guixsd-installer.scm
b/gnu/system/installer/guixsd-installer.scm
index 58f15f5..c09c557 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -20,35 +20,36 @@
(use-modules (ncurses curses)
(gurses menu)
- (gnu system installer utils)
- (gnu system installer misc)
- (gnu system installer partition-reader)
- (gnu system installer disks)
- (gnu system installer configure)
+ (gurses colors)
+ (gnu system installer utils)
+ (gnu system installer misc)
+ (gnu system installer partition-reader)
+ (gnu system installer disks)
+ (gnu system installer configure)
(gnu system installer filesystems)
- (gnu system installer hostname)
+ (gnu system installer hostname)
(gnu system installer locale)
(gnu system installer levelled-stack)
- (gnu system installer key-map)
- (gnu system installer time-zone)
+ (gnu system installer key-map)
+ (gnu system installer time-zone)
(gnu system installer role)
- (gnu system installer network)
+ (gnu system installer network)
(gnu system installer install)
(gnu system installer format)
- (gnu system installer page)
+ (gnu system installer page)
(gnu system installer users)
(gnu system installer ping)
- (gnu system installer dialog)
+ (gnu system installer dialog)
(guix build utils)
(guix utils)
- (ice-9 format)
+ (ice-9 format)
(ice-9 pretty-print)
(ice-9 match)
(ice-9 i18n)
(srfi srfi-1)
- (srfi srfi-9))
+ (srfi srfi-9))
(include "i18n.scm")
diff --git a/gnu/system/installer/hostname.scm
b/gnu/system/installer/hostname.scm
index 9f2a2d6..061a07b 100644
--- a/gnu/system/installer/hostname.scm
+++ b/gnu/system/installer/hostname.scm
@@ -89,7 +89,7 @@
(define (host-name-init p)
(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))
+ (let ((nav (make-buttons my-buttons))
(form (make-form my-fields)))
(page-set-datum! p 'navigation nav)
(page-set-datum! p 'text-window text-window)
diff --git a/gnu/system/installer/install.scm b/gnu/system/installer/install.scm
index 8a4f580..a741552 100644
--- a/gnu/system/installer/install.scm
+++ b/gnu/system/installer/install.scm
@@ -162,7 +162,7 @@
3 (getmaxx s)
(- (getmaxy s) 3) 0
#:panel #t))
- (buttons (make-buttons my-buttons 1))
+ (buttons (make-buttons my-buttons))
(config-window (make-boxed-window
s
diff --git a/gnu/system/installer/key-map.scm b/gnu/system/installer/key-map.scm
index 69dde11..0c11922 100644
--- a/gnu/system/installer/key-map.scm
+++ b/gnu/system/installer/key-map.scm
@@ -32,10 +32,10 @@
(define* (make-key-map parent directory)
(let ((page (make-page (page-surface parent)
- (gettext "Keyboard Mapping")
- key-map-page-refresh
- 0
- #:activator key-map-page-activate-item)))
+ (gettext "Keyboard Mapping")
+ key-map-page-refresh
+ 0
+ #:activator key-map-page-activate-item)))
(page-set-datum! page 'directory directory)
page))
@@ -71,7 +71,7 @@
(define (key-map-page-init p)
(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))
+ (let ((buttons (make-buttons my-buttons))
(menu (make-menu
(let ((dir (page-datum p 'directory)))
(filter (lambda (name)
diff --git a/gnu/system/installer/locale.scm b/gnu/system/installer/locale.scm
index bf446f3..9f3f8f4 100644
--- a/gnu/system/installer/locale.scm
+++ b/gnu/system/installer/locale.scm
@@ -89,7 +89,7 @@
(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))
+ (let ((buttons (make-buttons my-buttons))
(menu (make-menu %default-locale-definitions
#:disp-proc (lambda (d row)
(format #f "~60a ~10a"
diff --git a/gnu/system/installer/misc.scm b/gnu/system/installer/misc.scm
index f9dab42..f38d11f 100644
--- a/gnu/system/installer/misc.scm
+++ b/gnu/system/installer/misc.scm
@@ -18,10 +18,9 @@
(define-module (gnu system installer misc)
#:use-module (ncurses curses)
+ #:use-module (gurses colors)
#:use-module (gnu system shadow)
- #:export (livery-title)
- #:export (strong-colour)
#:export (time-zone)
#:export (host-name)
#:export (config-file)
@@ -32,9 +31,6 @@
#:export (install-attempts)
#:export (mount-points))
-(define livery-title 1)
-(define strong-colour 2)
-
(define mount-points '())
(define time-zone "")
@@ -63,7 +59,7 @@
(acro . ,normal)
(email . ,normal)
(emph . ,dim)
- (strong . ,(lambda (x) (color strong-colour x)))
+ (strong . ,(lambda (x) (color (color-index-by-symbol 'strong) x)))
(sample . ,normal)
(sc . ,normal)
(titlefont . ,normal)
diff --git a/gnu/system/installer/mount-point.scm
b/gnu/system/installer/mount-point.scm
index 3235edf..529bcfd 100644
--- a/gnu/system/installer/mount-point.scm
+++ b/gnu/system/installer/mount-point.scm
@@ -90,7 +90,7 @@
(define (mount-point-page-init p)
(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))
+ (let ((nav (make-buttons my-buttons))
(form (make-form
(my-fields)
(lambda (f)
diff --git a/gnu/system/installer/network.scm b/gnu/system/installer/network.scm
index 31d8114..082398d 100644
--- a/gnu/system/installer/network.scm
+++ b/gnu/system/installer/network.scm
@@ -146,7 +146,7 @@
(define prev-flags (map-in-order if-flags (interfaces)))
(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))
+ (let ((buttons (make-buttons my-buttons))
(menu (make-menu
(filter (lambda (i) (memq
(assq-ref i 'class)
diff --git a/gnu/system/installer/passphrase.scm
b/gnu/system/installer/passphrase.scm
index 95365ec..8a9bd86 100644
--- a/gnu/system/installer/passphrase.scm
+++ b/gnu/system/installer/passphrase.scm
@@ -105,7 +105,7 @@
(define (passphrase-init p)
(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))
+ (let ((nav (make-buttons my-buttons))
(form (make-form my-fields)))
(push-cursor (page-cursor-visibility p))
diff --git a/gnu/system/installer/ping.scm b/gnu/system/installer/ping.scm
index 5108ad9..d08325b 100644
--- a/gnu/system/installer/ping.scm
+++ b/gnu/system/installer/ping.scm
@@ -91,7 +91,7 @@
(define (ping-page-init p)
(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)))
+ (let ((buttons (make-buttons my-buttons)))
(box test-window 0 0)
(page-set-datum! p 'test-window test-window)
(page-set-datum! p 'text-window text-window)
diff --git a/gnu/system/installer/role.scm b/gnu/system/installer/role.scm
index 50a7551..76d6376 100644
--- a/gnu/system/installer/role.scm
+++ b/gnu/system/installer/role.scm
@@ -98,7 +98,7 @@
(define (role-page-init p)
(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))
+ (let* ((buttons (make-buttons my-buttons))
(menu (make-menu roles
#:disp-proc (lambda (datum row)
(gettext (role-description datum))))))
diff --git a/gnu/system/installer/time-zone.scm
b/gnu/system/installer/time-zone.scm
index dfc9609..926f55f 100644
--- a/gnu/system/installer/time-zone.scm
+++ b/gnu/system/installer/time-zone.scm
@@ -82,7 +82,7 @@
(define (time-zone-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))
+ (let ((buttons (make-buttons my-buttons))
(menu (make-menu
(let* ((dir (page-datum p 'directory))
(all-names (scandir-with-slashes dir))
diff --git a/gnu/system/installer/user-edit.scm
b/gnu/system/installer/user-edit.scm
index a95b3bd..70267ed 100644
--- a/gnu/system/installer/user-edit.scm
+++ b/gnu/system/installer/user-edit.scm
@@ -94,7 +94,7 @@
(define (user-edit-page-init p)
(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))
+ (let* ((nav (make-buttons my-buttons))
(form (make-form (my-fields)
(lambda (frm)
;; Infer the most likely desired values of the
diff --git a/gnu/system/installer/users.scm b/gnu/system/installer/users.scm
index b2961fe..b54dd2f 100644
--- a/gnu/system/installer/users.scm
+++ b/gnu/system/installer/users.scm
@@ -99,7 +99,7 @@
(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))
+ (let* ((buttons (make-buttons my-buttons))
(menu (make-menu users
#:disp-proc (lambda (x r)
(format #f header-format
diff --git a/gnu/system/installer/utils.scm b/gnu/system/installer/utils.scm
index a07fb1e..27ba098 100644
--- a/gnu/system/installer/utils.scm
+++ b/gnu/system/installer/utils.scm
@@ -35,7 +35,6 @@
inner
outer
deep-visit-windows
- register-color-palette!
open-input-pipe-with-fallback*
@@ -60,7 +59,8 @@
(gnu system installer filesystems)
(ncurses form)
(ncurses panel)
- (ncurses curses))
+ (ncurses curses)
+ (gurses colors))
(define (refresh* win)
#f)
@@ -266,14 +266,10 @@ Ignore blank lines."
(error "~s is not a window" outside))
outside)))
-(define (register-color-palette!)
- (init-pair! livery-title COLOR_MAGENTA COLOR_BLACK)
- (init-pair! strong-colour COLOR_RED COLOR_BLACK))
-
(define* (boxed-window-decoration-refresh pr title)
(let ((win (outer pr)))
;(erase win)
- (color-set! win 0)
+ (select-color! win 'normal)
(move win 0 0)
;(addstr win "X")
(box win (acs-vline) (acs-hline))
@@ -281,9 +277,9 @@ Ignore blank lines."
(let ((title (string-append "[ " title " ]")))
;(move win 2 1)
;(hline win (acs-hline) (- (getmaxx win) 2))
- (color-set! win livery-title)
+ (select-color! win 'livery-title)
(addstr win title #:y 0 #:x (round (/ (- (getmaxx win) (string-length
title)) 2)))))
- (color-set! win 0)))
+ (select-color! win 'normal)))
(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
diff --git a/gnu/system/installer/wireless.scm
b/gnu/system/installer/wireless.scm
index 9cb2a88..df8e307 100644
--- a/gnu/system/installer/wireless.scm
+++ b/gnu/system/installer/wireless.scm
@@ -86,7 +86,7 @@
(define (wireless-page-init p)
(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))
+ (let* ((buttons (make-buttons my-buttons))
(menu (make-menu
;; Present a menu of available Access points in decreasing
;; order of signal strength
diff --git a/gurses/buttons.scm b/gurses/buttons.scm
index 73d23b4..9dab545 100644
--- a/gurses/buttons.scm
+++ b/gurses/buttons.scm
@@ -35,21 +35,21 @@
#:export (buttons-refresh)
#:use-module (ncurses curses)
+ #:use-module (gurses colors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9))
(define-record-type <buttons>
- (make-buttons' items bwindows selected active-color)
+ (make-buttons' items bwindows selected)
buttons?
(items buttons-items buttons-set-items!) ;; FIXME this need not be
here
(bwindows buttons-bwindows buttons-set-bwindows!)
(selected buttons-selected buttons-set-selected!)
- (array buttons-array buttons-set-array!)
- (active-color buttons-active-color))
+ (array buttons-array buttons-set-array!))
-(define (make-buttons items color)
- (make-buttons' items '() -1 color))
+(define (make-buttons items)
+ (make-buttons' items '() -1))
(define (buttons-n-buttons buttons)
(array-length (buttons-array buttons)))
@@ -62,7 +62,7 @@
(list-ref (array-ref (buttons-array buttons) sel) 2))))
(define (draw-button b color)
- (color-set! b color)
+ (select-color! b color)
(box b 0 0)
;(refresh b)
)
@@ -73,7 +73,7 @@
(old (if (array-in-bounds? arry current)
(cadr (array-ref arry current)) #f)))
(if old
- (draw-button old 0))
+ (draw-button old 'button))
(buttons-set-selected! buttons -1)))
(define (buttons-fetch-by-key buttons c)
@@ -95,9 +95,9 @@
(cadr (array-ref arry current)) #f)))
(if (not (eqv? old new))
(begin
- (draw-button new (buttons-active-color buttons))
+ (draw-button new 'focused-button)
(if old
- (draw-button old 0))))
+ (draw-button old 'button))))
(buttons-set-selected! buttons which)))))
(define (buttons-select-prev buttons)
@@ -214,12 +214,11 @@
(car (buttons-bwindows buttons)))
(define (buttons-refresh buttons)
- (let ((selected-index (buttons-selected buttons))
- (selected-color (buttons-active-color buttons)))
+ (let ((selected-index (buttons-selected buttons)))
(for-each (lambda (index button a)
(draw-button button (if (= index selected-index)
- selected-color
- 0))
+ 'focused-button
+ 'button))
(match a
((ch win sym label)
(addchstr button label #:y 1 #:x 1))))
diff --git a/gurses/colors.scm b/gurses/colors.scm
new file mode 100644
index 0000000..bd84790
--- /dev/null
+++ b/gurses/colors.scm
@@ -0,0 +1,33 @@
+(define-module (gurses colors)
+ #:use-module (ncurses curses)
+ #:use-module (ice-9 match))
+
+(define colors
+ (list (list 'normal COLOR_WHITE COLOR_BLACK)
+ (list 'livery-title COLOR_MAGENTA COLOR_BLACK)
+ (list 'strong COLOR_RED COLOR_BLACK)
+ (list 'button COLOR_BLACK COLOR_GREEN)
+ (list 'button-shadow COLOR_BLACK COLOR_BLACK)
+ (list 'focused-button COLOR_CYAN COLOR_GREEN)))
+
+(define-public (color-index-by-symbol color)
+ (let loop ((i 0) (p colors))
+ (if (null? colors)
+ (error "unknown color" color)
+ (match (car colors)
+ ((color-symbol foreground background)
+ (if (eq? color-symbol color)
+ i
+ (loop (1+ i) (cdr colors))))))))
+
+(define-public (register-color-palette!)
+ (for-each (lambda (index entry)
+ (match entry
+ ((color-symbol foreground background)
+ (init-pair! index foreground background))))
+ (iota (length colors))
+ colors))
+
+(define-public (select-color! win color)
+; (color-set! win (color-index-by-symbol color))
+1)