Skip to content
Snippets Groups Projects
Unverified Commit 10f0a40c authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

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'.
parent f03df3ee
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
guix/scripts/environment.scm
+ 62
− 96
View file @ 10f0a40c
;;; 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 @@ (define (show-search-paths profile search-paths pure?)
(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 @@ (define same-key? (cut eq? key <>))
(_ 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))))
(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)))
((? 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))))
(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 @@ (define* (build-environment derivations 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 @@ (define (guix-environment . args)
;; 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 @@ (define (guix-environment . args)
(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)))
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment