01/01: installer: page: Handle common events centrally by default.

[Danny Milosavljevic]

dannym pushed a commit to branch wip-installer-2
in repository guix.

commit 98477cd7232705f99c41fa97bdf5c59d65a3ad06
Author: Danny Milosavljevic <address@hidden>
Date:   Tue Jul 4 21:28:45 2017 +0200

    installer: page: Handle common events centrally by default.
    
    * gnu/system/installer/page.scm (page-activate-focused-item): New variable.
    (page-default-mouse-handler): New variable.
    (page-default-key-handler): New variable.
    (make-page): Add keyword argument #:activator and use default key and
    mouse handler.
    * gurses/buttons.scm (buttons-selected-symbol): New variable.  Export it.
    (buttons-select-by-symbol): New variable.  Export it.
    * gurses/menu.scm (std-menu-key-handler): Check whether menu is active in
    all cases.
---
 gnu/system/installer/page.scm | 117 +++++++++++++++++++++++++++++++++++++++++-
 gurses/buttons.scm            |  22 ++++++++
 gurses/menu.scm               |  57 +++++++++++---------
 3 files changed, 170 insertions(+), 26 deletions(-)

diff --git a/gnu/system/installer/page.scm b/gnu/system/installer/page.scm
index f5ddade..80905e0 100644
--- a/gnu/system/installer/page.scm
+++ b/gnu/system/installer/page.scm
@@ -32,7 +32,13 @@
   #:export (page-set-datum!)
   #:export (page-key-handler)
   #:export (page-mouse-handler)
+  #:export (page-default-key-handler)
+  #:export (page-default-mouse-handler)
 
+  #:use-module (gurses buttons)
+  #:use-module (gurses menu)
+  #:use-module (gurses form)
+  #:use-module (ncurses curses)
   #:use-module (gnu system installer utils)
   #:use-module (gnu system installer levelled-stack)
   #:use-module (srfi srfi-9))
@@ -50,8 +56,115 @@
   (wwin page-wwin page-set-wwin!)
   (data page-data page-set-data!))
 
