#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix monads)
+ #:use-module (guix gexp)
#:use-module (guix base32)
#:use-module (guix derivations)
#:use-module (guix build-system)
+ #:use-module (guix search-paths)
+ #:use-module (guix gexp)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:re-export (%current-system
- %current-target-system)
+ %current-target-system
+ search-path-specification) ;for convenience
#:export (origin
origin?
origin-uri
origin-imported-modules
base32
- <search-path-specification>
- search-path-specification
- search-path-specification?
- search-path-specification->sexp
-
package
package?
package-name
package-location
package-field-location
+ package-direct-sources
+ package-transitive-sources
package-direct-inputs
package-transitive-inputs
package-transitive-target-inputs
package-grafts
%supported-systems
+ %hydra-supported-systems
+ supported-package?
&package-error
package-error?
&package-cross-build-system-error
package-cross-build-system-error?
- %graft?
package->bag
bag->derivation
+ bag-direct-inputs
bag-transitive-inputs
bag-transitive-host-inputs
bag-transitive-build-inputs
bag-transitive-target-inputs
default-guile
-
+ default-guile-derivation
set-guile-for-build
package-file
package->derivation
((_ str)
#'(nix-base32-string->bytevector str)))))
-;; The specification of a search path.
-(define-record-type* <search-path-specification>
- search-path-specification make-search-path-specification
- search-path-specification?
- (variable search-path-specification-variable) ;string
- (files search-path-specification-files) ;list of strings
- (separator search-path-specification-separator ;string
- (default ":"))
- (file-type search-path-specification-file-type ;symbol
- (default 'directory))
- (file-pattern search-path-specification-file-pattern ;#f | string
- (default #f)))
-
-(define (search-path-specification->sexp spec)
- "Return an sexp representing SPEC, a <search-path-specification>. The sexp
-corresponds to the arguments expected by `set-path-environment-variable'."
- (match spec
- (($ <search-path-specification> variable files separator type pattern)
- `(,variable ,files ,separator ,type ,pattern))))
-
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "mips64el-linux"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "mips64el-linux"))
+
+(define %hydra-supported-systems
+ ;; This is the list of system types for which build slaves are available.
+ (delete "armhf-linux" %supported-systems))
+
;; A package.
(define-record-type* <package>
(location package-location
(default (and=> (current-source-location)
- source-properties->location))))
+ source-properties->location))
+ (innate)))
(set-record-type-printer! <package>
(lambda (package port)
(string-append (package-name package) "-" (package-version package)))
(define (%standard-patch-inputs)
- (let ((ref (lambda (module var)
- (module-ref (resolve-interface module) var))))
+ (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
+ 'canonical-package))
+ (ref (lambda (module var)
+ (canonical
+ (module-ref (resolve-interface module) var)))))
`(("tar" ,(ref '(gnu packages base) 'tar))
("xz" ,(ref '(gnu packages compression) 'xz))
("bzip2" ,(ref '(gnu packages compression) 'bzip2))
("gzip" ,(ref '(gnu packages compression) 'gzip))
("lzip" ,(ref '(gnu packages compression) 'lzip))
- ("patch" ,(ref '(gnu packages base) 'patch)))))
+ ("unzip" ,(ref '(gnu packages zip) 'unzip))
+ ("patch" ,(ref '(gnu packages base) 'patch))
+ ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
(define (default-guile)
"Return the default Guile package used to run the build code of
(let ((distro (resolve-interface '(gnu packages commencement))))
(module-ref distro 'guile-final)))
-;; TODO: Rewrite using %STORE-MONAD and gexps.
-(define* (patch-and-repack store source patches
+(define* (default-guile-derivation #:optional (system (%current-system)))
+ "Return the derivation for SYSTEM of the default Guile package used to run
+the build code of derivation."
+ (package->derivation (default-guile) system
+ #:graft? #f))
+
+(define* (patch-and-repack source patches
#:key
- (inputs '())
+ inputs
(snippet #f)
(flags '("-p1"))
(modules '())
(derivation->output-path source)
source))
+ (define lookup-input
+ ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
+ ;; so deal with that.
+ (let ((inputs (or inputs (%standard-patch-inputs))))
+ (lambda (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")
((string-suffix? "lz" source-file-name) "lzip")
+ ((string-suffix? "zip" source-file-name) "unzip")
(else "xz")))
(define original-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))
-
- patches))
-
- (define builder
- `(begin
- (use-modules (ice-9 ftw)
- (srfi srfi-1)
- (guix build utils))
-
- (let ((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 '("." "..")))))))
-
- (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 (%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)
+ (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)
((input rest ...)
(loop rest (cons input result))))))
+(define (package-direct-sources package)
+ "Return all source origins associated with PACKAGE; including origins in
+PACKAGE's inputs."
+ `(,@(or (and=> (package-source package) list) '())
+ ,@(filter-map (match-lambda
+ ((_ (? origin? orig) _ ...)
+ orig)
+ (_ #f))
+ (package-direct-inputs package))))
+
+(define (package-transitive-sources package)
+ "Return PACKAGE's direct sources, and their direct sources, recursively."
+ (delete-duplicates
+ (concatenate (filter-map (match-lambda
+ ((_ (? origin? orig) _ ...)
+ (list orig))
+ ((_ (? package? p) _ ...)
+ (package-direct-sources p))
+ (_ #f))
+ (bag-transitive-inputs
+ (package->bag package))))))
+
(define (package-direct-inputs package)
"Return all the direct inputs of PACKAGE---i.e, its direct inputs along
with their propagated inputs."
(_
systems)))
(package-supported-systems package)
- (package-direct-inputs package)))
+ (bag-direct-inputs (package->bag package))))
+
+(define* (supported-package? package #:optional (system (%current-system)))
+ "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
+dependencies are known to build on SYSTEM."
+ (member system (package-transitive-supported-systems package)))
+
+(define (bag-direct-inputs bag)
+ "Same as 'package-direct-inputs', but applied to a bag."
+ (append (bag-build-inputs bag)
+ (bag-host-inputs bag)
+ (bag-target-inputs bag)))
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."
- (transitive-inputs (append (bag-build-inputs bag)
- (bag-host-inputs bag)
- (bag-target-inputs bag))))
+ (transitive-inputs (bag-direct-inputs bag)))
(define (bag-transitive-build-inputs bag)
"Same as 'package-transitive-native-inputs', but applied to a bag."
(package package)
(input x)))))))
-(define %graft?
- ;; Whether to honor package grafts by default.
- (make-parameter #t))
-
(define* (package->bag package #:optional
(system (%current-system))
(target (%current-target-system))
(define package->cross-derivation
(store-lift package-cross-derivation))
-(define patch-and-repack*
- (store-lift patch-and-repack))
+(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
#:optional (system (%current-system)))
(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)))
(interned-file file (basename file)
#:recursive? #t))))
+(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))
HCoop / jackhill / guix / guix.git / blobdiff