;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
origin-patch-guile
origin-snippet
origin-modules
- origin-imported-modules
base32
package
package-maintainers
package-properties
package-location
+ hidden-package
+ hidden-package?
+ package-superseded
+ deprecated-package
package-field-location
package-direct-sources
package-transitive-propagated-inputs
package-transitive-native-search-paths
package-transitive-supported-systems
+ package-input-rewriting
package-source-derivation
package-derivation
package-cross-derivation
(default #f))
(modules origin-modules ; list of module names
(default '()))
- (imported-modules origin-imported-modules ; list of module names
- (default '()))
+
(patch-guile origin-patch-guile ; package or #f
(default #f)))
package)
16)))))
+(define (hidden-package p)
+ "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
+user interfaces, ignores."
+ (package
+ (inherit p)
+ (properties `((hidden? . #t)
+ ,@(package-properties p)))))
+
+(define (hidden-package? p)
+ "Return true if P is \"hidden\"--i.e., must not be visible to user
+interfaces."
+ (assoc-ref (package-properties p) 'hidden?))
+
+(define (package-superseded p)
+ "Return the package the supersedes P, or #f if P is still current."
+ (assoc-ref (package-properties p) 'superseded))
+
+(define (deprecated-package old-name p)
+ "Return a package called OLD-NAME and marked as superseded by P, a package
+object."
+ (package
+ (inherit p)
+ (name old-name)
+ (properties `((superseded . ,p)))))
+
(define (package-field-location package field)
"Return the source code location of the definition of FIELD for PACKAGE, or
#f if it could not be determined."
(snippet #f)
(flags '("-p1"))
(modules '())
- (imported-modules '())
(guile-for-build (%guile-for-build))
(system (%current-system)))
"Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
it must be an s-expression that will run from within the directory where
-SOURCE was unpacked, after all of PATCHES have been applied. MODULES and
-IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
+SOURCE was unpacked, after all of PATCHES have been applied. MODULES
+specifies modules in scope when evaluating SNIPPET."
(define source-file-name
;; SOURCE is usually a derivation, but it could be a store file.
(if (derivation? source)
(patches (sequence %store-monad
(map instantiate-patch patches))))
(define build
- #~(begin
- (use-modules (ice-9 ftw)
- (srfi srfi-1)
- (guix build utils))
-
- ;; The --sort option was added to GNU tar in version 1.28, released
- ;; 2014-07-28. During bootstrap we must cope with older versions.
- (define tar-supports-sort?
- (zero? (system* (string-append #+tar "/bin/tar")
- "cf" "/dev/null" "--files-from=/dev/null"
- "--sort=name")))
-
- (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/"
- #+(and locales
- (package-version locales))))
- (setlocale LC_ALL "en_US.utf8"))
-
- (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 (%store-directory))
- (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)
- #+(if (string=? decompression-type "unzip")
- #~(zero? (system* "unzip" #+source))
- #~(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)
-
- (unless tar-supports-sort?
- (call-with-output-file ".file_list"
- (lambda (port)
- (for-each (lambda (name) (format port "~a~%" name))
- (find-files directory
- #:directories? #t
- #:fail-on-error? #t)))))
- (zero? (apply system* (string-append #+tar "/bin/tar")
- "cvfa" #$output
- ;; avoid non-determinism in the archive
- "--mtime=@0"
- "--owner=root:0"
- "--group=root:0"
- (if tar-supports-sort?
- `("--sort=name"
- ,directory)
- '("--no-recursion"
- "--files-from=.file_list")))))))))
-
- (let ((name (tarxz-name original-file-name))
- (modules (delete-duplicates (cons '(guix build utils) modules))))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (ice-9 ftw)
+ (srfi srfi-1)
+ (guix build utils))
+
+ ;; The --sort option was added to GNU tar in version 1.28, released
+ ;; 2014-07-28. During bootstrap we must cope with older versions.
+ (define tar-supports-sort?
+ (zero? (system* (string-append #+tar "/bin/tar")
+ "cf" "/dev/null" "--files-from=/dev/null"
+ "--sort=name")))
+
+ (define (apply-patch patch)
+ (format (current-error-port) "applying '~a'...~%" patch)
+
+ ;; Use '--force' so that patches that do not apply perfectly are
+ ;; rejected. Use '--no-backup-if-mismatch' to prevent making
+ ;; "*.orig" file if a patch is applied with offset.
+ (zero? (system* (string-append #+patch "/bin/patch")
+ "--force" "--no-backup-if-mismatch"
+ #+@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/"
+ #+(and locales
+ (package-version locales))))
+ (setlocale LC_ALL "en_US.utf8"))
+
+ (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 (%store-directory))
+ (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)
+ #+(if (string=? decompression-type "unzip")
+ #~(zero? (system* "unzip" #+source))
+ #~(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)
+
+ (unless tar-supports-sort?
+ (call-with-output-file ".file_list"
+ (lambda (port)
+ (for-each (lambda (name)
+ (format port "~a~%" name))
+ (find-files directory
+ #:directories? #t
+ #:fail-on-error? #t)))))
+ (zero? (apply system*
+ (string-append #+tar "/bin/tar")
+ "cvfa" #$output
+ ;; avoid non-determinism in the archive
+ "--mtime=@0"
+ "--owner=root:0"
+ "--group=root:0"
+ (if tar-supports-sort?
+ `("--sort=name"
+ ,directory)
+ '("--no-recursion"
+ "--files-from=.file_list"))))))))))
+
+ (let ((name (tarxz-name original-file-name)))
(gexp->derivation name build
#:graft? #f
#:system system
- #:modules modules
#:guile-for-build guile-for-build))))
(define (transitive-inputs inputs)
"Return the \"target inputs\" of BAG, recursively."
(transitive-inputs (bag-target-inputs bag)))
+(define* (package-input-rewriting replacements
+ #:optional (rewrite-name identity))
+ "Return a procedure that, when passed a package, replaces its direct and
+indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
+REPLACEMENTS is a list of package pairs; the first element of each pair is the
+package to replace, and the second one is the replacement.
+
+Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
+package and returns its new name after rewrite."
+ (define (rewrite input)
+ (match input
+ ((label (? package? package) outputs ...)
+ (match (assq-ref replacements package)
+ (#f (cons* label (replace package) outputs))
+ (new (cons* label new outputs))))
+ (_
+ input)))
+
+ (define-memoized/v (replace p)
+ "Return a variant of P with its inputs rewritten."
+ (package
+ (inherit p)
+ (name (rewrite-name (package-name p)))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))))
+
+ replace)
+
\f
;;;
;;; Package derivations.
;; store path, it needs to be added anyway, so it can be used as a
;; source.
(list name (intern file)))
- (((? string? name) (? origin? source))
+ (((? string? name) (? struct? source))
(list name (package-source-derivation store source system)))
(x
(raise (condition (&package-input-error
(cached (=> %graft-cache) package system
(let ((orig (package-derivation store package system
#:graft? #f))
- (new (package-derivation store replacement system)))
+ (new (package-derivation store replacement system
+ #:graft? #t)))
(graft
(origin orig)
(replacement new)))))))
(let ((orig (package-cross-derivation store package target system
#:graft? #f))
(new (package-cross-derivation store replacement
- target system)))
+ target system
+ #:graft? #t)))
(graft
(origin orig)
(replacement new))))))
(define package->cross-derivation
(store-lift package-cross-derivation))
-(define-gexp-compiler (package-compiler (package package?) system target)
+(define-gexp-compiler (package-compiler (package <package>) system target)
;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
;; TARGET. This is used when referring to a package from within a gexp.
(if target
(package->cross-derivation package target system)
(package->derivation package system)))
-(define* (origin->derivation source
+(define* (origin->derivation origin
#:optional (system (%current-system)))
- "When SOURCE is an <origin> object, return its derivation for SYSTEM. When
-SOURCE is a file name, return either the interned file name (if SOURCE is
-outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
- (match source
+ "Return the derivation corresponding to ORIGIN."
+ (match origin
(($ <origin> uri method sha256 name (= force ()) #f)
;; No patches, no snippet: this is a fixed-output derivation.
(method uri 'sha256 sha256 name #:system system))
(($ <origin> uri method sha256 name (= force (patches ...)) snippet
- (flags ...) inputs (modules ...) (imported-modules ...)
- guile-for-build)
+ (flags ...) inputs (modules ...) guile-for-build)
;; Patches and/or a snippet.
(mlet %store-monad ((source (method uri 'sha256 sha256 name
#:system system))
#: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)))
- ((? string? file)
- (interned-file file (basename file)
- #:recursive? #t))))
-
-(define-gexp-compiler (origin-compiler (origin origin?) system target)
+ #:guile-for-build guile)))))
+
+(define-gexp-compiler (origin-compiler (origin <origin>) system target)
;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
;; to an origin from within a gexp.
(origin->derivation origin system))
-(define package-source-derivation
- (store-lower origin->derivation))
+(define package-source-derivation ;somewhat deprecated
+ (let ((lower (store-lower lower-object)))
+ (lambda* (store source #:optional (system (%current-system)))
+ "Return the derivation or file corresponding to SOURCE, which can be an
+a file name or any object handled by 'lower-object', such as an <origin>.
+When SOURCE is a file name, return either the interned file name (if SOURCE is
+outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
+ (match source
+ ((and (? string?) (? direct-store-path?) file)
+ file)
+ ((? string? file)
+ (add-to-store store (basename file) #t "sha256" file))
+ (_
+ (lower store source system))))))
HCoop / jackhill / guix / guix.git / blobdiff