From 2abcc97fd1867176d5530f988ab34c26530de2c2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 25 May 2015 18:25:19 +0200
Subject: [PATCH] ui: Auto-compile user code, and improve error reporting.

Reported by Christian Grothoff.

* guix/ui.scm (load*): Add 'frame-with-source'.  Set
  %load-should-auto-compile.  Change error handle to just (exit 1).  Add
  pre-unwind handler to capture the stack and call 'report-load-error'.
  (report-load-error): Add optional 'frame' parameter and pass it to
  'display-error'.
* tests/guix-system.sh: Add "unbound variable" test.
---
 .dir-locals.el       |  1 +
 guix/ui.scm          | 43 ++++++++++++++++++++++++++++++++++++++-----
 tests/guix-system.sh | 26 ++++++++++++++++++++++++++
 3 files changed, 65 insertions(+), 5 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index eb3da94da4..7ac7e13ff1 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -13,6 +13,7 @@
   .
   ((indent-tabs-mode . nil)
    (eval . (put 'eval-when 'scheme-indent-function 1))
+   (eval . (put 'call-with-prompt 'scheme-indent-function 1))
    (eval . (put 'test-assert 'scheme-indent-function 1))
    (eval . (put 'test-assertm 'scheme-indent-function 1))
    (eval . (put 'test-equal 'scheme-indent-function 1))
diff --git a/guix/ui.scm b/guix/ui.scm
index 2b62e7abc8..d590eef040 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -35,6 +35,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-31)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
@@ -147,18 +148,50 @@ messages."
 
 (define (load* file user-module)
   "Load the user provided Scheme source code FILE."
+  (define (frame-with-source frame)
+    ;; Walk from FRAME upwards until source location information is found.
+    (let loop ((frame    frame)
+               (previous frame))
+      (if (not frame)
+          previous
+          (if (frame-source frame)
+              frame
+              (loop (frame-previous frame) frame)))))
+
   (catch #t
     (lambda ()
+      ;; XXX: Force a recompilation to avoid ABI issues.
       (set! %fresh-auto-compile #t)
+      (set! %load-should-auto-compile #t)
 
       (save-module-excursion
        (lambda ()
          (set-current-module user-module)
-         (primitive-load file))))
-    (lambda args
-      (report-load-error file args))))
 
-(define (report-load-error file args)
+         ;; Hide the "auto-compiling" messages.
+         (parameterize ((current-warning-port (%make-void-port "w")))
+           ;; Give 'load' an absolute file name so that it doesn't try to
+           ;; search for FILE in %LOAD-PATH.  Note: use 'load', not
+           ;; 'primitive-load', so that FILE is compiled, which then allows us
+           ;; to provide better error reporting with source line numbers.
+           (load (canonicalize-path file))))))
+    (lambda _
+      ;; XXX: Errors are reported from the pre-unwind handler below, but
+      ;; calling 'exit' from there has no effect, so we call it here.
+      (exit 1))
+    (rec (handle-error . args)
+         ;; Capture the stack up to this procedure call, excluded, and pass
+         ;; the faulty stack frame to 'report-load-error'.
+         (let* ((stack (make-stack #t handle-error))
+                (depth (stack-length stack))
+                (last  (and (> depth 0) (stack-ref stack 0)))
+                (frame (frame-with-source
+                        (if (> depth 1)
+                            (stack-ref stack 1)   ;skip the 'throw' frame
+                            last))))
+           (report-load-error file args frame)))))
+
+(define* (report-load-error file args #:optional frame)
   "Report the failure to load FILE, a user-provided Scheme file, and exit.
 ARGS is the list of arguments received by the 'throw' handler."
   (match args
@@ -172,7 +205,7 @@ ARGS is the list of arguments received by the 'throw' handler."
        (exit 1)))
     ((error args ...)
      (report-error (_ "failed to load '~a':~%") file)
-     (apply display-error #f (current-error-port) args)
+     (apply display-error frame (current-error-port) args)
      (exit 1))))
 
 (define (warn-about-load-error file args)         ;FIXME: factorize with ↑
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 7008ef8031..4289db2390 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -45,6 +45,32 @@ else
 fi
 
 
+# Reporting of unbound variables.
+
+cat > "$tmpfile" <<EOF
+(use-modules (gnu))                                   ; 1
+(use-service-modules networking)                      ; 2
+
+(operating-system                                     ; 4
+  (host-name "antelope")                              ; 5
+  (timezone "Europe/Paris")                           ; 6
+  (locale "en_US.UTF-8")                              ; 7
+
+  (bootloader (GRUB-config (device "/dev/sdX")))      ; 9
+  (file-systems (cons (file-system
+                        (device "root")
+                        (title 'label)
+                        (mount-point "/")
+                        (type "ext4"))
+                      %base-file-systems)))
+EOF
+
+if guix system build "$tmpfile" -n 2> "$errorfile"
+then false
+else
+    grep "$tmpfile:9:.*[Uu]nbound variable.*GRUB-config" "$errorfile"
+fi
+
 # Reporting of duplicate service identifiers.
 
 cat > "$tmpfile" <<EOF