04/07: installer: Create dedicated module to maintainer the page stack.

[John Darrington]

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

commit a94e5115bae3576bc460af69685dcdbdd525b6f5
Author: John Darrington <address@hidden>
Date:   Fri Feb 17 14:16:56 2017 +0100

    installer: Create dedicated module to maintainer the page stack.
    
    * gnu/system/installer/levelled-stack.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MOCULES): Add it.
    * gnu/system/installer/guixsd-installer.scm,
    gnu/system/installer/key-map.scm,
    gnu/system/installer/page.scm,
    gnu/system/installer/passphrase.scm,
    gnu/system/installer/time-zone.scm: use it.
---
 gnu/local.mk                              |  1 +
 gnu/system/installer/guixsd-installer.scm | 25 ++++------
 gnu/system/installer/key-map.scm          |  4 +-
 gnu/system/installer/levelled-stack.scm   | 79 +++++++++++++++++++++++++++++++
 gnu/system/installer/page.scm             | 11 ++---
 gnu/system/installer/passphrase.scm       |  2 +-
 gnu/system/installer/time-zone.scm        |  4 +-
 7 files changed, 97 insertions(+), 29 deletions(-)

diff --git a/gnu/local.mk b/gnu/local.mk
index f3a6feb..67fe767 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -454,6 +454,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/installer/disks.scm                \
   %D%/system/installer/format.scm               \
   %D%/system/installer/locale.scm               \
+  %D%/system/installer/levelled-stack.scm       \
   %D%/system/installer/ping.scm                 \
   %D%/system/installer/key-map.scm              \
   %D%/system/installer/role.scm                 \
diff --git a/gnu/system/installer/guixsd-installer.scm 
b/gnu/system/installer/guixsd-installer.scm
index 12f0d90..6529d1a 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -29,6 +29,7 @@
              (gnu system installer filesystems)
             (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 role)
@@ -44,6 +45,7 @@
              (guix utils)
 
             (ice-9 format)
+             (ice-9 pretty-print)
              (ice-9 match)
              (ice-9 i18n)
              (srfi srfi-1)
@@ -191,7 +193,7 @@
 (define (do-task task-name page)
   "Queue the task whose name is TASK-NAME and any dependencies"
   (let ((task (assoc-ref main-options task-name)))
-    (set! page-stack (cons ((task-init task) page) page-stack))
+    (page-push ((task-init task) page))
     (do-task-list (task-dependencies task) page)))
 
 (define (do-task-list task-name-list page)
@@ -204,18 +206,6 @@
    task-name-list))
 
 
