Merge remote-tracking branch 'origin/master' into core-updates-frozen

1 files changed, 85 insertions, 16 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index fa23cc39b3..fb7eabdc64 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -52,6 +52,7 @@
   #:use-module (srfi srfi-35)
   #:use-module (rnrs bytevectors)
   #:use-module (web uri)
+  #:autoload   (texinfo) (texi-fragment->stexi)
   #:re-export (%current-system
                %current-target-system
                search-path-specification)         ;for convenience
@@ -169,6 +170,7 @@
             bag-transitive-host-inputs
             bag-transitive-build-inputs
             bag-transitive-target-inputs
+            package-development-inputs
             package-closure
 
             default-guile
@@ -465,6 +467,49 @@ lexical scope of its body."
                                   (lambda (s) #,location)))
              body ...))))))
 
+(define-syntax validate-texinfo
+  (let ((validate? (getenv "GUIX_UNINSTALLED")))
+    (define ensure-thread-safe-texinfo-parser!
+      ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7.
+      (let ((patched? (or (> (string->number (major-version)) 3)
+                          (> (string->number (minor-version)) 0)
+                          (> (string->number (micro-version)) 7)))
+            (next-token-of/thread-safe
+             (lambda (pred port)
+               (let loop ((chars '()))
+                 (match (read-char port)
+                   ((? eof-object?)
+                    (list->string (reverse! chars)))
+                   (chr
+                    (let ((chr* (pred chr)))
+                      (if chr*
+                          (loop (cons chr* chars))
+                          (begin
+                            (unread-char chr port)
+                            (list->string (reverse! chars)))))))))))
+        (lambda ()
+          (unless patched?
+            (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe)
+            (set! patched? #t)))))
+
+    (lambda (s)
+      "Raise a syntax error when passed a literal string that is not valid
+Texinfo.  Otherwise, return the string."
+      (syntax-case s ()
+        ((_ str)
+         (string? (syntax->datum #'str))
+         (if validate?
+             (catch 'parser-error
+               (lambda ()
+                 (ensure-thread-safe-texinfo-parser!)
+                 (texi-fragment->stexi (syntax->datum #'str))
+                 #'str)
+               (lambda _
+                 (syntax-violation 'package "invalid Texinfo markup" #'str)))
+             #'str))
+        ((_ obj)
+         #'obj)))))
+
 ;; A package.
 (define-record-type* <package>
   package make-package
@@ -502,9 +547,11 @@ lexical scope of its body."
   (replacement package-replacement                ; package | #f
                (default #f) (thunked) (innate))
 
-  (synopsis package-synopsis)                    ; one-line description
-  (description package-description)              ; one or two paragraphs
-  (license package-license)
+  (synopsis package-synopsis
+            (sanitize validate-texinfo))          ; one-line description
+  (description package-description
+               (sanitize validate-texinfo))       ; one or two paragraphs
+  (license package-license)                       ; <license> instance or list
   (home-page package-home-page)
   (supported-systems package-supported-systems    ; list of strings
                      (default %supported-systems))
@@ -1176,23 +1223,36 @@ in INPUTS and their transitive propagated inputs."
 
 (define package-transitive-supported-systems
   (let ()
-    (define supported-systems
-      (mlambda (package system)
-        (parameterize ((%current-system system))
-          (fold (lambda (input systems)
-                  (match input
-                    ((label (? package? package) . _)
-                     (lset-intersection string=? systems
-                                        (supported-systems package system)))
-                    (_
-                     systems)))
-                (package-supported-systems package)
-                (bag-direct-inputs (package->bag package))))))
+    (define (supported-systems-procedure system)
+      (define supported-systems
+        (mlambdaq (package)
+          (parameterize ((%current-system system))
+            (fold (lambda (input systems)
+                    (match input
+                      ((label (? package? package) . _)
+                       (lset-intersection string=? systems
+                                          (supported-systems package)))
+                      (_
+                       systems)))
+                  (package-supported-systems package)
+                  (bag-direct-inputs (package->bag package))))))
+
+      supported-systems)
+
+    (define procs
+      ;; Map system strings to one-argument procedures.  This allows these
+      ;; procedures to have fast 'eq?' memoization on their argument.
+      (make-hash-table))
 
     (lambda* (package #:optional (system (%current-system)))
       "Return the intersection of the systems supported by PACKAGE and those
 supported by its dependencies."
-      (supported-systems package system))))
+      (match (hash-ref procs system)
+        (#f
+         (hash-set! procs system (supported-systems-procedure system))
+         (package-transitive-supported-systems package system))
+        (proc
+         (proc package))))))
 
 (define* (supported-package? package #:optional (system (%current-system)))
   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
@@ -1229,6 +1289,15 @@ dependencies are known to build on SYSTEM."
                  (%current-system (bag-system bag)))
     (transitive-inputs (bag-target-inputs bag))))
 
+(define* (package-development-inputs package
+                                     #:optional (system (%current-system))
+                                     #:key target)
+  "Return the list of inputs required by PACKAGE for development purposes on
+SYSTEM.  When TARGET is true, return the inputs needed to cross-compile
+PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as
+\"aarch64-linux-gnu\"."
+  (bag-transitive-inputs (package->bag package system target)))
+
 (define* (package-closure packages #:key (system (%current-system)))
   "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
 packages they depend on, recursively."