Merge branch 'master' into core-updates

6 files changed, 138 insertions, 75 deletions

diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index 1bd8c60fe5..7b6e31107c 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -120,6 +120,28 @@ front."
       (lambda ()
         (set! path initial-value)))))
 
+(define (call/exit-on-exception thunk)
+  "Evaluate THUNK and exit right away if an exception is thrown."
+  (catch #t
+    thunk
+    (const #f)
+    (lambda (key . args)
+      (false-if-exception
+       ;; Duplicate stderr to avoid thread-safety issues.
+       (let* ((port  (duplicate-port (current-error-port) "w0"))
+              (stack (make-stack #t))
+              (depth (stack-length stack))
+              (frame (and (> depth 1) (stack-ref stack 1))))
+         (false-if-exception (display-backtrace stack port))
+         (print-exception port frame key args)))
+
+      ;; Don't go any further.
+      (primitive-exit 1))))
+
+(define-syntax-rule (exit-on-exception exp ...)
+  "Evaluate EXP and exit if an exception is thrown."
+  (call/exit-on-exception (lambda () exp ...)))
+
 (define* (compile-files source-directory build-directory files
                         #:key
                         (host %host-type)
@@ -139,15 +161,18 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
   (define (build file)
     (with-mutex progress-lock
       (report-compilation file total completed))
-    (with-fluids ((*current-warning-prefix* ""))
-      (with-target host
-        (lambda ()
-          (let ((relative (relative-file source-directory file)))
-            (compile-file file
-                          #:output-file (string-append build-directory "/"
-                                                       (scm->go relative))
-                          #:opts (append warning-options
-                                         (optimization-options relative)))))))
+
+    ;; Exit as soon as something goes wrong.
+    (exit-on-exception
+     (with-fluids ((*current-warning-prefix* ""))
+       (with-target host
+         (lambda ()
+           (let ((relative (relative-file source-directory file)))
+             (compile-file file
+                           #:output-file (string-append build-directory "/"
+                                                        (scm->go relative))
+                           #:opts (append warning-options
+                                          (optimization-options relative))))))))
     (with-mutex progress-lock
       (set! completed (+ 1 completed))))
 
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm
index c1b00c7890..fdacd30dd6 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -60,7 +60,9 @@
 
 (define* (emacs-byte-compile-directory dir)
   "Byte compile all files in DIR and its sub-directories."
-  (let ((expr `(byte-recompile-directory (file-name-as-directory ,dir) 0)))
+  (let ((expr `(progn
+                (setq byte-compile-debug t) ; for proper exit status
+                (byte-recompile-directory (file-name-as-directory ,dir) 0 1))))
     (emacs-batch-eval expr)))
 
 (define-syntax emacs-substitute-sexps
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 401087e830..4dd4fbccdf 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -661,43 +661,47 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
 
-  (parameterize ((%graft? graft?))
-    (append-map (match-lambda
-                  ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p)))
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (G_ "~a: warning: \
+  ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
+  ;; of user packages.  Since 'guix build' is the primary tool for people
+  ;; testing new packages, report such errors gracefully.
+  (with-unbound-variable-handling
+   (parameterize ((%graft? graft?))
+     (append-map (match-lambda
+                   ((? package? p)
+                    (let ((p (or (and graft? (package-replacement p)) p)))
+                      (match src
+                        (#f
+                         (list (package->derivation store p system)))
+                        (#t
+                         (match (package-source p)
+                           (#f
+                            (format (current-error-port)
+                                    (G_ "~a: warning: \
 package '~a' has no source~%")
-                                   (location->string (package-location p))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
-                  ((? derivation? drv)
-                   (list drv))
-                  ((? procedure? proc)
-                   (list (run-with-store store
-                           (mbegin %store-monad
-                             (set-guile-for-build (default-guile))
-                             (proc))
-                           #:system system)))
-                  ((? gexp? gexp)
-                   (list (run-with-store store
-                           (mbegin %store-monad
-                             (set-guile-for-build (default-guile))
-                             (gexp->derivation "gexp" gexp
-                                               #:system system))))))
-                (map (cut transform store <>)
-                     (options->things-to-build opts)))))
+                                    (location->string (package-location p))
+                                    (package-name p))
+                            '())
+                           (s
+                            (list (package-source-derivation store s)))))
+                        (proc
+                         (map (cut package-source-derivation store <>)
+                              (proc p))))))
+                   ((? derivation? drv)
+                    (list drv))
+                   ((? procedure? proc)
+                    (list (run-with-store store
+                            (mbegin %store-monad
+                              (set-guile-for-build (default-guile))
+                              (proc))
+                            #:system system)))
+                   ((? gexp? gexp)
+                    (list (run-with-store store
+                            (mbegin %store-monad
+                              (set-guile-for-build (default-guile))
+                              (gexp->derivation "gexp" gexp
+                                                #:system system))))))
+                 (map (cut transform store <>)
+                      (options->things-to-build opts))))))
 
 (define (show-build-log store file urls)
   "Show the build log for FILE, falling back to remote logs from URLS if
diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm
index 7229c60a02..955cdd1e95 100644
--- a/guix/scripts/system/search.scm
+++ b/guix/scripts/system/search.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -59,10 +60,8 @@ provided TYPE has a default value."
 
 (define (service-type-shepherd-names type)
   "Return the default names of Shepherd services created for TYPE."
-  (match (map shepherd-service-provision
-              (service-type-default-shepherd-services type))
-    (((names . _) ...)
-     names)))
+  (append-map shepherd-service-provision
+              (service-type-default-shepherd-services type)))
 
 (define* (service-type->recutils type port
                                  #:optional (width (%text-width))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 5c934abaef..d7c2fbea10 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -208,10 +208,10 @@ unavailable)~%"))
                                   0 queue)))
           (newline)
           (unless (null? missing)
-            (let ((missing (length missing)))
-              (match (queued-subset queue missing)
-                (#f #f)
-                ((= length queued)
+            (match (queued-subset queue missing)
+              (#f #f)
+              ((= length queued)
+               (let ((missing (length missing)))
                  (format #t (G_ "  ~,1f% (~h out of ~h) of the missing items \
 are queued~%")
                          (* 100. (/ queued missing))
diff --git a/guix/ui.scm b/guix/ui.scm
index 07c78289ff..45f438fc45 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -82,6 +82,7 @@
             show-manifest-transaction
             call-with-error-handling
             with-error-handling
+            with-unbound-variable-handling
             leave-on-EPIPE
             read/eval
             read/eval-package-expression
@@ -164,7 +165,7 @@ messages."
     ((proc message (variable) _ ...)
      ;; We can always omit PROC because when it's useful (i.e., different from
      ;; "module-lookup"), it gets displayed before.
-     (format port (G_ "~a: unbound variable") variable))
+     (format port (G_ "error: ~a: unbound variable") variable))
     (_
      (default-printer))))
 
@@ -179,9 +180,9 @@ messages."
               modules)
     module))
 
-(define* (load* file user-module
-                #:key (on-error 'nothing-special))
-  "Load the user provided Scheme source code FILE."
+(define (last-frame-with-source stack)
+  "Walk stack upwards and return the last frame that has source location
+information, or #f if it could not be found."
   (define (frame-with-source frame)
     ;; Walk from FRAME upwards until source location information is found.
     (let loop ((frame    frame)
@@ -192,6 +193,15 @@ messages."
               frame
               (loop (frame-previous frame) frame)))))
 
+  (let* ((depth (stack-length stack))
+         (last  (and (> depth 0) (stack-ref stack 0))))
+    (frame-with-source (if (> depth 1)
+                           (stack-ref stack 1)    ;skip the 'throw' frame
+                           last))))
+
+(define* (load* file user-module
+                #:key (on-error 'nothing-special))
+  "Load the user provided Scheme source code FILE."
   (define (error-string frame args)
     (call-with-output-string
       (lambda (port)
@@ -244,12 +254,7 @@ messages."
          ;; 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 tag))
-                (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))))
+                (frame (last-frame-with-source stack)))
 
            (report-load-error file args frame)
 
@@ -311,6 +316,21 @@ PORT."
                                            (- (terminal-columns) 5))))
             (texi->plain-text message))))
 
+(define* (report-unbound-variable-error args #:key frame)
+  "Return the given unbound-variable error, where ARGS is the list of 'throw'
+arguments."
+  (match args
+    ((key . args)
+     (print-exception (current-error-port) frame key args)))
+  (match args
+    (('unbound-variable proc message (variable) _ ...)
+     (match (known-variable-definition variable)
+       (#f
+        (display-hint (G_ "Did you forget a @code{use-modules} form?")))
+       ((? module? module)
+        (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
+                              (module-name module))))))))
+
 (define* (report-load-error file args #:optional frame)
   "Report the failure to load FILE, a user-provided Scheme file.
 ARGS is the list of arguments received by the 'throw' handler."
@@ -331,16 +351,8 @@ ARGS is the list of arguments received by the 'throw' handler."
      (let ((loc (source-properties->location properties)))
        (format (current-error-port) (G_ "~a: error: ~a~%")
                (location->string loc) message)))
-    (('unbound-variable proc message (variable) _ ...)
-     (match args
-       ((key . args)
-        (print-exception (current-error-port) frame key args)))
-     (match (known-variable-definition variable)
-       (#f
-        (display-hint (G_ "Did you forget a @code{use-modules} form?")))
-       (module
-        (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
-                              (module-name module))))))
+    (('unbound-variable _ ...)
+     (report-unbound-variable-error args #:frame frame))
     (('srfi-34 obj)
      (if (message-condition? obj)
          (if (error-location? obj)
@@ -381,6 +393,27 @@ exiting.  ARGS is the list of arguments received by the 'throw' handler."
      (warning (G_ "failed to load '~a':~%") file)
      (apply display-error #f (current-error-port) args))))
 
+(define (call-with-unbound-variable-handling thunk)
+  (define tag
+    (make-prompt-tag "user-code"))
+
+  (catch 'unbound-variable
+    (lambda ()
+      (call-with-prompt tag
+        thunk
+        (const #f)))
+    (const #t)
+    (rec (handle-error . args)
+         (let* ((stack (make-stack #t handle-error tag))
+                (frame (and stack (last-frame-with-source stack))))
+           (report-unbound-variable-error args #:frame frame)
+           (exit 1)))))
+
+(define-syntax-rule (with-unbound-variable-handling exp ...)
+  "Capture 'unbound-variable' exceptions in the dynamic extent of EXP... and
+report them in a user-friendly way."
+  (call-with-unbound-variable-handling (lambda () exp ...)))
+
 (define (install-locale)
   "Install the current locale settings."
   (catch 'system-error