packages: Rewrite 'patch-and-repack' using gexps.
* guix/packages.scm (patch-and-repack): Remove 'store' parameter and
change default value of #:inputs to (%standard-patch-inputs).
[lookup-input, instantiate-patch]: New procedures.
[patch-inputs]: Remove.
[builder]: Rename to...
[build]: ... this. Use gexps instead of sexps.
(patch-and-repack*): Remove.
(origin->derivation): Use 'patch-and-repack' instead of
'patch-and-repack*'.
* tests/packages.scm ("package-source-derivation,
snippet")[source](snippet): Remove references to '%build-inputs' and
'%outputs'.
This commit is contained in:
Ludovic Courtès
parent
381c540b93
commit
cf87cc894d
@ -26,6 +26,7 @@
|
||||
#:use-module (guix base32)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix build-system)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (srfi srfi-1)
|
||||
@ -349,10 +350,9 @@ the build code of derivation."
|
||||
(package->derivation (default-guile) system
|
||||
#:graft? #f))
|
||||
|
||||
;; TODO: Rewrite using %STORE-MONAD and gexps.
|
||||
(define* (patch-and-repack store source patches
|
||||
(define* (patch-and-repack source patches
|
||||
#:key
|
||||
(inputs '())
|
||||
(inputs (%standard-patch-inputs))
|
||||
(snippet #f)
|
||||
(flags '("-p1"))
|
||||
(modules '())
|
||||
@ -370,6 +370,11 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
|
||||
(derivation->output-path source)
|
||||
source))
|
||||
|
||||
(define (lookup-input name)
|
||||
(match (assoc-ref inputs name)
|
||||
((package) package)
|
||||
(#f #f)))
|
||||
|
||||
(define decompression-type
|
||||
(cond ((string-suffix? "gz" source-file-name) "gzip")
|
||||
((string-suffix? "bz2" source-file-name) "bzip2")
|
||||
@ -398,115 +403,93 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
|
||||
".xz"
|
||||
".tar.xz"))))
|
||||
|
||||
(define patch-inputs
|
||||
(map (lambda (number patch)
|
||||
(list (string-append "patch" (number->string number))
|
||||
(match patch
|
||||
((? string?)
|
||||
(add-to-store store (basename patch) #t
|
||||
"sha256" patch))
|
||||
((? origin?)
|
||||
(package-source-derivation store patch system)))))
|
||||
(iota (length patches))
|
||||
(define instantiate-patch
|
||||
(match-lambda
|
||||
((? string? patch)
|
||||
(interned-file patch #:recursive? #t))
|
||||
((? origin? patch)
|
||||
(origin->derivation patch system))))
|
||||
|
||||
patches))
|
||||
(mlet %store-monad ((tar -> (lookup-input "tar"))
|
||||
(xz -> (lookup-input "xz"))
|
||||
(patch -> (lookup-input "patch"))
|
||||
(locales -> (lookup-input "locales"))
|
||||
(decomp -> (lookup-input decompression-type))
|
||||
(patches (sequence %store-monad
|
||||
(map instantiate-patch patches))))
|
||||
(define build
|
||||
#~(begin
|
||||
(use-modules (ice-9 ftw)
|
||||
(srfi srfi-1)
|
||||
(guix build utils))
|
||||
|
||||
(define builder
|
||||
`(begin
|
||||
(use-modules (ice-9 ftw)
|
||||
(srfi srfi-1)
|
||||
(guix build utils))
|
||||
(define (apply-patch patch)
|
||||
(format (current-error-port) "applying '~a'...~%" patch)
|
||||
|
||||
;; Encoding/decoding errors shouldn't be silent.
|
||||
(fluid-set! %default-port-conversion-strategy 'error)
|
||||
;; Use '--force' so that patches that do not apply perfectly are
|
||||
;; rejected.
|
||||
(zero? (system* (string-append #$patch "/bin/patch")
|
||||
"--force" #$@flags "--input" patch)))
|
||||
|
||||
(let ((locales (assoc-ref %build-inputs "locales"))
|
||||
(out (assoc-ref %outputs "out"))
|
||||
(xz (assoc-ref %build-inputs "xz"))
|
||||
(decomp (assoc-ref %build-inputs ,decompression-type))
|
||||
(source (assoc-ref %build-inputs "source"))
|
||||
(tar (string-append (assoc-ref %build-inputs "tar")
|
||||
"/bin/tar"))
|
||||
(patch (string-append (assoc-ref %build-inputs "patch")
|
||||
"/bin/patch")))
|
||||
(define (apply-patch input)
|
||||
(let ((patch* (assoc-ref %build-inputs input)))
|
||||
(format (current-error-port) "applying '~a'...~%" patch*)
|
||||
(define (first-file directory)
|
||||
;; Return the name of the first file in DIRECTORY.
|
||||
(car (scandir directory
|
||||
(lambda (name)
|
||||
(not (member name '("." "..")))))))
|
||||
|
||||
;; Use '--force' so that patches that do not apply perfectly are
|
||||
;; rejected.
|
||||
(zero? (system* patch "--force" ,@flags "--input" patch*))))
|
||||
;; Encoding/decoding errors shouldn't be silent.
|
||||
(fluid-set! %default-port-conversion-strategy 'error)
|
||||
|
||||
(define (first-file directory)
|
||||
;; Return the name of the first file in DIRECTORY.
|
||||
(car (scandir directory
|
||||
(lambda (name)
|
||||
(not (member name '("." "..")))))))
|
||||
(when #$locales
|
||||
;; First of all, install a UTF-8 locale so that UTF-8 file names
|
||||
;; are correctly interpreted. During bootstrap, LOCALES is #f.
|
||||
(setenv "LOCPATH" (string-append #$locales "/lib/locale"))
|
||||
(setlocale LC_ALL "en_US.UTF-8"))
|
||||
|
||||
(when locales
|
||||
;; First of all, install a UTF-8 locale so that UTF-8 file names
|
||||
;; are correctly interpreted. During bootstrap, LOCALES is #f.
|
||||
(setenv "LOCPATH" (string-append locales "/lib/locale"))
|
||||
(setlocale LC_ALL "en_US.UTF-8"))
|
||||
(setenv "PATH" (string-append #$xz "/bin" ":"
|
||||
#$decomp "/bin"))
|
||||
|
||||
(setenv "PATH" (string-append xz "/bin" ":"
|
||||
decomp "/bin"))
|
||||
;; SOURCE may be either a directory or a tarball.
|
||||
(and (if (file-is-directory? #$source)
|
||||
(let* ((store (or (getenv "NIX_STORE") "/gnu/store"))
|
||||
(len (+ 1 (string-length store)))
|
||||
(base (string-drop #$source len))
|
||||
(dash (string-index base #\-))
|
||||
(directory (string-drop base (+ 1 dash))))
|
||||
(mkdir directory)
|
||||
(copy-recursively #$source directory)
|
||||
#t)
|
||||
(zero? (system* (string-append #$tar "/bin/tar")
|
||||
"xvf" #$source)))
|
||||
(let ((directory (first-file ".")))
|
||||
(format (current-error-port)
|
||||
"source is under '~a'~%" directory)
|
||||
(chdir directory)
|
||||
|
||||
;; SOURCE may be either a directory or a tarball.
|
||||
(and (if (file-is-directory? source)
|
||||
(let* ((store (or (getenv "NIX_STORE") "/gnu/store"))
|
||||
(len (+ 1 (string-length store)))
|
||||
(base (string-drop source len))
|
||||
(dash (string-index base #\-))
|
||||
(directory (string-drop base (+ 1 dash))))
|
||||
(mkdir directory)
|
||||
(copy-recursively source directory)
|
||||
#t)
|
||||
(zero? (system* tar "xvf" source)))
|
||||
(let ((directory (first-file ".")))
|
||||
(format (current-error-port)
|
||||
"source is under '~a'~%" directory)
|
||||
(chdir directory)
|
||||
(and (every apply-patch '#$patches)
|
||||
#$@(if snippet
|
||||
#~((let ((module (make-fresh-user-module)))
|
||||
(module-use-interfaces! module
|
||||
(map resolve-interface
|
||||
'#$modules))
|
||||
((@ (system base compile) compile)
|
||||
'#$snippet
|
||||
#:to 'value
|
||||
#:opts %auto-compilation-options
|
||||
#:env module)))
|
||||
#~())
|
||||
|
||||
(and (every apply-patch ',(map car patch-inputs))
|
||||
(begin (chdir "..") #t)
|
||||
(zero? (system* (string-append #$tar "/bin/tar")
|
||||
"cvfa" #$output directory)))))))
|
||||
|
||||
,@(if snippet
|
||||
`((let ((module (make-fresh-user-module)))
|
||||
(module-use-interfaces! module
|
||||
(map resolve-interface
|
||||
',modules))
|
||||
(module-define! module '%build-inputs
|
||||
%build-inputs)
|
||||
(module-define! module '%outputs %outputs)
|
||||
((@ (system base compile) compile)
|
||||
',snippet
|
||||
#:to 'value
|
||||
#:opts %auto-compilation-options
|
||||
#:env module)))
|
||||
'())
|
||||
|
||||
(begin (chdir "..") #t)
|
||||
(zero? (system* tar "cvfa" out directory))))))))
|
||||
|
||||
|
||||
(let ((name (tarxz-name original-file-name))
|
||||
(inputs (filter-map (match-lambda
|
||||
((name (? package? p))
|
||||
(and (member name (cons decompression-type
|
||||
'("tar" "xz" "patch")))
|
||||
(list name
|
||||
(package-derivation store p system
|
||||
#:graft? #f)))))
|
||||
(or inputs (%standard-patch-inputs))))
|
||||
(modules (delete-duplicates (cons '(guix build utils) modules))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:inputs `(("source" ,source)
|
||||
,@inputs
|
||||
,@patch-inputs)
|
||||
#:system system
|
||||
#:modules modules
|
||||
#:guile-for-build guile-for-build)))
|
||||
(let ((name (tarxz-name original-file-name))
|
||||
(modules (delete-duplicates (cons '(guix build utils) modules))))
|
||||
(gexp->derivation name build
|
||||
#:graft? #f
|
||||
#:system system
|
||||
#:modules modules
|
||||
#:guile-for-build guile-for-build))))
|
||||
|
||||
(define (transitive-inputs inputs)
|
||||
(let loop ((inputs inputs)
|
||||
@ -954,9 +937,6 @@ cross-compilation target triplet."
|
||||
(package->cross-derivation package target system)
|
||||
(package->derivation package system)))
|
||||
|
||||
(define patch-and-repack*
|
||||
(store-lift patch-and-repack))
|
||||
|
||||
(define* (origin->derivation source
|
||||
#:optional (system (%current-system)))
|
||||
"When SOURCE is an <origin> object, return its derivation for SYSTEM. When
|
||||
@ -976,14 +956,14 @@ outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
|
||||
(default-guile))
|
||||
system
|
||||
#:graft? #f)))
|
||||
(patch-and-repack* source patches
|
||||
#:inputs inputs
|
||||
#:snippet snippet
|
||||
#:flags flags
|
||||
#:system system
|
||||
#:modules modules
|
||||
#:imported-modules modules
|
||||
#:guile-for-build guile)))
|
||||
(patch-and-repack source patches
|
||||
#:inputs inputs
|
||||
#:snippet snippet
|
||||
#:flags flags
|
||||
#:system system
|
||||
#:modules modules
|
||||
#:imported-modules modules
|
||||
#:guile-for-build guile)))
|
||||
((and (? string?) (? direct-store-path?) file)
|
||||
(with-monad %store-monad
|
||||
(return file)))
|
||||
|
||||
@ -205,10 +205,7 @@
|
||||
(chmod "." #o777)
|
||||
(symlink "guile" "guile-rocks")
|
||||
(copy-recursively "../share/guile/2.0/scripts"
|
||||
"scripts")
|
||||
|
||||
;; These variables must exist.
|
||||
(pk %build-inputs %outputs))))))
|
||||
"scripts"))))))
|
||||
(package (package (inherit (dummy-package "with-snippet"))
|
||||
(source source)
|
||||
(build-system trivial-build-system)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user