ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Revert "Add (guix self) and use it when pulling."

Browse source 
This reverts commit 5f93d97005.

'guix pull' would fail because (guix self) needs 'scheme-files'
from (guix discovery), which was not exported until now.
This commit is contained in:
Ludovic Courtès 2017-11-21 23:51:59 +01:00
parent aa33cc29ca
commit cd295fbe17
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
6 changed files with 250 additions and 753 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -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 \

268
build-aux/build-self.scm
View file

@ -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 @@ (define-module (build-self)
;;; 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 @@ (define* (build source
#: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

21
gnu/packages.scm
View file

@ -110,25 +110,8 @@ (define (search-bootstrap-binary file-name system)
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

3
guix/discovery.scm
View file

@ -25,8 +25,7 @@ (define-module (guix discovery)
#: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))

67
guix/scripts/pull.scm
View file

@ -149,6 +149,8 @@ (define %options
(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 @@ (define* (build-from-source source
;; 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")))
(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"))
#t)
(return #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)))))
(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 @@ (define (use-le-certs? url)
(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,14 +276,8 @@ (define (use-le-certs? url)
(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
(run-with-store store
(build-and-install checkout (config-directory)
#:commit commit
#:verbose?
(assoc-ref opts 'verbose?))))))))))))

619
guix/self.scm
View file

@ -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))))