bug#22629: [PATCH 1/4] self: Produce a complete package with the 'guix' command.

["Ludovic Courtès" <ludo@gnu.org>]

* 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.
---
 build-aux/build-self.scm            |  19 +++-
 build-aux/compile-as-derivation.scm |   2 +-
 guix/self.scm                       | 148 +++++++++++++++++++++-------
 3 files changed, 129 insertions(+), 40 deletions(-)

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index bccb7a959..5898b6515 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -184,7 +184,8 @@ person's version identifier."
   (date->string (current-date 0) "~Y~m~d.~H"))
 
 (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."
   (define select?
     ;; Select every module but (guix config) and non-Guix modules.
@@ -253,11 +254,14 @@ person's version identifier."
                               (spin system)))
 
                            (display
-                            (derivation-file-name
+                            (and=>
                              (run-with-store store
                                (guix-derivation #$source #$version
-                                                #$guile-version)
-                               #:system system)))))))
+                                                #$guile-version
+                                                #:pull-version
+                                                #$pull-version)
+                               #:system system)
+                             derivation-file-name))))))
                   #:module-path (list source))))
 
 ;; The procedure below is our return value.
@@ -266,13 +270,15 @@ person's version identifier."
                 (guile-version (match ((@ (guile) version))
                                  ("2.2.2" "2.2.2")
                                  (_       (effective-version))))
+                (pull-version 0)
                 #:allow-other-keys
                 #:rest rest)
   "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
 files."
   ;; Build the build program and then use it as a trampoline to build from
   ;; 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))))
     (mbegin %store-monad
       (show-what-to-build* (list build))
@@ -292,6 +298,9 @@ files."
              (return (newline (current-output-port)))
              ((store-lift add-temp-root) drv)
              (return (read-derivation-from-file drv))))
+          ("#f"
+           ;; Unsupported PULL-VERSION.
+           (return #f))
           ((? string? str)
            (error "invalid build result" (list build str))))))))
 
diff --git a/build-aux/compile-as-derivation.scm b/build-aux/compile-as-derivation.scm
index afb134a92..2a45e71bb 100644
--- a/build-aux/compile-as-derivation.scm
+++ b/build-aux/compile-as-derivation.scm
@@ -43,7 +43,7 @@
            (mlet* %store-monad ((source (interned-file source "guix-source"
                                                        #:select? git?
                                                        #:recursive? #t))
-                                (drv    (build source)))
+                                (drv    (build source #:pull-version 1)))
              (mbegin %store-monad
                (show-what-to-build* (list drv))
                (built-derivations (list drv))
diff --git a/guix/self.scm b/guix/self.scm
index 4378a3dee..f0641c342 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -34,6 +34,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
   #:export (make-config.scm
+            whole-package                     ;for internal use in 'guix pull'
             compiled-guix
             guix-derivation
             reload-guix))
@@ -189,7 +190,66 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
            (file-name->module-name (string-drop file prefix)))
          (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)
+                        (pull-version 1)
                         (name (string-append "guix-" version))
                         (guile-version (effective-version))
                         (guile-for-build (guile-for-build guile-version))
@@ -215,7 +275,6 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
                        "guile-git"
                        "guile2.0-git"))
 
-
   (define dependencies
     (match (append-map (lambda (package)
                          (cons (list "x" package)
@@ -332,32 +391,46 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
                                          %guix-home-page-url)))
                  #:guile-for-build guile-for-build))
 
-  (directory-union name
-                   (append-map (lambda (node)
-                                 (list (node-source node)
-                                       (node-compiled node)))
+  (define built-modules
+    (directory-union (string-append name "-modules")
+                     (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*
-                                     *core-package-modules*
-                                     *extra-modules*
-                                     *core-modules*))
+                                 ;; 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*
+                                       *core-package-modules*
+                                       *extra-modules*
+                                       *core-modules*))
 
-                   ;; Silently choose the first entry upon collision so that
-                   ;; we choose *CONFIG*.
-                   #:resolve-collision 'first
+                     ;; Silently choose the first entry upon collision so that
+                     ;; we choose *CONFIG*.
+                     #:resolve-collision 'first
 
-                   ;; When we do (add-to-store "utils.scm"), "utils.scm" must
-                   ;; be a regular file, not a symlink.  Thus, arrange so that
-                   ;; regular files appear as regular files in the final
-                   ;; output.
-                   #:copy? #t
-                   #:quiet? #t))
+                     ;; 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))
+
+  ;; 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)))
 
 \f
 ;;;
@@ -601,9 +674,12 @@ running Guile."
                  'guile-2.0))))
 
 (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
-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)
     (if (and (string-every char-set:hex-digit version)
              (> (string-length version) 9))
@@ -615,11 +691,15 @@ for GUILE-VERSION.  Use VERSION as the version string."
 
   (mbegin %store-monad
     (set-guile-for-build guile)
-    (lower-object (compiled-guix source
-                                 #:version version
-                                 #:name (string-append "guix-"
-                                                       (shorten version))
-                                 #:guile-version (match guile-version
-                                                   ("2.2.2" "2.2")
-                                                   (version version))
-                                 #:guile-for-build guile))))
+    (let ((guix (compiled-guix source
+                               #:version version
+                               #:name (string-append "guix-"
+                                                     (shorten version))
+                               #:pull-version pull-version
+                               #:guile-version (match guile-version
+                                                 ("2.2.2" "2.2")
+                                                 (version version))
+                               #:guile-for-build guile)))
+      (if guix
+          (lower-object guix)
+          (return #f)))))
-- 
2.17.0