gexp: 'lower-object' raises an exception when passed an invalid object.
* guix/gexp.scm (&gexp-error, &gexp-input-error): New error conditions. (lower-object): Raise &gexp-input-error when 'lookup-compiler' returns #f. * tests/gexp.scm ("lower-object & gexp-input-error?"): New test. * guix/ui.scm (call-with-error-handling): Add case for 'gexp-input-error?'.
This commit is contained in:
parent
b98d4ec0aa
commit
3e43166ffc
|
@ -26,6 +26,8 @@
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-9 gnu)
|
#:use-module (srfi srfi-9 gnu)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (srfi srfi-34)
|
||||||
|
#:use-module (srfi srfi-35)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export (gexp
|
#:export (gexp
|
||||||
gexp?
|
gexp?
|
||||||
|
@ -84,7 +86,13 @@
|
||||||
gexp-compiler?
|
gexp-compiler?
|
||||||
lower-object
|
lower-object
|
||||||
|
|
||||||
lower-inputs))
|
lower-inputs
|
||||||
|
|
||||||
|
&gexp-error
|
||||||
|
gexp-error?
|
||||||
|
&gexp-input-error
|
||||||
|
gexp-input-error?
|
||||||
|
gexp-error-invalid-input))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -140,6 +148,14 @@
|
||||||
(lower gexp-compiler-lower)
|
(lower gexp-compiler-lower)
|
||||||
(expand gexp-compiler-expand)) ;#f | DRV -> sexp
|
(expand gexp-compiler-expand)) ;#f | DRV -> sexp
|
||||||
|
|
||||||
|
(define-condition-type &gexp-error &error
|
||||||
|
gexp-error?)
|
||||||
|
|
||||||
|
(define-condition-type &gexp-input-error &gexp-error
|
||||||
|
gexp-input-error?
|
||||||
|
(input gexp-error-invalid-input))
|
||||||
|
|
||||||
|
|
||||||
(define %gexp-compilers
|
(define %gexp-compilers
|
||||||
;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
|
;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
|
||||||
(make-hash-table 20))
|
(make-hash-table 20))
|
||||||
|
@ -177,8 +193,11 @@ procedure to expand it; otherwise return #f."
|
||||||
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
|
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
|
||||||
OBJ must be an object that has an associated gexp compiler, such as a
|
OBJ must be an object that has an associated gexp compiler, such as a
|
||||||
<package>."
|
<package>."
|
||||||
(let ((lower (lookup-compiler obj)))
|
(match (lookup-compiler obj)
|
||||||
(lower obj system target)))
|
(#f
|
||||||
|
(raise (condition (&gexp-input-error (input obj)))))
|
||||||
|
(lower
|
||||||
|
(lower obj system target))))
|
||||||
|
|
||||||
(define-syntax define-gexp-compiler
|
(define-syntax define-gexp-compiler
|
||||||
(syntax-rules (=> compiler expander)
|
(syntax-rules (=> compiler expander)
|
||||||
|
|
|
@ -26,6 +26,7 @@
|
||||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (guix ui)
|
(define-module (guix ui)
|
||||||
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix config)
|
#:use-module (guix config)
|
||||||
|
@ -448,6 +449,10 @@ interpreted."
|
||||||
(location->string loc)
|
(location->string loc)
|
||||||
(package-full-name package)
|
(package-full-name package)
|
||||||
(build-system-name system))))
|
(build-system-name system))))
|
||||||
|
((gexp-input-error? c)
|
||||||
|
(let ((input (package-error-invalid-input c)))
|
||||||
|
(leave (_ "~s: invalid G-expression input~%")
|
||||||
|
(gexp-error-invalid-input c))))
|
||||||
((profile-not-found-error? c)
|
((profile-not-found-error? c)
|
||||||
(leave (_ "profile '~a' does not exist~%")
|
(leave (_ "profile '~a' does not exist~%")
|
||||||
(profile-error-profile c)))
|
(profile-error-profile c)))
|
||||||
|
|
|
@ -946,6 +946,13 @@
|
||||||
(string=? (readlink (string-append comp "/text"))
|
(string=? (readlink (string-append comp "/text"))
|
||||||
text)))))))
|
text)))))))
|
||||||
|
|
||||||
|
(test-assert "lower-object & gexp-input-error?"
|
||||||
|
(guard (c ((gexp-input-error? c)
|
||||||
|
(gexp-error-invalid-input c)))
|
||||||
|
(run-with-store %store
|
||||||
|
(lower-object (current-module))
|
||||||
|
#:guile-for-build (%guile-for-build))))
|
||||||
|
|
||||||
(test-assert "printer"
|
(test-assert "printer"
|
||||||
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\
|
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\
|
||||||
\"/bin/uname\"\\) [[:xdigit:]]+>$"
|
\"/bin/uname\"\\) [[:xdigit:]]+>$"
|
||||||
|
|
Loading…
Reference in New Issue