summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-01-13 12:07:10 +0100
committerLudovic Courtès <ludo@gnu.org>2017-01-13 18:24:19 +0100
commite7ff05438f6044eb452b6dcd8b05b45afbc61496 (patch)
tree121d3bfab812b43f662abc30297b8ba4ae6c335d
parentce195ba12277ec4286ad0d8ddf7294655987ea9d (diff)
ui: Factorize error-reporting wrapper code.
* guix/ui.scm (augmented-system-error-handler): New procedure. (error-reporting-wrapper): New macro. (symlink, copy-file): Define using 'error-reporting-wrapper'.
-rw-r--r--guix/ui.scm49
1 files changed, 23 insertions, 26 deletions
diff --git a/guix/ui.scm b/guix/ui.scm
index 7d4c437354..03196dbeaf 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -332,39 +332,36 @@ Report bugs to: ~a.") %guix-bug-report-address)
General help using GNU software: <http://www.gnu.org/gethelp/>"))
(newline))
+(define (augmented-system-error-handler file)
+ "Return a 'system-error' handler that mentions FILE in its message."
+ (lambda (key proc fmt args errno)
+ ;; Augment the FMT and ARGS with information about TARGET (this
+ ;; information is missing as of Guile 2.0.11, making the exception
+ ;; uninformative.)
+ (apply throw key proc "~A: ~S"
+ (list (strerror (car errno)) file)
+ (list errno))))
+
+(define-syntax-rule (error-reporting-wrapper proc (args ...) file)
+ "Wrap PROC such that its 'system-error' exceptions are augmented to mention
+FILE."
+ (let ((real-proc (@ (guile) proc)))
+ (lambda (args ...)
+ (catch 'system-error
+ (lambda ()
+ (real-proc args ...))
+ (augmented-system-error-handler file)))))
+
(set! symlink
;; We 'set!' the global binding because (gnu build ...) modules and similar
;; typically don't use (guix ui).
- (let ((real-symlink (@ (guile) symlink)))
- (lambda (target link)
- "This is a 'symlink' replacement that provides proper error reporting."
- (catch 'system-error
- (lambda ()
- (real-symlink target link))
- (lambda (key proc fmt args errno)
- ;; Augment the FMT and ARGS with information about LINK (this
- ;; information is missing as of Guile 2.0.11, making the exception
- ;; uninformative.)
- (apply throw key proc "~A: ~S"
- (list (strerror (car errno)) link)
- (list errno)))))))
+ (error-reporting-wrapper symlink (source target) target))
(set! copy-file
;; Note: here we use 'set!', not #:replace, because UIs typically use
;; 'copy-recursively', which doesn't use (guix ui).
- (let ((real-copy-file (@ (guile) copy-file)))
- (lambda (source target)
- "This is a 'copy-file' replacement that provides proper error reporting."
- (catch 'system-error
- (lambda ()
- (real-copy-file source target))
- (lambda (key proc fmt args errno)
- ;; Augment the FMT and ARGS with information about TARGET (this
- ;; information is missing as of Guile 2.0.11, making the exception
- ;; uninformative.)
- (apply throw key proc "~A: ~S"
- (list (strerror (car errno)) target)
- (list errno)))))))
+ (error-reporting-wrapper copy-file (source target) target))
+
(define (make-regexp* regexp . flags)
"Like 'make-regexp' but error out if REGEXP is invalid, reporting the error