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