nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

self: Produce a complete package with the 'guix' command. 

* guix/self.scm (guix-command): New procedure.
(compiled-guix): Add #:pull-version parameter.
[command, package]: New variables.
Honor PULL-VERSION.
(guix-derivation): Add #:pull-version and pass it to 'compiled-guix'.
* build-aux/build-self.scm (build-program): Add #:pull-version
parameter.  Pass it to 'guix-derivation'.
(build): Add #:pull-version and pass it to 'build-program'.
* build-aux/compile-as-derivation.scm: Pass #:pull-version to BUILD.
This commit is contained in:
Ludovic Courtès 2018-05-30 11:10:27 +02:00
parent d6fb0985a6
commit 8a0d9bc8a3
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 129 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
build-aux/build-self.scm
View File

@ -184,7 +184,8 @@ person's version identifier."
(date->string (current-date 0) "~Y~m~d.~H")) (date->string (current-date 0) "~Y~m~d.~H"))
(define* (build-program source version (define* (build-program source version
#:optional (guile-version (effective-version))) #:optional (guile-version (effective-version))
#:key (pull-version 0))
"Return a program that computes the derivation to build Guix from SOURCE." "Return a program that computes the derivation to build Guix from SOURCE."
(define select? (define select?
;; Select every module but (guix config) and non-Guix modules. ;; Select every module but (guix config) and non-Guix modules.
@ -253,11 +254,14 @@ person's version identifier."
(spin system))) (spin system)))
(display (display
(derivation-file-name (and=>
(run-with-store store (run-with-store store
(guix-derivation #$source #$version (guix-derivation #$source #$version
#$guile-version) #$guile-version
#:system system))))))) #:pull-version
#$pull-version)
#:system system)
derivation-file-name))))))
#:module-path (list source)))) #:module-path (list source))))
;; The procedure below is our return value. ;; The procedure below is our return value.
@ -266,13 +270,15 @@ person's version identifier."
(guile-version (match ((@ (guile) version)) (guile-version (match ((@ (guile) version))
("2.2.2" "2.2.2") ("2.2.2" "2.2.2")
(_ (effective-version)))) (_ (effective-version))))
(pull-version 0)
#:allow-other-keys #:allow-other-keys
#:rest rest) #:rest rest)
"Return a derivation that unpacks SOURCE into STORE and compiles Scheme "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files." files."
;; Build the build program and then use it as a trampoline to build from ;; Build the build program and then use it as a trampoline to build from
;; SOURCE. ;; SOURCE.
(mlet %store-monad ((build (build-program source version guile-version)) (mlet %store-monad ((build (build-program source version guile-version
#:pull-version pull-version))
(system (if system (return system) (current-system)))) (system (if system (return system) (current-system))))
(mbegin %store-monad (mbegin %store-monad
(show-what-to-build* (list build)) (show-what-to-build* (list build))
@ -292,6 +298,9 @@ files."
(return (newline (current-output-port))) (return (newline (current-output-port)))
((store-lift add-temp-root) drv) ((store-lift add-temp-root) drv)
(return (read-derivation-from-file drv)))) (return (read-derivation-from-file drv))))
("#f"
;; Unsupported PULL-VERSION.
(return #f))
((? string? str) ((? string? str)
(error "invalid build result" (list build str)))))))) (error "invalid build result" (list build str))))))))

2
build-aux/compile-as-derivation.scm
View File

