diff options
author | Efraim Flashner <efraim@flashner.co.il> | 2021-10-31 12:47:14 +0200 |
---|---|---|
committer | Efraim Flashner <efraim@flashner.co.il> | 2021-10-31 14:49:47 +0200 |
commit | bc5155b952ae8bdbc56aded4d8d39768b4e2a7d4 (patch) | |
tree | 6b55475d86c522543384dea7d1ab66bba32af63e /guix/packages.scm | |
parent | dac8d013bd1fc7f57b8ba3582eef6e0e01b23dfd (diff) | |
parent | 4e5000114ec01b5e92a87c52f2a10f9ba7a601c8 (diff) |
Merge remote-tracking branch 'origin/master' into core-updates-frozen
Diffstat (limited to 'guix/packages.scm')
-rw-r--r-- | guix/packages.scm | 101 |
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." |