mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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:
parent
111111d046
commit
073c34d72f
6 changed files with 82 additions and 29 deletions
|
@ -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))))
|
||||||
|
|
|
@ -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 \
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
75
guix/ui.scm
Normal 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
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue