From a8220b430d196e5bb079e23ac63b1acd16fdaaee Mon Sep 17 00:00:00 2001 From: Federico Beffa 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 ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2017 Federico Beffa ;;; ;;; 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 +;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2017 Federico Beffa +;;; +;;; 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 . + +(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