From 5d6d81e4c3e37de53fe7f62ff7ef94da8b2df033 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 15 Nov 2020 16:59:48 +0100
Subject: [PATCH 2/4] DRAFT transformations: Add '--with-parameter'.

DRAFT: Missing tests & doc.

* guix/transformations.scm (evaluate-parameter-specs)
(transform-package-parameters): New procedures.
(%transformations, %transformation-options): Add 'with-parameter'.
---
 guix/transformations.scm | 39 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 39 insertions(+)

diff --git a/guix/transformations.scm b/guix/transformations.scm
index 30142dd059..0f83eb470d 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -25,6 +25,7 @@
   #:autoload   (guix download) (download-to-store)
   #:autoload   (guix git-download) (git-reference? git-reference-url)
   #:autoload   (guix git) (git-checkout git-checkout? git-checkout-url)
+  #:autoload   (guix parameters) (set-package-parameter-value)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix gexp)
@@ -324,6 +325,41 @@ a checkout of the Git repository at the given URL."
         (rewrite obj)
         obj)))
 
+(define (evaluate-parameter-specs specs proc)
+  "Parse SPECS, a list of strings like \"bitlbee=purple=true\", and return a
+list of spec/procedure pairs, where (PROC PACKAGE PARAMETER VALUE) is called
+to return the replacement package.  Raise an error if an element of SPECS uses
+invalid syntax, or if a package it refers to could not be found."
+  (map (lambda (spec)
+         (match (string-tokenize spec %not-equal)
+           ((spec name value)
+            (define (replace old)
+              (proc old name value))
+
+            (cons spec replace))
+           (_
+            (raise
+             (formatted-message
+              (G_ "invalid package parameter specification: ~s")
+              spec)))))
+       specs))
+
+(define (transform-package-parameters replacement-specs)
+  "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
+strings like \"guile-next=stable-3.0\" meaning that packages are built using
+'guile-next' from the latest commit on its 'stable-3.0' branch."
+  (define (replace old name value)
+    (set-package-parameter-value old name value))
+
+  (let* ((replacements (evaluate-parameter-specs replacement-specs
+                                                 replace))
+         (rewrite      (package-input-rewriting/spec replacements)))
+    (lambda (obj)
+      (if (package? obj)
+          (rewrite obj)
+          obj))))
+
 (define (package-dependents/spec top bottom)
   "Return the list of dependents of BOTTOM, a spec string, that are also
 dependencies of TOP, a package."
@@ -467,6 +503,7 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
     (with-branch . ,transform-package-source-branch)
     (with-commit . ,transform-package-source-commit)
     (with-git-url . ,transform-package-source-git-url)
+    (with-parameter . ,transform-package-parameters)
     (with-c-toolchain . ,transform-package-toolchain)
     (with-debug-info . ,transform-package-with-debug-info)
     (without-tests . ,transform-package-tests)))
@@ -503,6 +540,8 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
                   (parser 'with-commit))
           (option '("with-git-url") #t #f
                   (parser 'with-git-url))
+          (option '("with-parameter") #t #f
+                  (parser 'with-parameter))
           (option '("with-c-toolchain") #t #f
                   (parser 'with-c-toolchain))
           (option '("with-debug-info") #t #f
-- 
2.29.2