[PATCH] guix environment: add a '--env-name' option

[Cyril Roelandt <tipecaml@gmail.com>]

* guix/scripts/environment.scm: add a '--env-name' option.
---
 guix/scripts/environment.scm | 26 +++++++++++++++++++++++++-
 1 file changed, 25 insertions(+), 1 deletion(-)

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 007fde1..1d078ce 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -30,6 +30,7 @@
   #:use-module (gnu packages)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
@@ -106,6 +107,8 @@ shell command in that environment.\n"))
       --ad-hoc           include all specified packages in the environment instead
                          of only their inputs"))
   (display (_ "
+      --env-name         name of the environment, used in the prompt"))
+  (display (_ "
       --pure             unset existing environment variables"))
   (display (_ "
       --search-paths     display needed environment variable definitions"))
@@ -124,6 +127,7 @@ shell command in that environment.\n"))
   `((exec . ,(or (getenv "SHELL") "/bin/sh"))
     (substitutes? . #t)
     (max-silent-time . 3600)
+    (env-name . "guix-env")
     (verbosity . 0)))
 
 (define %options
@@ -153,6 +157,9 @@ shell command in that environment.\n"))
          (option '("ad-hoc") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'ad-hoc? #t result)))
+         (option '("env-name") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'env-name arg result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
@@ -226,6 +233,20 @@ packages."
               (built-derivations drvs)
               (return drvs)))))))
 
+(define (run-shell shell env-name)
+  "Run the given SHELL, adding '(ENV-NAME) ' at the start of the prompt."
+  (cond ((string=? shell "/bin/bash")
+         (let* ((directory (or (getenv "TMPDIR") "/tmp"))
+                (template  (string-append directory "/guix-file.XXXXXX"))
+                (out       (mkstemp! template)))
+           (format out "export PS1=\"(~a) $PS1\"" env-name)
+           (flush-output-port out)
+           (system (string-append "/bin/bash --rcfile " template))))
+        (else
+         (begin
+           (warning (_ "Unknown shell, will not update the prompt"))
+           (system shell)))))
+
 ;; Entry point.
 (define (guix-environment . args)
   (define (handle-argument arg result)
@@ -237,6 +258,7 @@ packages."
            (pure?    (assoc-ref opts 'pure))
            (ad-hoc?  (assoc-ref opts 'ad-hoc?))
            (command  (assoc-ref opts 'exec))
+           (env-name (assoc-ref opts 'env-name))
            (packages (pick-all (options/resolve-packages opts) 'package))
            (inputs   (if ad-hoc?
                          (packages+propagated-inputs packages)
@@ -254,4 +276,6 @@ packages."
                (show-search-paths inputs drvs pure?))
               (else
                (create-environment inputs drvs pure?)
-               (system command)))))))
+               (if (string=? command (assoc-ref %default-options 'exec))
+                   (run-shell command env-name)
+                   (system command))))))))
-- 
1.8.4.rc3