diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/gexp.scm | 106 | ||||
| -rw-r--r-- | guix/scripts.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 30 | ||||
| -rw-r--r-- | guix/utils.scm | 19 |
6 files changed, 197 insertions, 23 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index de49fef088..27bccc6206 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -43,10 +43,30 @@ plain-file-name plain-file-content + computed-file + computed-file? + computed-file-name + computed-file-gexp + computed-file-modules + computed-file-options + + program-file + program-file? + program-file-name + program-file-gexp + program-file-modules + program-file-guile + + scheme-file + scheme-file? + scheme-file-name + scheme-file-gexp + gexp->derivation gexp->file gexp->script text-file* + mixed-text-file imported-files imported-modules compiled-modules @@ -214,6 +234,77 @@ This is the declarative counterpart of 'text-file'." (($ <plain-file> name content references) (text-file name content references)))) +(define-record-type <computed-file> + (%computed-file name gexp modules options) + computed-file? + (name computed-file-name) ;string + (gexp computed-file-gexp) ;gexp + (modules computed-file-modules) ;list of module names + (options computed-file-options)) ;list of arguments + +(define* (computed-file name gexp + #:key (modules '()) (options '(#:local-build? #t))) + "Return an object representing the store item NAME, a file or directory +computed by GEXP. MODULES specifies the set of modules visible in the +execution context of GEXP. OPTIONS is a list of additional arguments to pass +to 'gexp->derivation'. + +This is the declarative counterpart of 'gexp->derivation'." + (%computed-file name gexp modules options)) + +(define-gexp-compiler (computed-file-compiler (file computed-file?) + system target) + ;; Compile FILE by returning a derivation whose build expression is its + ;; gexp. + (match file + (($ <computed-file> name gexp modules options) + (apply gexp->derivation name gexp #:modules modules options)))) + +(define-record-type <program-file> + (%program-file name gexp modules guile) + program-file? + (name program-file-name) ;string + (gexp program-file-gexp) ;gexp + (modules program-file-modules) ;list of module names + (guile program-file-guile)) ;package + +(define* (program-file name gexp + #:key (modules '()) (guile #f)) + "Return an object representing the executable store item NAME that runs +GEXP. GUILE is the Guile package used to execute that script, and MODULES is +the list of modules visible to that script. + +This is the declarative counterpart of 'gexp->script'." + (%program-file name gexp modules guile)) + +(define-gexp-compiler (program-file-compiler (file program-file?) + system target) + ;; Compile FILE by returning a derivation that builds the script. + (match file + (($ <program-file> name gexp modules guile) + (gexp->script name gexp + #:modules modules + #:guile (or guile (default-guile)))))) + +(define-record-type <scheme-file> + (%scheme-file name gexp) + scheme-file? + (name scheme-file-name) ;string + (gexp scheme-file-gexp)) ;gexp + +(define* (scheme-file name gexp) + "Return an object representing the Scheme file NAME that contains GEXP. + +This is the declarative counterpart of 'gexp->file'." + (%scheme-file name gexp)) + +(define-gexp-compiler (scheme-file-compiler (file scheme-file?) + system target) + ;; Compile FILE by returning a derivation that builds the file. + (match file + (($ <scheme-file> name gexp) + (gexp->file name gexp)))) + ;;; ;;; Inputs & outputs. @@ -903,6 +994,21 @@ resulting store file holds references to all these." (gexp->derivation name builder)) +(define* (mixed-text-file name #:rest text) + "Return an object representing store file NAME containing TEXT. TEXT is a +sequence of strings and file-like objects, as in: + + (mixed-text-file \"profile\" + \"export PATH=\" coreutils \"/bin:\" grep \"/bin\") + +This is the declarative counterpart of 'text-file*'." + (define build + (gexp (call-with-output-file (ungexp output "out") + (lambda (port) + (display (string-append (ungexp-splicing text)) port))))) + + (computed-file name build)) + ;;; ;;; Syntactic sugar. diff --git a/guix/scripts.scm b/guix/scripts.scm index e34d38904c..d84375f570 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -31,7 +31,8 @@ #:export (args-fold* parse-command-line maybe-build - build-package)) + build-package + build-package-source)) ;;; Commentary: ;;; @@ -115,4 +116,21 @@ Show what and how will/would be built." #:dry-run? dry-run?) (return (show-derivation-outputs derivation)))))) +(define* (build-package-source package + #:key dry-run? (use-substitutes? #t) + #:allow-other-keys + #:rest build-options) + "Build PACKAGE source using BUILD-OPTIONS." + (mbegin %store-monad + (apply set-build-options* + #:use-substitutes? use-substitutes? + (strip-keyword-arguments '(#:dry-run?) build-options)) + (mlet %store-monad ((derivation (origin->derivation + (package-source package)))) + (mbegin %store-monad + (maybe-build (list derivation) + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + (return (show-derivation-outputs derivation)))))) + ;;; scripts.scm ends here diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 7aa52e8a8a..2408420e18 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -57,6 +57,9 @@ OUTPUT) tuples." (define %precious-variables '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER")) +(define %default-shell + (or (getenv "SHELL") "/bin/sh")) + (define (purify-environment) "Unset almost all environment variables. A small number of variables such as 'HOME' and 'USER' are left untouched." @@ -103,9 +106,9 @@ existing environment variables with additional search paths." ,@(package-transitive-propagated-inputs package))) (define (show-help) - (display (_ "Usage: guix environment [OPTION]... PACKAGE... -Build an environment that includes the dependencies of PACKAGE and execute a -shell command in that environment.\n")) + (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] +Build an environment that includes the dependencies of PACKAGE and execute +COMMAND or an interactive shell in that environment.\n")) (display (_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) @@ -113,8 +116,6 @@ shell command in that environment.\n")) -l, --load=FILE create environment for the package that the code within FILE evaluates to")) (display (_ " - -E, --exec=COMMAND execute COMMAND in new environment")) - (display (_ " --ad-hoc include all specified packages in the environment instead of only their inputs")) (display (_ " @@ -135,7 +136,7 @@ shell command in that environment.\n")) (define %default-options ;; Default to opening a new shell. - `((exec . ,(or (getenv "SHELL") "/bin/sh")) + `((exec . (,%default-shell)) (system . ,(%current-system)) (substitutes? . #t) (max-silent-time . 3600) @@ -153,9 +154,9 @@ shell command in that environment.\n")) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) - (option '(#\E "exec") #t #f + (option '(#\E "exec") #t #f ; deprecated (lambda (opt name arg result) - (alist-cons 'exec arg result))) + (alist-cons 'exec (list %default-shell "-c" arg) result))) (option '("search-paths") #f #f (lambda (opt name arg result) (alist-cons 'search-paths #t result))) @@ -230,14 +231,24 @@ OUTPUT) tuples, using the build options in OPTS." (built-derivations derivations) (return derivations)))))))) -;; Entry point. -(define (guix-environment . args) +(define (parse-args args) + "Parse the list of command line arguments ARGS." (define (handle-argument arg result) (alist-cons 'package arg result)) + ;; The '--' token is used to separate the command to run from the rest of + ;; the operands. + (let-values (((args command) (split args "--"))) + (let ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument))) + (if (null? command) + opts + (alist-cons 'exec command opts))))) + +;; Entry point. +(define (guix-environment . args) (with-error-handling - (let* ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument)) + (let* ((opts (parse-args args)) (pure? (assoc-ref opts 'pure)) (ad-hoc? (assoc-ref opts 'ad-hoc?)) (command (assoc-ref opts 'exec)) @@ -282,4 +293,7 @@ OUTPUT) tuples, using the build options in OPTS." (return #t)) (else (create-environment inputs paths pure?) - (return (exit (status:exit-val (system command))))))))))))) + (return + (exit + (status:exit-val + (apply system* command))))))))))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 3b4ff722e9..b1707ade44 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -62,6 +62,7 @@ check-source-file-name check-license check-formatting + run-checkers %checkers lint-checker @@ -709,8 +710,8 @@ or a list thereof") (description "Look for formatting issues in the source") (check check-formatting)))) -(define (run-checkers package checkers) - ;; Run the given CHECKERS on PACKAGE. +(define* (run-checkers package #:optional (checkers %checkers)) + "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port))) (name (package-full-name package))) (for-each (lambda (checker) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5e2d226dfe..71b92dacc7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -300,7 +300,7 @@ it atomically, and then run OS's activation script." (system-disk-image os #:disk-image-size image-size)))) (define* (perform-action action os - #:key grub? dry-run? + #:key grub? dry-run? derivations-only? use-substitutes? device target image-size full-boot? (mappings '())) @@ -308,7 +308,13 @@ it atomically, and then run OS's activation script." the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE is the size of the image to be built, for the 'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action; it determines whether to -boot directly to the kernel or to the bootloader." +boot directly to the kernel or to the bootloader. + +When DERIVATIONS-ONLY? is true, print the derivation file name(s) without +building anything." + (define println + (cut format #t "~a~%" <>)) + (mlet* %store-monad ((sys (system-derivation-for-action os action #:image-size image-size @@ -322,14 +328,17 @@ boot directly to the kernel or to the bootloader." (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) - (% (maybe-build drvs #:dry-run? dry-run? - #:use-substitutes? use-substitutes?))) + (% (if derivations-only? + (return (for-each (compose println derivation-file-name) + drvs)) + (maybe-build drvs #:dry-run? dry-run? + #:use-substitutes? use-substitutes?)))) - (if dry-run? + (if (or dry-run? derivations-only?) (return #f) (begin - (for-each (cut format #t "~a~%" <>) - (map derivation->output-path drvs)) + (for-each (compose println derivation->output-path) + drvs) ;; Make sure GRUB is accessible. (when grub? @@ -383,6 +392,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (show-build-options-help) (display (_ " + -d, --derivation return the derivation of the given system")) + (display (_ " --on-error=STRATEGY apply STRATEGY when an error occurs while reading FILE")) (display (_ " @@ -425,6 +436,9 @@ Build the operating system declared in FILE according to ACTION.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) + (option '(#\d "derivation") #f #f + (lambda (opt name arg result) + (alist-cons 'derivations-only? #t result))) (option '("on-error") #t #f (lambda (opt name arg result) (alist-cons 'on-error (string->symbol arg) @@ -549,6 +563,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (set-guile-for-build (default-guile)) (perform-action action os #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) diff --git a/guix/utils.scm b/guix/utils.scm index 1d4b2ff9b0..0802a1b67a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> +;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -79,6 +80,7 @@ fold2 fold-tree fold-tree-leaves + split filtered-port compressed-port @@ -684,6 +686,23 @@ are connected to NODE in the tree, or '() or #f if NODE is a leaf node." (else result))) init children roots)) +(define (split lst e) + "Return two values, a list containing the elements of the list LST that +appear before the first occurence of the object E and a list containing the +elements after E." + (define (same? x) + (equal? e x)) + + (let loop ((rest lst) + (acc '())) + (match rest + (() + (values lst '())) + (((? same?) . tail) + (values (reverse acc) tail)) + ((head . tail) + (loop tail (cons head acc)))))) + ;;; ;;; Source location. |