@ -43,7 +43,7 @@
(mlet* %store-monad ((source (interned-file source "guix-source" (mlet* %store-monad ((source (interned-file source "guix-source"
#:select? git? #:select? git?
#:recursive? #t)) #:recursive? #t))
(drv (build source))) (drv (build source #:pull-version 1)))
(mbegin %store-monad (mbegin %store-monad
(show-what-to-build* (list drv)) (show-what-to-build* (list drv))
(built-derivations (list drv)) (built-derivations (list drv))

147
guix/self.scm
View File

@ -34,6 +34,7 @@
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (make-config.scm #:export (make-config.scm
whole-package ;for internal use in 'guix pull'
compiled-guix compiled-guix
guix-derivation guix-derivation
reload-guix)) reload-guix))
@ -192,7 +193,66 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
(file-name->module-name (string-drop file prefix))) (file-name->module-name (string-drop file prefix)))
(scheme-files (string-append directory "/" sub-directory))))) (scheme-files (string-append directory "/" sub-directory)))))
(define* (guix-command modules #:key (dependencies '())
(guile-version (effective-version)))
"Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
load path."
(program-file "guix-command"
#~(begin
(set! %load-path
(append '#$(map (lambda (package)
(file-append package
"/share/guile/site/"
guile-version))
dependencies)
%load-path))
(set! %load-compiled-path
(append '#$(map (lambda (package)
(file-append package "/lib/guile/"
guile-version
"/site-ccache"))
dependencies)
%load-compiled-path))
(set! %load-path (cons #$modules %load-path))
(set! %load-compiled-path
(cons #$modules %load-compiled-path))
(let ((guix-main (module-ref (resolve-interface '(guix ui))
'guix-main)))
;; TODO: Compute locale data.
;; (bindtextdomain "guix" "@localedir@")
;; (bindtextdomain "guix-packages" "@localedir@")
;; XXX: It would be more convenient to change it to:
;; (exit (apply guix-main (command-line)))
(apply guix-main (command-line))))))
(define* (whole-package name modules dependencies
#:key (guile-version (effective-version)))
"Return the whole Guix package NAME that uses MODULES, a derivation of all
the modules, and DEPENDENCIES, a list of packages depended on."
(let ((command (guix-command modules
#:dependencies dependencies
#:guile-version guile-version)))
;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'.
(computed-file name
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(mkdir-p (string-append #$output "/bin"))
(symlink #$command
(string-append #$output "/bin/guix"))
(let ((modules (string-append #$output
"/share/guile/site/"
(effective-version))))
(mkdir-p (dirname modules))
(symlink #$modules modules)))))))
(define* (compiled-guix source #:key (version %guix-version) (define* (compiled-guix source #:key (version %guix-version)
(pull-version 1)
(name (string-append "guix-" version)) (name (string-append "guix-" version))
(guile-version (effective-version)) (guile-version (effective-version))
(guile-for-build (guile-for-build guile-version)) (guile-for-build (guile-for-build guile-version))
@ -351,32 +411,46 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
%guix-home-page-url))) %guix-home-page-url)))
#:guile-for-build guile-for-build)) #:guile-for-build guile-for-build))
(directory-union name (define built-modules
(append-map (lambda (node) (directory-union (string-append name "-modules")
(list (node-source node) (append-map (lambda (node)
(node-compiled node))) (list (node-source node)
(node-compiled node)))
;; Note: *CONFIG* comes first so that it ;; Note: *CONFIG* comes first so that it
;; overrides the (guix config) module that ;; overrides the (guix config) module that
;; comes with *CORE-MODULES*. ;; comes with *CORE-MODULES*.
(list *config* (list *config*
*cli-modules* *cli-modules*
*system-modules* *system-modules*
*package-modules* *package-modules*
*core-package-modules* *core-package-modules*
*extra-modules* *extra-modules*
*core-modules*)) *core-modules*))
;; Silently choose the first entry upon collision so that ;; Silently choose the first entry upon collision so that
;; we choose *CONFIG*. ;; we choose *CONFIG*.
#:resolve-collision 'first #:resolve-collision 'first
;; When we do (add-to-store "utils.scm"), "utils.scm" must ;; When we do (add-to-store "utils.scm"), "utils.scm" must
;; be a regular file, not a symlink. Thus, arrange so that ;; be a regular file, not a symlink. Thus, arrange so that
;; regular files appear as regular files in the final ;; regular files appear as regular files in the final
;; output. ;; output.
#:copy? #t #:copy? #t
#:quiet? #t)) #:quiet? #t))
;; Version 0 of 'guix pull' meant we'd just return Scheme modules.
;; Version 1 is when we return the full package.
(cond ((= 1 pull-version)
;; The whole package, with a standard file hierarchy.
(whole-package name built-modules dependencies
#:guile-version guile-version))
((= 0 pull-version)
;; Legacy 'guix pull': just return the compiled modules.
built-modules)
(else
;; Unsupported 'guix pull' version.
#f)))
;;; ;;;
@ -630,9 +704,12 @@ running Guile."
'guile-2.0)))) 'guile-2.0))))
(define* (guix-derivation source version (define* (guix-derivation source version
#:optional (guile-version (effective-version))) #:optional (guile-version (effective-version))
#:key (pull-version 0))
"Return, as a monadic value, the derivation to build the Guix from SOURCE "Return, as a monadic value, the derivation to build the Guix from SOURCE
for GUILE-VERSION. Use VERSION as the version string." for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies
the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value
is not supported."
(define (shorten version) (define (shorten version)
(if (and (string-every char-set:hex-digit version) (if (and (string-every char-set:hex-digit version)
(> (string-length version) 9)) (> (string-length version) 9))
@ -644,11 +721,15 @@ for GUILE-VERSION. Use VERSION as the version string."
(mbegin %store-monad (mbegin %store-monad
(set-guile-for-build guile) (set-guile-for-build guile)
(lower-object (compiled-guix source (let ((guix (compiled-guix source
#:version version #:version version
#:name (string-append "guix-" #:name (string-append "guix-"
(shorten version)) (shorten version))
#:guile-version (match guile-version #:pull-version pull-version
("2.2.2" "2.2") #:guile-version (match guile-version
(version version)) ("2.2.2" "2.2")
#:guile-for-build guile)))) (version version))
#:guile-for-build guile)))
(if guix
(lower-object guix)
(return #f)))))