49/80: installer: Wrap installer in (catch #t ...)

[John Darrington]

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

commit 492aa1606bed2df20e59b666b5e6cffbd8592597
Author: John Darrington <address@hidden>
Date:   Wed Dec 28 09:30:32 2016 +0100

    installer: Wrap installer in (catch #t ...)
    
    * gnu/system/installer/new.scm (guixsd-installer): Close the curses
    display before showing backtrace on exceptions.
---
 gnu/system/installer/new.scm |   73 ++++++++++++++++++++++++------------------
 1 file changed, 42 insertions(+), 31 deletions(-)

diff --git a/gnu/system/installer/new.scm b/gnu/system/installer/new.scm
index a1e6275..ca280f4 100644
--- a/gnu/system/installer/new.scm
+++ b/gnu/system/installer/new.scm
@@ -230,34 +230,45 @@
 
 
 (define-public (guixsd-installer)
-
-  (define stdscr (initscr))            ; Start curses
-
-  ;; We don't want any nasty kernel messages damaging our beautifully
-  ;; crafted display.
-  (system* "dmesg" "--console-off")
-
-  (cbreak!)                            ; Line buffering disabled
-  (keypad! stdscr #t)                  ; Check for function keys
-  (noecho!)
-
-  (start-color!)
-
-  (init-pair! livery-title COLOR_RED COLOR_BLACK)
-
-  (curs-set 0)
-
-  (let ((page (make-page
-               stdscr (gettext "GuixSD Installer")
-               main-page-refresh main-page-key-handler)))
-
-    (set! page-stack (cons page page-stack))
-    ((page-refresh page) (car page-stack))
-    (let loop ((ch (getch stdscr)))
-      (let ((current-page (car page-stack)))
-        ((page-key-handler current-page) current-page ch)
-        (base-page-key-handler current-page ch))
-      ((page-refresh (car page-stack)) (car page-stack))
-      (loop (getch stdscr)))
-
-    (endwin)))
+  (catch #t
+    (lambda ()
+
+      (define stdscr (initscr))                ; Start curses
+
+      ;; We don't want any nasty kernel messages damaging our beautifully
+      ;; crafted display.
+      (system* "dmesg" "--console-off")
+
+      (cbreak!)                                ; Line buffering disabled
+      (keypad! stdscr #t)                      ; Check for function keys
+      (noecho!)
+
+      (start-color!)
+
+      (init-pair! livery-title COLOR_RED COLOR_BLACK)
+
+      (curs-set 0)
+
+      (let ((page (make-page
+                   stdscr (gettext "GuixSD Installer")
+                   main-page-refresh main-page-key-handler)))
+
+        (set! page-stack (cons page page-stack))
+        ((page-refresh page) (car page-stack))
+        (let loop ((ch (getch stdscr)))
+          (let ((current-page (car page-stack)))
+            ((page-key-handler current-page) current-page ch)
+            (base-page-key-handler current-page ch))
+          ((page-refresh (car page-stack)) (car page-stack))
+          (loop (getch stdscr)))
+
+        (endwin)))
+    (lambda (key . args)
+      (system* "dmesg" "--console-on")
+      (exit 2))
+    (lambda (key subr message args rest)
+      (let ((s (make-stack #t 3 primitive-load)))
+        (endwin)
+        (display-backtrace s (current-error-port))
+        (display-error (stack-ref s 0)
+                       (current-error-port) subr message args rest)))))