From cc90fbbf39e310a166e356f7019036eb30d4808a Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 25 Oct 2015 22:33:33 -0400 Subject: scripts: environment: Allow mixing regular and ad-hoc packages. This patch changes the --ad-hoc flag to be positional. That is, the packages that appear before --ad-hoc are interpreted as packages whose inputs should be in the environment; the packages that appear after are interpreted as packages to be directly added to the environment. * guix/scripts/environment.scm (tag-package-arg, compact): New procedures. (%options): Tweak the handlers for --load and --expression options. (options/resolve-packages): Preserve package mode tag. (parse-args): Tweak argument handler to use package tagging procedure. (guix-environment): Apply ad-hoc behavior on a per package basis. * tests/guix-environment.sh: Add test. * doc/guix.texi ("invoking guix environment"): Document new behavior of --ad-hoc. --- guix/scripts/environment.scm | 85 ++++++++++++++++++++++++++------------------ 1 file changed, 51 insertions(+), 34 deletions(-) (limited to 'guix/scripts/environment.scm') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d21a768dc..188838574f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -166,6 +166,16 @@ (define %default-options (max-silent-time . 3600) (verbosity . 0))) +(define (tag-package-arg opts arg) + "Return a two-element list with the form (TAG ARG) that tags ARG with either +'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." + ;; Normally, the transitive inputs to a package are added to an environment, + ;; but the ad-hoc? flag changes the meaning of a package argument such that + ;; the package itself is added to the environment instead. + (if (assoc-ref opts 'ad-hoc?) + `(ad-hoc-package ,arg) + `(package ,arg))) + (define %options ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f @@ -186,10 +196,14 @@ (define %options (alist-cons 'search-paths #t result))) (option '(#\l "load") #t #f (lambda (opt name arg result) - (alist-cons 'load arg result))) + (alist-cons 'load + (tag-package-arg result arg) + result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) - (alist-cons 'expression arg result))) + (alist-cons 'expression + (tag-package-arg result arg) + result))) (option '("ad-hoc") #f #f (lambda (opt name arg result) (alist-cons 'ad-hoc? #t result))) @@ -232,29 +246,34 @@ (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." - (append-map (match-lambda - (('package . (? string? spec)) - (let-values (((package output) - (specification->package+output spec))) - `((package ,package ,output)))) - (('expression . str) - ;; Add all the outputs of the package STR evaluates to. - (match (read/eval str) - ((? package? package) + (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. + (match (read/eval str) + ((? package? package) + (map (lambda (output) + (list mode package output)) + (package-outputs package))))) + (('load mode file) + ;; Add all the outputs of the package defined in FILE. + (let ((package (load* file (make-user-module '())))) (map (lambda (output) - `(package ,package ,output)) - (package-outputs package))))) - (('load . file) - ;; Add all the outputs of the package defined in FILE. - (let ((package (load* file (make-user-module '())))) - (map (lambda (output) - `(package ,package ,output)) - (package-outputs package)))) - (opt (list opt))) - opts)) + (list mode package output)) + (package-outputs package)))) + (_ '(#f))) + opts))) (define (build-inputs inputs opts) "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION @@ -402,7 +421,7 @@ (define (environment-bash container? bootstrap? system) (define (parse-args args) "Parse the list of command line arguments ARGS." (define (handle-argument arg result) - (alist-cons 'package arg result)) + (alist-cons 'package (tag-package-arg result arg) result)) ;; The '--' token is used to separate the command to run from the rest of ;; the operands. @@ -420,22 +439,20 @@ (define (guix-environment . args) (pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (network? (assoc-ref opts 'network?)) - (ad-hoc? (assoc-ref opts 'ad-hoc?)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) (command (assoc-ref opts 'exec)) - (packages (pick-all (options/resolve-packages opts) 'package)) + (packages (options/resolve-packages opts)) (mappings (pick-all opts 'file-system-mapping)) - (inputs (if ad-hoc? - (append-map (match-lambda - ((package output) - (package+propagated-inputs package - output))) - packages) - (append-map (compose bag-transitive-inputs - package->bag - first) - packages))) + (inputs (delete-duplicates + (append-map (match-lambda + (('ad-hoc-package package output) + (package+propagated-inputs package + output)) + (('package package output) + (bag-transitive-inputs + (package->bag package)))) + packages))) (paths (delete-duplicates (cons $PATH (append-map (match-lambda -- cgit v1.2.3