diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/emacs-utils.scm | 92 | ||||
| -rw-r--r-- | guix/build/linux-initrd.scm | 8 | ||||
| -rw-r--r-- | guix/download.scm | 2 | ||||
| -rw-r--r-- | guix/gexp.scm | 184 | ||||
| -rw-r--r-- | guix/monad-repl.scm | 81 | ||||
| -rw-r--r-- | guix/monads.scm | 20 | ||||
| -rw-r--r-- | guix/profiles.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 77 | ||||
| -rw-r--r-- | guix/ui.scm | 25 |
9 files changed, 395 insertions, 134 deletions
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm new file mode 100644 index 0000000000..10ef3c8d0f --- /dev/null +++ b/guix/build/emacs-utils.scm @@ -0,0 +1,92 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build emacs-utils) + #:export (%emacs + emacs-batch-eval + emacs-batch-edit-file + emacs-substitute-sexps + emacs-substitute-variables)) + +;;; Commentary: +;;; +;;; Tools to programmatically edit files using Emacs, +;;; e.g. to replace entire s-expressions in elisp files. +;;; +;;; Code: + +(define %emacs + ;; The `emacs' command. + (make-parameter "emacs")) + +(define (emacs-batch-eval expr) + "Run Emacs in batch mode, and execute the elisp code EXPR." + (unless (zero? (system* (%emacs) "--quick" "--batch" + (format #f "--eval=~S" expr))) + (error "emacs-batch-eval failed!" expr))) + +(define (emacs-batch-edit-file file expr) + "Load FILE in Emacs using batch mode, and execute the elisp code EXPR." + (unless (zero? (system* (%emacs) "--quick" "--batch" + (string-append "--visit=" file) + (format #f "--eval=~S" expr))) + (error "emacs-batch-edit-file failed!" file expr))) + +(define-syntax emacs-substitute-sexps + (syntax-rules () + "Substitute the S-expression immediately following the first occurrence of +LEADING-REGEXP by the string returned by REPLACEMENT in FILE. For example: + + (emacs-substitute-sexps \"w3m.el\" + (\"defcustom w3m-command\" + (string-append w3m \"/bin/w3m\")) + (\"defvar w3m-image-viewer\" + (string-append imagemagick \"/bin/display\"))) + +This replaces the default values of the `w3m-command' and `w3m-image-viewer' +variables declared in `w3m.el' with the results of the `string-append' calls +above. Note that LEADING-REGEXP uses Emacs regexp syntax." + ((emacs-substitute-sexps file (leading-regexp replacement) ...) + (emacs-batch-edit-file file + `(progn (progn (goto-char (point-min)) + (re-search-forward ,leading-regexp) + (kill-sexp) + (insert " ") + (insert ,(format #f "~S" replacement))) + ... + (basic-save-buffer)))))) + +(define-syntax emacs-substitute-variables + (syntax-rules () + "Substitute the default value of VARIABLE by the string returned by +REPLACEMENT in FILE. For example: + + (emacs-substitute-variables \"w3m.el\" + (\"w3m-command\" (string-append w3m \"/bin/w3m\")) + (\"w3m-image-viewer\" (string-append imagemagick \"/bin/display\"))) + +This replaces the default values of the `w3m-command' and `w3m-image-viewer' +variables declared in `w3m.el' with the results of the `string-append' calls +above." + ((emacs-substitute-variables file (variable replacement) ...) + (emacs-substitute-sexps file + ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\>") + replacement) + ...)))) + +;;; emacs-utils.scm ends here diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 662f7967e3..bce289987b 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -384,11 +384,9 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." (set-network-interface-address sock interface address) (set-network-interface-flags sock interface (logior flags IFF_UP)) - (unless (file-exists? "/etc") - (mkdir "/etc")) - (call-with-output-file "/etc/resolv.conf" - (lambda (p) - (display "nameserver 10.0.2.3\n" p))) + ;; Hello! We used to create /etc/resolv.conf here, with "nameserver + ;; 10.0.2.3\n". However, with Linux-libre 3.16, we're getting ENOSPC. + ;; And since it's actually unnecessary, it's gone. (logand (network-interface-flags sock interface) IFF_UP))) diff --git a/guix/download.scm b/guix/download.scm index 47b72f432a..22c3ba19ca 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -130,7 +130,6 @@ "ftp://ftp.piotrkosoft.net/pub/mirrors/ftp.x.org/" "ftp://ftp.portal-to-web.de/pub/mirrors/x.org/" "ftp://ftp.solnet.ch/mirror/x.org/" - "ftp://ftp.sunet.se/pub/X11/" "ftp://gd.tuwien.ac.at/X11/" "ftp://mi.mirror.garr.it/mirrors/x.org/" "ftp://mirror.cict.fr/x.org/" @@ -161,7 +160,6 @@ ;; from http://www.imagemagick.org/script/download.php ;; (without mirrors that are unavailable or not up to date) ;; mirrors keeping old versions at the top level - "ftp://ftp.sunet.se/pub/multimedia/graphics/ImageMagick/" "ftp://sunsite.icm.edu.pl/packages/ImageMagick/" ;; mirrors moving old versions to "legacy" "http://mirrors-au.go-parts.com/mirrors/ImageMagick/" diff --git a/guix/gexp.scm b/guix/gexp.scm index c9f6cbe99a..6d1f328aef 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -41,7 +41,9 @@ ;;; S-expressions (sexps), with two differences: ;;; ;;; 1. References (un-quotations) to derivations or packages in a gexp are -;;; replaced by the corresponding output file name; +;;; replaced by the corresponding output file name; in addition, the +;;; 'ungexp-native' unquote-like form allows code to explicitly refer to +;;; the native code of a given package, in case of cross-compilation; ;;; ;;; 2. Gexps embed information about the derivations they refer to. ;;; @@ -52,9 +54,10 @@ ;; "G expressions". (define-record-type <gexp> - (make-gexp references proc) + (make-gexp references natives proc) gexp? (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) + (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...) (proc gexp-proc)) ; procedure (define (write-gexp gexp port) @@ -65,7 +68,10 @@ ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure ;; tries to use 'append' on that, which fails with wrong-type-arg. (false-if-exception - (write (apply (gexp-proc gexp) (gexp-references gexp)) port)) + (write (apply (gexp-proc gexp) + (append (gexp-references gexp) + (gexp-native-references gexp))) + port)) (format port " ~a>" (number->string (object-address gexp) 16))) @@ -81,14 +87,20 @@ (define raw-derivation (store-lift derivation)) -(define (lower-inputs inputs) - "Turn any package from INPUTS into a derivation; return the corresponding -input list as a monadic value." +(define* (lower-inputs inputs + #:key system target) + "Turn any package from INPUTS into a derivation for SYSTEM; return the +corresponding input list as a monadic value. When TARGET is true, use it as +the cross-compilation target triplet." (with-monad %store-monad (sequence %store-monad (map (match-lambda (((? package? package) sub-drv ...) - (mlet %store-monad ((drv (package->derivation package))) + (mlet %store-monad + ((drv (if target + (package->cross-derivation package target + system) + (package->derivation package system)))) (return `(,drv ,@sub-drv)))) (((? origin? origin) sub-drv ...) (mlet %store-monad ((drv (origin->derivation origin))) @@ -99,7 +111,7 @@ input list as a monadic value." (define* (gexp->derivation name exp #:key - system + system (target 'current) hash hash-algo recursive? (env-vars '()) (modules '()) @@ -107,7 +119,8 @@ input list as a monadic value." references-graphs local-build?) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a -derivation) on SYSTEM. +derivation) on SYSTEM. When TARGET is true, it is used as the +cross-compilation target triplet for packages referred to by EXP. Make MODULES available in the evaluation context of EXP; MODULES is a list of names of Guile modules from the current search path to be copied in the store, @@ -118,9 +131,25 @@ The other arguments are as for 'derivation'." (define %modules modules) (define outputs (gexp-outputs exp)) - (mlet* %store-monad ((inputs (lower-inputs (gexp-inputs exp))) + (mlet* %store-monad (;; The following binding is here to force + ;; '%current-system' and '%current-target-system' to be + ;; looked up at >>= time. + (unused (return #f)) + (system -> (or system (%current-system))) - (sexp (gexp->sexp exp)) + (target -> (if (eq? target 'current) + (%current-target-system) + target)) + (normals (lower-inputs (gexp-inputs exp) + #:system system + #:target target)) + (natives (lower-inputs (gexp-native-inputs exp) + #:system system + #:target #f)) + (inputs -> (append normals natives)) + (sexp (gexp->sexp exp + #:system system + #:target target)) (builder (text-file (string-append name "-builder") (object->string sexp))) (modules (if (pair? %modules) @@ -158,8 +187,9 @@ The other arguments are as for 'derivation'." #:references-graphs references-graphs #:local-build? local-build?))) -(define (gexp-inputs exp) - "Return the input list for EXP." +(define* (gexp-inputs exp #:optional (references gexp-references)) + "Return the input list for EXP, using REFERENCES to get its list of +references." (define (add-reference-inputs ref result) (match ref (((? derivation?) (? string?)) @@ -169,7 +199,7 @@ The other arguments are as for 'derivation'." (((? origin?) (? string?)) (cons ref result)) ((? gexp? exp) - (append (gexp-inputs exp) result)) + (append (gexp-inputs exp references) result)) (((? string? file)) (if (direct-store-path? file) (cons ref result) @@ -182,7 +212,10 @@ The other arguments are as for 'derivation'." (fold-right add-reference-inputs '() - (gexp-references exp))) + (references exp))) + +(define gexp-native-inputs + (cut gexp-inputs <> gexp-native-references)) (define (gexp-outputs exp) "Return the outputs referred to by EXP as a list of strings." @@ -199,16 +232,21 @@ The other arguments are as for 'derivation'." '() (gexp-references exp))) -(define* (gexp->sexp exp) +(define* (gexp->sexp exp #:key + (system (%current-system)) + (target (%current-target-system))) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" - (define (reference->sexp ref) + (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref (((? derivation? drv) (? string? output)) (return (derivation->output-path drv output))) (((? package? p) (? string? output)) - (package-file p #:output output)) + (package-file p + #:output output + #:system system + #:target (if native? #f target))) (((? origin? o) (? string? output)) (mlet %store-monad ((drv (origin->derivation o))) (return (derivation->output-path drv output)))) @@ -218,17 +256,22 @@ and in the current monad setting (system type, etc.)" ;; that trick. (return `((@ (guile) getenv) ,output))) ((? gexp? exp) - (gexp->sexp exp)) + (gexp->sexp exp + #:system system + #:target (if native? #f target))) (((? string? str)) (return (if (direct-store-path? str) str ref))) ((refs ...) - (sequence %store-monad (map reference->sexp refs))) + (sequence %store-monad + (map (cut reference->sexp <> native?) refs))) (x (return x))))) (mlet %store-monad ((args (sequence %store-monad - (map reference->sexp (gexp-references exp))))) + (append (map reference->sexp (gexp-references exp)) + (map (cut reference->sexp <> #t) + (gexp-native-references exp)))))) (return (apply (gexp-proc exp) args)))) (define (canonicalize-reference ref) @@ -285,9 +328,28 @@ package/derivation references." (_ result)))) + (define (collect-native-escapes exp) + ;; Return all the 'ungexp-native' forms present in EXP. + (let loop ((exp exp) + (result '())) + (syntax-case exp (ungexp-native ungexp-native-splicing) + ((ungexp-native _) + (cons exp result)) + ((ungexp-native _ _) + (cons exp result)) + ((ungexp-native-splicing _ ...) + (cons exp result)) + ((exp0 exp ...) + (let ((result (loop #'exp0 result))) + (fold loop result #'(exp ...)))) + (_ + result)))) + (define (escape->ref exp) ;; Turn 'ungexp' form EXP into a "reference". - (syntax-case exp (ungexp ungexp-splicing output) + (syntax-case exp (ungexp ungexp-splicing + ungexp-native ungexp-native-splicing + output) ((ungexp output) #'(output-ref "out")) ((ungexp output name) @@ -297,30 +359,49 @@ package/derivation references." ((ungexp drv-or-pkg out) #'(list drv-or-pkg out)) ((ungexp-splicing lst) + #'lst) + ((ungexp-native thing) + #'thing) + ((ungexp-native drv-or-pkg out) + #'(list drv-or-pkg out)) + ((ungexp-native-splicing lst) #'lst))) + (define (substitute-ungexp exp substs) + ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with + ;; the corresponding form in SUBSTS. + (match (assoc exp substs) + ((_ id) + id) + (_ + #'(syntax-error "error: no 'ungexp' substitution" + #'ref)))) + + (define (substitute-ungexp-splicing exp substs) + (syntax-case exp () + ((exp rest ...) + (match (assoc #'exp substs) + ((_ id) + (with-syntax ((id id)) + #`(append id + #,(substitute-references #'(rest ...) substs)))) + (_ + #'(syntax-error "error: no 'ungexp-splicing' substitution" + #'ref)))))) + (define (substitute-references exp substs) ;; Return a variant of EXP where all the cars of SUBSTS have been ;; replaced by the corresponding cdr. - (syntax-case exp (ungexp ungexp-splicing) + (syntax-case exp (ungexp ungexp-native + ungexp-splicing ungexp-native-splicing) ((ungexp _ ...) - (match (assoc exp substs) - ((_ id) - id) - (_ - #'(syntax-error "error: no 'ungexp' substitution" - #'ref)))) + (substitute-ungexp exp substs)) + ((ungexp-native _ ...) + (substitute-ungexp exp substs)) (((ungexp-splicing _ ...) rest ...) - (syntax-case exp () - ((exp rest ...) - (match (assoc #'exp substs) - ((_ id) - (with-syntax ((id id)) - #`(append id - #,(substitute-references #'(rest ...) substs)))) - (_ - #'(syntax-error "error: no 'ungexp-splicing' substitution" - #'ref)))))) + (substitute-ungexp-splicing exp substs)) + (((ungexp-native-splicing _ ...) rest ...) + (substitute-ungexp-splicing exp substs)) ((exp0 exp ...) #`(cons #,(substitute-references #'exp0 substs) #,(substitute-references #'(exp ...) substs))) @@ -328,11 +409,15 @@ package/derivation references." (syntax-case s (ungexp output) ((_ exp) - (let* ((escapes (delete-duplicates (collect-escapes #'exp))) + (let* ((normals (delete-duplicates (collect-escapes #'exp))) + (natives (delete-duplicates (collect-native-escapes #'exp))) + (escapes (append normals natives)) (formals (generate-temporaries escapes)) (sexp (substitute-references #'exp (zip escapes formals))) - (refs (map escape->ref escapes))) + (refs (map escape->ref normals)) + (nrefs (map escape->ref natives))) #`(make-gexp (map canonicalize-reference (list #,@refs)) + (map canonicalize-reference (list #,@nrefs)) (lambda #,formals #,sexp))))))) @@ -385,22 +470,26 @@ its search path." (write '(ungexp exp) port)))) #:local-build? #t)) - ;;; ;;; Syntactic sugar. ;;; (eval-when (expand load eval) - (define (read-ungexp chr port) - "Read an 'ungexp' or 'ungexp-splicing' form from PORT." + (define* (read-ungexp chr port #:optional native?) + "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is +true, use 'ungexp-native' and 'ungexp-native-splicing' instead." (define unquote-symbol (match (peek-char port) (#\@ (read-char port) - 'ungexp-splicing) + (if native? + 'ungexp-native-splicing + 'ungexp-splicing)) (_ - 'ungexp))) + (if native? + 'ungexp-native + 'ungexp)))) (match (read port) ((? symbol? symbol) @@ -421,6 +510,7 @@ its search path." ;; Extend the reader (read-hash-extend #\~ read-gexp) - (read-hash-extend #\$ read-ungexp)) + (read-hash-extend #\$ read-ungexp) + (read-hash-extend #\+ (cut read-ungexp <> <> #t))) ;;; gexp.scm ends here diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm new file mode 100644 index 0000000000..5242f5448b --- /dev/null +++ b/guix/monad-repl.scm @@ -0,0 +1,81 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix monad-repl) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (ice-9 pretty-print) + #:use-module (system repl repl) + #:use-module (system repl common) + #:use-module (system repl command) + #:use-module (system base language) + #:use-module (system base compile) + #:use-module (srfi srfi-26) + #:export (run-in-store + enter-store-monad)) + +;;; Comment: +;;; +;;; This modules provides a couple of REPL meta-commands that make it easier +;;; to work with monadic procedures in the store monad. +;;; +;;; Code: + +(define* (monad-language monad run #:optional (name 'monad)) + "Return a language with a special evaluator that causes monadic values + to be \"run\" in MONAD using procedure RUN." + (let ((scheme (lookup-language 'scheme))) + (define (evaluate-monadic-expression exp env) + (let ((mvalue (compile exp #:to 'value #:env env))) + (run mvalue))) + + (make-language #:name name + #:title "Monad" + #:reader (language-reader scheme) + #:compilers (language-compilers scheme) + #:decompilers (language-decompilers scheme) + #:evaluator evaluate-monadic-expression + #:printer (language-printer scheme) + #:make-default-environment + (language-make-default-environment scheme)))) + +(define (store-monad-language) + "Return a compiler language for the store monad." + (let ((store (open-connection))) + (monad-language %store-monad + (cut run-with-store store <>) + 'store-monad))) + +(define-meta-command ((run-in-store guix) repl (form)) + "run-in-store EXP +Run EXP through the store monad." + (let ((value (with-store store + (run-with-store store (repl-eval repl form))))) + (run-hook before-print-hook value) + (pretty-print value))) + +(define-meta-command ((enter-store-monad guix) repl) + "enter-store-monad +Enter a REPL for values in the store monad." + (let ((new (make-repl (store-monad-language)))) + ;; Force interpretation so that our specially-crafted language evaluator + ;; is actually used. + (repl-option-set! new 'interp #t) + (run-repl new))) + +;;; monad-repl.scm ends here diff --git a/guix/monads.scm b/guix/monads.scm index 4af2b704ab..c714941a0c 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -59,6 +59,7 @@ package-file origin->derivation package->derivation + package->cross-derivation built-derivations) #:replace (imported-modules compiled-modules)) @@ -377,13 +378,21 @@ permission bits are kept." (define* (package-file package #:optional file - #:key (system (%current-system)) (output "out")) + #:key + system (output "out") target) "Return as a monadic value the absolute file name of FILE within the OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the -OUTPUT directory of PACKAGE." +OUTPUT directory of PACKAGE. When TARGET is true, use it as a +cross-compilation target triplet." (lambda (store) - (let* ((drv (package-derivation store package system)) - (out (derivation->output-path drv output))) + (define compute-derivation + (if target + (cut package-cross-derivation <> <> target <>) + package-derivation)) + + (let* ((system (or system (%current-system))) + (drv (compute-derivation store package system)) + (out (derivation->output-path drv output))) (if file (string-append out "/" file) out)))) @@ -411,6 +420,9 @@ input list as a monadic value." (define package->derivation (store-lift package-derivation)) +(define package->cross-derivation + (store-lift package-cross-derivation)) + (define origin->derivation (store-lift package-source-derivation)) diff --git a/guix/profiles.scm b/guix/profiles.scm index 5e69e012f9..e921566e5a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -47,6 +47,7 @@ manifest-pattern? manifest-remove + manifest-add manifest-installed? manifest-matching-entries @@ -157,12 +158,20 @@ omitted or #f, use the first output of PACKAGE." ('packages ((name version output path deps) ...))) (manifest (map (lambda (name version output path deps) - (manifest-entry - (name name) - (version version) - (output output) - (item path) - (dependencies deps))) + ;; Up to Guix 0.7 included, dependencies were listed as ("gmp" + ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in + ;; such lists. + (let ((deps (match deps + (((labels directories) ...) + directories) + ((directories ...) + directories)))) + (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps)))) name version output path deps))) (_ @@ -196,6 +205,25 @@ must be a manifest-pattern." (manifest-entries manifest) patterns))) +(define (manifest-add manifest entries) + "Add a list of manifest ENTRIES to MANIFEST and return new manifest. +Remove MANIFEST entries that have the same name and output as ENTRIES." + (define (same-entry? entry name output) + (match entry + (($ <manifest-entry> entry-name _ entry-output _ ...) + (and (equal? name entry-name) + (equal? output entry-output))))) + + (make-manifest + (append entries + (fold (lambda (entry result) + (match entry + (($ <manifest-entry> name _ out _ ...) + (filter (negate (cut same-entry? <> name out)) + result)))) + (manifest-entries manifest) + entries)))) + (define (manifest-installed? manifest pattern) "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), #f otherwise." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 31da773a53..3bfef4fc9a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -104,8 +104,7 @@ return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if "Roll back to the previous generation of PROFILE." (let* ((number (generation-number profile)) (previous-number (previous-generation-number profile number)) - (previous-generation (generation-file-name profile previous-number)) - (manifest (string-append previous-generation "/manifest"))) + (previous-generation (generation-file-name profile previous-number))) (cond ((not (file-exists? profile)) ; invalid profile (leave (_ "profile '~a' does not exist~%") profile)) @@ -623,24 +622,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define (options->installable opts manifest) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', return the new list of manifest entries." - (define (deduplicate deps) - ;; Remove duplicate entries from DEPS, a list of propagated inputs, where - ;; each input is a name/path tuple. - (define (same? d1 d2) - (match d1 - ((_ p1) - (match d2 - ((_ p2) (eq? p1 p2)) - (_ #f))) - ((_ p1 out1) - (match d2 - ((_ p2 out2) - (and (string=? out1 out2) - (eq? p1 p2))) - (_ #f))))) - - (delete-duplicates deps same?)) - (define (package->manifest-entry* package output) (check-package-freshness package) ;; When given a package via `-e', install the first of its @@ -659,19 +640,18 @@ return the new list of manifest entries." (() '()) ((_ ...) - (let ((newest (find-newest-available-packages))) - (filter-map (match-lambda - (($ <manifest-entry> name version output path _) - (and (any (cut regexp-exec <> name) - upgrade-regexps) - (upgradeable? name version path) - (let ((output (or output "out"))) - (call-with-values - (lambda () - (specification->package+output name output)) - list)))) - (_ #f)) - (manifest-entries manifest)))))) + (filter-map (match-lambda + (($ <manifest-entry> name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (let ((output (or output "out"))) + (call-with-values + (lambda () + (specification->package+output name output)) + list)))) + (_ #f)) + (manifest-entries manifest))))) (define to-upgrade (map (match-lambda @@ -762,11 +742,6 @@ removed from MANIFEST." %default-options #f)) - (define (guile-missing?) - ;; Return #t if %GUILE-FOR-BUILD is not available yet. - (let ((out (derivation->output-path (%guile-for-build)))) - (not (valid-path? (%store) out)))) - (define (ensure-default-profile) ;; Ensure the default profile symlink and directory exist and are ;; writable. @@ -819,15 +794,8 @@ more information.~%")) ;; Process any install/remove/upgrade action from OPTS. (define dry-run? (assoc-ref opts 'dry-run?)) - (define verbose? (assoc-ref opts 'verbose?)) (define profile (assoc-ref opts 'profile)) - (define (same-package? entry name output) - (match entry - (($ <manifest-entry> entry-name _ entry-output _ ...) - (and (equal? name entry-name) - (equal? output entry-output))))) - (define current-generation-number (generation-number profile)) @@ -898,19 +866,8 @@ more information.~%")) (let* ((manifest (profile-manifest profile)) (install (options->installable opts manifest)) (remove (options->removable opts manifest)) - (entries - (append install - (fold (lambda (package result) - (match package - (($ <manifest-entry> name _ out _ ...) - (filter (negate - (cut same-package? <> - name out)) - result)))) - (manifest-entries - (manifest-remove manifest remove)) - install))) - (new (make-manifest entries))) + (new (manifest-add (manifest-remove manifest remove) + install))) (when (equal? profile %current-profile) (ensure-default-profile)) @@ -940,7 +897,8 @@ more information.~%")) (name (generation-file-name profile (+ 1 number)))) (and (build-derivations (%store) (list prof-drv)) - (let ((count (length entries))) + (let* ((entries (manifest-entries new)) + (count (length entries))) (switch-symlinks name prof) (switch-symlinks profile name) (maybe-register-gc-root (%store) profile) @@ -1059,7 +1017,6 @@ more information.~%")) (('search-paths) (let* ((manifest (profile-manifest profile)) (entries (manifest-entries manifest)) - (packages (map manifest-entry-name entries)) (settings (search-path-environment-variables entries profile (const #f)))) (format #t "~{~a~%~}" settings) diff --git a/guix/ui.scm b/guix/ui.scm index 9112d55daf..f11c2e9c92 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -393,15 +393,17 @@ converted to a space; sequences of more than one line break are preserved." ((#\newline) `(,column ,(+ 1 newlines) ,chars)) (else - (let ((chars (case newlines - ((0) chars) - ((1) (cons #\space chars)) - (else - (append (make-list newlines #\newline) chars)))) - (column (case newlines - ((0) column) - ((1) (+ 1 column)) - (else 0)))) + (let* ((spaces (if (and (pair? chars) (eqv? (car chars) #\.)) 2 1)) + (chars (case newlines + ((0) chars) + ((1) + (append (make-list spaces #\space) chars)) + (else + (append (make-list newlines #\newline) chars)))) + (column (case newlines + ((0) column) + ((1) (+ spaces column)) + (else 0)))) (let ((chars (cons chr chars)) (column (+ 1 column))) (if (> column width) @@ -414,7 +416,10 @@ converted to a space; sequences of more than one line break are preserved." 0 ,(if (null? after) before - (append before (cons #\newline (cdr after))))) + (append before + (cons #\newline + (drop-while (cut eqv? #\space <>) + after))))) `(,column 0 ,chars))) ; unbreakable `(,column 0 ,chars))))))))) |