ui: Add a 'define-diagnostic' macro.

[jackhill/guix/guix.git] / guix / scripts / package.scm

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 89708cc..c5656ef 100644 (file)
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -208,10 +208,11 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
       (switch-symlinks profile previous-profile))
 
     (cond ((not (file-exists? profile))           ; invalid profile
-           (leave (_ "error: profile `~a' does not exist~%")
+           (leave (_ "profile `~a' does not exist~%")
                   profile))
           ((zero? number)                         ; empty profile
-           (leave (_ "nothing to do: already at the empty profile~%")))
+           (format (current-error-port)
+                   (_ "nothing to do: already at the empty profile~%")))
           ((or (zero? previous-number)            ; going to emptiness
                (not (file-exists? previous-profile)))
            (let*-values (((drv-path drv)
@@ -265,19 +266,42 @@ matching packages."
                        (assoc-ref (derivation-outputs drv) sub-drv))))
          `(,name ,out))))))
 
+(define %sigint-prompt
+  ;; The prompt to jump to upon SIGINT.
+  (make-prompt-tag "interruptible"))
+
+(define (call-with-sigint-handler thunk handler)
+  "Call THUNK and return its value.  Upon SIGINT, call HANDLER with the signal
+number in the context of the continuation of the call to this function, and
+return its return value."
+  (call-with-prompt %sigint-prompt
+                    (lambda ()
+                      (sigaction SIGINT
+                        (lambda (signum)
+                          (sigaction SIGINT SIG_DFL)
+                          (abort-to-prompt %sigint-prompt signum)))
+                      (thunk))
+                    (lambda (k signum)
+                      (handler signum))))
+
 (define-syntax-rule (waiting exp fmt rest ...)
   "Display the given message while EXP is being evaluated."
   (let* ((message (format #f fmt rest ...))
          (blank   (make-string (string-length message) #\space)))
     (display message (current-error-port))
     (force-output (current-error-port))
-    (let ((result exp))
-      ;; Clear the line.
-      (display #\cr (current-error-port))
-      (display blank (current-error-port))
-      (display #\cr (current-error-port))
-      (force-output (current-error-port))
-      exp)))
+    (call-with-sigint-handler
+     (lambda ()
+       (let ((result exp))
+         ;; Clear the line.
+         (display #\cr (current-error-port))
+         (display blank (current-error-port))
+         (display #\cr (current-error-port))
+         (force-output (current-error-port))
+         exp))
+     (lambda (signum)
+       (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
+       #f))))
 
 (define (check-package-freshness package)
   "Check whether PACKAGE has a newer version available upstream, and report
@@ -313,7 +337,8 @@ but ~a is available upstream~%")
 
 (define %default-options
   ;; Alist of default option values.
-  `((profile . ,%current-profile)))
+  `((profile . ,%current-profile)
+    (substitutes? . #t)))
 
 (define (show-help)
   (display (_ "Usage: guix package [OPTION]... PACKAGES...
@@ -326,7 +351,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   (display (_ "
   -r, --remove=PACKAGE   remove PACKAGE"))
   (display (_ "
-  -u, --upgrade=REGEXP   upgrade all the installed packages matching REGEXP"))
+  -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
   (display (_ "
       --roll-back        roll back to the previous generation"))
   (newline)
@@ -334,6 +359,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
   (display (_ "
   -n, --dry-run          show what would be done without actually doing it"))
+  (display (_ "
+      --no-substitutes   build instead of resorting to pre-built substitutes"))
   (display (_ "
       --bootstrap        use the bootstrap Guile to build the profile"))
   (display (_ "
@@ -375,7 +402,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '(#\r "remove") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'remove arg result)))
-        (option '(#\u "upgrade") #t #f
+        (option '(#\u "upgrade") #f #t
                 (lambda (opt name arg result)
                   (alist-cons 'upgrade arg result)))
         (option '("roll-back") #f #f
@@ -388,6 +415,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
+        (option '("no-substitutes") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'substitutes? #f
+                              (alist-delete 'substitutes? result))))
         (option '("bootstrap") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'bootstrap? #t result)))
@@ -446,8 +477,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
     (define (ensure-output p sub-drv)
       (if (member sub-drv (package-outputs p))
           p
-          (leave (_ "~a: error: package `~a' lacks output `~a'~%")
-                 (location->string (package-location p))
+          (leave (_ "package `~a' lacks output `~a'~%")
                  (package-full-name p)
                  sub-drv)))
 
@@ -594,7 +624,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (let* ((installed (manifest-packages (profile-manifest profile)))
                (upgrade-regexps (filter-map (match-lambda
                                              (('upgrade . regexp)
-                                              (make-regexp regexp))
+                                              (make-regexp (or regexp "")))
                                              (_ #f))
                                             opts))
                (upgrade  (if (null? upgrade-regexps)
@@ -666,7 +696,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
             (ensure-default-profile))
 
           (show-what-to-remove/install remove* install* dry-run?)
-          (show-what-to-build (%store) drv dry-run?)
+          (show-what-to-build (%store) drv
+                              #:use-substitutes? (assoc-ref opts 'substitutes?)
+                              #:dry-run? dry-run?)
 
           (or dry-run?
               (and (build-derivations (%store) drv)
@@ -750,6 +782,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
     (or (process-query opts)
         (with-error-handling
           (parameterize ((%store (open-connection)))
+            (set-build-options (%store)
+                               #:use-substitutes?
+                               (assoc-ref opts 'substitutes?))
+
             (parameterize ((%guile-for-build
                             (package-derivation (%store)
                                                 (if (assoc-ref opts 'bootstrap?)