TakeV/guix
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

guix package: Specify inputs for each manifest entry.

Browse source 
* guix/scripts/package.scm (<manifest-entry>): Add 'inputs' field.
  (manifest=?, lower-input): New procedure.
  (profile-derivation)[builder]: Add #:log-port argument to
  'union-build'.
  [ensure-valid-input]: Remove.
  Add each entry's inputs to the input list.
  (options->installable): Return just the list of entries.
  [package->manifest-entry]: Set 'inputs' field.
  [canonicalize-deps]: Rename to...
  [deduplicate]: ... this.  Remove input fiddling.
  (guix-package)[process-actions]: Use 'manifest=?' to compare the new
  and old manifests.  Pass directly PROF-DRV to 'show-what-to-build'.
  Pass #:print-build-trace #f to 'set-build-options'.
This commit is contained in:
Ludovic Courtès 2013-10-30 22:01:43 +01:00
parent c065c443a0
commit 1fcc3ba309
1 changed files with 92 additions and 102 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

122
guix/scripts/package.scm
View file

@ -91,7 +91,9 @@ (define-record-type* <manifest-entry> manifest-entry
(default "out")) (default "out"))
(path manifest-entry-path) ; store path (path manifest-entry-path) ; store path
(dependencies manifest-entry-dependencies ; list of store paths (dependencies manifest-entry-dependencies ; list of store paths
(default '()))) (default '()))
(inputs manifest-entry-inputs ; list of inputs to build
(default '()))) ; this entry
(define (profile-manifest profile) (define (profile-manifest profile)
"Return the PROFILE's manifest." "Return the PROFILE's manifest."
@ -174,6 +176,13 @@ (define (->bool x)
(string=? entry-name name))) (string=? entry-name name)))
(manifest-entries manifest)))) (manifest-entries manifest))))
(define (manifest=? m1 m2)
"Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
that the 'inputs' field is ignored for the comparison, since it is know to
have no effect on the manifest contents."
(equal? (manifest->sexp m1)
(manifest->sexp m2)))
;;; ;;;
;;; Profiles. ;;; Profiles.
@ -258,31 +267,28 @@ (define builder
(let ((output (assoc-ref %outputs "out")) (let ((output (assoc-ref %outputs "out"))
(inputs (map cdr %build-inputs))) (inputs (map cdr %build-inputs)))
(format #t "building profile `~a' with ~a packages...~%" (format #t "building profile '~a' with ~a packages...~%"
output (length inputs)) output (length inputs))
(union-build output inputs) (union-build output inputs
#:log-port (%make-void-port "w"))
(call-with-output-file (string-append output "/manifest") (call-with-output-file (string-append output "/manifest")
(lambda (p) (lambda (p)
(pretty-print ',(manifest->sexp manifest) p)))))) (pretty-print ',(manifest->sexp manifest) p))))))
(define ensure-valid-input
;; If a package object appears in the given input, turn it into a
;; derivation path.
(match-lambda
((name (? package? p) sub-drv ...)
`(,name ,(package-derivation (%store) p) ,@sub-drv))
(input
input)))
(build-expression->derivation store "profile" (build-expression->derivation store "profile"
(%current-system) (%current-system)
builder builder
(append-map (match-lambda (append-map (match-lambda
(($ <manifest-entry> name version
output path deps (inputs ..1))
(map (cute lower-input
(%store) <>)
inputs))
(($ <manifest-entry> name version (($ <manifest-entry> name version
output path deps) output path deps)
`((,name ,path) ;; Assume PATH and DEPS are
,@(map ensure-valid-input ;; already valid.
deps)))) `((,name ,path) ,@deps)))
(manifest-entries manifest)) (manifest-entries manifest))
#:modules '((guix build union)))) #:modules '((guix build union))))
@ -429,6 +435,16 @@ (define matches?
(package-name p2)))) (package-name p2))))
same-location?)) same-location?))
(define* (lower-input store input #:optional (system (%current-system)))
"Lower INPUT so that it contains derivations instead of packages."
(match input
((name (? package? package))
`(,name ,(package-derivation store package system)))
((name (? package? package) output)
`(,name ,(package-derivation store package system)
,output))
(_ input)))
(define (input->name+path input) (define (input->name+path input)
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
(let loop ((input input)) (let loop ((input input))
@ -790,12 +806,10 @@ (define %options
(define (options->installable opts manifest) (define (options->installable opts manifest)
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
return two values: the new list of manifest entries, and the list of return the new list of manifest entries."
derivations that need to be built." (define (deduplicate deps)
(define (canonicalize-deps deps) ;; Remove duplicate entries from DEPS, a list of propagated inputs, where
;; Remove duplicate entries from DEPS, a list of propagated inputs, ;; each input is a name/path tuple.
;; where each input is a name/path tuple, and replace package objects with
;; store paths.
(define (same? d1 d2) (define (same? d1 d2)
(match d1 (match d1
((_ p1) ((_ p1)
@ -809,12 +823,7 @@ (define (same? d1 d2)
(eq? p1 p2))) (eq? p1 p2)))
(_ #f))))) (_ #f)))))
(map (match-lambda (delete-duplicates deps same?))
((name package)
(list name (package-output (%store) package)))
((name package output)
(list name (package-output (%store) package output))))
(delete-duplicates deps same?)))
(define (package->manifest-entry p output) (define (package->manifest-entry p output)
;; Return a manifest entry for the OUTPUT of package P. ;; Return a manifest entry for the OUTPUT of package P.
@ -823,13 +832,15 @@ (define (package->manifest-entry p output)
;; outputs (XXX). ;; outputs (XXX).
(let* ((output (or output (car (package-outputs p)))) (let* ((output (or output (car (package-outputs p))))
(path (package-output (%store) p output)) (path (package-output (%store) p output))
(deps (package-transitive-propagated-inputs p))) (deps (deduplicate (package-transitive-propagated-inputs p))))
(manifest-entry (manifest-entry
(name (package-name p)) (name (package-name p))
(version (package-version p)) (version (package-version p))
(output output) (output output)
(path path) (path path)
(dependencies (canonicalize-deps deps))))) (dependencies (map input->name+path deps))
(inputs (cons (list (package-name p) p output)
deps)))))
(define upgrade-regexps (define upgrade-regexps
(filter-map (match-lambda (filter-map (match-lambda
@ -895,15 +906,7 @@ (define to-install
(_ #f)) (_ #f))
opts))) opts)))
(define derivations (append to-upgrade to-install))
(map (match-lambda
((package output)
;; FIXME: We should really depend on just OUTPUT rather than on all
;; the outputs of PACKAGE.
(package-derivation (%store) package)))
(append packages-to-install packages-to-upgrade)))
(values (append to-upgrade to-install) derivations))
;;; ;;;
@ -1089,11 +1092,9 @@ (define (delete-generation number)
(_ #f)) (_ #f))
opts)) opts))
(else (else
(let*-values (((manifest) (let* ((manifest (profile-manifest profile))
(profile-manifest profile)) (install* (options->installable opts manifest))
((install* drv) (remove (filter-map (match-lambda
(options->installable opts manifest)))
(let* ((remove (filter-map (match-lambda
(('remove . package) (('remove . package)
package) package)
(_ #f)) (_ #f))
@ -1111,25 +1112,23 @@ (define (delete-generation number)
result)))) result))))
(manifest-entries (manifest-entries
(manifest-remove manifest remove)) (manifest-remove manifest remove))
install*)))) install*)))
(new (make-manifest entries)))
(when (equal? profile %current-profile) (when (equal? profile %current-profile)
(ensure-default-profile)) (ensure-default-profile))
(if (manifest=? new manifest)
(format (current-error-port) (_ "nothing to be done~%"))
(let ((prof-drv (profile-derivation (%store) new)))
(show-what-to-remove/install remove* install* dry-run?) (show-what-to-remove/install remove* install* dry-run?)
(show-what-to-build (%store) drv (show-what-to-build (%store) (list prof-drv)
#:use-substitutes? (assoc-ref opts 'substitutes?) #:use-substitutes?
(assoc-ref opts 'substitutes?)
#:dry-run? dry-run?) #:dry-run? dry-run?)
(or dry-run? (or dry-run?
(and (build-derivations (%store) drv) (let* ((prof (derivation->output-path prof-drv))
(let* ((prof-drv (profile-derivation (%store)
(make-manifest
entries)))
(prof (derivation->output-path prof-drv))
(old-drv (profile-derivation
(%store) (profile-manifest profile)))
(old-prof (derivation->output-path old-drv))
(number (generation-number profile)) (number (generation-number profile))
;; Always use NUMBER + 1 for the new profile, ;; Always use NUMBER + 1 for the new profile,
@ -1137,17 +1136,7 @@ (define (delete-generation number)
;; generation". ;; generation".
(name (format #f "~a-~a-link" (name (format #f "~a-~a-link"
profile (+ 1 number)))) profile (+ 1 number))))
(if (string=? old-prof prof) (and (build-derivations (%store) (list prof-drv))
(when (or (pair? install*) (pair? remove))
(format (current-error-port)
(_ "nothing to be done~%")))
(and (parameterize ((current-build-output-port
;; Output something when Guile
;; needs to be built.
(if (or verbose? (guile-missing?))
(current-error-port)
(%make-void-port "w"))))
(build-derivations (%store) (list prof-drv)))
(let ((count (length entries))) (let ((count (length entries)))
(switch-symlinks name prof) (switch-symlinks name prof)
(switch-symlinks profile name) (switch-symlinks profile name)
@ -1156,7 +1145,7 @@ (define (delete-generation number)
count) count)
count) count)
(display-search-paths entries (display-search-paths entries
profile)))))))))))) profile)))))))))))
(define (process-query opts) (define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was ;; Process any query specified by OPTS. Return #t when a query was
@ -1266,6 +1255,7 @@ (define (list-generation number)
(with-error-handling (with-error-handling
(parameterize ((%store (open-connection))) (parameterize ((%store (open-connection)))
(set-build-options (%store) (set-build-options (%store)
#:print-build-trace #f
#:fallback? (assoc-ref opts 'fallback?) #:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? #:use-substitutes?
(assoc-ref opts 'substitutes?) (assoc-ref opts 'substitutes?)