@@ 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))
-
- patches))
-
- (define builder
- `(begin
- (use-modules (ice-9 ftw)
- (srfi srfi-1)
- (guix build utils))
-
- ;; Encoding/decoding errors shouldn't be silent.
- (fluid-set! %default-port-conversion-strategy 'error)
-
- (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
- ;; rejected.
- (zero? (system* patch "--force" ,@flags "--input" patch*))))
-
- (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"))
-
- (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* tar "xvf" source)))
- (let ((directory (first-file ".")))
- (format (current-error-port)
- "source is under '~a'~%" directory)
- (chdir directory)
-
- (and (every apply-patch ',(map car patch-inputs))
-
- ,@(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)))
+ (define instantiate-patch
+ (match-lambda
+ ((? string? patch)
+ (interned-file patch #:recursive? #t))
+ ((? origin? patch)
+ (origin->derivation patch system))))
+
+ (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 (apply-patch patch)
+ (format (current-error-port) "applying '~a'...~%" patch)
+
+ ;; Use '--force' so that patches that do not apply perfectly are
+ ;; rejected.
+ (zero? (system* (string-append #$patch "/bin/patch")
+ "--force" #$@flags "--input" patch)))
+
+ (define (first-file directory)
+ ;; Return the name of the first file in DIRECTORY.
+ (car (scandir directory
+ (lambda (name)
+ (not (member name '("." "..")))))))
+
+ ;; 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
+ ;; 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"))
+
+ ;; 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)
+
+ (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)))
+ #~())
+
+ (begin (chdir "..") #t)
+ (zero? (system* (string-append #$tar "/bin/tar")
+ "cvfa" #$output directory)))))))
+
+ (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)