nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

environment: Simplify code by using manifests internally. 

* guix/scripts/environment.scm (strip-input-name)
(package+propagated-inputs, package-or-package+output?)
(compact): Remove.
(inputs->profile-derivation): Rename to...
(manifest->derivation): ... this.  Replace 'inputs' parameter with
'manifest'.
(input->manifest-entry): New procedure.
(package-environment-inputs): Rewrite to return a list of manifest
entries.
(options/resolve-packages): Rewrite to return a manifest.
(guix-environment): Remove 'inputs'.  Define 'paths' in terms of
'manifest-search-paths'.
This commit is contained in:
Ludovic Courtès 2018-07-09 13:00:46 +02:00
parent f03df3ee75
commit 10f0a40c16
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 61 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
guix/scripts/environment.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -102,35 +102,23 @@ existing environment variables with additional search paths."
(newline))) (newline)))
(evaluate-profile-search-paths profile search-paths))) (evaluate-profile-search-paths profile search-paths)))
(define (strip-input-name input) (define (input->manifest-entry input)
"Remove the name element from the tuple INPUT." "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a
package."
(match input (match input
((_ package) package) ((_ (? package? package))
((_ package output) (package->manifest-entry package))
(list package output)))) ((_ (? package? package) output)
(package->manifest-entry package output))
(define (package+propagated-inputs package output) (_
"Return the union of PACKAGE's OUTPUT and its transitive propagated inputs." #f)))
(cons (list package output)
(map strip-input-name
(package-transitive-propagated-inputs package))))
(define (package-or-package+output? expr)
"Return #t if EXPR is a package or a 2 element list consisting of a package
and an output string."
(match expr
((or (? package?) ; bare package object
((? package?) (? string?))) ; package+output tuple
#t)
(_ #f)))
(define (package-environment-inputs package) (define (package-environment-inputs package)
"Return a list of the transitive input packages for PACKAGE." "Return a list of manifest entries corresponding to the transitive input
packages for PACKAGE."
;; Remove non-package inputs such as origin records. ;; Remove non-package inputs such as origin records.
(filter package-or-package+output? (filter-map input->manifest-entry
(map strip-input-name (bag-transitive-inputs (package->bag package))))
(bag-transitive-inputs
(package->bag package)))))
(define (show-help) (define (show-help)
(display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...]
@ -287,55 +275,50 @@ COMMAND or an interactive shell in that environment.\n"))
(_ memo))) (_ memo)))
'() alist)) '() alist))
(define (compact lst)
"Remove all #f elements from LST."
(filter identity lst))
(define (options/resolve-packages opts) (define (options/resolve-packages opts)
"Return OPTS with package specification strings replaced by actual "Return OPTS with package specification strings replaced by manifest entries
packages." for the corresponding packages."
(define (package->output package mode) (define (manifest-entry=? e1 e2)
(match package (and (eq? (manifest-entry-item e1) (manifest-entry-item e2))
((? package?) (string=? (manifest-entry-output e1)
(list mode package "out")) (manifest-entry-output e2))))
(((? package? package) (? string? output))
(list mode package output))))
(define (packages->outputs packages mode) (define (packages->outputs packages mode)
(match packages (match packages
((? package-or-package+output? package) ; single package ((? package? package)
(list (package->output package mode))) (if (eq? mode 'ad-hoc-package)
(((? package-or-package+output?) ...) ; many packages (list (package->manifest-entry package))
(map (cut package->output <> mode) packages)))) (package-environment-inputs package)))
(((? package? package) (? string? output))
(if (eq? mode 'ad-hoc-package)
(list (package->manifest-entry package output))
(package-environment-inputs package)))
((lst ...)
(append-map (cut packages->outputs <> mode) lst))))
(define (manifest->outputs manifest) (manifest
(map (lambda (entry) (delete-duplicates
(cons 'ad-hoc-package ; manifests are implicitly ad-hoc (append-map (match-lambda
(if (package? (manifest-entry-item entry)) (('package 'ad-hoc-package (? string? spec))
(list (manifest-entry-item entry) (let-values (((package output)
(manifest-entry-output entry)) (specification->package+output spec)))
;; Direct store paths have no output. (list (package->manifest-entry package output))))
(list (manifest-entry-item entry))))) (('package 'package (? string? spec))
(manifest-entries manifest))) (package-environment-inputs
(specification->package+output spec)))
(compact (('expression mode str)
(append-map (match-lambda ;; Add all the outputs of the package STR evaluates to.
(('package mode (? string? spec)) (packages->outputs (read/eval str) mode))
(let-values (((package output) (('load mode file)
(specification->package+output spec))) ;; Add all the outputs of the package defined in FILE.
(list (list mode package output)))) (let ((module (make-user-module '())))
(('expression mode str) (packages->outputs (load* file module) mode)))
;; Add all the outputs of the package STR evaluates to. (('manifest . file)
(packages->outputs (read/eval str) mode)) (let ((module (make-user-module '((guix profiles) (gnu)))))
(('load mode file) (manifest-entries (load* file module))))
;; Add all the outputs of the package defined in FILE. (_ '()))
(let ((module (make-user-module '()))) opts)
(packages->outputs (load* file module) mode))) manifest-entry=?)))
(('manifest . file)
(let ((module (make-user-module '((guix profiles) (gnu)))))
(manifest->outputs (load* file module))))
(_ '(#f)))
opts)))
(define* (build-environment derivations opts) (define* (build-environment derivations opts)
"Build the DERIVATIONS required by the environment using the build options "Build the DERIVATIONS required by the environment using the build options
@ -350,11 +333,10 @@ in OPTS."
(return #f) (return #f)
(built-derivations derivations))))) (built-derivations derivations)))))
(define (inputs->profile-derivation inputs system bootstrap?) (define (manifest->derivation manifest system bootstrap?)
"Return the derivation for a profile consisting of INPUTS for SYSTEM. "Return the derivation for a profile of MANIFEST.
BOOTSTRAP? specifies whether to use the bootstrap Guile to build the BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
profile." (profile-derivation manifest
(profile-derivation (packages->manifest inputs)
#:system system #:system system
;; Packages can have conflicting inputs, or explicit ;; Packages can have conflicting inputs, or explicit
@ -671,25 +653,9 @@ message if any test fails."
;; within the container. ;; within the container.
'("/bin/sh") '("/bin/sh")
(list %default-shell)))) (list %default-shell))))
(packages (options/resolve-packages opts)) (manifest (options/resolve-packages opts))
(mappings (pick-all opts 'file-system-mapping)) (mappings (pick-all opts 'file-system-mapping))
(inputs (delete-duplicates (paths (manifest-search-paths manifest)))
(append-map (match-lambda
(('ad-hoc-package package output)
(package+propagated-inputs package
output))
(('package package _)
(package-environment-inputs package)))
packages)))
(paths (delete-duplicates
(cons $PATH
(append-map (match-lambda
((or ((? package? p) _ ...)
(? package? p))
(package-native-search-paths p))
(_ '()))
inputs))
eq?)))
(when container? (assert-container-features)) (when container? (assert-container-features))
@ -714,8 +680,8 @@ message if any test fails."
(mlet* %store-monad ((bash (environment-bash container? (mlet* %store-monad ((bash (environment-bash container?
bootstrap? bootstrap?
system)) system))
(prof-drv (inputs->profile-derivation (prof-drv (manifest->derivation
inputs system bootstrap?)) manifest system bootstrap?))
(profile -> (derivation->output-path prof-drv)) (profile -> (derivation->output-path prof-drv))
(gc-root -> (assoc-ref opts 'gc-root))) (gc-root -> (assoc-ref opts 'gc-root)))