ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -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

204
guix/packages.scm
View file

@ -26,6 +26,7 @@ (define-module (guix packages)
#: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 @@ (define* (default-guile-derivation #:optional (system (%current-system)))
(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 @@ (define source-file-name
(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 @@ (define (tarxz-name file-name)
".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 @@ (define-gexp-compiler (package-compiler (package package?) system target)
(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 @@ (define* (origin->derivation source
(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)))

5
tests/packages.scm
View file

@ -205,10 +205,7 @@ (define read-at
(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)