diff options
Diffstat (limited to 'guix/scripts/build.scm')
| -rw-r--r-- | guix/scripts/build.scm | 138 |
1 files changed, 116 insertions, 22 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 25418661b9..72a5d46347 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -38,6 +38,7 @@ #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix profiles) + #:use-module (guix diagnostics) #:autoload (guix http-client) (http-fetch http-get-error?) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -46,6 +47,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) #:autoload (guix download) (download-to-store) @@ -61,6 +63,7 @@ %transformation-options options->transformation + manifest-entry-with-transformations show-transformation-options-help guix-build @@ -393,6 +396,25 @@ a checkout of the Git repository at the given URL." (rewrite obj) obj))) +(define (transform-package-tests specs) + "Return a procedure that, when passed a package, sets #:tests? #f in its +'arguments' field." + (define (package-without-tests p) + (package/inherit p + (arguments + (substitute-keyword-arguments (package-arguments p) + ((#:tests? _ #f) #f))))) + + (define rewrite + (package-input-rewriting/spec (map (lambda (spec) + (cons spec package-without-tests)) + specs))) + + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -403,7 +425,16 @@ a checkout of the Git repository at the given URL." (with-graft . ,transform-package-inputs/graft) (with-branch . ,transform-package-source-branch) (with-commit . ,transform-package-source-commit) - (with-git-url . ,transform-package-source-git-url))) + (with-git-url . ,transform-package-source-git-url) + (without-tests . ,transform-package-tests))) + +(define (transformation-procedure key) + "Return the transformation procedure associated with KEY, a symbol such as +'with-source', or #f if there is none." + (any (match-lambda + ((k . proc) + (and (eq? k key) proc))) + %transformations)) (define %transformation-options ;; The command-line interface to the above transformations. @@ -423,11 +454,13 @@ a checkout of the Git repository at the given URL." (option '("with-commit") #t #f (parser 'with-commit)) (option '("with-git-url") #t #f - (parser 'with-git-url))))) + (parser 'with-git-url)) + (option '("without-tests") #t #f + (parser 'without-tests))))) (define (show-transformation-options-help) (display (G_ " - --with-source=SOURCE + --with-source=[PACKAGE=]SOURCE use SOURCE when building the corresponding package")) (display (G_ " --with-input=PACKAGE=REPLACEMENT @@ -443,7 +476,10 @@ a checkout of the Git repository at the given URL." build PACKAGE from COMMIT")) (display (G_ " --with-git-url=PACKAGE=URL - build PACKAGE from the repository at URL"))) + build PACKAGE from the repository at URL")) + (display (G_ " + --without-tests=PACKAGE + build PACKAGE without running its tests"))) (define (options->transformation opts) @@ -454,32 +490,69 @@ derivation, etc.), applies the transformations specified by OPTS." ;; order in which they appear on the command line. (filter-map (match-lambda ((key . value) - (match (any (match-lambda - ((k . proc) - (and (eq? k key) proc))) - %transformations) + (match (transformation-procedure key) (#f #f) (transform ;; XXX: We used to pass TRANSFORM a list of several ;; arguments, but we now pass only one, assuming that ;; transform composes well. - (cons key (transform (list value))))))) + (list key value (transform (list value))))))) (reverse opts))) + (define (package-with-transformation-properties p) + (package/inherit p + (properties `((transformations + . ,(map (match-lambda + ((key value _) + (cons key value))) + applicable)) + ,@(package-properties p))))) + (lambda (store obj) - (fold (match-lambda* - (((name . transform) obj) - (let ((new (transform store obj))) - (when (eq? new obj) - (warning (G_ "transformation '~a' had no effect on ~a~%") - name - (if (package? obj) - (package-full-name obj) - obj))) - new))) - obj - applicable))) + (define (tagged-object new) + (if (and (not (eq? obj new)) + (package? new) (not (null? applicable))) + (package-with-transformation-properties new) + new)) + + (tagged-object + (fold (match-lambda* + (((name value transform) obj) + (let ((new (transform store obj))) + (when (eq? new obj) + (warning (G_ "transformation '~a' had no effect on ~a~%") + name + (if (package? obj) + (package-full-name obj) + obj))) + new))) + obj + applicable)))) + +(define (package-transformations package) + "Return the transformations applied to PACKAGE according to its properties." + (match (assq-ref (package-properties package) 'transformations) + (#f '()) + (transformations transformations))) + +(define (manifest-entry-with-transformations entry) + "Return ENTRY with an additional 'transformations' property if it's not +already there." + (let ((properties (manifest-entry-properties entry))) + (if (assq 'transformations properties) + entry + (let ((item (manifest-entry-item entry))) + (manifest-entry + (inherit entry) + (properties + (match (and (package? item) + (package-transformations item)) + ((or #f '()) + properties) + (transformations + `((transformations . ,transformations) + ,@properties))))))))) ;;; @@ -805,7 +878,28 @@ must be one of 'package', 'all', or 'transitive'~%") build---packages, gexps, derivations, and so on." (define (validate-type x) (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x)) - (leave (G_ "~s: not something we can build~%") x))) + (raise (make-compound-condition + (formatted-message (G_ "~s: not something we can build~%") x) + (condition + (&fix-hint + (hint + (if (unspecified? x) + (G_ "If you build from a file, make sure the last Scheme +expression returns a package value. @code{define-public} defines a variable, +but returns @code{#<unspecified>}. To fix this, add a Scheme expression at +the end of the file that consists only of the package's variable name you +defined, as in this example: + +@example +(define-public my-package + (package + ...)) + +my-package +@end example") + (G_ "If you build from a file, make sure the last +Scheme expression returns a package, gexp, derivation or a list of such +values."))))))))) (define (ensure-list x) (let ((lst (match x |