diff options
author | Mark H Weaver <mhw@netris.org> | 2018-04-10 00:42:22 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2018-04-10 00:42:22 -0400 |
commit | f89aa1521af69b0e1a1350c2380579788b0f8945 (patch) | |
tree | 5009cca687ac669ef846920877cbfb6fffdd9893 /guix | |
parent | 169c658f7f286efae397fa3eda55b1c56fa92a01 (diff) | |
parent | 60e1de6d95bd32b4996c199708541781b8f828fd (diff) | |
download | guix-patches-f89aa1521af69b0e1a1350c2380579788b0f8945.tar guix-patches-f89aa1521af69b0e1a1350c2380579788b0f8945.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/cargo.scm | 21 | ||||
-rw-r--r-- | guix/build/union.scm | 40 | ||||
-rw-r--r-- | guix/discovery.scm | 31 | ||||
-rw-r--r-- | guix/gexp.scm | 15 | ||||
-rw-r--r-- | guix/git.scm | 87 | ||||
-rw-r--r-- | guix/modules.scm | 7 | ||||
-rw-r--r-- | guix/scripts/package.scm | 17 | ||||
-rw-r--r-- | guix/self.scm | 599 | ||||
-rw-r--r-- | guix/upstream.scm | 5 |
9 files changed, 733 insertions, 89 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index c637fbb162..4a1eb0cfa0 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -43,17 +43,11 @@ to NAME and VERSION." (string-append crate-url name "/" version "/download")) -(define (default-cargo) - "Return the default Cargo package." +(define (default-rust) + "Return the default Rust package." ;; Lazily resolve the binding to avoid a circular dependency. (let ((rust (resolve-interface '(gnu packages rust)))) - (module-ref rust 'cargo))) - -(define (default-rustc) - "Return the default Rustc package." - ;; Lazily resolve the binding to avoid a circular dependency. - (let ((rust (resolve-interface '(gnu packages rust)))) - (module-ref rust 'rustc))) + (module-ref rust 'rust))) (define %cargo-build-system-modules ;; Build-side modules imported by default. @@ -115,14 +109,13 @@ to NAME and VERSION." (define* (lower name #:key source inputs native-inputs outputs system target - (cargo (default-cargo)) - (rustc (default-rustc)) + (rust (default-rust)) #:allow-other-keys #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:cargo #:rustc #:inputs #:native-inputs #:outputs)) + '(#:source #:target #:rust #:inputs #:native-inputs #:outputs)) (and (not target) ;; TODO: support cross-compilation (bag @@ -136,8 +129,8 @@ to NAME and VERSION." ;; Keep the standard inputs of 'gnu-build-system' ,@(standard-packages))) - (build-inputs `(("cargo" ,cargo) - ("rustc" ,rustc) + (build-inputs `(("cargo" ,rust "cargo") + ("rustc" ,rust) ,@native-inputs)) (outputs outputs) (build cargo-build) diff --git a/guix/build/union.scm b/guix/build/union.scm index d46b750035..1179f1234b 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; @@ -25,7 +25,9 @@ #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) - #:export (union-build)) + #:export (union-build + + warn-about-collision)) ;;; Commentary: ;;; @@ -76,14 +78,29 @@ identical, #f otherwise." (or (eof-object? n1) (loop)))))))))))))) +(define (warn-about-collision files) + "Handle the collision among FILES by emitting a warning and choosing the +first one of THEM." + (format (current-error-port) + "~%warning: collision encountered:~%~{ ~a~%~}" + files) + (let ((file (first files))) + (format (current-error-port) "warning: choosing ~a~%" file) + file)) + (define* (union-build output inputs #:key (log-port (current-error-port)) (create-all-directories? #f) - (symlink symlink)) + (symlink symlink) + (resolve-collision warn-about-collision)) "Build in the OUTPUT directory a symlink tree that is the union of all the INPUTS, using SYMLINK to create symlinks. As a special case, if CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to -make sure the caller can modify them later." +make sure the caller can modify them later. + +When two or more regular files collide, call RESOLVE-COLLISION with the list +of colliding files and use the one that it returns; or, if RESOLVE-COLLISION +returns #f, skip the faulty file altogether." (define (symlink* input output) (format log-port "`~a' ~~> `~a'~%" input output) @@ -92,17 +109,10 @@ make sure the caller can modify them later." (define (resolve-collisions output dirs files) (cond ((null? dirs) ;; The inputs are all files. - (format (current-error-port) - "~%warning: collision encountered:~%~{~a~%~}" - files) - - (let ((file (first files))) - ;; TODO: Implement smarter strategies. - (format (current-error-port) - "warning: arbitrarily choosing ~a~%" - file) - - (symlink* file output))) + (match (resolve-collision files) + (#f #f) + ((? string? file) + (symlink* file output)))) (else ;; The inputs are a mixture of files and directories diff --git a/guix/discovery.scm b/guix/discovery.scm index 7b57579023..2b627d108e 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix discovery) - #:use-module (guix ui) + #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix combinators) #:use-module (guix build syscalls) @@ -25,7 +25,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 ftw) - #:export (scheme-modules + #:export (scheme-files + scheme-modules fold-modules all-modules fold-module-public-variables)) @@ -85,13 +86,18 @@ DIRECTORY is not accessible." (lambda args (let ((errno (system-error-errno args))) (unless (= errno ENOENT) - (warning (G_ "cannot access `~a': ~a~%") - directory (strerror errno))) + (format (current-error-port) ;XXX + (G_ "cannot access `~a': ~a~%") + directory (strerror errno))) '()))))) -(define* (scheme-modules directory #:optional sub-directory) +(define* (scheme-modules directory #:optional sub-directory + #:key (warn (const #f))) "Return the list of Scheme modules available under DIRECTORY. -Optionally, narrow the search to SUB-DIRECTORY." +Optionally, narrow the search to SUB-DIRECTORY. + +WARN is called when a module could not be loaded. It is passed the module +name and the exception key and arguments." (define prefix-len (string-length directory)) @@ -103,31 +109,32 @@ Optionally, narrow the search to SUB-DIRECTORY." (resolve-interface module)) (lambda args ;; Report the error, but keep going. - (warn-about-load-error module args) + (warn module args) #f)))) (scheme-files (if sub-directory (string-append directory "/" sub-directory) directory)))) -(define (fold-modules proc init path) +(define* (fold-modules proc init path #:key (warn (const #f))) "Fold over all the Scheme modules present in PATH, a list of directories. Call (PROC MODULE RESULT) for each module that is found." (fold (lambda (spec result) (match spec ((? string? directory) - (fold proc result (scheme-modules directory))) + (fold proc result (scheme-modules directory #:warn warn))) ((directory . sub-directory) (fold proc result - (scheme-modules directory sub-directory))))) + (scheme-modules directory sub-directory + #:warn warn))))) '() path)) -(define (all-modules path) +(define* (all-modules path #:key (warn (const #f))) "Return the list of package modules found in PATH, a list of directories to search. Entries in PATH can be directory names (strings) or (DIRECTORY . SUB-DIRECTORY) pairs, in which case modules are searched for beneath SUB-DIRECTORY." - (fold-modules cons '() path)) + (fold-modules cons '() path #:warn warn)) (define (fold-module-public-variables proc init modules) "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES, diff --git a/guix/gexp.scm b/guix/gexp.scm index 2deec253ff..bedb387edb 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1258,7 +1258,8 @@ This yields an 'etc' directory containing these two files." files)))))) (define* (directory-union name things - #:key (copy? #f) (quiet? #f)) + #:key (copy? #f) (quiet? #f) + (resolve-collision 'warn-about-collision)) "Return a directory that is the union of THINGS, where THINGS is a list of file-like objects denoting directories. For example: @@ -1266,6 +1267,10 @@ file-like objects denoting directories. For example: yields a directory that is the union of the 'guile' and 'emacs' packages. +Call RESOLVE-COLLISION when several files collide, passing it the list of +colliding files. RESOLVE-COLLISION must return the chosen file or #f, in +which case the colliding entry is skipped altogether. + When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET? is true, the derivation will not print anything." (define symlink @@ -1289,12 +1294,16 @@ is true, the derivation will not print anything." (computed-file name (with-imported-modules '((guix build union)) (gexp (begin - (use-modules (guix build union)) + (use-modules (guix build union) + (srfi srfi-1)) ;for 'first' and 'last' + (union-build (ungexp output) '(ungexp things) #:log-port (ungexp log-port) - #:symlink (ungexp symlink))))))))) + #:symlink (ungexp symlink) + #:resolve-collision + (ungexp resolve-collision))))))))) ;;; diff --git a/guix/git.scm b/guix/git.scm index 103749d0e2..9e89cc0062 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -28,9 +28,11 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (%repository-cache-directory + update-cached-checkout latest-repository-commit)) (define %repository-cache-directory @@ -68,11 +70,6 @@ make sure no empty directory is left behind." (lambda _ (false-if-exception (rmdir directory))))) -(define (repository->head-sha1 repo) - "Return the sha1 of the HEAD commit in REPOSITORY as a string." - (let ((oid (reference-target (repository-head repo)))) - (oid->string (commit-id (commit-lookup repo oid))))) - (define (url+commit->name url sha1) "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of the git repository, extracted from URL and SHA1:7 the seven first digits @@ -82,21 +79,9 @@ of SHA1 string." (last (string-split url #\/)) ".git" "") "-" (string-take sha1 7))) -(define* (copy-to-store store cache-directory #:key url repository) - "Copy CACHE-DIRECTORY recursively to STORE. URL and REPOSITORY are used to -create the store directory name." - (define (dot-git? file stat) - (and (string=? (basename file) ".git") - (eq? 'directory (stat:type stat)))) - - (let* ((commit (repository->head-sha1 repository)) - (name (url+commit->name url commit))) - (values (add-to-store store name #t "sha256" cache-directory - #:select? (negate dot-git?)) - commit))) - (define (switch-to-ref repository ref) - "Switch to REPOSITORY's branch, commit or tag specified by REF." + "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the +OID (roughly the commit hash) corresponding to REF." (define obj (match ref (('branch . branch) @@ -122,7 +107,38 @@ create the store directory name." (string-append "refs/tags/" tag)))) (object-lookup repository oid))))) - (reset repository obj RESET_HARD)) + (reset repository obj RESET_HARD) + (object-id obj)) + +(define* (update-cached-checkout url + #:key + (ref '(branch . "origin/master")) + (cache-directory + (%repository-cache-directory))) + "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two +values: the cache directory name, and the SHA1 commit (a string) corresponding +to REF. + +REF is pair whose key is [branch | commit | tag] and value the associated +data, respectively [<branch name> | <sha1> | <tag name>]." + (with-libgit2 + (let* ((cache-dir (url-cache-directory url cache-directory)) + (cache-exists? (openable-repository? cache-dir)) + (repository (if cache-exists? + (repository-open cache-dir) + (clone* url cache-dir)))) + ;; Only fetch remote if it has not been cloned just before. + (when cache-exists? + (remote-fetch (remote-lookup repository "origin"))) + (let ((oid (switch-to-ref repository ref))) + + ;; Reclaim file descriptors and memory mappings associated with + ;; REPOSITORY as soon as possible. + (when (module-defined? (resolve-interface '(git repository)) + 'repository-close!) + (repository-close! repository)) + + (values cache-dir (oid->string oid)))))) (define* (latest-repository-commit store url #:key @@ -137,23 +153,16 @@ data, respectively [<branch name> | <sha1> | <tag name>]. Git repositories are kept in the cache directory specified by %repository-cache-directory parameter." - (with-libgit2 - (let* ((cache-dir (url-cache-directory url cache-directory)) - (cache-exists? (openable-repository? cache-dir)) - (repository (if cache-exists? - (repository-open cache-dir) - (clone* url cache-dir)))) - ;; Only fetch remote if it has not been cloned just before. - (when cache-exists? - (remote-fetch (remote-lookup repository "origin"))) - (switch-to-ref repository ref) - - ;; Reclaim file descriptors and memory mappings associated with - ;; REPOSITORY as soon as possible. - (when (module-defined? (resolve-interface '(git repository)) - 'repository-close!) - (repository-close! repository)) + (define (dot-git? file stat) + (and (string=? (basename file) ".git") + (eq? 'directory (stat:type stat)))) - (copy-to-store store cache-dir - #:url url - #:repository repository)))) + (let*-values (((checkout commit) + (update-cached-checkout url + #:ref ref + #:cache-directory cache-directory)) + ((name) + (url+commit->name url commit))) + (values (add-to-store store name #t "sha256" checkout + #:select? (negate dot-git?)) + commit))) diff --git a/guix/modules.scm b/guix/modules.scm index bf656bb241..65928f67f2 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 match) #:export (missing-dependency-error? missing-dependency-module + missing-dependency-search-path file-name->module-name module-name->file-name @@ -47,7 +48,8 @@ ;; The error corresponding to a missing module. (define-condition-type &missing-dependency-error &error missing-dependency-error? - (module missing-dependency-module)) + (module missing-dependency-module) + (search-path missing-dependency-search-path)) (define (colon-symbol? obj) "Return true if OBJ is a symbol that starts with a colon." @@ -132,7 +134,8 @@ depends on." (module-file-dependencies file)) (#f (raise (condition (&missing-dependency-error - (module module)))))))) + (module module) + (search-path load-path)))))))) (define* (module-closure modules #:key diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d8b80efe8e..4f519e6f33 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -194,15 +194,18 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + allow-collisions? bootstrap? use-substitutes? dry-run?) "Build a new generation of PROFILE, a file name, using the packages -specified in MANIFEST, a manifest object." +specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, +do not treat collisions in MANIFEST as an error." (when (equal? profile %current-profile) (ensure-default-profile)) (let* ((prof-drv (run-with-store store (profile-derivation manifest + #:allow-collisions? allow-collisions? #:hooks (if bootstrap? '() %default-profile-hooks) @@ -408,6 +411,8 @@ Install, remove, or upgrade packages in a single transaction.\n")) -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (newline) (display (G_ " + --allow-collisions do not treat collisions in the profile as an error")) + (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) (display (G_ " --verbose produce verbose output")) @@ -544,6 +549,10 @@ kind of search path~%") (lambda (opt name arg result arg-handler) (values (alist-cons 'verbose? #t result) #f))) + (option '("allow-collisions") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'allow-collisions? #t result) + #f))) (option '(#\s "search") #t #f (lambda (opt name arg result arg-handler) (values (cons `(query search ,(or arg "")) @@ -831,13 +840,15 @@ processed, #f otherwise." (let* ((user-module (make-user-module '((guix profiles) (gnu)))) (manifest (load* file user-module)) (bootstrap? (assoc-ref opts 'bootstrap?)) - (substitutes? (assoc-ref opts 'substitutes?))) + (substitutes? (assoc-ref opts 'substitutes?)) + (allow-collisions? (assoc-ref opts 'allow-collisions?))) (if dry-run? (format #t (G_ "would install new manifest from '~a' with ~d entries~%") file (length (manifest-entries manifest))) (format #t (G_ "installing new manifest from '~a' with ~d entries~%") file (length (manifest-entries manifest)))) (build-and-use-profile store profile manifest + #:allow-collisions? allow-collisions? #:bootstrap? bootstrap? #:use-substitutes? substitutes? #:dry-run? dry-run?))) @@ -856,6 +867,7 @@ processed, #f otherwise." (define dry-run? (assoc-ref opts 'dry-run?)) (define bootstrap? (assoc-ref opts 'bootstrap?)) (define substitutes? (assoc-ref opts 'substitutes?)) + (define allow-collisions? (assoc-ref opts 'allow-collisions?)) (define profile (or (assoc-ref opts 'profile) %current-profile)) (define transform (options->transformation opts)) @@ -894,6 +906,7 @@ processed, #f otherwise." (show-manifest-transaction store manifest step3 #:dry-run? dry-run?) (build-and-use-profile store profile new + #:allow-collisions? allow-collisions? #:bootstrap? bootstrap? #:use-substitutes? substitutes? #:dry-run? dry-run?)))) diff --git a/guix/self.scm b/guix/self.scm new file mode 100644 index 0000000000..c9e4a4250e --- /dev/null +++ b/guix/self.scm @@ -0,0 +1,599 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 2018 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 self) + #:use-module (guix config) + #:use-module (guix i18n) + #:use-module (guix modules) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix discovery) + #:use-module (guix packages) + #:use-module (guix sets) + #:use-module (guix utils) + #:use-module (guix modules) + #:use-module (guix build utils) + #:use-module ((guix build compile) #:select (%lightweight-optimizations)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + #:export (make-config.scm + compiled-guix + guix-derivation + reload-guix)) + + +;;; +;;; Dependency handling. +;;; + +(define* (false-if-wrong-guile package + #:optional (guile-version (effective-version))) + "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., +2.0 instead of 2.2), otherwise return PACKAGE." + (let ((guile (any (match-lambda + ((label (? package? dep) _ ...) + (and (string=? (package-name dep) "guile") + dep))) + (package-direct-inputs package)))) + (and (or (not guile) + (string-prefix? guile-version + (package-version guile))) + package))) + +(define (package-for-guile guile-version . names) + "Return the package with one of the given NAMES that depends on +GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." + (let loop ((names names)) + (match names + (() + #f) + ((name rest ...) + (match (specification->package name) + (#f + (loop rest)) + ((? package? package) + (or (false-if-wrong-guile package) + (loop rest)))))))) + +(define specification->package + ;; Use our own variant of that procedure because that of (gnu packages) + ;; would traverse all the .scm files, which is wasteful. + (let ((ref (lambda (module variable) + (module-ref (resolve-interface module) variable)))) + (match-lambda + ("guile" (ref '(gnu packages commencement) 'guile-final)) + ("guile-json" (ref '(gnu packages guile) 'guile-json)) + ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) + ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) + ("zlib" (ref '(gnu packages compression) 'zlib)) + ("gzip" (ref '(gnu packages compression) 'gzip)) + ("bzip2" (ref '(gnu packages compression) 'bzip2)) + ("xz" (ref '(gnu packages compression) 'xz)) + ("guix" (ref '(gnu packages package-management) + 'guix-register))))) + + +;;; +;;; Derivations. +;;; + +;; Node in a DAG of build tasks. Each node maps to a derivation, but it's +;; easier to express things this way. +(define-record-type <node> + (node name modules source dependencies compiled) + node? + (name node-name) ;string + (modules node-modules) ;list of module names + (source node-source) ;list of source files + (dependencies node-dependencies) ;list of nodes + (compiled node-compiled)) ;node -> lowerable object + +(define (node-fold proc init nodes) + (let loop ((nodes nodes) + (visited (setq)) + (result init)) + (match nodes + (() result) + ((head tail ...) + (if (set-contains? visited head) + (loop tail visited result) + (loop tail (set-insert head visited) + (proc head result))))))) + +(define (node-modules/recursive nodes) + (node-fold (lambda (node modules) + (append (node-modules node) modules)) + '() + nodes)) + +(define* (closure modules #:optional (except '())) + (source-module-closure modules + #:select? + (match-lambda + (('guix 'config) + #f) + ((and module + (or ('guix _ ...) ('gnu _ ...))) + (not (member module except))) + (rest #f)))) + +(define module->import + ;; Return a file-name/file-like object pair for the specified module and + ;; suitable for 'imported-files'. + (match-lambda + ((module '=> thing) + (let ((file (module-name->file-name module))) + (list file thing))) + (module + (let ((file (module-name->file-name module))) + (list file + (local-file (search-path %load-path file))))))) + +(define* (scheme-node name modules #:optional (dependencies '()) + #:key (extra-modules '()) (extra-files '()) + (extensions '()) + parallel? guile-for-build) + "Return a node that builds the given Scheme MODULES, and depends on +DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules +added to the source, and EXTRA-FILES is a list of additional files. +EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that +must be present in the search path." + (let* ((modules (append extra-modules + (closure modules + (node-modules/recursive dependencies)))) + (module-files (map module->import modules)) + (source (imported-files (string-append name "-source") + (append module-files extra-files)))) + (node name modules source dependencies + (compiled-modules name source modules + (map node-source dependencies) + (map node-compiled dependencies) + #:extensions extensions + #:parallel? parallel? + #:guile-for-build guile-for-build)))) + +(define (file-imports directory sub-directory pred) + "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a +list of file-name/file-like objects suitable as inputs to 'imported-files'." + (map (lambda (file) + (list (string-drop file (+ 1 (string-length directory))) + (local-file file #:recursive? #t))) + (find-files (string-append directory "/" sub-directory) pred))) + +(define (scheme-modules* directory sub-directory) + "Return the list of module names found under SUB-DIRECTORY in DIRECTORY." + (let ((prefix (string-length directory))) + (map (lambda (file) + (file-name->module-name (string-drop file prefix))) + (scheme-files (string-append directory "/" sub-directory))))) + +(define* (compiled-guix source #:key (version %guix-version) + (name (string-append "guix-" version)) + (guile-version (effective-version)) + (guile-for-build (guile-for-build guile-version)) + (libgcrypt (specification->package "libgcrypt")) + (zlib (specification->package "zlib")) + (gzip (specification->package "gzip")) + (bzip2 (specification->package "bzip2")) + (xz (specification->package "xz")) + (guix (specification->package "guix"))) + "Return a file-like object that contains a compiled Guix." + (define guile-json + (package-for-guile guile-version + "guile-json" + "guile2.2-json" + "guile2.0-json")) + + (define guile-ssh + (package-for-guile guile-version + "guile-ssh" + "guile2.2-ssh" + "guile2.0-ssh")) + + (define guile-git + (package-for-guile guile-version + "guile-git" + "guile2.0-git")) + + + (define dependencies + (match (append-map (lambda (package) + (cons (list "x" package) + (package-transitive-inputs package))) + (list guile-git guile-json guile-ssh)) + (((labels packages _ ...) ...) + packages))) + + (define *core-modules* + (scheme-node "guix-core" + '((guix) + (guix monad-repl) + (guix packages) + (guix download) + (guix discovery) + (guix profiles) + (guix build-system gnu) + (guix build-system trivial) + (guix build profiles) + (guix build gnu-build-system)) + + ;; Provide a dummy (guix config) with the default version + ;; number, storedir, etc. This is so that "guix-core" is the + ;; same across all installations and doesn't need to be + ;; rebuilt when the version changes, which in turn means we + ;; can have substitutes for it. + #:extra-modules + `(((guix config) + => ,(make-config.scm #:libgcrypt + (specification->package + "libgcrypt")))) + + #:guile-for-build guile-for-build)) + + (define *extra-modules* + (scheme-node "guix-extra" + (filter-map (match-lambda + (('guix 'scripts _ ..1) #f) + (name name)) + (scheme-modules* source "guix")) + (list *core-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + + (define *package-modules* + (scheme-node "guix-packages" + `((gnu packages) + ,@(scheme-modules* source "gnu/packages")) + (list *core-modules* *extra-modules*) + #:extensions dependencies + #:extra-files ;all the non-Scheme files + (file-imports source "gnu/packages" + (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (not (string-suffix? ".scm" file)) + (not (string-suffix? ".go" file)) + (not (string-prefix? ".#" file)) + (not (string-suffix? "~" file))))) + #:guile-for-build guile-for-build)) + + (define *system-modules* + (scheme-node "guix-system" + `((gnu system) + (gnu services) + ,@(scheme-modules* source "gnu/system") + ,@(scheme-modules* source "gnu/services")) + (list *package-modules* *extra-modules* *core-modules*) + #:extensions dependencies + #:extra-files + (file-imports source "gnu/system/examples" (const #t)) + #:guile-for-build + guile-for-build)) + + (define *cli-modules* + (scheme-node "guix-cli" + (scheme-modules* source "/guix/scripts") + (list *core-modules* *extra-modules* *package-modules* + *system-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + + (define *config* + (scheme-node "guix-config" + '() + #:extra-modules + `(((guix config) + => ,(make-config.scm #:libgcrypt libgcrypt + #:zlib zlib + #:gzip gzip + #:bzip2 bzip2 + #:xz xz + #:guix guix + #:package-name + %guix-package-name + #:package-version + version + #:bug-report-address + %guix-bug-report-address + #:home-page-url + %guix-home-page-url))) + #:guile-for-build guile-for-build)) + + (directory-union name + (append-map (lambda (node) + (list (node-source node) + (node-compiled node))) + + ;; Note: *CONFIG* comes first so that it + ;; overrides the (guix config) module that + ;; comes with *CORE-MODULES*. + (list *config* + *cli-modules* + *system-modules* + *package-modules* + *extra-modules* + *core-modules*)) + + ;; Silently choose the first entry upon collision so that + ;; we choose *CONFIG*. + #:resolve-collision 'first + + ;; When we do (add-to-store "utils.scm"), "utils.scm" must + ;; be a regular file, not a symlink. Thus, arrange so that + ;; regular files appear as regular files in the final + ;; output. + #:copy? #t + #:quiet? #t)) + + +;;; +;;; Generating (guix config). +;;; + +(define %dependency-variables + ;; (guix config) variables corresponding to dependencies. + '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate + %sbindir %guix-register-program)) + +(define %persona-variables + ;; (guix config) variables that define Guix's persona. + '(%guix-package-name + %guix-version + %guix-bug-report-address + %guix-home-page-url)) + +(define %config-variables + ;; (guix config) variables corresponding to Guix configuration (storedir, + ;; localstatedir, etc.) + (sort (filter pair? + (module-map (lambda (name var) + (and (not (memq name %dependency-variables)) + (not (memq name %persona-variables)) + (cons name (variable-ref var)))) + (resolve-interface '(guix config)))) + (lambda (name+value1 name+value2) + (string<? (symbol->string (car name+value1)) + (symbol->string (car name+value2)))))) + +(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix + (package-name "GNU Guix") + (package-version "0") + (bug-report-address "bug-guix@gnu.org") + (home-page-url "https://gnu.org/s/guix")) + + ;; Hack so that Geiser is not confused. + (define defmod 'define-module) + + (scheme-file "config.scm" + #~(begin + (#$defmod (guix config) + #:export (%guix-package-name + %guix-version + %guix-bug-report-address + %guix-home-page-url + %sbindir + %libgcrypt + %libz + %gzip + %bzip2 + %xz + %nix-instantiate)) + + ;; XXX: Work around <http://bugs.gnu.org/15602>. + (eval-when (expand load eval) + #$@(map (match-lambda + ((name . value) + #~(define-public #$name #$value))) + %config-variables) + + (define %guix-package-name #$package-name) + (define %guix-version #$package-version) + (define %guix-bug-report-address #$bug-report-address) + (define %guix-home-page-url #$home-page-url) + + (define %sbindir + ;; This is used to define '%guix-register-program'. + ;; TODO: Use a derivation that builds nothing but the + ;; C++ part. + #+(and guix (file-append guix "/sbin"))) + + (define %guix-register-program + (or (getenv "GUIX_REGISTER") + (and %sbindir + (string-append %sbindir "/guix-register")))) + + (define %gzip + #+(and gzip (file-append gzip "/bin/gzip"))) + (define %bzip2 + #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) + (define %xz + #+(and xz (file-append xz "/bin/xz"))) + + (define %libgcrypt + #+(and libgcrypt + (file-append libgcrypt "/lib/libgcrypt"))) + (define %libz + #+(and zlib + (file-append zlib "/lib/libz"))) + + (define %nix-instantiate ;for (guix import snix) + "nix-instantiate"))))) + + + +;;; +;;; Building. +;;; + +(define (imported-files name files) + ;; This is a non-monadic, simplified version of 'imported-files' from (guix + ;; gexp). + (define build + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + + (mkdir (ungexp output)) (chdir (ungexp output)) + (for-each (match-lambda + ((final-path store-path) + (mkdir-p (dirname final-path)) + + ;; Note: We need regular files to be regular files, not + ;; symlinks, as this makes a difference for + ;; 'add-to-store'. + (copy-file store-path final-path))) + '#$files)))) + + (computed-file name build)) + +(define* (compiled-modules name module-tree modules + #:optional + (dependencies '()) + (dependencies-compiled '()) + #:key + (extensions '()) ;full-blown Guile packages + parallel? + guile-for-build) + ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix + ;; gexp). + (define build + (with-imported-modules (source-module-closure + '((guix build compile) + (guix build utils))) + #~(begin + (use-modules (srfi srfi-26) + (ice-9 match) + (ice-9 format) + (ice-9 threads) + (guix build compile) + (guix build utils)) + + (define (regular? file) + (not (member file '("." "..")))) + + (define (report-load file total completed) + (display #\cr) + (format #t + "loading...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output)) + + (define (report-compilation file total completed) + (display #\cr) + (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output)) + + (define (process-directory directory output) + (let ((files (find-files directory "\\.scm$")) + (prefix (+ 1 (string-length directory)))) + ;; Hide compilation warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-files directory #$output + (map (cut string-drop <> prefix) files) + #:workers (parallel-job-count) + #:report-load report-load + #:report-compilation report-compilation)))) + + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) _IONBF) + + (set! %load-path (cons #+module-tree %load-path)) + (set! %load-path + (append '#+dependencies + (map (lambda (extension) + (string-append extension "/share/guile/site/" + (effective-version))) + '#+extensions) + %load-path)) + + (set! %load-compiled-path + (append '#+dependencies-compiled + (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + '#+extensions) + %load-compiled-path)) + + ;; Load the compiler modules upfront. + (compile #f) + + (mkdir #$output) + (chdir #+module-tree) + (process-directory "." #$output)))) + + (computed-file name build + #:guile guile-for-build + #:options + `(#:local-build? #f ;allow substitutes + + ;; Don't annoy people about _IONBF deprecation. + #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) + + +;;; +;;; Building. +;;; + +(define (guile-for-build version) + "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently +running Guile." + (define canonical-package ;soft reference + (module-ref (resolve-interface '(gnu packages base)) + 'canonical-package)) + + (match version + ("2.2.2" + ;; Gross hack to avoid ABI incompatibilities (see + ;; <https://bugs.gnu.org/29570>.) + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-2.2.2)) + ("2.2" + (canonical-package (module-ref (resolve-interface '(gnu packages guile)) + 'guile-2.2/fixed))) + ("2.0" + (canonical-package (specification->package "guile@2.0"))))) + +(define* (guix-derivation source version + #:optional (guile-version (effective-version))) + "Return, as a monadic value, the derivation to build the Guix from SOURCE +for GUILE-VERSION. Use VERSION as the version string." + (define (shorten version) + (if (and (string-every char-set:hex-digit version) + (> (string-length version) 9)) + (string-take version 9) ;Git commit + version)) + + (define guile + (guile-for-build guile-version)) + + (mbegin %store-monad + (set-guile-for-build guile) + (lower-object (compiled-guix source + #:version version + #:name (string-append "guix-" + (shorten version)) + #:guile-version (match guile-version + ("2.2.2" "2.2") + (version version)) + #:guile-for-build guile)))) diff --git a/guix/upstream.scm b/guix/upstream.scm index caaa0e44e4..9e1056f7a7 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -153,7 +153,8 @@ correspond to the same version." (cons (resolve-interface '(guix gnu-maintenance)) (all-modules (map (lambda (entry) `(,entry . "guix/import")) - %load-path)))) + %load-path) + #:warn warn-about-load-error))) (define %updaters ;; The list of publically-known updaters. |