ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

packages: Rewrite 'patch-and-repack' using gexps.

Browse source 
* 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 2015-03-18 19:00:12 +01:00
parent 381c540b93
commit cf87cc894d
2 changed files with 93 additions and 116 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

122
guix/packages.scm
View file

@ -26,6 +26,7 @@ (define-module (guix packages)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix build-system) #:use-module (guix build-system)
#:use-module (guix gexp)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -349,10 +350,9 @@ (define* (default-guile-derivation #:optional (system (%current-system)))
(package->derivation (default-guile) system (package->derivation (default-guile) system
#:graft? #f)) #:graft? #f))
;; TODO: Rewrite using %STORE-MONAD and gexps. (define* (patch-and-repack source patches
(define* (patch-and-repack store source patches
#:key #:key
(inputs '()) (inputs (%standard-patch-inputs))
(snippet #f) (snippet #f)
(flags '("-p1")) (flags '("-p1"))
(modules '()) (modules '())
@ -370,6 +370,11 @@ (define source-file-name
(derivation->output-path source) (derivation->output-path source)
source)) source))
(define (lookup-input name)
(match (assoc-ref inputs name)
((package) package)
(#f #f)))
(define decompression-type (define decompression-type
(cond ((string-suffix? "gz" source-file-name) "gzip") (cond ((string-suffix? "gz" source-file-name) "gzip")
((string-suffix? "bz2" source-file-name) "bzip2") ((string-suffix? "bz2" source-file-name) "bzip2")
@ -398,44 +403,33 @@ (define (tarxz-name file-name)
".xz" ".xz"
".tar.xz")))) ".tar.xz"))))
(define patch-inputs (define instantiate-patch
(map (lambda (number patch) (match-lambda
(list (string-append "patch" (number->string number)) ((? string? patch)
(match patch (interned-file patch #:recursive? #t))
((? string?) ((? origin? patch)
(add-to-store store (basename patch) #t (origin->derivation patch system))))
"sha256" patch))
((? origin?)
(package-source-derivation store patch system)))))
(iota (length patches))
patches)) (mlet %store-monad ((tar -> (lookup-input "tar"))
(xz -> (lookup-input "xz"))
(define builder (patch -> (lookup-input "patch"))
`(begin (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) (use-modules (ice-9 ftw)
(srfi srfi-1) (srfi srfi-1)
(guix build utils)) (guix build utils))
;; Encoding/decoding errors shouldn't be silent. (define (apply-patch patch)
(fluid-set! %default-port-conversion-strategy 'error) (format (current-error-port) "applying '~a'...~%" 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*)
;; Use '--force' so that patches that do not apply perfectly are ;; Use '--force' so that patches that do not apply perfectly are
;; rejected. ;; rejected.
(zero? (system* patch "--force" ,@flags "--input" patch*)))) (zero? (system* (string-append #$patch "/bin/patch")
"--force" #$@flags "--input" patch)))
(define (first-file directory) (define (first-file directory)
;; Return the name of the first file in DIRECTORY. ;; Return the name of the first file in DIRECTORY.
@ -443,70 +437,59 @@ (define (first-file directory)
(lambda (name) (lambda (name)
(not (member name '("." ".."))))))) (not (member name '("." "..")))))))
(when locales ;; Encoding/decoding errors shouldn't be silent.
(fluid-set! %default-port-conversion-strategy 'error)
(when #$locales
;; First of all, install a UTF-8 locale so that UTF-8 file names ;; First of all, install a UTF-8 locale so that UTF-8 file names
;; are correctly interpreted. During bootstrap, LOCALES is #f. ;; are correctly interpreted. During bootstrap, LOCALES is #f.
(setenv "LOCPATH" (string-append locales "/lib/locale")) (setenv "LOCPATH" (string-append #$locales "/lib/locale"))
(setlocale LC_ALL "en_US.UTF-8")) (setlocale LC_ALL "en_US.UTF-8"))
(setenv "PATH" (string-append xz "/bin" ":" (setenv "PATH" (string-append #$xz "/bin" ":"
decomp "/bin")) #$decomp "/bin"))
;; SOURCE may be either a directory or a tarball. ;; SOURCE may be either a directory or a tarball.
(and (if (file-is-directory? source) (and (if (file-is-directory? #$source)
(let* ((store (or (getenv "NIX_STORE") "/gnu/store")) (let* ((store (or (getenv "NIX_STORE") "/gnu/store"))
(len (+ 1 (string-length store))) (len (+ 1 (string-length store)))
(base (string-drop source len)) (base (string-drop #$source len))
(dash (string-index base #\-)) (dash (string-index base #\-))
(directory (string-drop base (+ 1 dash)))) (directory (string-drop base (+ 1 dash))))
(mkdir directory) (mkdir directory)
(copy-recursively source directory) (copy-recursively #$source directory)
#t) #t)
(zero? (system* tar "xvf" source))) (zero? (system* (string-append #$tar "/bin/tar")
"xvf" #$source)))
(let ((directory (first-file "."))) (let ((directory (first-file ".")))
(format (current-error-port) (format (current-error-port)
"source is under '~a'~%" directory) "source is under '~a'~%" directory)
(chdir directory) (chdir directory)
(and (every apply-patch ',(map car patch-inputs)) (and (every apply-patch '#$patches)
#$@(if snippet
,@(if snippet #~((let ((module (make-fresh-user-module)))
`((let ((module (make-fresh-user-module)))
(module-use-interfaces! module (module-use-interfaces! module
(map resolve-interface (map resolve-interface
',modules)) '#$modules))
(module-define! module '%build-inputs
%build-inputs)
(module-define! module '%outputs %outputs)
((@ (system base compile) compile) ((@ (system base compile) compile)
',snippet '#$snippet
#:to 'value #:to 'value
#:opts %auto-compilation-options #:opts %auto-compilation-options
#:env module))) #:env module)))
'()) #~())
(begin (chdir "..") #t) (begin (chdir "..") #t)
(zero? (system* tar "cvfa" out directory)))))))) (zero? (system* (string-append #$tar "/bin/tar")
"cvfa" #$output directory)))))))
(let ((name (tarxz-name original-file-name)) (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)))) (modules (delete-duplicates (cons '(guix build utils) modules))))
(gexp->derivation name build
(build-expression->derivation store name builder #:graft? #f
#:inputs `(("source" ,source)
,@inputs
,@patch-inputs)
#:system system #:system system
#:modules modules #:modules modules
#:guile-for-build guile-for-build))) #:guile-for-build guile-for-build))))
(define (transitive-inputs inputs) (define (transitive-inputs inputs)
(let loop ((inputs inputs) (let loop ((inputs inputs)
@ -954,9 +937,6 @@ (define-gexp-compiler (package-compiler (package package?) system target)
(package->cross-derivation package target system) (package->cross-derivation package target system)
(package->derivation package system))) (package->derivation package system)))
(define patch-and-repack*
(store-lift patch-and-repack))
(define* (origin->derivation source (define* (origin->derivation source
#:optional (system (%current-system))) #:optional (system (%current-system)))
"When SOURCE is an <origin> object, return its derivation for SYSTEM. When "When SOURCE is an <origin> object, return its derivation for SYSTEM. When
@ -976,7 +956,7 @@ (define* (origin->derivation source
(default-guile)) (default-guile))
system system
#:graft? #f))) #:graft? #f)))
(patch-and-repack* source patches (patch-and-repack source patches
#:inputs inputs #:inputs inputs
#:snippet snippet #:snippet snippet
#:flags flags #:flags flags

5
tests/packages.scm
View file

@ -205,10 +205,7 @@ (define read-at
(chmod "." #o777) (chmod "." #o777)
(symlink "guile" "guile-rocks") (symlink "guile" "guile-rocks")
(copy-recursively "../share/guile/2.0/scripts" (copy-recursively "../share/guile/2.0/scripts"
"scripts") "scripts"))))))
;; These variables must exist.
(pk %build-inputs %outputs))))))
(package (package (inherit (dummy-package "with-snippet")) (package (package (inherit (dummy-package "with-snippet"))
(source source) (source source)
(build-system trivial-build-system) (build-system trivial-build-system)