Revert "Add (guix self) and use it when pulling."
This reverts commit 5f93d97005.
'guix pull' would fail because (guix self) needs 'scheme-files'
from (guix discovery), which was not exported until now.
master
Ludovic Courtès
parent
aa33cc29ca
commit
cd295fbe17
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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 "guile@2.2")))
|
||||
(else
|
||||
(canonical-package
|
||||
(specification->package "guile@2.0"))))))
|
||||
|
||||
;; 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)
|
||||
;; 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)))
|
||||
|
||||
;; 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!
|
||||
(define builder
|
||||
#~(begin
|
||||
(use-modules (guix build pull))
|
||||
|
||||
(let ((guix-derivation (module-ref (resolve-interface '(guix self))
|
||||
'guix-derivation)))
|
||||
(guix-derivation source version))))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
619
guix/self.scm
619
guix/self.scm
|
|
@ -1,619 +0,0 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2017 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 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 "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
|
||||
%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 "guile@2.2")))
|
||||
("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 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))))
|
||||
Reference in New Issue