Re: [PATCH] guix: refresh: Use bags.

[Eric Bavier]

Ludovic Courtès writes:

> Eric Bavier <address@hidden> skribis:
>
>> Ludovic Courtès writes:
>>
>> From 1d22367e0806cea004631e22a782b7db3ffe65b0 Mon Sep 17 00:00:00 2001
>> From: Eric Bavier <address@hidden>
>> Date: Mon, 13 Oct 2014 13:46:09 -0500
>> Subject: [PATCH] guix: refresh: Use bags.
>>
>> * guix/packages.scm (bag-direct-inputs): New procedure.
>> * gnu/packages.scm (package-dependencies): Use it.
>>   (fold-packages*): New procedure.
>> * guix/scripts/refresh.scm (guix-refresh)[list-dependent]: Use it.
>
> [...]
>
> Could you move the computation of the package list to a different
> procedure?  Possibly merging it with the existing expression that
> computes ‘packages’ and which is already quite big.

New patch attached that cleans up the package list computation a bit.

>From 0125e2d9a1564eb5e0817d50ea304bb4cb8d7030 Mon Sep 17 00:00:00 2001
From: Eric Bavier <address@hidden>
Date: Mon, 20 Oct 2014 11:44:03 -0500
Subject: [PATCH] guix: refresh: Use bags.

* guix/packages.scm (bag-direct-inputs): New procedure.
* gnu/packages.scm (package-dependencies): Use it.
  (fold-packages*): New procedure.
* guix/scripts/refresh.scm (guix-refresh)[list-dependent]: Use it.
---
 gnu/packages.scm         |   19 +++++++--
 guix/packages.scm        |   11 +++--
 guix/scripts/refresh.scm |  100 +++++++++++++++++++++++++++++-----------------
 3 files changed, 87 insertions(+), 43 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 281d0d2..d3a064c 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -38,6 +38,7 @@
             %package-module-path
 
             fold-packages
+            fold-packages*
 
             find-packages-by-name
             find-best-packages-by-name
@@ -179,6 +180,18 @@ same package twice."
           vlist-null
           (all-package-modules))))
 
+(define (fold-packages* proc init)
+  "Call (PROC PACKAGE RESULT) for every defined package, including
+module-private packages, using INIT as the initial value of RESULT.  It is
+guaranteed to never traverse the same package twice."
+  (fold-tree
+   proc init
+   (lambda (package)
+     (match (bag-direct-inputs (package->bag package))
+       (((labels inputs . _) ...)
+        (filter package? inputs))))
+   (fold-packages cons '())))
+
 (define find-packages-by-name
   (let ((packages (delay
                     (fold-packages (lambda (p r)
@@ -250,9 +263,9 @@ list of packages that depend on that package."
                         (cons package (vhash-refq d in '()))
                         (vhash-delq in d)))
          dag
-         (match (package-direct-inputs package)
-           (((labels packages . _) ...)
-            packages) )))
+         (match (bag-direct-inputs (package->bag package))
+           (((labels inputs . _) ...)
+            (filter package? inputs)))))
       vlist-null))))
 
 (define (package-direct-dependents packages)
diff --git a/guix/packages.scm b/guix/packages.scm
index b397a24..4bf0a08 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -98,6 +98,7 @@
 
             package->bag
             bag->derivation
+            bag-direct-inputs
             bag-transitive-inputs
             bag-transitive-host-inputs
             bag-transitive-build-inputs
@@ -537,11 +538,15 @@ for the host system (\"native inputs\"), and not target 
inputs."
 recursively."
   (transitive-inputs (package-propagated-inputs package)))
 
+(define (bag-direct-inputs bag)
+  "Same as 'package-direct-inputs', but applied to a bag."
+  (append (bag-build-inputs bag)
+          (bag-host-inputs bag)
+          (bag-target-inputs bag)))
+
 (define (bag-transitive-inputs bag)
   "Same as 'package-transitive-inputs', but applied to a bag."
-  (transitive-inputs (append (bag-build-inputs bag)
-                             (bag-host-inputs bag)
-                             (bag-target-inputs bag))))
+  (transitive-inputs (bag-direct-inputs bag)))
 
 (define (bag-transitive-build-inputs bag)
   "Same as 'package-transitive-native-inputs', but applied to a bag."
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index d31e6d4..1f878d8 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -182,6 +182,39 @@ downloaded and authenticated; not updating")
         (_
          (cons package lst)))))
 
