[jackhill/guix/guix.git] / tests / transformations.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (test-transformations)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module ((guix gexp) #:select (lower-object))
  #:use-module ((guix profiles)
                #:select (package->manifest-entry
                          manifest-entry-properties))
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix transformations)
  #:use-module ((guix gexp) #:select (local-file? local-file-file))
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix git)
  #:use-module (guix upstream)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages busybox)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

\f
(test-begin "transformations")

(test-assert "options->transformation, no transformations"
  (let ((p (dummy-package "foo"))
        (t (options->transformation '())))
    (eq? (t p) p)))

(test-assert "options->transformation, with-source"
  ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
  ;; be applicable.
  (let* ((p (dummy-package "guix.scm"))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (with-store store
      (let* ((new (t p))
             (source (run-with-store store
                       (lower-object (package-source new)))))
        (and (not (eq? new p))
             (string=? source
                       (add-to-store store "guix.scm" #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-source, replacement"
  ;; Same, but this time the original package has a 'replacement' field.  We
  ;; expect that replacement to be set to #f in the new package.
  (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (not (package-replacement new))))))

(test-assert "options->transformation, with-source, with version"
  ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
  ;; should be applicable, and its version should be extracted.
  (let ((p (dummy-package "foo"))
        (s (search-path %load-path "guix.scm")))
    (call-with-temporary-directory
     (lambda (directory)
       (let* ((f (string-append directory "/foo-42.0.tar.gz"))
              (t (options->transformation `((with-source . ,f)))))
         (copy-file s f)
         (with-store store
           (let* ((new (t p))
                  (source (run-with-store store
                            (lower-object (package-source new)))))
             (and (not (eq? new p))
                  (string=? (package-name new) (package-name p))
                  (string=? (package-version new) "42.0")
                  (string=? source
                            (add-to-store store (basename f) #t
                                          "sha256" f))))))))))

(test-assert "options->transformation, with-source, no matches"
  ;; When a transformation in not applicable, a warning must be raised.
  (let* ((p (dummy-package "foobar"))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (let* ((port (open-output-string))
           (new  (parameterize ((guix-warning-port port))
                   (t p))))
      (and (eq? new p)
           (string-contains (get-output-string port)
                            "had no effect")))))

(test-assert "options->transformation, with-source, PKG=URI"
  (let* ((p (dummy-package "foo"))
         (s (search-path %load-path "guix.scm"))
         (f (string-append "foo=" s))
         (t (options->transformation `((with-source . ,f)))))
    (with-store store
      (let* ((new (t p))
             (source (run-with-store store
                       (lower-object (package-source new)))))
        (and (not (eq? new p))
             (string=? (package-name new) (package-name p))
             (string=? (package-version new)
                       (package-version p))
             (string=? source
                       (add-to-store store (basename s) #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-source, PKG@VER=URI"
  (let* ((p (dummy-package "foo"))
         (s (search-path %load-path "guix.scm"))
         (f (string-append "foo@42.0=" s))
         (t (options->transformation `((with-source . ,f)))))
    (with-store store
      (let* ((new (t p))
             (source (run-with-store store
                       (lower-object (package-source new)))))
        (and (not (eq? new p))
             (string=? (package-name new) (package-name p))
             (string=? (package-version new) "42.0")
             (string=? source
                       (add-to-store store (basename s) #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-input"
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,(specification->package "coreutils"))
                        ("bar" ,(specification->package "grep"))
                        ("baz" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-input . "coreutils=busybox")
                                       (with-input . "grep=findutils")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2) ("baz" dep3))
              (and (string=? (package-full-name dep1)
                             (package-full-name busybox))
                   (string=? (package-full-name dep2)
                             (package-full-name findutils))
                   (string=? (package-name dep3) "chbouib")
                   (match (package-native-inputs dep3)
                     ((("x" dep))
                      (string=? (package-full-name dep)
                                (package-full-name findutils)))))))))))

(test-assert "options->transformation, with-graft"
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-graft . "grep=findutils")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-full-name (package-replacement dep1))
                             (package-full-name findutils))
                   (string=? (package-name dep2) "chbouib")
                   (match (package-native-inputs dep2)
                     ((("x" dep))
                      (with-store store
                        (string=? (derivation-file-name
                                   (package-derivation store findutils))
                                  (derivation-file-name
                                   (package-derivation store dep)))))))))))))

(test-equal "options->transformation, with-branch"
  (git-checkout (url "https://example.org")
                (branch "devel")
                (recursive? #t))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (source (origin
                                            (method git-fetch)
                                            (uri (git-reference
                                                  (url "https://example.org")
                                                  (commit "cabba9e")))
                                            (sha256 #f)))))))))
         (t (options->transformation '((with-branch . "chbouib=devel")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-name dep2) "chbouib")
                   (package-source dep2))))))))

(test-equal "options->transformation, with-commit"
  (git-checkout (url "https://example.org")
                (commit "abcdef")
                (recursive? #t))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (source (origin
                                            (method git-fetch)
                                            (uri (git-reference
                                                  (url "https://example.org")
                                                  (commit "cabba9e")))
                                            (sha256 #f)))))))))
         (t (options->transformation '((with-commit . "chbouib=abcdef")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-name dep2) "chbouib")
                   (package-source dep2))))))))

(test-equal "options->transformation, with-git-url"
  (let ((source (git-checkout (url "https://example.org")
                              (recursive? #t))))
    (list source source))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-git-url . "grep=https://example.org")))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-full-name dep1)
                             (package-full-name grep))
                   (string=? (package-name dep2) "chbouib")
                   (match (package-native-inputs dep2)
                     ((("x" dep3))
                      (map package-source (list dep1 dep3)))))))))))

(test-equal "options->transformation, with-git-url + with-branch"
  ;; Combine the two options and make sure the 'with-branch' transformation
  ;; comes after the 'with-git-url' transformation.
  (let ((source (git-checkout (url "https://example.org")
                              (branch "BRANCH")
                              (recursive? #t))))
    (list source source))
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation
             (reverse '((with-git-url
                         . "grep=https://example.org")
                        (with-branch . "grep=BRANCH"))))))
    (let ((new (t p)))
      (and (not (eq? new p))
           (match (package-inputs new)
             ((("foo" dep1) ("bar" dep2))
              (and (string=? (package-name dep1) "grep")
                   (string=? (package-name dep2) "chbouib")
                   (match (package-native-inputs dep2)
                     ((("x" dep3))
                      (map package-source (list dep1 dep3)))))))))))

(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
  "Return true if P depends on TOOLCHAIN instead of the default tool chain."
  (define toolchain-packages
    '("gcc" "binutils" "glibc" "ld-wrapper"))

  (define (package-name* obj)
    (and (package? obj) (package-name obj)))

  (match (bag-build-inputs (package->bag p))
    (((_ (= package-name* packages) . _) ...)
     (and (not (any (cut member <> packages) toolchain-packages))
          (member toolchain packages)))))

(test-assert "options->transformation, with-c-toolchain"
  (let* ((dep0 (dummy-package "chbouib"
                 (build-system gnu-build-system)
                 (native-inputs `(("y" ,grep)))))
         (dep1 (dummy-package "stuff"
                 (native-inputs `(("x" ,dep0)))))
         (p    (dummy-package "thingie"
                 (build-system gnu-build-system)
                 (inputs `(("foo" ,grep)
                           ("bar" ,dep1)))))
         (t    (options->transformation
                '((with-c-toolchain . "chbouib=gcc-toolchain")))))
    ;; Here we check that the transformation applies to DEP0 and all its
    ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
    ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
    (let ((new (t p)))
      (and (depends-on-toolchain? new "gcc-toolchain")
           (match (bag-build-inputs (package->bag new))
             ((("foo" dep0) ("bar" dep1) _ ...)
              (and (depends-on-toolchain? dep1 "gcc-toolchain")
                   (not (depends-on-toolchain? dep0 "gcc-toolchain"))
                   (string=? (package-full-name dep0)
                             (package-full-name grep))
                   (match (bag-build-inputs (package->bag dep1))
                     ((("x" dep) _ ...)
                      (and (depends-on-toolchain? dep "gcc-toolchain")
                           (match (bag-build-inputs (package->bag dep))
                             ((("y" dep) _ ...)   ;this one is unchanged
                              (eq? dep grep)))))))))))))

(test-equal "options->transformation, with-c-toolchain twice"
  (package-full-name grep)
  (let* ((dep0 (dummy-package "chbouib"))
         (dep1 (dummy-package "stuff"))
         (p    (dummy-package "thingie"
                 (build-system gnu-build-system)
                 (inputs `(("foo" ,dep0)
                           ("bar" ,dep1)
                           ("baz" ,grep)))))
         (t    (options->transformation
                '((with-c-toolchain . "chbouib=clang-toolchain")
                  (with-c-toolchain . "stuff=clang-toolchain")))))
    (let ((new (t p)))
      (and (depends-on-toolchain? new "clang-toolchain")
           (match (bag-build-inputs (package->bag new))
             ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
              (and (depends-on-toolchain? dep0 "clang-toolchain")
                   (depends-on-toolchain? dep1 "clang-toolchain")
                   (not (depends-on-toolchain? dep2 "clang-toolchain"))
                   (package-full-name dep2))))))))

(test-assert "options->transformation, with-c-toolchain, no effect"
  (let ((p (dummy-package "thingie"))
        (t (options->transformation
            '((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
    ;; When it has no effect, '--with-c-toolchain' returns P.
    (eq? (t p) p)))

(test-equal "options->transformation, with-debug-info"
  '(#:strip-binaries? #f)
  (let* ((dep  (dummy-package "chbouib"))
         (p    (dummy-package "thingie"
                 (build-system gnu-build-system)
                 (inputs `(("foo" ,dep)
                           ("bar" ,grep)))))
         (t    (options->transformation
                '((with-debug-info . "chbouib")))))
    (let ((new (t p)))
      (match (package-inputs new)
        ((("foo" dep0) ("bar" dep1))
         (and (string=? (package-full-name dep1)
                        (package-full-name grep))
              (package-arguments (package-replacement dep0))))))))

(test-assert "options->transformation, without-tests"
  (let* ((dep (dummy-package "dep"))
         (p   (dummy-package "foo"
                (inputs `(("dep" ,dep)))))
         (t   (options->transformation '((without-tests . "dep")
                                         (without-tests . "tar")))))
    (let ((new (t p)))
      (match (bag-direct-inputs (package->bag new))
        ((("dep" dep) ("tar" tar) _ ...)
         (and (equal? (package-arguments dep) '(#:tests? #f))
              (match (memq #:tests? (package-arguments tar))
                ((#:tests? #f _ ...) #t))))))))

(test-equal "options->transformation, with-patch"
  (search-patches "glibc-locales.patch" "guile-relocatable.patch")
  (let* ((dep    (dummy-package "dep"
                   (source (dummy-origin))))
         (p      (dummy-package "foo"
                   (inputs `(("dep" ,dep)))))
         (patch1 (search-patch "glibc-locales.patch"))
         (patch2 (search-patch "guile-relocatable.patch"))
         (t      (options->transformation
                  `((with-patch . ,(string-append "dep=" patch1))
                    (with-patch . ,(string-append "dep=" patch2))
                    (with-patch . ,(string-append "tar=" patch1))))))
    (let ((new (t p)))
      (match (bag-direct-inputs (package->bag new))
        ((("dep" dep) ("tar" tar) _ ...)
         (and (member patch1
                      (filter-map (lambda (patch)
                                    (and (local-file? patch)
                                         (local-file-file patch)))
                                  (origin-patches (package-source tar))))
              (map local-file-file
                   (origin-patches (package-source dep)))))))))

(test-equal "options->transformation, with-latest"
  "42.0"
  (mock ((guix upstream) %updaters
         (delay (list (upstream-updater
                       (name 'dummy)
                       (pred (const #t))
                       (description "")
                       (latest (const (upstream-source
                                       (package "foo")
                                       (version "42.0")
                                       (urls '("http://example.org")))))))))
        (let* ((p (dummy-package "foo" (version "1.0")))
               (t (options->transformation
                   `((with-latest . "foo")))))
          (package-version (t p)))))

(test-equal "options->transformation + package->manifest-entry"
  '((transformations . ((without-tests . "foo"))))
  (let* ((p (dummy-package "foo"))
         (t (options->transformation '((without-tests . "foo"))))
         (e (package->manifest-entry (t p))))
    (manifest-entry-properties e)))

(test-end)

;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End:
Commit	Line	Data
629a064f	1	;;; GNU Guix --- Functional package management for GNU
9ab817b2	2	;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
629a064f LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
f68b3ba1	19	(define-module (test-transformations)
629a064f LC	20	#:use-module (guix tests)
629a064f LC	21	#:use-module (guix store)
1ae33664	22	#:use-module ((guix gexp) #:select (lower-object))
90ea8b16 LC	23	#:use-module ((guix profiles)
	24	#:select (package->manifest-entry
	25	manifest-entry-properties))
2bf6f962	26	#:use-module (guix derivations)
629a064f	27	#:use-module (guix packages)
845c4401	28	#:use-module (guix git-download)
abd7a474 LC	29	#:use-module (guix build-system)
abd7a474 LC	30	#:use-module (guix build-system gnu)
f68b3ba1	31	#:use-module (guix transformations)
e38d90d4	32	#:use-module ((guix gexp) #:select (local-file? local-file-file))
629a064f	33	#:use-module (guix ui)
9a2a2005	34	#:use-module (guix utils)
880916ac	35	#:use-module (guix git)
9ab817b2	36	#:use-module (guix upstream)
904c6c42	37	#:use-module (gnu packages)
47c0f92c LC	38	#:use-module (gnu packages base)
	39	#:use-module (gnu packages busybox)
	40	#:use-module (ice-9 match)
abd7a474 LC	41	#:use-module (srfi srfi-1)
abd7a474 LC	42	#:use-module (srfi srfi-26)
629a064f LC	43	#:use-module (srfi srfi-64))
	44
	45	\f
f68b3ba1	46	(test-begin "transformations")
629a064f LC	47
	48	(test-assert "options->transformation, no transformations"
	49	(let ((p (dummy-package "foo"))
	50	(t (options->transformation '())))
1ae33664	51	(eq? (t p) p)))
629a064f LC	52
	53	(test-assert "options->transformation, with-source"
	54	;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
	55	;; be applicable.
	56	(let* ((p (dummy-package "guix.scm"))
	57	(s (search-path %load-path "guix.scm"))
	58	(t (options->transformation `((with-source . ,s)))))
	59	(with-store store
1ae33664 LC	60	(let* ((new (t p))
	61	(source (run-with-store store
	62	(lower-object (package-source new)))))
629a064f	63	(and (not (eq? new p))
1ae33664	64	(string=? source
629a064f LC	65	(add-to-store store "guix.scm" #t
	66	"sha256" s)))))))
	67
7c247809 LC	68	(test-assert "options->transformation, with-source, replacement"
	69	;; Same, but this time the original package has a 'replacement' field. We
	70	;; expect that replacement to be set to #f in the new package.
	71	(let* ((p (dummy-package "guix.scm" (replacement coreutils)))
	72	(s (search-path %load-path "guix.scm"))
	73	(t (options->transformation `((with-source . ,s)))))
1ae33664 LC	74	(let ((new (t p)))
	75	(and (not (eq? new p))
	76	(not (package-replacement new))))))
7c247809	77
9a2a2005 LC	78	(test-assert "options->transformation, with-source, with version"
	79	;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
	80	;; should be applicable, and its version should be extracted.
	81	(let ((p (dummy-package "foo"))
	82	(s (search-path %load-path "guix.scm")))
	83	(call-with-temporary-directory
	84	(lambda (directory)
	85	(let* ((f (string-append directory "/foo-42.0.tar.gz"))
	86	(t (options->transformation `((with-source . ,f)))))
	87	(copy-file s f)
	88	(with-store store
1ae33664 LC	89	(let* ((new (t p))
	90	(source (run-with-store store
	91	(lower-object (package-source new)))))
9a2a2005 LC	92	(and (not (eq? new p))
	93	(string=? (package-name new) (package-name p))
	94	(string=? (package-version new) "42.0")
1ae33664	95	(string=? source
9a2a2005 LC	96	(add-to-store store (basename f) #t
	97	"sha256" f))))))))))
	98
629a064f LC	99	(test-assert "options->transformation, with-source, no matches"
	100	;; When a transformation in not applicable, a warning must be raised.
	101	(let* ((p (dummy-package "foobar"))
	102	(s (search-path %load-path "guix.scm"))
	103	(t (options->transformation `((with-source . ,s)))))
1ae33664 LC	104	(let* ((port (open-output-string))
	105	(new (parameterize ((guix-warning-port port))
	106	(t p))))
	107	(and (eq? new p)
	108	(string-contains (get-output-string port)
	109	"had no effect")))))
629a064f	110
3e30cdf1 LC	111	(test-assert "options->transformation, with-source, PKG=URI"
	112	(let* ((p (dummy-package "foo"))
	113	(s (search-path %load-path "guix.scm"))
	114	(f (string-append "foo=" s))
	115	(t (options->transformation `((with-source . ,f)))))
	116	(with-store store
1ae33664 LC	117	(let* ((new (t p))
	118	(source (run-with-store store
	119	(lower-object (package-source new)))))
3e30cdf1 LC	120	(and (not (eq? new p))
	121	(string=? (package-name new) (package-name p))
	122	(string=? (package-version new)
	123	(package-version p))
1ae33664	124	(string=? source
3e30cdf1 LC	125	(add-to-store store (basename s) #t
	126	"sha256" s)))))))
	127
	128	(test-assert "options->transformation, with-source, PKG@VER=URI"
	129	(let* ((p (dummy-package "foo"))
	130	(s (search-path %load-path "guix.scm"))
	131	(f (string-append "foo@42.0=" s))
	132	(t (options->transformation `((with-source . ,f)))))
	133	(with-store store
1ae33664 LC	134	(let* ((new (t p))
	135	(source (run-with-store store
	136	(lower-object (package-source new)))))
3e30cdf1 LC	137	(and (not (eq? new p))
	138	(string=? (package-name new) (package-name p))
	139	(string=? (package-version new) "42.0")
1ae33664	140	(string=? source
3e30cdf1 LC	141	(add-to-store store (basename s) #t
	142	"sha256" s)))))))
	143
47c0f92c LC	144	(test-assert "options->transformation, with-input"
47c0f92c LC	145	(let* ((p (dummy-package "guix.scm"
904c6c42 LC	146	(inputs `(("foo" ,(specification->package "coreutils"))
904c6c42 LC	147	("bar" ,(specification->package "grep"))
47c0f92c LC	148	("baz" ,(dummy-package "chbouib"
	149	(native-inputs `(("x" ,grep)))))))))
	150	(t (options->transformation '((with-input . "coreutils=busybox")
	151	(with-input . "grep=findutils")))))
1ae33664 LC	152	(let ((new (t p)))
	153	(and (not (eq? new p))
	154	(match (package-inputs new)
	155	((("foo" dep1) ("bar" dep2) ("baz" dep3))
	156	(and (string=? (package-full-name dep1)
	157	(package-full-name busybox))
	158	(string=? (package-full-name dep2)
	159	(package-full-name findutils))
	160	(string=? (package-name dep3) "chbouib")
	161	(match (package-native-inputs dep3)
	162	((("x" dep))
	163	(string=? (package-full-name dep)
	164	(package-full-name findutils)))))))))))
47c0f92c	165
645b9df8 LC	166	(test-assert "options->transformation, with-graft"
	167	(let* ((p (dummy-package "guix.scm"
	168	(inputs `(("foo" ,grep)
	169	("bar" ,(dummy-package "chbouib"
	170	(native-inputs `(("x" ,grep)))))))))
0d7034ca	171	(t (options->transformation '((with-graft . "grep=findutils")))))
1ae33664 LC	172	(let ((new (t p)))
	173	(and (not (eq? new p))
	174	(match (package-inputs new)
	175	((("foo" dep1) ("bar" dep2))
	176	(and (string=? (package-full-name dep1)
	177	(package-full-name grep))
	178	(string=? (package-full-name (package-replacement dep1))
	179	(package-full-name findutils))
	180	(string=? (package-name dep2) "chbouib")
	181	(match (package-native-inputs dep2)
	182	((("x" dep))
	183	(with-store store
	184	(string=? (derivation-file-name
	185	(package-derivation store findutils))
	186	(derivation-file-name
	187	(package-derivation store dep)))))))))))))
645b9df8	188
845c4401 LC	189	(test-equal "options->transformation, with-branch"
	190	(git-checkout (url "https://example.org")
	191	(branch "devel")
	192	(recursive? #t))
	193	(let* ((p (dummy-package "guix.scm"
	194	(inputs `(("foo" ,grep)
	195	("bar" ,(dummy-package "chbouib"
	196	(source (origin
	197	(method git-fetch)
	198	(uri (git-reference
	199	(url "https://example.org")
	200	(commit "cabba9e")))
	201	(sha256 #f)))))))))
	202	(t (options->transformation '((with-branch . "chbouib=devel")))))
1ae33664 LC	203	(let ((new (t p)))
	204	(and (not (eq? new p))
	205	(match (package-inputs new)
	206	((("foo" dep1) ("bar" dep2))
	207	(and (string=? (package-full-name dep1)
	208	(package-full-name grep))
	209	(string=? (package-name dep2) "chbouib")
	210	(package-source dep2))))))))
845c4401 LC	211
	212	(test-equal "options->transformation, with-commit"
	213	(git-checkout (url "https://example.org")
	214	(commit "abcdef")
	215	(recursive? #t))
	216	(let* ((p (dummy-package "guix.scm"
	217	(inputs `(("foo" ,grep)
	218	("bar" ,(dummy-package "chbouib"
	219	(source (origin
	220	(method git-fetch)
	221	(uri (git-reference
	222	(url "https://example.org")
	223	(commit "cabba9e")))
	224	(sha256 #f)))))))))
	225	(t (options->transformation '((with-commit . "chbouib=abcdef")))))
1ae33664 LC	226	(let ((new (t p)))
	227	(and (not (eq? new p))
	228	(match (package-inputs new)
	229	((("foo" dep1) ("bar" dep2))
	230	(and (string=? (package-full-name dep1)
	231	(package-full-name grep))
	232	(string=? (package-name dep2) "chbouib")
	233	(package-source dep2))))))))
845c4401	234
880916ac LC	235	(test-equal "options->transformation, with-git-url"
	236	(let ((source (git-checkout (url "https://example.org")
	237	(recursive? #t))))
	238	(list source source))
	239	(let* ((p (dummy-package "guix.scm"
	240	(inputs `(("foo" ,grep)
	241	("bar" ,(dummy-package "chbouib"
	242	(native-inputs `(("x" ,grep)))))))))
	243	(t (options->transformation '((with-git-url . "grep=https://example.org")))))
1ae33664 LC	244	(let ((new (t p)))
	245	(and (not (eq? new p))
	246	(match (package-inputs new)
	247	((("foo" dep1) ("bar" dep2))
	248	(and (string=? (package-full-name dep1)
	249	(package-full-name grep))
	250	(string=? (package-name dep2) "chbouib")
	251	(match (package-native-inputs dep2)
	252	((("x" dep3))
	253	(map package-source (list dep1 dep3)))))))))))
880916ac	254
14328b81 LC	255	(test-equal "options->transformation, with-git-url + with-branch"
	256	;; Combine the two options and make sure the 'with-branch' transformation
	257	;; comes after the 'with-git-url' transformation.
	258	(let ((source (git-checkout (url "https://example.org")
	259	(branch "BRANCH")
	260	(recursive? #t))))
	261	(list source source))
	262	(let* ((p (dummy-package "guix.scm"
	263	(inputs `(("foo" ,grep)
	264	("bar" ,(dummy-package "chbouib"
	265	(native-inputs `(("x" ,grep)))))))))
	266	(t (options->transformation
	267	(reverse '((with-git-url
	268	. "grep=https://example.org")
	269	(with-branch . "grep=BRANCH"))))))
1ae33664 LC	270	(let ((new (t p)))
	271	(and (not (eq? new p))
	272	(match (package-inputs new)
	273	((("foo" dep1) ("bar" dep2))
	274	(and (string=? (package-name dep1) "grep")
	275	(string=? (package-name dep2) "chbouib")
	276	(match (package-native-inputs dep2)
	277	((("x" dep3))
	278	(map package-source (list dep1 dep3)))))))))))
14328b81	279
abd7a474 LC	280	(define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain"))
	281	"Return true if P depends on TOOLCHAIN instead of the default tool chain."
	282	(define toolchain-packages
	283	'("gcc" "binutils" "glibc" "ld-wrapper"))
	284
	285	(define (package-name* obj)
	286	(and (package? obj) (package-name obj)))
	287
	288	(match (bag-build-inputs (package->bag p))
	289	(((_ (= package-name* packages) . _) ...)
	290	(and (not (any (cut member <> packages) toolchain-packages))
	291	(member toolchain packages)))))
	292
	293	(test-assert "options->transformation, with-c-toolchain"
	294	(let* ((dep0 (dummy-package "chbouib"
	295	(build-system gnu-build-system)
	296	(native-inputs `(("y" ,grep)))))
	297	(dep1 (dummy-package "stuff"
	298	(native-inputs `(("x" ,dep0)))))
	299	(p (dummy-package "thingie"
	300	(build-system gnu-build-system)
	301	(inputs `(("foo" ,grep)
	302	("bar" ,dep1)))))
	303	(t (options->transformation
	304	'((with-c-toolchain . "chbouib=gcc-toolchain")))))
	305	;; Here we check that the transformation applies to DEP0 and all its
	306	;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN
	307	;; and the DEP0 that uses GCC-TOOLCHAIN, and so on.
1ae33664 LC	308	(let ((new (t p)))
	309	(and (depends-on-toolchain? new "gcc-toolchain")
	310	(match (bag-build-inputs (package->bag new))
	311	((("foo" dep0) ("bar" dep1) _ ...)
	312	(and (depends-on-toolchain? dep1 "gcc-toolchain")
	313	(not (depends-on-toolchain? dep0 "gcc-toolchain"))
	314	(string=? (package-full-name dep0)
	315	(package-full-name grep))
	316	(match (bag-build-inputs (package->bag dep1))
	317	((("x" dep) _ ...)
	318	(and (depends-on-toolchain? dep "gcc-toolchain")
	319	(match (bag-build-inputs (package->bag dep))
	320	((("y" dep) _ ...) ;this one is unchanged
	321	(eq? dep grep)))))))))))))
abd7a474 LC	322
	323	(test-equal "options->transformation, with-c-toolchain twice"
	324	(package-full-name grep)
	325	(let* ((dep0 (dummy-package "chbouib"))
	326	(dep1 (dummy-package "stuff"))
	327	(p (dummy-package "thingie"
	328	(build-system gnu-build-system)
	329	(inputs `(("foo" ,dep0)
	330	("bar" ,dep1)
	331	("baz" ,grep)))))
	332	(t (options->transformation
	333	'((with-c-toolchain . "chbouib=clang-toolchain")
	334	(with-c-toolchain . "stuff=clang-toolchain")))))
1ae33664 LC	335	(let ((new (t p)))
	336	(and (depends-on-toolchain? new "clang-toolchain")
	337	(match (bag-build-inputs (package->bag new))
	338	((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...)
	339	(and (depends-on-toolchain? dep0 "clang-toolchain")
	340	(depends-on-toolchain? dep1 "clang-toolchain")
	341	(not (depends-on-toolchain? dep2 "clang-toolchain"))
	342	(package-full-name dep2))))))))
abd7a474 LC	343
	344	(test-assert "options->transformation, with-c-toolchain, no effect"
	345	(let ((p (dummy-package "thingie"))
	346	(t (options->transformation
	347	'((with-c-toolchain . "does-not-exist=gcc-toolchain")))))
	348	;; When it has no effect, '--with-c-toolchain' returns P.
1ae33664	349	(eq? (t p) p)))
abd7a474	350
6aeda816 LC	351	(test-equal "options->transformation, with-debug-info"
	352	'(#:strip-binaries? #f)
	353	(let* ((dep (dummy-package "chbouib"))
	354	(p (dummy-package "thingie"
	355	(build-system gnu-build-system)
	356	(inputs `(("foo" ,dep)
	357	("bar" ,grep)))))
	358	(t (options->transformation
	359	'((with-debug-info . "chbouib")))))
1ae33664 LC	360	(let ((new (t p)))
	361	(match (package-inputs new)
	362	((("foo" dep0) ("bar" dep1))
	363	(and (string=? (package-full-name dep1)
	364	(package-full-name grep))
	365	(package-arguments (package-replacement dep0))))))))
6aeda816	366
f458cfbc LC	367	(test-assert "options->transformation, without-tests"
	368	(let* ((dep (dummy-package "dep"))
	369	(p (dummy-package "foo"
	370	(inputs `(("dep" ,dep)))))
	371	(t (options->transformation '((without-tests . "dep")
	372	(without-tests . "tar")))))
1ae33664 LC	373	(let ((new (t p)))
	374	(match (bag-direct-inputs (package->bag new))
	375	((("dep" dep) ("tar" tar) _ ...)
52755128 LC	376	(and (equal? (package-arguments dep) '(#:tests? #f))
	377	(match (memq #:tests? (package-arguments tar))
	378	((#:tests? #f _ ...) #t))))))))
14328b81	379
e38d90d4 LC	380	(test-equal "options->transformation, with-patch"
	381	(search-patches "glibc-locales.patch" "guile-relocatable.patch")
	382	(let* ((dep (dummy-package "dep"
	383	(source (dummy-origin))))
	384	(p (dummy-package "foo"
	385	(inputs `(("dep" ,dep)))))
	386	(patch1 (search-patch "glibc-locales.patch"))
	387	(patch2 (search-patch "guile-relocatable.patch"))
	388	(t (options->transformation
	389	`((with-patch . ,(string-append "dep=" patch1))
	390	(with-patch . ,(string-append "dep=" patch2))
	391	(with-patch . ,(string-append "tar=" patch1))))))
	392	(let ((new (t p)))
	393	(match (bag-direct-inputs (package->bag new))
	394	((("dep" dep) ("tar" tar) _ ...)
	395	(and (member patch1
	396	(filter-map (lambda (patch)
	397	(and (local-file? patch)
	398	(local-file-file patch)))
	399	(origin-patches (package-source tar))))
	400	(map local-file-file
	401	(origin-patches (package-source dep)))))))))
	402
9ab817b2 LC	403	(test-equal "options->transformation, with-latest"
	404	"42.0"
	405	(mock ((guix upstream) %updaters
	406	(delay (list (upstream-updater
	407	(name 'dummy)
	408	(pred (const #t))
	409	(description "")
	410	(latest (const (upstream-source
	411	(package "foo")
	412	(version "42.0")
	413	(urls '("http://example.org")))))))))
	414	(let* ((p (dummy-package "foo" (version "1.0")))
	415	(t (options->transformation
	416	`((with-latest . "foo")))))
	417	(package-version (t p)))))
	418
90ea8b16 LC	419	(test-equal "options->transformation + package->manifest-entry"
	420	'((transformations . ((without-tests . "foo"))))
	421	(let* ((p (dummy-package "foo"))
	422	(t (options->transformation '((without-tests . "foo"))))
	423	(e (package->manifest-entry (t p))))
	424	(manifest-entry-properties e)))
	425
629a064f	426	(test-end)
abd7a474 LC	427
	428	;;; Local Variables:
	429	;;; eval: (put 'dummy-package 'scheme-indent-function 1)
	430	;;; End: