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 gnu)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (gexp
|
||||
gexp?
|
||||
|
@ -84,7 +86,13 @@
|
|||
gexp-compiler?
|
||||
lower-object
|
||||
|
||||
lower-inputs))
|
||||
lower-inputs
|
||||
|
||||
&gexp-error
|
||||
gexp-error?
|
||||
&gexp-input-error
|
||||
gexp-input-error?
|
||||
gexp-error-invalid-input))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
@ -140,6 +148,14 @@
|
|||
(lower gexp-compiler-lower)
|
||||
(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
|
||||
;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
|
||||
(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.
|
||||
OBJ must be an object that has an associated gexp compiler, such as a
|
||||
<package>."
|
||||
(let ((lower (lookup-compiler obj)))
|
||||
(lower obj system target)))
|
||||
(match (lookup-compiler obj)
|
||||
(#f
|
||||
(raise (condition (&gexp-input-error (input obj)))))
|
||||
(lower
|
||||
(lower obj system target))))
|
||||
|
||||
(define-syntax define-gexp-compiler
|
||||
(syntax-rules (=> compiler expander)
|
||||
|
|
|
@ -26,6 +26,7 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix ui)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix config)
|
||||
|
@ -448,6 +449,10 @@ interpreted."
|
|||
(location->string loc)
|
||||
(package-full-name package)
|
||||
(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)
|
||||
(leave (_ "profile '~a' does not exist~%")
|
||||
(profile-error-profile c)))
|
||||
|
|
|
@ -946,6 +946,13 @@
|
|||
(string=? (readlink (string-append comp "/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"
|
||||
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\
|
||||
\"/bin/uname\"\\) [[:xdigit:]]+>$"
|
||||
|
|
Loading…
Reference in New Issue