This is written in such a way that the type check turns into a no-op at
macro-expansion time for trivial cases:
> ,optimize (validate-license gpl3+)
$18 = gpl3+
> ,optimize (validate-license (list gpl3+ gpl2+))
$19 = (list gpl3+ gpl2+)
* guix/packages.scm (valid-license-value?, validate-license): New
macros.
(<package>)[license]: Add 'sanitize' option.
(&package-license-error): New error condition type.
* tests/packages.scm ("license type checking"): New test.
---
guix/packages.scm | 40 +++++++++++++++++++++++++++++++++++++++-
tests/packages.scm | 7 +++++++
2 files changed, 46 insertions(+), 1 deletion(-)
Toggle diff (99 lines)
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 @@ (define-module (guix packages)
#: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 @@ (define-module (guix packages)
&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 @@ (define ensure-thread-safe-texinfo-parser!
((_ 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 @@ (define-record-type* <package>
(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 @@ (define-condition-type &package-error &error
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 @@ (define %store
(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")))))
--
2.37.3
