amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

build-system/asdf: Use 'mlambda'.

Browse source 
* guix/build-system/asdf.scm (package-with-build-system): Use 'mlambda'
instead of 'memoize'.
This commit is contained in:
Ludovic Courtès 2017-12-10 23:39:01 +01:00
parent 6146603d54
commit 8bc1935c7c
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 57 additions and 57 deletions
Download patch file Download diff file Expand all files Collapse all files

114
guix/build-system/asdf.scm
View file

@ -19,6 +19,7 @@
(define-module (guix build-system asdf) (define-module (guix build-system asdf)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix memoization)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix search-paths) #:use-module (guix search-paths)
@ -160,70 +161,69 @@ set up using CL source package conventions."
(eq? from-build-system (package-build-system pkg))) (eq? from-build-system (package-build-system pkg)))
(define transform (define transform
(memoize (mlambda (pkg)
(lambda (pkg) (define rewrite
(define rewrite (match-lambda
(match-lambda ((name content . rest)
((name content . rest) (let* ((is-package? (package? content))
(let* ((is-package? (package? content)) (new-content (if is-package? (transform content) content)))
(new-content (if is-package? (transform content) content))) `(,name ,new-content ,@rest)))))
`(,name ,new-content ,@rest)))))
;; Special considerations for source packages: CL inputs become ;; Special considerations for source packages: CL inputs become
;; propagated, and un-handled arguments are removed. ;; propagated, and un-handled arguments are removed.
(define new-propagated-inputs (define new-propagated-inputs
(if target-is-source? (if target-is-source?
(map rewrite (map rewrite
(append (append
(filter (match-lambda
((_ input . _)
(has-from-build-system? input)))
(append (package-inputs pkg)
;; The native inputs might be needed just
;; to load the system.
(package-native-inputs pkg)))
(package-propagated-inputs pkg)))
(map rewrite (package-propagated-inputs pkg))))
(define (new-inputs inputs-getter)
(if target-is-source?
(map rewrite
(filter (match-lambda (filter (match-lambda
((_ input . _) ((_ input . _)
(not (has-from-build-system? input)))) (has-from-build-system? input)))
(inputs-getter pkg))) (append (package-inputs pkg)
(map rewrite (inputs-getter pkg)))) ;; The native inputs might be needed just
;; to load the system.
(package-native-inputs pkg)))
(package-propagated-inputs pkg)))
(define base-arguments (map rewrite (package-propagated-inputs pkg))))
(if target-is-source?
(strip-keyword-arguments
'(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file)
(package-arguments pkg))
(package-arguments pkg)))
(cond (define (new-inputs inputs-getter)
((and variant-property (if target-is-source?
(assoc-ref (package-properties pkg) variant-property)) (map rewrite
=> force) (filter (match-lambda
((_ input . _)
(not (has-from-build-system? input))))
(inputs-getter pkg)))
(map rewrite (inputs-getter pkg))))
((has-from-build-system? pkg) (define base-arguments
(package (if target-is-source?
(inherit pkg) (strip-keyword-arguments
(location (package-location pkg)) '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file)
(name (transform-package-name (package-name pkg))) (package-arguments pkg))
(build-system to-build-system) (package-arguments pkg)))
(arguments
(substitute-keyword-arguments base-arguments (cond
((#:phases phases) (list phases-transformer phases)))) ((and variant-property
(inputs (new-inputs package-inputs)) (assoc-ref (package-properties pkg) variant-property))
(propagated-inputs new-propagated-inputs) => force)
(native-inputs (new-inputs package-native-inputs))
(outputs (if target-is-source? ((has-from-build-system? pkg)
'("out") (package
(package-outputs pkg))))) (inherit pkg)
(else pkg))))) (location (package-location pkg))
(name (transform-package-name (package-name pkg)))
(build-system to-build-system)
(arguments
(substitute-keyword-arguments base-arguments
((#:phases phases) (list phases-transformer phases))))
(inputs (new-inputs package-inputs))
(propagated-inputs new-propagated-inputs)
(native-inputs (new-inputs package-native-inputs))
(outputs (if target-is-source?
'("out")
(package-outputs pkg)))))
(else pkg))))
transform) transform)