Add (guix ui).

* guix/ui.scm: New file.
* Makefile.am (MODULES): Add it.
* po/POTFILES.in: Add it.

* guix-build.in: Use it.
  (_, N_, leave): Remove.
  (guix-build): Use `with-error-handling' instead of the `guard' form.
* guix-download.in: Use it.
  (_, N_, leave): Remove.
This commit is contained in:
Ludovic Courtès 2012-11-01 00:50:01 +01:00
parent 111111d046
commit 073c34d72f
6 changed files with 82 additions and 29 deletions

View file

@ -10,7 +10,8 @@
(eval . (put 'substitute* 'scheme-indent-function 1)) (eval . (put 'substitute* 'scheme-indent-function 1))
(eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package '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))) (emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil) (texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72)))) (fill-column . 72))))

View file

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

View file

@ -30,6 +30,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix-build) (define-module (guix-build)
#:use-module (guix ui)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
@ -43,9 +44,6 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
#:autoload (distro) (find-packages-by-name) #:autoload (distro) (find-packages-by-name)
#:export (guix-build)) #:export (guix-build))
(define _ (cut gettext <> "guix"))
(define N_ (cut ngettext <> <> <> "guix"))
(define %store (define %store
(open-connection)) (open-connection))
@ -73,12 +71,6 @@ When SOURCE? is true, return the derivations of the package sources."
`((system . ,(%current-system)) `((system . ,(%current-system))
(substitutes? . #t))) (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) (define (show-version)
(display "guix-build (@PACKAGE_NAME@) @PACKAGE_VERSION@\n")) (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-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF) (setvbuf (current-error-port) _IOLBF)
(guard (c ((package-input-error? c) (with-error-handling
(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))))
(let* ((opts (parse-options)) (let* ((opts (parse-options))
(src? (assoc-ref opts 'source?)) (src? (assoc-ref opts 'source?))
(sys (assoc-ref opts 'system)) (sys (assoc-ref opts 'system))

View file

@ -32,6 +32,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
(define-module (guix-download) (define-module (guix-download)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web client) #:use-module (web client)
#:use-module (guix ui)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix ftp-client) #:use-module (guix ftp-client)
@ -44,9 +45,6 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:export (guix-download)) #:export (guix-download))
(define _ (cut gettext <> "guix"))
(define N_ (cut ngettext <> <> <> "guix"))
(define (call-with-temporary-output-file proc) (define (call-with-temporary-output-file proc)
(let* ((template (string-copy "guix-download.XXXXXX")) (let* ((template (string-copy "guix-download.XXXXXX"))
(out (mkstemp! template))) (out (mkstemp! template)))
@ -90,12 +88,6 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
;; Alist of default option values. ;; Alist of default option values.
`((format . ,bytevector->nix-base32-string))) `((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) (define (show-version)
(display "guix-download (@PACKAGE_NAME@) @PACKAGE_VERSION@\n")) (display "guix-download (@PACKAGE_NAME@) @PACKAGE_VERSION@\n"))

75
guix/ui.scm Normal file
View file

@ -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

View file

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