From 79601521fceb6b2f76d87cf3df45a76e43b1ffcf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 30 Aug 2014 21:52:32 +0200
Subject: profiles: Compute transaction effects in a functional way.

* guix/profiles.scm (manifest-transaction-effects): New procedure.
  (manifest-show-transaction): Use it instead of locally computing it.
* tests/profiles.scm (glibc): New variable.
  ("manifest-transaction-effects"): New test.
---
 guix/profiles.scm  | 49 +++++++++++++++++++++++++++++++++----------------
 tests/profiles.scm | 19 +++++++++++++++++++
 2 files changed, 52 insertions(+), 16 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 55c3b6e768..843040156c 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -32,6 +32,7 @@
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:export (manifest make-manifest
@@ -60,6 +61,7 @@
             manifest-transaction-install
             manifest-transaction-remove
             manifest-perform-transaction
+            manifest-transaction-effects
             manifest-show-transaction
 
             profile-manifest
@@ -266,6 +268,35 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
   (remove  manifest-transaction-remove  ; list of <manifest-pattern>
            (default '())))
 
+(define (manifest-transaction-effects manifest transaction)
+  "Compute the effect of applying TRANSACTION to MANIFEST.  Return 3 values:
+the list of packages that would be removed, installed, or upgraded when
+applying TRANSACTION to MANIFEST."
+  (define (manifest-entry->pattern entry)
+    (manifest-pattern
+      (name   (manifest-entry-name entry))
+      (output (manifest-entry-output entry))))
+
+  (let loop ((input    (manifest-transaction-install transaction))
+             (install '())
+             (upgrade '()))
+    (match input
+      (()
+       (let ((remove (manifest-transaction-remove transaction)))
+         (values (manifest-matching-entries manifest remove)
+                 (reverse install) (reverse upgrade))))
+      ((entry rest ...)
+       ;; Check whether installing ENTRY corresponds to the installation of a
+       ;; new package or to an upgrade.
+
+       ;; XXX: When the exact same output directory is installed, we're not
+       ;; really upgrading anything.  Add a check for that case.
+       (let* ((pattern  (manifest-entry->pattern entry))
+              (upgrade? (manifest-installed? manifest pattern)))
+         (loop rest
+               (if upgrade? install (cons entry install))
+               (if upgrade? (cons entry upgrade) upgrade)))))))
+
 (define (manifest-perform-transaction manifest transaction)
   "Perform TRANSACTION on MANIFEST and return new manifest."
   (let ((install (manifest-transaction-install transaction))
@@ -284,22 +315,8 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
                        item)))
          name version output item))
 
-  (let* ((remove (manifest-matching-entries
-                  manifest (manifest-transaction-remove transaction)))
-         (install/upgrade (manifest-transaction-install transaction))
-         (install '())
-         (upgrade (append-map
-                   (lambda (entry)
-                     (let ((matching
-                            (manifest-matching-entries
-                             manifest
-                             (list (manifest-pattern
-                                    (name   (manifest-entry-name entry))
-                                    (output (manifest-entry-output entry)))))))
-                       (when (null? matching)
-                         (set! install (cons entry install)))
-                       matching))
-                   install/upgrade)))
+  (let-values (((remove install upgrade)
+                (manifest-transaction-effects manifest transaction)))
     (match remove
       ((($ <manifest-entry> name version output item _) ..1)
        (let ((len    (length name))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 047c5ba49b..d88def32fd 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -26,6 +26,7 @@
   #:use-module (guix derivations)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64))
 
 ;; Test the (guix profiles) module.
@@ -53,6 +54,13 @@
   (manifest-entry (inherit guile-2.0.9)
     (output "debug")))
 
+(define glibc
+  (manifest-entry
+    (name "glibc")
+    (version "2.19")
+    (item "/gnu/store/...")
+    (output "out")))
+
 
 (test-begin "profiles")
 
@@ -136,6 +144,17 @@
          (equal? m1 m2)
          (null? (manifest-entries m3)))))
 
+(test-assert "manifest-transaction-effects"
+  (let* ((m0 (manifest (list guile-1.8.8)))
+         (t  (manifest-transaction
+              (install (list guile-2.0.9 glibc))
+              (remove (list (manifest-pattern (name "coreutils")))))))
+    (let-values (((remove install upgrade)
+                  (manifest-transaction-effects m0 t)))
+      (and (null? remove)
+           (equal? (list glibc) install)
+           (equal? (list guile-2.0.9) upgrade)))))
+
 (test-assert "profile-derivation"
   (run-with-store %store
     (mlet* %store-monad
-- 
cgit v1.2.1