Merge branch 'wip-guix-home'

2 files changed, 753 insertions, 0 deletions

diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
new file mode 100644
index 0000000000..75df6d707d
--- /dev/null
+++ b/guix/scripts/home.scm
@@ -0,0 +1,512 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 scripts home)
+  #:use-module (gnu packages admin)
+  #:use-module ((gnu services) #:hide (delete))
+  #:use-module (gnu packages)
+  #:use-module (gnu home)
+  #:use-module (gnu home-services)
+  #:use-module (guix channels)
+  #:use-module (guix derivations)
+  #:use-module (guix ui)
+  #:use-module (guix grafts)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts package)
+  #:use-module (guix scripts build)
+  #:use-module (guix scripts system search)
+  #:autoload   (guix scripts pull) (channel-commit-hyperlink)
+  #:use-module (guix scripts home import)
+  #:use-module ((guix status) #:select (with-status-verbosity))
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:export (guix-home))
+
+
+;;;
+;;; Options.
+;;;
+
+(define %user-module
+  (make-user-module '((gnu home))))
+
+(define %guix-home
+  (string-append %profile-directory "/guix-home"))
+
+(define (show-help)
+  (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE]
+Build the home environment declared in FILE according to ACTION.
+Some ACTIONS support additional ARGS.\n"))
+    (newline)
+  (display (G_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (G_ "\
+   search             search for existing service types\n"))
+  (display (G_ "\
+   reconfigure        switch to a new home environment configuration\n"))
+  (display (G_ "\
+   roll-back          switch to the previous home environment configuration\n"))
+  (display (G_ "\
+   describe           describe the current home environment\n"))
+  (display (G_ "\
+   list-generations   list the home environment generations\n"))
+  (display (G_ "\
+   switch-generation  switch to an existing home environment configuration\n"))
+  (display (G_ "\
+   delete-generations delete old home environment generations\n"))
+  (display (G_ "\
+   build              build the home environment without installing anything\n"))
+  (display (G_ "\
+   import             generates a home environment definition from dotfiles\n"))
+
+  (show-build-options-help)
+  (display (G_ "
+  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define (verbosity-level opts)
+  "Return the verbosity level based on OPTS, the alist of parsed options."
+  (or (assoc-ref opts 'verbosity)
+      (if (eq? (assoc-ref opts 'action) 'build)
+          2 1)))
+
+(define %options
+  ;; Specification of the command-line options.
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix show")))
+         (option '(#\v "verbosity") #t #f
+                 (lambda (opt name arg result)
+                   (let ((level (string->number* arg)))
+                     (alist-cons 'verbosity level
+                                 (alist-delete 'verbosity result)))))
+         %standard-build-options))
+
+(define %default-options
+  `((build-mode . ,(build-mode normal))
+    (graft? . #t)
+    (substitutes? . #t)
+    (offload? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
+    (verbosity . 3)
+    (debug . 0)))
+
+
+;;;
+;;; Actions.
+;;;
+
+(define* (perform-action action he
+                         #:key
+                         dry-run?
+                         derivations-only?
+                         use-substitutes?)
+  "Perform ACTION for home environment. "
+
+  (define println
+    (cut format #t "~a~%" <>))
+
+  (mlet* %store-monad
+      ((he-drv   (home-environment-derivation he))
+       (drvs     (mapm/accumulate-builds lower-object (list he-drv)))
+       (%        (if derivations-only?
+                     (return
+                      (for-each (compose println derivation-file-name) drvs))
+                     (built-derivations drvs)))
+
+       (he-out-path -> (derivation->output-path he-drv)))
+    (if (or dry-run? derivations-only?)
+        (return #f)
+        (begin
+          (for-each (compose println derivation->output-path) drvs)
+
+          (case action
+            ((reconfigure)
+             (let* ((number (generation-number %guix-home))
+                    (generation (generation-file-name
+                                 %guix-home (+ 1 number))))
+
+               (switch-symlinks generation he-out-path)
+               (switch-symlinks %guix-home generation)
+               (setenv "GUIX_NEW_HOME" he-out-path)
+               (primitive-load (string-append he-out-path "/activate"))
+               (setenv "GUIX_NEW_HOME" #f)
+               (return he-out-path)))
+            (else
+             (newline)
+             (return he-out-path)))))))
+
+(define (process-action action args opts)
+  "Process ACTION, a sub-command, with the arguments are listed in ARGS.
+ACTION must be one of the sub-commands that takes a home environment
+declaration as an argument (a file name.)  OPTS is the raw alist of options
+resulting from command-line parsing."
+  (define (ensure-home-environment file-or-exp obj)
+    (unless (home-environment? obj)
+      (leave (G_ "'~a' does not return a home environment ~%")
+             file-or-exp))
+    obj)
+
+  (let* ((file   (match args
+                   (() #f)
+                   ((x . _) x)))
+         (expr   (assoc-ref opts 'expression))
+         (system (assoc-ref opts 'system))
+
+         (transform   (lambda (obj)
+                        (home-environment-with-provenance obj file)))
+
+         (home-environment
+          (transform
+           (ensure-home-environment
+            (or file expr)
+            (cond
+             ((and expr file)
+              (leave
+               (G_ "both file and expression cannot be specified~%")))
+             (expr
+              (read/eval expr))
+             (file
+              (load* file %user-module
+                     #:on-error (assoc-ref opts 'on-error)))
+             (else
+              (leave (G_ "no configuration specified~%")))))))
+
+         (dry?        (assoc-ref opts 'dry-run?)))
+
+    (with-store store
+      (set-build-options-from-command-line store opts)
+      (with-build-handler (build-notifier #:use-substitutes?
+                                          (assoc-ref opts 'substitutes?)
+                                          #:verbosity
+                                          (verbosity-level opts)
+                                          #:dry-run?
+                                          (assoc-ref opts 'dry-run?))
+
+        (run-with-store store
+          (mbegin %store-monad
+            (set-guile-for-build (default-guile))
+
+            (case action
+              (else
+               (perform-action action home-environment
+                               #:dry-run? dry?
+                               #:derivations-only? (assoc-ref opts 'derivations-only?)
+                               #:use-substitutes? (assoc-ref opts 'substitutes?))
+               ))))))
+    (warn-about-disk-space)))
+
+
+(define (process-command command args opts)
+  "Process COMMAND, one of the 'guix home' sub-commands.  ARGS is its
+argument list and OPTS is the option alist."
+  (define-syntax-rule (with-store* store exp ...)
+    (with-store store
+      (set-build-options-from-command-line store opts)
+      exp ...))
+  (case command
+    ;; The following commands do not need to use the store, and they do not need
+    ;; an home environment file.
+    ((search)
+     (apply search args))
+    ((import)
+     (let* ((profiles (delete-duplicates
+                      (match (filter-map (match-lambda
+                                           (('profile . p) p)
+                                           (_              #f))
+                                         opts)
+                        (() (list %current-profile))
+                        (lst (reverse lst)))))
+           (manifest (concatenate-manifests
+                      (map profile-manifest profiles))))
+       (import-manifest manifest (current-output-port))))
+    ((describe)
+     (match (generation-number %guix-home)
+       (0
+        (error (G_ "no home environment generation, nothing to describe~%")))
+       (generation
+        (display-home-environment-generation generation))))
+    ((list-generations)
+     (let ((pattern (match args
+                      (() #f)
+                      ((pattern) pattern)
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (list-generations pattern)))
+    ((switch-generation)
+     (let ((pattern (match args
+                      ((pattern) pattern)
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (with-store* store
+                    (switch-to-home-environment-generation store pattern))))
+    ((roll-back)
+     (let ((pattern (match args
+                      (() "")
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (with-store* store
+                    (roll-back-home-environment store))))
+    ((delete-generations)
+     (let ((pattern (match args
+                      (() #f)
+                      ((pattern) pattern)
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (with-store*
+        store
+        (delete-matching-generations store %guix-home pattern))))
+    (else (process-action command args opts))))
+
+(define-command (guix-home . args)
+  (synopsis "build and deploy home environments")
+
+  (define (parse-sub-command arg result)
+    ;; Parse sub-command ARG and augment RESULT accordingly.
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (let ((action (string->symbol arg)))
+          (case action
+            ((build
+              reconfigure
+              extension-graph shepherd-graph
+              list-generations describe
+              delete-generations roll-back
+              switch-generation search
+              import)
+             (alist-cons 'action action result))
+            (else (leave (G_ "~a: unknown action~%") action))))))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (define (option-arguments opts)
+    ;; Extract the plain arguments from OPTS.
+    (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
+           (count  (length args))
+           (action (assoc-ref opts 'action))
+           (expr   (assoc-ref opts 'expression)))
+      (define (fail)
+        (leave (G_ "wrong number of arguments for action '~a'~%")
+               action))
+
+      (unless action
+        (format (current-error-port)
+                (G_ "guix home: missing command name~%"))
+        (format (current-error-port)
+                (G_ "Try 'guix home --help' for more information.~%"))
+        (exit 1))
+
+      (case action
+        ((build reconfigure)
+         (unless (or (= count 1)
+                     (and expr (= count 0)))
+           (fail)))
+        ((init)
+         (unless (= count 2)
+           (fail))))
+      args))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (args     (option-arguments opts))
+           (command  (assoc-ref opts 'action)))
+      (parameterize ((%graft? (assoc-ref opts 'graft?)))
+        (with-status-verbosity (verbosity-level opts)
+          (process-command command args opts))))))
+
+
+;;;
+;;; Searching.
+;;;
+
+(define service-type-name*
+  (compose symbol->string service-type-name))
+
+(define (service-type-description-string type)
+  "Return the rendered and localised description of TYPE, a service type."
+  (and=> (service-type-description type)
+         (compose texi->plain-text P_)))
+
+(define %service-type-metrics
+  ;; Metrics used to estimate the relevance of a search result.
+  `((,service-type-name* . 3)
+    (,service-type-description-string . 2)
+    (,(lambda (type)
+        (match (and=> (service-type-location type) location-file)
+          ((? string? file)
+           (basename file ".scm"))
+          (#f
+           "")))
+     . 1)))
+
+(define (find-service-types regexps)
+  "Return a list of service type/score pairs: service types whose name or
+description matches REGEXPS sorted by relevance, and their score."
+  (let ((matches (fold-home-service-types
+                  (lambda (type result)
+                    (match (relevance type regexps
+                                      %service-type-metrics)
+                      ((? zero?)
+                       result)
+                      (score
+                       (cons (cons type score) result))))
+                  '())))
+    (sort matches
+          (lambda (m1 m2)
+            (match m1
+              ((type1 . score1)
+               (match m2
+                 ((type2 . score2)
+                  (if (= score1 score2)
+                      (string>? (service-type-name* type1)
+                                (service-type-name* type2))
+                      (> score1 score2))))))))))
+
+(define (search . args)
+  (with-error-handling
+    (let* ((regexps (map (cut make-regexp* <> regexp/icase) args))
+           (matches (find-service-types regexps)))
+      (leave-on-EPIPE
+       (display-search-results matches (current-output-port)
+                               #:print service-type->recutils
+                               #:command "guix home search")))))
+
+
+;;;
+;;; Generations.
+;;;
+
+(define* (display-home-environment-generation
+          number
+          #:optional (profile %guix-home))
+  "Display a summary of home-environment generation NUMBER in a
+human-readable format."
+  (define (display-channel channel)
+    (format #t     "    ~a:~%" (channel-name channel))
+    (format #t (G_ "      repository URL: ~a~%") (channel-url channel))
+    (when (channel-branch channel)
+      (format #t (G_ "      branch: ~a~%") (channel-branch channel)))
+    (format #t (G_ "      commit: ~a~%")
+            (if (supports-hyperlinks?)
+                (channel-commit-hyperlink channel)
+                (channel-commit channel))))
+
+  (unless (zero? number)
+    (let* ((generation  (generation-file-name profile number)))
+      (define-values (channels config-file)
+        ;; The function will work for home environments too, we just
+        ;; need to keep provenance file.
+        (system-provenance generation))
+
+      (display-generation profile number)
+      (format #t (G_ "  file name: ~a~%") generation)
+      (format #t (G_ "  canonical file name: ~a~%") (readlink* generation))
+      ;; TRANSLATORS: Please preserve the two-space indentation.
+
+      (unless (null? channels)
+        ;; TRANSLATORS: Here "channel" is the same terminology as used in
+        ;; "guix describe" and "guix pull --channels".
+        (format #t (G_ "  channels:~%"))
+        (for-each display-channel channels))
+      (when config-file
+        (format #t (G_ "  configuration file: ~a~%")
+                (if (supports-hyperlinks?)
+                    (file-hyperlink config-file)
+                    config-file))))))
+
+(define* (list-generations pattern #:optional (profile %guix-home))
+  "Display in a human-readable format all the home environment
+generations matching PATTERN, a string.  When PATTERN is #f, display
+all the home environment generations."
+  (cond ((not (file-exists? profile))             ; XXX: race condition
+         (raise (condition (&profile-not-found-error
+                            (profile profile)))))
+        ((not pattern)
+         (for-each display-home-environment-generation (profile-generations profile)))
+        ((matching-generations pattern profile)
+         =>
+         (lambda (numbers)
+           (if (null-list? numbers)
+               (exit 1)
+               (leave-on-EPIPE
+                (for-each display-home-environment-generation numbers)))))))
+
+
+;;;
+;;; Switch generations.
+;;;
+
+;; TODO: Make it public in (guix scripts system)
+(define-syntax-rule (unless-file-not-found exp)
+  (catch 'system-error
+    (lambda ()
+      exp)
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          #f
+          (apply throw args)))))
+
+(define (switch-to-home-environment-generation store spec)
+  "Switch the home-environment profile to the generation specified by
+SPEC.  STORE is an open connection to the store."
+  (let* ((number (relative-generation-spec->number %guix-home spec))
+         (generation (generation-file-name %guix-home number))
+         (activate (string-append generation "/activate")))
+    (if number
+        (begin
+          (setenv "GUIX_NEW_HOME" (readlink generation))
+          (switch-to-generation* %guix-home number)
+          (unless-file-not-found (primitive-load activate))
+          (setenv "GUIX_NEW_HOME" #f))
+        (leave (G_ "cannot switch to home environment generation '~a'~%") spec))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-home-environment store)
+  "Roll back the home-environment profile to its previous generation.
+STORE is an open connection to the store."
+  (switch-to-home-environment-generation store "-1"))
diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
new file mode 100644
index 0000000000..39f45dbeac
--- /dev/null
+++ b/guix/scripts/home/import.scm
@@ -0,0 +1,241 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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 scripts home import)
+  #:use-module (guix profiles)
+  #:use-module (guix ui)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-1)
+  #:export (import-manifest))
+
+;;; Commentary:
+;;;
+;;; This module provides utilities for generating home service
+;;; configurations from existing "dotfiles".
+;;;
+;;; Code:
+
+
+(define (generate-bash-module+configuration)
+  (let ((rc (string-append (getenv "HOME") "/.bashrc"))
+        (profile (string-append (getenv "HOME") "/.bash_profile"))
+        (logout (string-append (getenv "HOME") "/.bash_logout")))
+    `((gnu home-services bash)
+      (service home-bash-service-type
+                 (home-bash-configuration
+                  ,@(if (file-exists? rc)
+                        `((bashrc
+                           (list (slurp-file-gexp (local-file ,rc)))))
+                        '())
+                  ,@(if (file-exists? profile)
+                        `((bash-profile
+                           (list (slurp-file-gexp
+                                  (local-file ,profile)))))
+                        '())
+                  ,@(if (file-exists? logout)
+                        `((bash-logout
+                           (list (slurp-file-gexp
+                                  (local-file ,logout)))))
+                        '()))))))
+
+
+(define %files-configurations-alist
+  `((".bashrc" . ,generate-bash-module+configuration)
+    (".bash_profile" . ,generate-bash-module+configuration)
+    (".bash_logout" . ,generate-bash-module+configuration)))
+
+(define (modules+configurations)
+  (let ((configurations (delete-duplicates
+                         (filter-map (match-lambda
+                                ((file . proc)
+                                 (if (file-exists?
+                                      (string-append (getenv "HOME") "/" file))
+                                     proc
+                                     #f)))
+                                     %files-configurations-alist)
+                         (lambda (x y)
+                           (equal? (procedure-name x) (procedure-name y))))))
+    (map (lambda (proc) (proc)) configurations)))
+
+;; Based on `manifest->code' from (guix profiles)
+;; MAYBE: Upstream it?
+(define* (manifest->code manifest
+                         #:key
+                         (entry-package-version (const ""))
+                         (home-environment? #f))
+  "Return an sexp representing code to build an approximate version of
+MANIFEST; the code is wrapped in a top-level 'begin' form.  If
+HOME-ENVIRONMENT? is #t, return an <home-environment> definition.
+Call ENTRY-PACKAGE-VERSION to determine the version number to use in
+the spec for a given entry; it can be set to 'manifest-entry-version'
+for fully-specified version numbers, or to some other procedure to
+disambiguate versions for packages for which several versions are
+available."
+  (define (entry-transformations entry)
+    ;; Return the transformations that apply to ENTRY.
+    (assoc-ref (manifest-entry-properties entry) 'transformations))
+
+  (define transformation-procedures
+    ;; List of transformation options/procedure name pairs.
+    (let loop ((entries (manifest-entries manifest))
+               (counter 1)
+               (result  '()))
+      (match entries
+        (() result)
+        ((entry . tail)
+         (match (entry-transformations entry)
+           (#f
+            (loop tail counter result))
+           (options
+            (if (assoc-ref result options)
+                (loop tail counter result)
+                (loop tail (+ 1 counter)
+                      (alist-cons options
+                                  (string->symbol
+                                   (format #f "transform~a" counter))
+                                  result)))))))))
+
+  (define (qualified-name entry)
+    ;; Return the name of ENTRY possibly with "@" followed by a version.
+    (match (entry-package-version entry)
+      (""      (manifest-entry-name entry))
+      (version (string-append (manifest-entry-name entry)
+                              "@" version))))
+
+  (if (null? transformation-procedures)
+      (let ((specs (map (lambda (entry)
+                          (match (manifest-entry-output entry)
+                            ("out"  (qualified-name entry))
+                            (output (string-append (qualified-name entry)
+                                                   ":" output))))
+                        (manifest-entries manifest))))
+        (if home-environment?
+            (let ((modules+configurations (modules+configurations)))
+              `(begin
+               (use-modules (gnu home)
+                            (gnu packages)
+                            ,@(map first modules+configurations))
+               ,(home-environment-template
+                 #:specs specs
+                 #:services (map second modules+configurations))))
+            `(begin
+               (use-modules (gnu packages))
+
+               (specifications->manifest
+                (list ,@specs)))))
+      (let* ((transform (lambda (options exp)
+                         (if (not options)
+                             exp
+                             (let ((proc (assoc-ref transformation-procedures
+                                                    options)))
+                               `(,proc ,exp)))))
+            (packages (map (lambda (entry)
+                                   (define options
+                                     (entry-transformations entry))
+
+                                   (define name
+                                     (qualified-name entry))
+
+                                   (match (manifest-entry-output entry)
+                                     ("out"
+                                      (transform options
+                                                 `(specification->package ,name)))
+                                     (output
+                                      `(list ,(transform
+                                               options
+                                               `(specification->package ,name))
+                                             ,output))))
+                           (manifest-entries manifest)))
+            (transformations (map (match-lambda
+                         ((options . name)
+                          `(define ,name
+                             (options->transformation ',options))))
+                       transformation-procedures)))
+        (if home-environment?
+            (let ((modules+configurations (modules+configurations)))
+              `(begin
+                 (use-modules (guix transformations)
+                              (gnu home)
+                              (gnu packages)
+                              ,@(map first modules+configurations))
+
+                 ,@transformations
+
+                 ,(home-environment-template
+                   #:packages packages
+                   #:services (map second modules+configurations))))
+            `(begin
+               (use-modules (guix transformations)
+                            (gnu packages))
+
+                ,@transformations
+
+                (packages->manifest
+                 (list ,@packages)))))))
+
+(define* (home-environment-template #:key (packages #f) (specs #f) services)
+  "Return an S-exp containing a <home-environment> declaration
+containing PACKAGES, or SPECS (package specifications), and SERVICES."
+  `(home-environment
+     (packages
+      ,@(if packages
+            `((list ,@packages))
+            `((map specification->package
+                   (list ,@specs)))))
+     (services (list ,@services))))
+
+(define* (import-manifest
+          manifest
+          #:optional (port (current-output-port)))
+  "Write to PORT a <home-environment> corresponding to MANIFEST."
+  (define (version-spec entry)
+    (let ((name (manifest-entry-name entry)))
+      (match (map package-version (find-packages-by-name name))
+        ((_)
+         ;; A single version of NAME is available, so do not specify the
+         ;; version number, even if the available version doesn't match ENTRY.
+         "")
+        (versions
+         ;; If ENTRY uses the latest version, don't specify any version.
+         ;; Otherwise return the shortest unique version prefix.  Note that
+         ;; this is based on the currently available packages, which could
+         ;; differ from the packages available in the revision that was used
+         ;; to build MANIFEST.
+         (let ((current (manifest-entry-version entry)))
+           (if (every (cut version>? current <>)
+                      (delete current versions))
+               ""
+               (version-unique-prefix (manifest-entry-version entry)
+                                      versions)))))))
+
+  (match (manifest->code manifest
+                         #:entry-package-version version-spec
+                         #:home-environment? #t)
+    (('begin exp ...)
+     (format port (G_ "\
+;; This \"home-environment\" file can be passed to 'guix home reconfigure'
+;; to reproduce the content of your profile.  This is \"symbolic\": it only
+;; specifies package names.  To reproduce the exact same profile, you also
+;; need to capture the channels being used, as returned by \"guix describe\".
+;; See the \"Replicating Guix\" section in the manual.\n"))
+     (for-each (lambda (exp)
+                 (newline port)
+                 (pretty-print exp port))
+               exp))))