6 files changed, 82 insertions(+), 29 deletions(-)

M .dir-locals.el
M Makefile.am
M guix-build.in
M guix-download.in
A guix/ui.scm
M po/POTFILES.in

@@ 10,7 10,8 @@
    (eval . (put 'substitute* 'scheme-indent-function 1))
    (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
    (eval . (put 'package 'scheme-indent-function 1))
-   (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))))
+   (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
+   (eval . (put 'with-error-handling 'scheme-indent-function 0))))
  (emacs-lisp-mode . ((indent-tabs-mode . nil)))
  (texinfo-mode    . ((indent-tabs-mode . nil)
                      (fill-column . 72))))

@@ 30,6 30,7 @@ MODULES =					\
   guix/ftp-client.scm				\
   guix/http.scm					\
   guix/store.scm				\
+  guix/ui.scm					\
   guix/build/gnu-build-system.scm		\
   guix/build/ftp.scm				\
   guix/build/http.scm				\

@@ 30,6 30,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
 ;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix-build)
+  #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)


@@ 43,9 44,6 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
   #:autoload   (distro) (find-packages-by-name)
   #:export (guix-build))
 
-(define _ (cut gettext <> "guix"))
-(define N_ (cut ngettext <> <> <> "guix"))
-
 (define %store
   (open-connection))
 


@@ 73,12 71,6 @@ When SOURCE? is true, return the derivations of the package sources."
   `((system . ,(%current-system))
     (substitutes? . #t)))
 
-(define-syntax-rule (leave fmt args ...)
-  "Format FMT and ARGS to the error port and exit."
-  (begin
-    (format (current-error-port) fmt args ...)
-    (exit 1)))
-
 (define (show-version)
   (display "guix-build (@PACKAGE_NAME@) @PACKAGE_VERSION@\n"))
 


@@ 206,16 198,7 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
   (setvbuf (current-output-port) _IOLBF)
   (setvbuf (current-error-port) _IOLBF)
 
-  (guard (c ((package-input-error? c)
-             (let* ((package  (package-error-package c))
-                    (input    (package-error-invalid-input c))
-                    (location (package-location package))
-                    (file     (location-file location))
-                    (line     (location-line location))
-                    (column   (location-column location)))
-               (leave (_ "~a:~a:~a: error: package `~a' has an invalid input: ~s~%")
-                      file line column
-                      (package-full-name package) input))))
+  (with-error-handling
     (let* ((opts (parse-options))
            (src? (assoc-ref opts 'source?))
            (sys  (assoc-ref opts 'system))

@@ 32,6 32,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
 (define-module (guix-download)
   #:use-module (web uri)
   #:use-module (web client)
+  #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix ftp-client)


@@ 44,9 45,6 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
   #:use-module (rnrs io ports)
   #:export (guix-download))
 
-(define _ (cut gettext <> "guix"))
-(define N_ (cut ngettext <> <> <> "guix"))
-
 (define (call-with-temporary-output-file proc)
   (let* ((template (string-copy "guix-download.XXXXXX"))
          (out      (mkstemp! template)))


@@ 90,12 88,6 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
   ;; Alist of default option values.
   `((format . ,bytevector->nix-base32-string)))
 
-(define-syntax-rule (leave fmt args ...)
-  "Format FMT and ARGS to the error port and exit."
-  (begin
-    (format (current-error-port) fmt args ...)
-    (exit 1)))
-
 (define (show-version)
   (display "guix-download (@PACKAGE_NAME@) @PACKAGE_VERSION@\n"))
 

@@ 0,0 1,75 @@
+;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix store)
+  #:use-module (guix packages)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:export (_
+            N_
+            leave
+            call-with-error-handling
+            with-error-handling))
+
+;;; Commentary:
+;;;
+;;; User interface facilities for command-line tools.
+;;;
+;;; Code:
+
+(define %gettext-domain
+  "guix")
+
+(define _ (cut gettext <> %gettext-domain))
+(define N_ (cut ngettext <> <> <> %gettext-domain))
+
+(define-syntax-rule (leave fmt args ...)
+  "Format FMT and ARGS to the error port and exit."
+  (begin
+    (format (current-error-port) fmt args ...)
+    (exit 1)))
+
+(define (call-with-error-handling thunk)
+  "Call THUNK within a user-friendly error handler."
+  (guard (c ((package-input-error? c)
+             (let* ((package  (package-error-package c))
+                    (input    (package-error-invalid-input c))
+                    (location (package-location package))
+                    (file     (location-file location))
+                    (line     (location-line location))
+                    (column   (location-column location)))
+               (leave (_ "~a:~a:~a: error: package `~a' has an invalid input: ~s~%")
+                      file line column
+                      (package-full-name package) input)))
+            ((nix-protocol-error? c)
+             ;; FIXME: Server-provided error messages aren't i18n'd.
+             (leave (_ "error: build failed: ~a~%")
+                    (nix-protocol-error-message c))))
+    (thunk)))
+
+(define-syntax with-error-handling
+  (syntax-rules ()
+    "Run BODY within a user-friendly error condition handler."
+    ((_ body ...)
+     (call-with-error-handling
+      (lambda ()
+        body ...)))))
+
+;;; ui.scm ends here

@@ 4,5 4,6 @@ distro/packages/base.scm
 distro/packages/databases.scm
 distro/packages/guile.scm
 distro/packages/typesetting.scm
+guix/ui.scm
 guix-build.in
 guix-download.in