diff options
| -rw-r--r-- | guix/packages.scm | 40 | ||||
| -rw-r--r-- | tests/packages.scm | 7 |
2 files changed, 46 insertions, 1 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 94e464cd01..704b4ee710 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -41,6 +41,9 @@ #:use-module (guix search-paths) #:use-module (guix sets) #:use-module (guix deprecation) + #:use-module ((guix diagnostics) + #:select (formatted-message define-with-syntax-properties)) + #:autoload (guix licenses) (license?) #:use-module (guix i18n) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -159,6 +162,8 @@ &package-error package-error? package-error-package + package-license-error? + package-error-invalid-license &package-input-error package-input-error? package-error-invalid-input @@ -533,6 +538,34 @@ Texinfo. Otherwise, return the string." ((_ obj) #'obj))))) +(define-syntax valid-license-value? + (syntax-rules (list package-license) + "Return #t if the given value is a valid license field, #f otherwise." + ;; Arrange so that the answer can be given at macro-expansion time in the + ;; most common cases. + ((_ (list x ...)) + (and (license? x) ...)) + ((_ (package-license _)) + #t) + ((_ obj) + (or (license? obj) + ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>. + (eq? #f obj) ;#f is considered valid + (let ((x obj)) + (and (pair? x) (every license? x))))))) + +(define-with-syntax-properties (validate-license (value properties)) + (unless (valid-license-value? value) + (raise + (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (condition + (&package-license-error (package #f) (license value))) + (formatted-message (G_ "~s: invalid package license~%") value)))) + value) + ;; A package. (define-record-type* <package> package make-package @@ -574,7 +607,8 @@ Texinfo. Otherwise, return the string." (sanitize validate-texinfo)) ; one-line description (description package-description (sanitize validate-texinfo)) ; one or two paragraphs - (license package-license) ; (list of) <license> + (license package-license ; (list of) <license> + (sanitize validate-license)) (home-page package-home-page) (supported-systems package-supported-systems ; list of strings (default %supported-systems)) @@ -737,6 +771,10 @@ exist, return #f instead." package-error? (package package-error-package)) +(define-condition-type &package-license-error &package-error + package-license-error? + (license package-error-invalid-license)) + (define-condition-type &package-input-error &package-error package-input-error? (input package-error-invalid-input)) diff --git a/tests/packages.scm b/tests/packages.scm index 6cbc34ba0b..dc03b13417 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -94,6 +94,13 @@ (write (dummy-package "foo" (location #f))))))) +(test-equal "license type checking" + 'bad-license + (guard (c ((package-license-error? c) + (package-error-invalid-license c))) + (dummy-package "foo" + (license 'bad-license)))) + (test-assert "hidden-package" (and (hidden-package? (hidden-package (dummy-package "foo"))) (not (hidden-package? (dummy-package "foo"))))) |