scripts: Use translations for guix.pot for service descriptions.

[jackhill/guix/guix.git] / guix / packages.scm

diff --git a/guix/packages.scm b/guix/packages.scm
index 715a639..704b4ee 100644 (file)
--- 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
@@ -414,7 +419,7 @@ from forcing GEXP-PROMISE."
 (define %supported-systems
   ;; This is the list of system types that are supported.  By default, we
   ;; expect all packages to build successfully here.
-  (append %32bit-supported-systems %64bit-supported-systems))
+  (append %64bit-supported-systems %32bit-supported-systems))
 
 (define %hurd-systems
   ;; The GNU/Hurd systems for which support is being developed.
@@ -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))