Merge branch 'master' into core-updates

2 files changed, 62 insertions, 38 deletions

diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index e47d207ee0..6f8d9aceec 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -182,20 +182,18 @@ string is ~a.~%")
                           (current-output-port))))
     (display-package-search-path fmt)))
 
-(define (display-profile-info profile fmt)
+(define* (display-profile-info profile fmt
+                               #:optional
+                               (channels (profile-channels profile)))
   "Display information about PROFILE, a profile as created by (guix channels),
-in the format specified by FMT."
+in the format specified by FMT.  PROFILE can be #f, in which case CHANNELS is
+what matters."
   (define number
-    (generation-number profile))
-
-  (define channels
-    (profile-channels (if (zero? number)
-                          profile
-                          (generation-file-name profile number))))
+    (and profile (generation-number profile)))
 
   (match fmt
     ('human
-     (display-profile-content profile number))
+     (display-profile-content profile number channels))
     ('channels
      (pretty-print `(list ,@(map channel->code channels))))
     ('channels-sans-intro
@@ -213,33 +211,37 @@ in the format specified by FMT."
                   channels))))
   (display-package-search-path fmt))
 
-(define (display-profile-content profile number)
-  "Display the packages in PROFILE, generation NUMBER, in a human-readable
-way and displaying details about the channel's source code."
-  (display-generation profile number)
-  (for-each (lambda (entry)
-              (format #t "  ~a ~a~%"
-                      (manifest-entry-name entry)
-                      (manifest-entry-version entry))
-              (match (manifest-entry-channel entry)
-                ((? channel? 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))))
-                (_ #f)))
+(define (profile-generation-channels profile number)
+  "Return the list of channels for generation NUMBER of PROFILE."
+  (profile-channels (if (zero? number)
+                        profile
+                        (generation-file-name profile number))))
 
-            ;; Show most recently installed packages last.
-            (reverse
-             (manifest-entries
-              (profile-manifest (if (zero? number)
-                                    profile
-                                    (generation-file-name profile number)))))))
+(define* (display-profile-content profile number
+                                  #:optional
+                                  (channels
+                                   (profile-generation-channels profile
+                                                                number)))
+  "Display CHANNELS along with PROFILE info, generation NUMBER, in a
+human-readable way and displaying details about the channel's source code.
+PROFILE and NUMBER "
+  (when (and number profile)
+    (display-generation profile number))
+
+  (for-each (lambda (channel)
+              (format #t "  ~a ~a~%"
+                      (channel-name channel)
+                      (string-take (channel-commit channel) 7))
+              (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))))
+            channels))
 
 (define %vcs-web-views
   ;; Hard-coded list of host names and corresponding web view URL templates.
@@ -295,6 +297,10 @@ text.  The hyperlink links to a web view of COMMIT, when available."
     (with-error-handling
       (match profile
         (#f
-         (display-checkout-info format))
+         (match (current-channels)
+           (()
+            (display-checkout-info format))
+           (channels
+            (display-profile-info #f format channels))))
         (profile
          (display-profile-info (canonicalize-profile profile) format))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index f4d12f89bf..a39347743e 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -21,6 +21,7 @@
 (define-module (guix scripts environment)
   #:use-module (guix ui)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix grafts)
   #:use-module (guix derivations)
@@ -137,6 +138,8 @@ COMMAND or an interactive shell in that environment.\n"))
   (display (G_ "
   -m, --manifest=FILE    create environment with the manifest from FILE"))
   (display (G_ "
+  -p, --profile=PATH     create environment from profile at PATH"))
+  (display (G_ "
       --ad-hoc           include all specified packages in the environment instead
                          of only their inputs"))
   (display (G_ "
@@ -269,6 +272,10 @@ use '--preserve' instead~%"))
          (option '(#\P "link-profile") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'link-profile? #t result)))
+         (option '(#\p "profile") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'profile arg
+                               (alist-delete 'profile result eq?))))
          (option '(#\u "user") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'user arg
@@ -706,6 +713,7 @@ message if any test fails."
            (user       (assoc-ref opts 'user))
            (bootstrap? (assoc-ref opts 'bootstrap?))
            (system     (assoc-ref opts 'system))
+           (profile    (assoc-ref opts 'profile))
            (command    (or (assoc-ref opts 'exec)
                            ;; Spawn a shell if the user didn't specify
                            ;; anything in particular.
@@ -735,8 +743,16 @@ message if any test fails."
                                             #:dry-run?
                                             (assoc-ref opts 'dry-run?))
           (with-status-verbosity (assoc-ref opts 'verbosity)
-            (define manifest
+            (define manifest-from-opts
               (options/resolve-packages store opts))
+            (when (and profile
+                       (> (length (manifest-entries manifest-from-opts)) 0))
+              (leave (G_ "'--profile' cannot be used with package options~%")))
+
+            (define manifest
+              (if profile
+                (profile-manifest profile)
+                manifest-from-opts))
 
             (set-build-options-from-command-line store opts)
 
@@ -755,7 +771,9 @@ message if any test fails."
                                                                    system))
                                      (prof-drv   (manifest->derivation
                                                   manifest system bootstrap?))
-                                     (profile -> (derivation->output-path prof-drv))
+                                     (profile -> (if profile
+                                                   (readlink* profile)
+                                                   (derivation->output-path prof-drv)))
                                      (gc-root -> (assoc-ref opts 'gc-root)))
 
                   ;; First build the inputs.  This is necessary even for