-(define (make-page surface title refresh cursor-visibility key-handler 
mouse-handler)
-  (make-page' surface title #f refresh cursor-visibility key-handler 
mouse-handler '()))
+(define (page-activate-focused-item page)
+  ((page-datum page 'activator) page))
+
+(define (page-default-mouse-handler page device-id x y z button-state)
+  (let* ((menu (page-datum page 'menu))
+         (status (std-menu-mouse-handler menu device-id x y z button-state))
+         (buttons (page-datum page 'navigation))
+         (status (if (and (eq? status 'ignored) buttons)
+                     (let ((button-status (buttons-mouse-handler buttons
+                                                                 device-id
+                                                                 x y z
+                                                                 
button-state)))
+                       (if (eq? button-status 'activated)
+                         (menu-set-active! menu #f))
+                       button-status)
+                     status)))
+    (if (eq? status 'activated)
+      (page-activate-focused-item page))
+    status))
+
+(define (page-default-key-handler page ch)
+  "Handle keypresses in a commonly-used page.
+The page is assumed to have only at most a menu, a form and a navigation.
+If a form is used it's assumed that the menu is not used and vice versa."
+  (let ((menu (page-datum page 'menu))
+        (nav  (page-datum page 'navigation))
+        (form (page-datum page 'form)))
+    (cond
+     ((eq? ch KEY_RIGHT)
+      (if menu
+        (menu-set-active! menu #f))
+      (if form
+        (form-set-enabled! form #f))
+      (if nav
+        (buttons-select-next nav)))
+
+     ((eq? ch KEY_LEFT)
+      (if menu
+        (menu-set-active! menu #f))
+      (if form
+        (form-set-enabled! form #f))
+      (if nav
+        (buttons-select-prev nav)))
+
+     ((eq? ch #\tab)
+      (cond
+       ((and menu (menu-active menu))
+        (menu-set-active! menu #f)
+        (if nav
+            (buttons-select nav 0)))
+
+       ((and form (form-enabled? form))
+        (form-set-enabled! form #f)
+        (if nav
+            (buttons-select nav 0)))
+
+       ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+        (if menu
+          (menu-set-active! menu #t)
+          (if form
+            (form-set-enabled! form #t)))
+        (if nav
+            (buttons-unselect-all nav)))
+
+       (else
+        (if nav
+            (buttons-select-next nav)))))
+
+     ((select-key? ch)
+      (page-activate-focused-item page))
+
+     ((and menu (menu-active menu))
+       (std-menu-key-handler menu ch))
+
+     ((eq? ch KEY_UP)
+      (if nav
+          (buttons-unselect-all nav))
+      (if menu
+        (menu-set-active! menu #t)
+        (if form
+          (form-set-enabled! form #t))))
+
+     ((eq? ch KEY_DOWN)
+      (if nav
+          (buttons-unselect-all nav))
+      (if menu
+        (menu-set-active! menu #t)
+        (if form
+          (form-set-enabled! form #t))))
+
+     ((and nav (buttons-fetch-by-key nav ch))
+      (buttons-select-by-symbol nav (buttons-fetch-by-key nav ch))
+      (page-activate-focused-item page))
+
+     (else
+      (if form
+          (form-enter form ch))))))
+
+
+(define* (make-page surface 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))
 
 (define (page-set-datum! page key value)
   (page-set-data! page (acons key value (page-data page))))
diff --git a/gurses/buttons.scm b/gurses/buttons.scm
index d44a684..ed69b8d 100644
--- a/gurses/buttons.scm
+++ b/gurses/buttons.scm
@@ -25,6 +25,8 @@
   #:export (buttons-unselect-all)
   #:export (buttons-select)
   #:export (buttons-selected)
+  #:export (buttons-selected-symbol)
+  #:export (buttons-select-by-symbol)
   #:export (buttons-fetch-by-key)
   #:export (buttons-n-buttons)
   #:export (buttons-key-matches-symbol?)
@@ -166,6 +168,26 @@
                      (lambda (x) (eq? x symbol)))))
   #f))
 
+(define (buttons-selected-symbol buttons)
+  (let* ((arry (buttons-array buttons))
+         (current (buttons-selected buttons)))
+    (if (= current -1)
+        #f
+        (match (array-ref arry current)
+          ((ch win sym)
+           sym)))))
+
+(define (buttons-select-by-symbol buttons sym)
+  (let* ((arry (buttons-array buttons))
+         (len (array-length arry)))
+    (let loop ((i 0))
+      (if (< i len)
+          (match (array-ref arry i)
+           ((ch win xsym)
+            (if (eq? xsym sym)
+              (buttons-set-selected! buttons i))))
+          (loop (1+ i))))))
+
 (define (buttons-mouse-handler buttons device-id g-x g-y z button-state)
   (if (logtest BUTTON1_CLICKED button-state)
       (let* ((arry (buttons-array buttons))
diff --git a/gurses/menu.scm b/gurses/menu.scm
index e572568..a6fe6f9 100644
--- a/gurses/menu.scm
+++ b/gurses/menu.scm
@@ -155,30 +155,39 @@
 
 
 (define (std-menu-key-handler menu ch)
-  (cond
-   ((eq? ch KEY_NPAGE)
-    (menu-active menu)
-    (menu-down menu #:step (getmaxy (menu-window menu))))
-
-   ((eq? ch KEY_PPAGE)
-    (menu-active menu)
-    (menu-up menu #:step (getmaxy (menu-window menu))))
-
-   ((eq? ch KEY_HOME)
-    (menu-goto-start menu))
-
-   ((eq? ch KEY_END)
-    (menu-goto-end menu))
-
-   ((or (eq? ch KEY_DOWN)
-       (eq? ch #\so))
-    (if (menu-active menu)
-       (menu-down menu)))
-
-   ((or (eq? ch KEY_UP)
-       (eq? ch #\dle))
-    (if (menu-active menu)
-       (menu-up menu)))))
+  "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)
+      (cond
+       ((eq? ch KEY_NPAGE)
+        (menu-down menu #:step (getmaxy (menu-window menu)))
+        'handled)
+
+       ((eq? ch KEY_PPAGE)
+        (menu-up menu #:step (getmaxy (menu-window menu)))
+        'handled)
+
+       ((eq? ch KEY_HOME)
+        (menu-goto-start menu)
+        'handled)
+
+       ((eq? ch KEY_END)
+        (menu-goto-end menu)
+        'handled)
+
+       ((or (eq? ch KEY_DOWN)
+            (eq? ch #\so))
+        (menu-down menu)
+        'handled)
+
+       ((or (eq? ch KEY_UP)
+            (eq? ch #\dle))
+        (menu-up menu)
+        'handled)
+       (else
+        'ignored))
+      'ignored))
 
 (define (std-menu-mouse-handler menu device-id g-x g-y z button-state)
   (if (logtest BUTTON1_CLICKED button-state)