01/02: utils: invoke: Raise exceptions using SRFI-34 and SRFI-35.

[Mark H. Weaver]

mhw pushed a commit to branch core-updates
in repository guix.

commit cbdfa50d9fb19704caa60818d7635047a6a26d71
Author: Mark H Weaver <address@hidden>
Date:   Fri Mar 16 18:29:31 2018 -0400

    utils: invoke: Raise exceptions using SRFI-34 and SRFI-35.
    
    * guix/build/utils.scm (&invoke-error): New condition type.
    (invoke-error?, invoke-error-program, invoke-error-arguments)
    (invoke-error-exit-status, invoke-error-term-signal)
    (invoke-error-stop-signal): New exported procedures.
    (invoke): Raise exceptions using SRFI-34 and SRFI-35.
    * guix/ui.scm (call-with-error-handling): Add a guard clause
    for &invoke-error conditions.
---
 guix/build/utils.scm | 35 ++++++++++++++++++++++++++++-------
 guix/ui.scm          | 18 +++++++++++++++++-
 2 files changed, 45 insertions(+), 8 deletions(-)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index ab309aa..c58a1af 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2013 Andreas Enge <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
-;;; Copyright © 2015 Mark H Weaver <address@hidden>
+;;; Copyright © 2015, 2018 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,8 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-60)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
@@ -86,7 +88,14 @@
             fold-port-matches
             remove-store-references
             wrap-program
+
             invoke
+            invoke-error?
+            invoke-error-program
+            invoke-error-arguments
+            invoke-error-exit-status
+            invoke-error-term-signal
+            invoke-error-stop-signal
 
             locale-category->string))
 
@@ -591,13 +600,25 @@ Where every <*-phase-name> is an expression evaluating to 
a symbol, and
     ((_ phases (add-after old-phase-name new-phase-name new-phase))
      (alist-cons-after old-phase-name new-phase-name new-phase phases))))
 
+(define-condition-type &invoke-error &error
+  invoke-error?
+  (program      invoke-error-program)
+  (arguments    invoke-error-arguments)
+  (exit-status  invoke-error-exit-status)
+  (term-signal  invoke-error-term-signal)
+  (stop-signal  invoke-error-stop-signal))
+
 (define (invoke program . args)
-  "Invoke PROGRAM with the given ARGS.  Raise an error if the exit
-code is non-zero; otherwise return #t."
-  (let ((status (apply system* program args)))
-    (unless (zero? status)
-      (error (format #f "program ~s exited with non-zero code" program)
-             status))
+  "Invoke PROGRAM with the given ARGS.  Raise an exception
+if the exit code is non-zero; otherwise return #t."
+  (let ((code (apply system* program args)))
+    (unless (zero? code)
+      (raise (condition (&invoke-error
+                         (program program)
+                         (arguments args)
+                         (exit-status (status:exit-val code))
+                         (term-signal (status:term-sig code))
+                         (stop-signal (status:stop-sig code))))))
     #t))
 
 
diff --git a/guix/ui.scm b/guix/ui.scm
index cb49a15..c6d0704 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
-;;; Copyright © 2013 Mark H Weaver <address@hidden>
+;;; Copyright © 2013, 2018 Mark H Weaver <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2014 Cyril Roelandt <address@hidden>
 ;;; Copyright © 2014 Cyrill Schenkel <address@hidden>
@@ -41,6 +41,12 @@
   #:use-module ((guix licenses) #:select (license? license-name))
   #:use-module ((guix build syscalls)
                 #:select (free-disk-space terminal-columns))
+  #:use-module ((guix build utils)
+                #:select (invoke-error? invoke-error-program
+                                        invoke-error-arguments
+                                        invoke-error-exit-status
+                                        invoke-error-term-signal
+                                        invoke-error-stop-signal))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
@@ -636,6 +642,16 @@ or remove one of them from the profile.")
 directories:~{ ~a~}~%")
                     (file-search-error-file-name c)
                     (file-search-error-search-path c)))
+            ((invoke-error? c)
+             (leave (G_ "program exited\
address@hidden with non-zero exit status ~a~]\
address@hidden terminated by signal ~a~]\
address@hidden stopped by signal ~a~]: ~s~%")
+                    (invoke-error-exit-status c)
+                    (invoke-error-term-signal c)
+                    (invoke-error-stop-signal c)
+                    (cons (invoke-error-program c)
+                          (invoke-error-arguments c))))
             ((and (error-location? c) (message-condition? c))
              (format (current-error-port)
                      (G_ "~a: error: ~a~%")