[PATCH 1/2] build: Generalize 'package-with-explicit-python'.

[Federico Beffa <beffa@ieee.org>]

[-- Attachment #1: Type: text/plain, Size: 77 bytes --]

Generalize the Python procedure to recursively replace compiler/interpreter.

[-- Attachment #2: 0001-build-Generalize-package-with-explicit-python.patch --]
[-- Type: text/x-patch, Size: 10830 bytes --]

From a8220b430d196e5bb079e23ac63b1acd16fdaaee Mon Sep 17 00:00:00 2001
From: Federico Beffa <beffa@fbengineering.ch>
Date: Wed, 8 Feb 2017 18:55:32 +0100
Subject: [PATCH 1/2] build: Generalize 'package-with-explicit-python'.

* guix/build-system/python.scm (package-with-explicit-python): Remove it and
  replace it with the generalized procedure 'package-with-explicit-compiler'
  in the new file. (package-with-python2): Adapt it.
* guix/build-system/utils.scm: New file with the generalized procedure.
* Makefile.am (MODULES): Add new file.
---
 Makefile.am                  |   1 +
 guix/build-system/python.scm |  71 +++--------------------------
 guix/build-system/utils.scm  | 105 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 112 insertions(+), 65 deletions(-)
 create mode 100644 guix/build-system/utils.scm

diff --git a/Makefile.am b/Makefile.am
index 360c356f1..2d2544a7b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -76,6 +76,7 @@ MODULES =					\
   guix/build-system/r.scm			\
   guix/build-system/ruby.scm			\
   guix/build-system/trivial.scm			\
+  guix/build-system/utils.scm			\
   guix/ftp-client.scm				\
   guix/http-client.scm				\
   guix/gnupg.scm				\
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 17173f121..8b3eb4008 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +28,7 @@
   #:use-module (guix search-paths)
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build-system utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -70,75 +72,14 @@ extension, such as '.tar.gz'."
   (let ((python (resolve-interface '(gnu packages python))))
     (module-ref python 'python-2)))
 
-(define* (package-with-explicit-python python old-prefix new-prefix
-                                       #:key variant-property)
-  "Return a procedure of one argument, P.  The procedure creates a package with
-the same fields as P, which is assumed to use PYTHON-BUILD-SYSTEM, such that
-it is compiled with PYTHON instead.  The inputs are changed recursively
-accordingly.  If the name of P starts with OLD-PREFIX, this is replaced by
-NEW-PREFIX; otherwise, NEW-PREFIX is prepended to the name.
-
-When VARIANT-PROPERTY is present, it is used as a key to search for
-pre-defined variants of this transformation recorded in the 'properties' field
-of packages.  The property value must be the promise of a package.  This is a
-convenient way for package writers to force the transformation to use
-pre-defined variants."
-  (define transform
-    ;; Memoize the transformations.  Failing to do that, we would build a huge
-    ;; object graph with lots of duplicates, which in turns prevents us from
-    ;; benefiting from memoization in 'package-derivation'.
-    (mlambdaq (p)
-      (let* ((rewrite-if-package
-              (lambda (content)
-                ;; CONTENT may be a file name, in which case it is returned,
-                ;; or a package, which is rewritten with the new PYTHON and
-                ;; NEW-PREFIX.
-                (if (package? content)
-                    (transform content)
-                    content)))
-             (rewrite
-              (match-lambda
-                ((name content . rest)
-                 (append (list name (rewrite-if-package content)) rest)))))
-
-        (cond
-         ;; If VARIANT-PROPERTY is present, use that.
-         ((and variant-property
-               (assoc-ref (package-properties p) variant-property))
-          => force)
-
-         ;; Otherwise build the new package object graph.
-         ((eq? (package-build-system p) python-build-system)
-          (package
-            (inherit p)
-            (location (package-location p))
-            (name (let ((name (package-name p)))
-                    (string-append new-prefix
-                                   (if (string-prefix? old-prefix name)
-                                       (substring name
-                                                  (string-length old-prefix))
-                                       name))))
-            (arguments
-             (let ((python (if (promise? python)
-                               (force python)
-                               python)))
-               (ensure-keyword-arguments (package-arguments p)
-                                         `(#:python ,python))))
-            (inputs (map rewrite (package-inputs p)))
-            (propagated-inputs (map rewrite (package-propagated-inputs p)))
-            (native-inputs (map rewrite (package-native-inputs p)))))
-         (else
-          p)))))
-
-  transform)
-
 (define package-with-python2
   ;; Note: delay call to 'default-python2' until after the 'arguments' field
   ;; of packages is accessed to avoid a circular dependency when evaluating
   ;; the top-level of (gnu packages python).
-  (package-with-explicit-python (delay (default-python2))
-                                "python-" "python2-"
-                                #:variant-property 'python2-variant))
+  (package-with-explicit-compiler (delay (default-python2))
+                                  'python
+                                  "python-" "python2-"
+                                  #:variant-property 'python2-variant))
 
 (define (strip-python2-variant p)
   "Remove the 'python2-variant' property from P."
diff --git a/guix/build-system/utils.scm b/guix/build-system/utils.scm
new file mode 100644
index 000000000..400696030
--- /dev/null
+++ b/guix/build-system/utils.scm
@@ -0,0 +1,105 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system utils)
+  #:use-module (guix build-system)
+  #:use-module (guix memoization)
+  #:use-module (guix packages)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:export (package-with-explicit-compiler))
+
+;; Note: delay call to 'compiler' until after the 'arguments' field of
+;; packages is accessed to avoid a circular dependency when evaluating the
+;; top-level of (gnu packages python).  For a similar reason we pass the name
+;; of the build-system and not the build-system itself.
+(define* (package-with-explicit-compiler compiler bs-name
+                                         old-prefix new-prefix
+                                         #:key variant-property)
+  "Return a procedure of one argument, P.  The procedure creates a package
+with the same fields as P, which is assumed a build-system named BS-NAME, such
+that it is compiled with COMPILER instead.  The inputs are changed recursively
+accordingly.  If the name of P starts with OLD-PREFIX, this is replaced by
+NEW-PREFIX; otherwise, NEW-PREFIX is prepended to the name.
+
+When VARIANT-PROPERTY is present, it is used as a key to search for
+pre-defined variants of this transformation recorded in the 'properties' field
+of packages.  The property value must be the promise of a package.  This is a
+convenient way for package writers to force the transformation to use
+pre-defined variants."
+  (define (maybe-force maybe-promise)
+    (if (promise? maybe-promise)
+        (force maybe-promise)
+        maybe-promise))
+
+  (define compiler-keyword
+    (case bs-name
+      ((haskell python emacs perl r ruby) (symbol->keyword bs-name))
+      (else
+       (leave (_ "Operation not supported by the build system: ~A~%") bs-name))))
+
+  (define transform
+    ;; Memoize the transformations.  Failing to do that, we would build a huge
+    ;; object graph with lots of duplicates, which in turns prevents us from
+    ;; benefiting from memoization in 'package-derivation'.
+    (mlambdaq (p)
+      (let* ((rewrite-if-package
+              (lambda (content)
+                ;; CONTENT may be a file name, in which case it is returned,
+                ;; or a package, which is rewritten with the new COMPILER and
+                ;; NEW-PREFIX.
+                (if (package? content)
+                    (transform content)
+                    content)))
+             (rewrite
+              (match-lambda
+                ((name content . rest)
+                 (append (list name (rewrite-if-package content)) rest)))))
+
+        (cond
+         ;; If VARIANT-PROPERTY is present, use that.
+         ((and variant-property
+               (assoc-ref (package-properties p) variant-property))
+          => force)
+
+         ;; Otherwise build the new package object graph.
+         ((eq? (build-system-name (package-build-system p)) bs-name)
+          (package
+            (inherit p)
+            (location (package-location p))
+            (name (let ((name (package-name p)))
+                    (string-append new-prefix
+                                   (if (string-prefix? old-prefix name)
+                                       (substring name
+                                                  (string-length old-prefix))
+                                       name))))
+            (arguments
+             (let ((compiler (maybe-force compiler)))
+               (ensure-keyword-arguments (package-arguments p)
+                                         `(,compiler-keyword ,compiler))))
+            (inputs (map rewrite (package-inputs p)))
+            (propagated-inputs (map rewrite (package-propagated-inputs p)))
+            (native-inputs (map rewrite (package-native-inputs p)))))
+         (else
+          p)))))
+
+  transform)
-- 
2.11.0