[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: Revert "Add (guix self) and use it when pulling."
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: Revert "Add (guix self) and use it when pulling." |
|
Date: |
Tue, 21 Nov 2017 17:53:24 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit cd295fbe170a93844f9c42cbfaa0fbe2490b6693
Author: Ludovic Courtès <address@hidden>
Date: Tue Nov 21 23:51:59 2017 +0100
Revert "Add (guix self) and use it when pulling."
This reverts commit 5f93d97005897c2d859f0be1bdff34c88467ec61.
'guix pull' would fail because (guix self) needs 'scheme-files'
from (guix discovery), which was not exported until now.
---
Makefile.am | 1 -
build-aux/build-self.scm | 272 ++++++++++++++++-----
gnu/packages.scm | 21 +-
guix/discovery.scm | 3 +-
guix/scripts/pull.scm | 91 +++----
guix/self.scm | 619 -----------------------------------------------
6 files changed, 252 insertions(+), 755 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index d64806d..eab4918 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -66,7 +66,6 @@ MODULES = \
guix/derivations.scm \
guix/grafts.scm \
guix/gnu-maintenance.scm \
- guix/self.scm \
guix/upstream.scm \
guix/licenses.scm \
guix/git.scm \
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index d9d9263..ed8ff5f 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -17,9 +17,11 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (build-self)
+ #:use-module (gnu)
+ #:use-module (guix)
+ #:use-module (guix config)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
- #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (build))
@@ -29,51 +31,105 @@
;;; argument: the source tree to build. It returns a derivation that
;;; builds it.
;;;
+;;; This file uses modules provided by the already-installed Guix. Those
+;;; modules may be arbitrarily old compared to the version we want to
+;;; build. Because of that, it must rely on the smallest set of features
+;;; that are likely to be provided by the (guix) and (gnu) modules, and by
+;;; Guile itself, forever and ever.
+;;;
;;; Code:
-;; Use our very own Guix modules.
-(eval-when (compile load eval)
+
+;; The dependencies. Don't refer explicitly to the variables because they
+;; could be renamed or shuffled around in modules over time. Conversely,
+;; 'find-best-packages-by-name' is expected to always have the same semantics.
+
+(define libgcrypt
+ (first (find-best-packages-by-name "libgcrypt" #f)))
+
+(define zlib
+ (first (find-best-packages-by-name "zlib" #f)))
+
+(define gzip
+ (first (find-best-packages-by-name "gzip" #f)))
+
+(define bzip2
+ (first (find-best-packages-by-name "bzip2" #f)))
+
+(define xz
+ (first (find-best-packages-by-name "xz" #f)))
+
+(define (false-if-wrong-guile package)
+ "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? (effective-version)
+ (package-version guile)))
+ package)))
+
+(define (package-for-current-guile . names)
+ "Return the package with one of the given NAMES that depends on the current
+Guile major version (2.0 or 2.2), or #f if none of the packages matches."
+ (let loop ((names names))
+ (match names
+ (()
+ #f)
+ ((name rest ...)
+ (match (find-best-packages-by-name name #f)
+ (()
+ (loop rest))
+ ((first _ ...)
+ (or (false-if-wrong-guile first)
+ (loop rest))))))))
+
+(define guile-json
+ (package-for-current-guile "guile-json"
+ "guile2.2-json"
+ "guile2.0-json"))
+
+(define guile-ssh
+ (package-for-current-guile "guile-ssh"
+ "guile2.2-ssh"
+ "guile2.0-ssh"))
+
+(define guile-git
+ (package-for-current-guile "guile-git"
+ "guile2.0-git"))
+
+(define guile-bytestructures
+ (package-for-current-guile "guile-bytestructures"
+ "guile2.0-bytestructures"))
+
+;; The actual build procedure.
+
+(define (top-source-directory)
+ "Return the name of the top-level directory of this source tree."
(and=> (assoc-ref (current-source-location) 'filename)
(lambda (file)
- (let ((dir (string-append (dirname file) "/..")))
- (set! %load-path (cons dir %load-path))))))
+ (string-append (dirname file) "/.."))))
+
(define (date-version-string)
"Return the current date and hour in UTC timezone, for use as a poor
person's version identifier."
- ;; XXX: Last resort when the Git commit id is missing.
+ ;; XXX: Replace with a Git commit id.
(date->string (current-date 0) "~Y~m~d.~H"))
-(define-syntax parameterize*
- (syntax-rules ()
- "Like 'parameterize' but for regular variables (!)."
- ((_ ((var value) rest ...) body ...)
- (let ((old var)
- (new value))
- (dynamic-wind
- (lambda ()
- (set! var new))
- (lambda ()
- (parameterize* (rest ...) body ...))
- (lambda ()
- (set! var old)))))
- ((_ () body ...)
- (begin body ...))))
-
-(define (pure-load-compiled-path)
- "Return %LOAD-COMPILED-PATH minus the directories containing .go files from
-Guix."
- (define (purify path)
- (fold-right delete path
- (filter-map (lambda (file)
- (and=> (search-path path file) dirname))
- '("guix.go" "gnu.go"))))
-
- (let loop ((path %load-compiled-path))
- (let ((next (purify path)))
- (if (equal? next path)
- path
- (loop next)))))
+(define (guile-for-build)
+ "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
+running Guile."
+ (package->derivation (cond-expand
+ (guile-2.2
+ (canonical-package
+ (specification->package "address@hidden")))
+ (else
+ (canonical-package
+ (specification->package "address@hidden"))))))
;; The procedure below is our return value.
(define* (build source
@@ -82,29 +138,131 @@ Guix."
#:rest rest)
"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files."
- ;; Start by jumping into the target Guix so that we have access to the
- ;; latest packages and APIs.
- ;;
- ;; Our checkout in the store has mtime set to the epoch, and thus .go
- ;; files look newer, even though they may not correspond.
- (parameterize* ((%load-should-auto-compile #f)
- (%fresh-auto-compile #f)
-
- ;; Work around <https://bugs.gnu.org/29226>.
- (%load-compiled-path (pure-load-compiled-path)))
- ;; FIXME: This is currently too expensive notably because it involves
- ;; compiling a number of the big package files such as perl.scm, which
- ;; takes lots of time and memory as of Guile 2.2.2.
- ;;
- ;; (let ((reload-guix (module-ref (resolve-interface '(guix self))
- ;; 'reload-guix)))
- ;; (reload-guix)) ;cross fingers!
-
- (let ((guix-derivation (module-ref (resolve-interface '(guix self))
- 'guix-derivation)))
- (guix-derivation source version))))
+ ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we
+ ;; cannot assume that they are defined. Try to guess their value when
+ ;; they're undefined (XXX: we get an incorrect guess when environment
+ ;; variables such as 'NIX_STATE_DIR' are defined!).
+ (define storedir
+ (if (defined? '%storedir) %storedir %store-directory))
+ (define localstatedir
+ (if (defined? '%localstatedir) %localstatedir (dirname %state-directory)))
+ (define sysconfdir
+ (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory)))
+ (define sbindir
+ (if (defined? '%sbindir) %sbindir (dirname %guix-register-program)))
+
+ (define builder
+ #~(begin
+ (use-modules (guix build pull))
+
+ (letrec-syntax ((maybe-load-path
+ (syntax-rules ()
+ ((_ item rest ...)
+ (let ((tail (maybe-load-path rest ...)))
+ (if (string? item)
+ (cons (string-append item
+ "/share/guile/site/"
+ #$(effective-version))
+ tail)
+ tail)))
+ ((_)
+ '()))))
+ (set! %load-path
+ (append
+ (maybe-load-path #$guile-json #$guile-ssh
+ #$guile-git #$guile-bytestructures)
+ %load-path)))
+
+ (letrec-syntax ((maybe-load-compiled-path
+ (syntax-rules ()
+ ((_ item rest ...)
+ (let ((tail (maybe-load-compiled-path rest ...)))
+ (if (string? item)
+ (cons (string-append item
+ "/lib/guile/"
+ #$(effective-version)
+ "/site-ccache")
+ tail)
+ tail)))
+ ((_)
+ '()))))
+ (set! %load-compiled-path
+ (append
+ (maybe-load-compiled-path #$guile-json #$guile-ssh
+ #$guile-git #$guile-bytestructures)
+ %load-compiled-path)))
+
+ ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was
+ ;; broken: libguile-ssh could not be found. Work around that.
+ ;; FIXME: We want Guile-SSH 0.10.2 or later anyway.
+ #$(if (string-prefix? "0.9." (package-version guile-ssh))
+ #~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib"))
+ #t)
+
+ (build-guix #$output #$source
+
+ #:system #$%system
+ #:storedir #$storedir
+ #:localstatedir #$localstatedir
+ #:sysconfdir #$sysconfdir
+ #:sbindir #$sbindir
+
+ #:package-name #$%guix-package-name
+ #:package-version #$version
+ #:bug-report-address #$%guix-bug-report-address
+ #:home-page-url #$%guix-home-page-url
+
+ #:libgcrypt #$libgcrypt
+ #:zlib #$zlib
+ #:gzip #$gzip
+ #:bzip2 #$bzip2
+ #:xz #$xz
+
+ ;; XXX: This is not perfect, enabling VERBOSE? means
+ ;; building a different derivation.
+ #:debug-port (if #$verbose?
+ (current-error-port)
+ (%make-void-port "w")))))
+
+ (unless guile-git
+ ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether.
+ ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not
+ ;; build (guix git), which will leave us with an unusable 'guix pull'. To
+ ;; avoid that, fail early.
+ (format (current-error-port)
+ "\
+Your installation is too old and lacks a '~a' package.
+Please upgrade to an intermediate version first, for instance with:
+
+ guix pull
--url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz
+\n"
+ (match (effective-version)
+ ("2.0" "guile2.0-git")
+ (_ "guile-git")))
+ (exit 1))
+
+ (mlet %store-monad ((guile (guile-for-build)))
+ (gexp->derivation "guix-latest" builder
+ #:modules '((guix build pull)
+ (guix build utils)
+ (guix build compile)
+
+ ;; Closure of (guix modules).
+ (guix modules)
+ (guix memoization)
+ (guix sets))
+
+ ;; Arrange so that our own (guix build …) modules are
+ ;; used.
+ #:module-path (list (top-source-directory))
+
+ #:guile-for-build guile)))
;; This file is loaded by 'guix pull'; return it the build procedure.
build
+;; Local Variables:
+;; eval: (put 'with-load-path 'scheme-indent-function 1)
+;; End:
+
;;; build-self.scm ends here
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 44a56df..97e6cb3 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -110,25 +110,8 @@ for system '~a'")
file-name system)))))))
(define %distro-root-directory
- ;; Absolute file name of the module hierarchy. Since (gnu packages …) might
- ;; live in a directory different from (guix), try to get the best match.
- (letrec-syntax ((dirname* (syntax-rules ()
- ((_ file)
- (dirname file))
- ((_ file head tail ...)
- (dirname (dirname* file tail ...)))))
- (try (syntax-rules ()
- ((_ (file things ...) rest ...)
- (match (search-path %load-path file)
- (#f
- (try rest ...))
- (absolute
- (dirname* absolute things ...))))
- ((_)
- #f))))
- (try ("gnu/packages/base.scm" gnu/ packages/)
- ("gnu/packages.scm" gnu/)
- ("guix.scm"))))
+ ;; Absolute file name of the module hierarchy.
+ (dirname (search-path %load-path "guix.scm")))
(define %package-module-path
;; Search path for package modules. Each item must be either a directory
diff --git a/guix/discovery.scm b/guix/discovery.scm
index 8ffcf7c..7b57579 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -25,8 +25,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 ftw)
- #:export (scheme-files
- scheme-modules
+ #:export (scheme-modules
fold-modules
all-modules
fold-module-public-variables))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 083b5c3..3e95bd5 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -149,6 +149,8 @@ Download and deploy the latest version of Guix.\n"))
(define what-to-build
(store-lift show-what-to-build))
+(define indirect-root-added
+ (store-lift add-indirect-root))
(define %self-build-file
;; The file containing code to build Guix. This serves the same purpose as
@@ -169,48 +171,33 @@ contained therein. Use COMMIT as the version string."
;; tree.
(build source #:verbose? verbose? #:version commit)))
-(define* (install-latest source-dir config-dir)
- "Make SOURCE-DIR, a store file name, the latest Guix in CONFIG-DIR."
- (let ((latest (string-append config-dir "/latest")))
- (if (and (file-exists? latest)
- (string=? (readlink latest) source-dir))
- (begin
- (display (G_ "Guix already up to date\n"))
- #t)
- (begin
- (switch-symlinks latest source-dir)
- (format #t
- (G_ "updated ~a successfully deployed under `~a'~%")
- %guix-package-name latest)
- #t))))
-
-(define (build-and-install mdrv)
- "Bind MDRV, a monadic value for a derivation, build it, and finally install
-it as the latest Guix."
- (define do-it
- ;; Weirdness follows! Before we were called, the Guix modules have
- ;; probably been reloaded, leading to a "parallel universe" with disjoint
- ;; record types. However, procedures in this file have already cached the
- ;; module relative to which they lookup global bindings (see
- ;; 'toplevel-box' documentation), so they're stuck in the old world. To
- ;; work around that, evaluate our procedure in the context of the "new"
- ;; (guix scripts pull) module--which has access to the new <derivation>
- ;; record, and so on.
- (eval '(lambda (mdrv cont)
- ;; Reopen a connection to the daemon so that we have a record
- ;; with the new type.
- (with-store store
- (run-with-store store
- (mlet %store-monad ((drv mdrv))
- (mbegin %store-monad
- (what-to-build (list drv))
- (built-derivations (list drv))
- (return (cont (derivation->output-path drv))))))))
- (resolve-module '(guix scripts pull)))) ;the new module
-
- (do-it mdrv
- (lambda (result)
- (install-latest result (config-directory)))))
+(define* (build-and-install source config-dir
+ #:key verbose? commit)
+ "Build the tool from SOURCE, and install it in CONFIG-DIR."
+ (mlet* %store-monad ((source (build-from-source source
+ #:commit commit
+ #:verbose? verbose?))
+ (source-dir -> (derivation->output-path source))
+ (to-do? (what-to-build (list source)))
+ (built? (built-derivations (list source))))
+ ;; Always update the 'latest' symlink, regardless of whether SOURCE was
+ ;; already built or not.
+ (if built?
+ (mlet* %store-monad
+ ((latest -> (string-append config-dir "/latest"))
+ (done (indirect-root-added latest)))
+ (if (and (file-exists? latest)
+ (string=? (readlink latest) source-dir))
+ (begin
+ (display (G_ "Guix already up to date\n"))
+ (return #t))
+ (begin
+ (switch-symlinks latest source-dir)
+ (format #t
+ (G_ "updated ~a successfully deployed under `~a'~%")
+ %guix-package-name latest)
+ (return #t))))
+ (leave (G_ "failed to update Guix, check the build log~%")))))
(define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates."
@@ -271,10 +258,6 @@ certificates~%"))
(when (use-le-certs? url)
(honor-lets-encrypt-certificates! store))
- ;; Ensure the 'latest' symlink is registered as a GC root.
- (add-indirect-root store
- (string-append (config-directory) "/latest"))
-
(format (current-error-port)
(G_ "Updating from Git repository at '~a'...~%")
url)
@@ -293,16 +276,10 @@ certificates~%"))
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.0)))))
-
- ;; 'build-from-source' may cause a reload of the Guix
- ;; modules. This leads to a parallel world: its record types
- ;; are disjoint from those we've seen until now (because we
- ;; use "generative" record types), and so on. Thus, special
- ;; care must be taken once we have return from that call.
- (build-and-install
- (build-from-source checkout
- #:commit commit
- #:verbose?
- (assoc-ref opts 'verbose?))))))))))))
+ (run-with-store store
+ (build-and-install checkout (config-directory)
+ #:commit commit
+ #:verbose?
+ (assoc-ref opts 'verbose?))))))))))))
;;; pull.scm ends here
diff --git a/guix/self.scm b/guix/self.scm
deleted file mode 100644
index 242fc9d..0000000
--- a/guix/self.scm
+++ /dev/null
@@ -1,619 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <address@hidden>
-;;;
-;;; 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 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 build utils)
- #:use-module (gnu packages)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (ice-9 match)
- #:export (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))))))))
-
-
-;;;
-;;; 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?)
- "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?))))
-
-(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)
- (guile-version (effective-version))
- (libgcrypt (specification->package "libgcrypt"))
- (zlib (specification->package "zlib"))
- (gzip (specification->package "gzip"))
- (bzip2 (specification->package "bzip2"))
- (xz (specification->package "xz")))
- "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"))))))
-
- (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))
-
- (define *package-modules*
- (scheme-node "guix-packages"
- `((gnu packages)
- ,@(scheme-modules* source "gnu/packages"))
- (list *core-modules* *extra-modules*)
- #: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)))))))
-
- (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*)
- #:extra-files
- (file-imports source "gnu/system/examples" (const #t))))
-
- (define *cli-modules*
- (scheme-node "guix-cli"
- (scheme-modules* source "/guix/scripts")
- (list *core-modules* *extra-modules* *package-modules*
- *system-modules*)
- #:extensions dependencies))
-
- (define *config*
- (scheme-node "guix-config"
- '()
- #:extra-modules
- `(((guix config)
- => ,(make-config.scm #:libgcrypt libgcrypt
- #:zlib zlib
- #:gzip gzip
- #:bzip2 bzip2
- #:xz xz
- #:package-name
- %guix-package-name
- #:package-version
- version
- #:bug-report-address
- %guix-bug-report-address
- #:home-page-url
- %guix-home-page-url)))))
-
- (directory-union (string-append "guix-" version)
- (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*))
-
- ;; 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))
-
-
-;;;
-;;; (guix config) generation.
-;;;
-
-(define %dependency-variables
- ;; (guix config) variables corresponding to dependencies.
- '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
-
-(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
- (package-name "GNU Guix")
- (package-version "0")
- (bug-report-address "address@hidden")
- (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
- %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 %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?)
- ;; 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
- #:options
- '(#:local-build? #f ;allow substitutes
-
- ;; Don't annoy people about _IONBF deprecation.
- #:env-vars (("GUILE_WARN_DEPRECATED" . "no")))))
-
-
-;;;
-;;; Live patching.
-;;;
-
-(define (recursive-submodules module)
- "Return the list of submodules of MODULE."
- (let loop ((module module)
- (result '()))
- (let ((submodules (hash-map->list (lambda (name module)
- module)
- (module-submodules module))))
- (fold loop (append submodules result) submodules))))
-
-(define (remove-submodule! module names)
- (let loop ((module module)
- (names names))
- (match names
- (() #t)
- ((head tail ...)
- (match (nested-ref-module module tail)
- (#f #t)
- ((? module? submodule)
- (hashq-remove! (module-submodules module) head)
- (loop submodule tail)))))))
-
-(define (unload-module-tree! module)
- (define (strip-prefix prefix lst)
- (let loop ((prefix prefix)
- (lst lst))
- (match prefix
- (()
- lst)
- ((_ prefix ...)
- (match lst
- ((_ lst ...)
- (loop prefix lst)))))))
-
- (let ((submodules (hash-map->list (lambda (name module)
- module)
- (module-submodules module))))
- (let loop ((root module)
- (submodules submodules))
- (match submodules
- (()
- #t)
- ((head tail ...)
- (unload-module-tree! head)
- (remove-submodule! root
- (strip-prefix (module-name root)
- (module-name head)))
-
- (match (module-name head)
- ((parents ... leaf)
- ;; Remove MODULE from the AUTOLOADS-DONE list. Note: We don't use
- ;; 'module-filename' because it could be an absolute file name.
- (set-autoloaded! (string-join (map symbol->string parents)
- "/" 'suffix)
- (symbol->string leaf) #f)))
- (loop root tail))))))
-
-(define* (reload-guix #:optional (log-port (current-error-port)))
- "Reload all the Guix and GNU modules currently loaded."
- (let* ((guix (resolve-module '(guix) #f #:ensure #f))
- (gnu (resolve-module '(gnu) #f #:ensure #f))
- (guix-submodules (recursive-submodules guix))
- (gnu-submodules (recursive-submodules gnu)))
- (define (reload module)
- (match (module-filename module)
- (#f #f)
- ((? string? file)
- ;; The following should auto-compile FILE.
- (primitive-load-path file))))
-
- ;; First, we need to nuke all the (guix) and (gnu) submodules so we don't
- ;; end up with a mixture of old and new modules when we reload (which
- ;; wouldn't work, because we'd have two different <package> record types,
- ;; for instance.)
- (format log-port "Unloading current Guix...~%")
- (unload-module-tree! gnu)
- (unload-module-tree! guix)
-
- (format log-port "Loading new Guix...~%")
- (for-each reload (append guix-submodules (list guix)))
- (for-each reload (append gnu-submodules (list gnu)))
- (format log-port "New Guix modules successfully loaded.~%")))
-
-
-;;;
-;;; Building.
-;;;
-
-(define* (guile-for-build #:optional (version (effective-version)))
- "Return a package for Guile VERSION."
- (define canonical-package ;soft reference
- (module-ref (resolve-interface '(gnu packages base))
- 'canonical-package))
-
- (match version
- ("2.2"
- (canonical-package
- (specification->package "address@hidden")))
- ("2.0"
- (canonical-package
- (specification->package "address@hidden")))))
-
-(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 max-version-length 9)
-
- (define (shorten version)
- ;; TODO: VERSION is a commit id, but we'd rather use something like what
- ;; 'git describe' provides.
- (if (> (string-length version) max-version-length)
- (string-take version max-version-length)
- version))
-
- (mbegin %store-monad
- (set-guile-for-build (guile-for-build guile-version))
- (lower-object (compiled-guix source
- #:version (shorten version)
- #:guile-version guile-version))))