-(define (uniquify in)
-  "Remove duplicates from the list IN. Keep the items which are closest to the
-tail of the list."
-  (let loop ((l (reverse in))
-             (acc '()))
-    (if (null? l)
-        acc
-        (loop (cdr l)
-              (if (member (car l) (cdr l))
-                  acc
-                  (cons (car l) acc))))))
-
 (define (main-page-key-handler page ch)
   (let ((main-menu (page-datum page 'menu)))
     (std-menu-key-handler main-menu ch)
@@ -223,8 +213,8 @@ tail of the list."
      ((eq? ch #\newline)
       (let ((item (menu-get-current-item main-menu)))
         (do-task (car item) page)
-        (set! page-stack (uniquify page-stack))
-        ((page-refresh (car page-stack)) (car page-stack)))))))
+        (page-uniquify)
+        ((page-refresh (car stack)) (car stack)))))))
 
 (define (main-page-init page)
   (let* ((frame (make-boxed-window (page-surface page) (lines) (cols) 0 0
@@ -324,11 +314,12 @@ tail of the list."
                    stdscr (gettext "GuixSD Installer")
                    main-page-refresh 0 main-page-key-handler)))
         (page-enter page)
+        (page-push #f)
         (let loop ((ch (getch stdscr)))
-          (let ((current-page (car page-stack)))
+          (let ((current-page (page-top)))
             ((page-key-handler current-page) current-page ch)
             (base-page-key-handler current-page ch))
-          ((page-refresh (car page-stack)) (car page-stack))
+          ((page-refresh (page-top)) (page-top))
           (loop (getch stdscr)))
 
         (endwin)))
diff --git a/gnu/system/installer/key-map.scm b/gnu/system/installer/key-map.scm
index 63e14a8..5fbedd5 100644
--- a/gnu/system/installer/key-map.scm
+++ b/gnu/system/installer/key-map.scm
@@ -20,6 +20,7 @@
   #:use-module (gnu system installer page)
   #:use-module (gnu system installer utils)
   #:use-module (gnu system installer misc)
+  #:use-module (gnu system installer levelled-stack)
   #:use-module (gurses menu)
   #:use-module (gurses buttons)
   #:use-module (ncurses curses)
@@ -65,8 +66,7 @@
        (if (eq? 'directory (stat:type (stat new-dir)))
            (let ((p (make-key-map
                      page new-dir)))
-              ;; Don't go back to the current page!
-              (set! page-stack (cdr page-stack))
+              (page-pop) ; Don't go back to the current page!
               (page-enter p))
            (begin
               (system* "loadkeys" i)
diff --git a/gnu/system/installer/levelled-stack.scm 
b/gnu/system/installer/levelled-stack.scm
new file mode 100644
index 0000000..3057300
--- /dev/null
+++ b/gnu/system/installer/levelled-stack.scm
@@ -0,0 +1,79 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer levelled-stack)
+  #:export (page-push)
+  #:export (page-pop)
+  #:export (page-top)
+  #:export (page-ppush)
+  #:export (page-ppop)
+  #:export (stack)
+  #:export (page-uniquify))
+
+;; This module provides a naive stack, from which either a single item
+;; may  be page-pushed or a "major" item.  When page-popping, either a single
+;; item may be page-popped or all the items down to just before the last
+;; major item.  The implementation uses #f to delimit major items, so
+;; that cannot be used as a regular item.
+
+(define stack '())
+
+
+(define (uniquify' in)
+  "Remove duplicates from the list IN. Keep the items which are closest to the
+tail of the list."
+  (let loop ((l (reverse in))
+             (acc '()))
+    (if (null? l)
+        acc
+        (loop (cdr l)
+              (if (and (car l) (member (car l) (cdr l)))
+                  acc
+                  (cons (car l) acc))))))
+
+(define (page-uniquify)
+  (set! stack (uniquify' stack)))
+
+
+(define (page-push x)
+  (set! stack (cons x stack)))
+
+(define (page-ppush x)
+  (set! stack (cons #f stack))
+  (page-push x))
+
+
+(define (page-pop)
+  (set! stack (cdr stack))
+  (when (and (not (null? stack))
+            (not (car stack)))
+       ;; If the top item is #f then page-pop again
+       (page-pop)))
+
+(define (page-top)
+  (if (car stack)
+      (car stack)
+      (car (cdr stack))))
+
+(define (page-ppop)
+  (set! stack (cdr stack))
+  (when (not (null? stack))
+       (let ((head (car stack)))
+         (if head
+             (page-ppop)
+             (page-pop)))))
diff --git a/gnu/system/installer/page.scm b/gnu/system/installer/page.scm
index 1197371..a18cde8 100644
--- a/gnu/system/installer/page.scm
+++ b/gnu/system/installer/page.scm
@@ -18,7 +18,6 @@
 
 (define-module (gnu system installer page)
   #:export (make-page)
-  #:export (page-stack)
   #:export (page-surface)
   #:export (page-refresh)
   #:export (page-initialised?)
@@ -34,10 +33,9 @@
   #:export (page-key-handler)
 
   #:use-module (gnu system installer utils)
+  #:use-module (gnu system installer levelled-stack)
   #:use-module (srfi srfi-9))
 
-(define page-stack '())
-
 (define-record-type <page>
   (make-page' surface title inited refresh cursor-visibility key-handler data)
   page?
@@ -59,12 +57,11 @@
 (define (page-datum page key)
   (assq-ref (page-data page) key))
 
-(define* (page-leave #:optional (return-point #f))
+(define (page-leave)
   (pop-cursor)
-  (set! page-stack
-    (or return-point (cdr page-stack))))
+  (page-pop))
 
 (define (page-enter p)
-  (set! page-stack (cons p page-stack))
+  (page-push p)
   ((page-refresh p) p))
 
diff --git a/gnu/system/installer/passphrase.scm 
b/gnu/system/installer/passphrase.scm
index e81b649..22eb13d 100644
--- a/gnu/system/installer/passphrase.scm
+++ b/gnu/system/installer/passphrase.scm
@@ -92,7 +92,7 @@
        (page-datum page 'ifce)
        access-point
        (form-get-value form 'passphrase))
-      (page-leave (cdr (cdr page-stack))))
+      (page-leave))
 
      (else
       (form-enter form ch)))
diff --git a/gnu/system/installer/time-zone.scm 
b/gnu/system/installer/time-zone.scm
index d4c3210..ff7fbc7 100644
--- a/gnu/system/installer/time-zone.scm
+++ b/gnu/system/installer/time-zone.scm
@@ -20,6 +20,7 @@
   #:use-module (gnu system installer page)
   #:use-module (gnu system installer utils)
   #:use-module (gnu system installer misc)
+  #:use-module (gnu system installer levelled-stack)
   #:use-module (gurses menu)
   #:use-module (gurses buttons)
   #:use-module (ncurses curses)
@@ -69,8 +70,7 @@
                               (if (page-datum page 'stem)
                                   (string-append (page-datum page 'stem) "/" i)
                                   i))
-              ;; Don't go back to the current page!
-              (set! page-stack (cdr page-stack))
+              (page-pop)  ; Don't go back to the current page!
               (page-enter p))
            (begin
              (set! time-zone