+  (define* (package-specs->packages specs #:key (include-private? #f))
+    "Return a list of packages from the package specifications in SPECS.  If
+INCLUDE-PRIVATE? is #t, then also include module-private packages having the
+same specification."
+    (let ((packages (map specification->package specs)))
+      (if include-private?
+          (fold-packages*
+           (let ((names (map package-full-name packages)))
+             (lambda (package result)
+               (if (find (cut string=? (package-full-name package) <>)
+                         names)
+                   (cons package result)
+                   result)))
+           '())
+          packages)))
+
+  (define (select-newest-packages select?)
+    "Return a list of packages for which (SELECT? PACKAGE) return #t.  If
+multiple packages of the same name are selected, only the newest version is
+returned."
+    (fold-packages (lambda (package result)
+                     (if (select? package)
+                         (keep-newest package result)
+                         result))
+                   '()))
+
+  (define (packages-from-specs-or-select specs select?)
+    "Return a list of packages from the package specifications in SPECS, or by
+selecting the newest packages with SELECT?."
+    (match specs
+      (() (select-newest-packages select?))
+      (specs (package-specs->packages specs))))
+
   (define core-package?
     (let* ((input->package (match-lambda
                             ((name (? package? package) _ ...) package)
@@ -206,33 +239,24 @@ update would trigger a complete rebuild."
          (update?         (assoc-ref opts 'update?))
          (list-dependent? (assoc-ref opts 'list-dependent?))
          (key-download    (assoc-ref opts 'key-download))
-         (packages
-          (match (concatenate
-                  (filter-map (match-lambda
-                               (('argument . value)
-                                (let ((p (find-packages-by-name value)))
-                                  (when (null? p)
-                                    (leave (_ "~a: no package by that name~%")
-                                           value))
-                                  p))
-                               (_ #f))
-                              opts))
-                 (()                          ; default to all packages
-                  (let ((select? (match (assoc-ref opts 'select)
-                                        ('core core-package?)
-                                        ('non-core (negate core-package?))
-                                        (_ (const #t)))))
-                    (fold-packages (lambda (package result)
-                                     (if (select? package)
-                                         (keep-newest package result)
-                                         result))
-                                   '())))
-                 (some                        ; user-specified packages
-                  some))))
+         (package-specs   (filter-map (match-lambda
+                                       (('argument . value) value)
+                                       (_ #f))
+                                      opts))
+         (select?         (match (assoc-ref opts 'select)
+                            ('core core-package?)
+                            ('non-core (negate core-package?))
+                            (_ (const #t)))))
     (with-error-handling
       (cond
        (list-dependent?
-        (let* ((rebuilds (map package-full-name
+        (let* ((packages (match package-specs
+                           (()
+                            (leave (_ "package arguments required~%")))
+                           (specs
+                            (package-specs->packages
+                             specs #:include-private? #t))))
+               (rebuilds (map package-full-name
                               (package-covering-dependents packages)))
                (total-dependents
                 (length (package-transitive-dependents packages))))
@@ -252,7 +276,8 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
                           (length rebuilds))
                       (length rebuilds) total-dependents rebuilds))))
        (update?
-        (let ((store (open-connection)))
+        (let ((store    (open-connection))
+              (packages (packages-from-specs-or-select package-specs select?)))
           (parameterize ((%openpgp-key-server
                           (or (assoc-ref opts 'key-server)
                               (%openpgp-key-server)))
@@ -263,15 +288,16 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
              (cut update-package store <> #:key-download key-download)
              packages))))
        (else
-        (for-each (lambda (package)
-                    (match (false-if-exception (package-update-path package))
-                      ((new-version . directory)
-                       (let ((loc (or (package-field-location package 'version)
-                                      (package-location package))))
-                         (format (current-error-port)
-                                 (_ "~a: ~a would be upgraded from ~a to ~a~%")
-                                 (location->string loc)
-                                 (package-name package) (package-version 
package)
-                                 new-version)))
-                      (_ #f)))
-                  packages))))))
+        (let ((packages (packages-from-specs-or-select package-specs select?)))
+          (for-each (lambda (package)
+                      (match (false-if-exception (package-update-path package))
+                        ((new-version . directory)
+                         (let ((loc (or (package-field-location package 
'version)
+                                        (package-location package))))
+                           (format (current-error-port)
+                                   (_ "~a: ~a would be upgraded from ~a to 
~a~%")
+                                   (location->string loc)
+                                   (package-name package) (package-version 
package)
+                                   new-version)))
+                        (_ #f)))
+                    packages)))))))
-- 
1.7.9.5

This patch also changes the behavior of `guix refresh` a little.
Previously, if there were a package with two versions, e.g. bison-2.7
and bison-3.0.2, `guix refresh bison` would report::

  gnu/packages/bison.scm:33:4: bison would be upgraded from 2.7 to 3.0.2

Which is silly because we already have a bison-3.0.2.  This patch uses
specification->package for the command-line named packages, so that only
the newest version of a package is considered by default for upgrading.
I would imagine this is the expected behavior.

> It would be nice to show this info on the output of
> build-aux/list-packages.scm (used to build
> <https://www.gnu.org/software/guix/package-list.html>.)

I'm following up this message with a new patch thread for this.

-- 
Eric Bavier