gnu: Add perl-getopt-tabular.

[jackhill/guix/guix.git] / emacs / guix-main.scm

diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm
index 1dd57bb..ae3a492 100644 (file)
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -46,10 +46,12 @@
  (ice-9 vlist)
  (ice-9 match)
  (srfi srfi-1)
+ (srfi srfi-2)
  (srfi srfi-11)
  (srfi srfi-19)
  (srfi srfi-26)
  (guix)
+ (guix git-download)
  (guix packages)
  (guix profiles)
  (guix licenses)
@@ -106,6 +108,38 @@
    (manifest-entry-version entry)
    (manifest-entry-output  entry)))
 
+(define (manifest-entry->package-specification entry)
+  (call-with-values
+      (lambda () (manifest-entry->name+version+output entry))
+    make-package-specification))
+
+(define (manifest-entries->package-specifications entries)
+  (map manifest-entry->package-specification entries))
+
+(define (generation-package-specifications profile number)
+  "Return a list of package specifications for generation NUMBER."
+  (let ((manifest (profile-manifest
+                   (generation-file-name profile number))))
+    (manifest-entries->package-specifications
+     (manifest-entries manifest))))
+
+(define (generation-package-specifications+paths profile number)
+  "Return a list of package specifications and paths for generation NUMBER.
+Each element of the list is a list of the package specification and its path."
+  (let ((manifest (profile-manifest
+                   (generation-file-name profile number))))
+    (map (lambda (entry)
+           (list (manifest-entry->package-specification entry)
+                 (manifest-entry-item entry)))
+         (manifest-entries manifest))))
+
+(define (generation-difference profile number1 number2)
+  "Return a list of package specifications for outputs installed in generation
+NUMBER1 and not installed in generation NUMBER2."
+  (let ((specs1 (generation-package-specifications profile number1))
+        (specs2 (generation-package-specifications profile number2)))
+    (lset-difference string=? specs1 specs2)))
+
 (define (manifest-entries->hash-table entries)
   "Return a hash table of name keys and lists of matching manifest ENTRIES."
   (let ((table (make-hash-table (length entries))))
@@ -220,6 +254,18 @@ Example:
                      (license-name license)))
               (list-maybe (package-license package))))
 
+(define (package-source-names package)
+  "Return a list of source names (URLs) of the PACKAGE."
+  (let ((source (package-source package)))
+    (and (origin? source)
+         (filter-map (lambda (uri)
+                       (cond ((string? uri)
+                              uri)
+                             ((git-reference? uri)
+                              (git-reference-url uri))
+                             (else "Unknown source type")))
+                     (list-maybe (origin-uri source))))))
+
 (define (package-unique? package)
   "Return #t if PACKAGE is a single package with such name/version."
   (null? (cdr (packages-by-name (package-name package)
@@ -231,6 +277,7 @@ Example:
     (name              . ,package-name)
     (version           . ,package-version)
     (license           . ,package-license-names)
+    (source            . ,package-source-names)
     (synopsis          . ,package-synopsis)
     (description       . ,package-description)
     (home-url          . ,package-home-page)
@@ -625,8 +672,15 @@ See 'entry-sexps' for details."
                       (generation-file-name profile (car search-vals))
                       profile))
          (manifest (profile-manifest profile))
-         (patterns (apply (patterns-maker entry-type search-type)
-                          manifest search-vals))
+         (patterns (if (and (eq? entry-type 'output)
+                            (eq? search-type 'generation-diff))
+                       (match search-vals
+                         ((g1 g2)
+                          (map specification->output-pattern
+                               (generation-difference profile g1 g2)))
+                         (_ '()))
+                       (apply (patterns-maker entry-type search-type)
+                              manifest search-vals)))
          (->sexps ((pattern-transformer entry-type) manifest params)))
     (append-map ->sexps patterns)))
 
@@ -803,6 +857,7 @@ OUTPUTS is a list of package outputs (may be an empty list)."
                (derivations (list derivation))
                (new-profile (derivation->output-path derivation)))
           (set-build-options store
+                             #:print-build-trace #f
                              #:use-substitutes? use-substitutes?)
           (show-manifest-transaction store manifest transaction
                                      #:dry-run? dry-run?)
@@ -828,3 +883,38 @@ OUTPUTS is a list of package outputs (may be an empty list)."
 GENERATIONS is a list of generation numbers."
   (with-store store
     (delete-generations store profile generations)))
+
+(define (package-source-derivation->store-path derivation)
+  "Return a store path of the package source DERIVATION."
+  (match (derivation-outputs derivation)
+    ;; Source derivation is always (("out" . derivation)).
+    (((_ . output-drv))
+     (derivation-output-path output-drv))
+    (_ #f)))
+
+(define (package-source-path package-id)
+  "Return a store file path to a source of a package PACKAGE-ID."
+  (and-let* ((package (package-by-id package-id))
+             (source  (package-source package)))
+    (with-store store
+      (package-source-derivation->store-path
+       (package-source-derivation store source)))))
+
+(define* (package-source-build-derivation package-id #:key dry-run?
+                                          (use-substitutes? #t))
+  "Build source derivation of a package PACKAGE-ID."
+  (and-let* ((package (package-by-id package-id))
+             (source  (package-source package)))
+    (with-store store
+      (let* ((derivation  (package-source-derivation store source))
+             (derivations (list derivation)))
+        (set-build-options store
+                           #:print-build-trace #f
+                           #:use-substitutes? use-substitutes?)
+        (show-what-to-build store derivations
+                            #:use-substitutes? use-substitutes?
+                            #:dry-run? dry-run?)
+        (unless dry-run?
+          (build-derivations store derivations))
+        (format #t "The source store path: ~a~%"
+                (package-source-derivation->store-path derivation))))))