;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014-2022 Ludovic Courtès ;;; Copyright © 2021-2022 Maxime Devos ;;; ;;; 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 (test-gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix derivatio
aboutsummaryrefslogtreecommitdiff
blob: d9710d1ed3c82c81c09c0a402b3cae75ce89c54f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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-print)
  #:use-module (guix import print)
  #:use-module (guix build-system gnu)
  #:use-module (guix download)
  #:use-module (guix packages)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module ((gnu packages) #:select (search-patches))
  #:use-module (srfi srfi-64))

(define-syntax-rule (define-with-source object source expr)
  (begin
    (define object expr)
    (define source 'expr)))

(test-begin "print")

(define-with-source pkg pkg-source
  (package
    (name "test")
    (version "1.2.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "file:///tmp/test-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
    (build-system (@ (guix build-system gnu) gnu-build-system))
    (home-page "http://gnu.org")
    (synopsis "Dummy")
    (description "This is a dummy package.")
    (license license:gpl3+)))

(define-with-source pkg-with-inputs pkg-with-inputs-source
  (package
    (name "test")
    (version "1.2.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "file:///tmp/test-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
    (build-system (@ (guix build-system gnu) gnu-build-system))
    (inputs (list (@ (gnu packages base) coreutils)
                  `(,(@ (gnu packages base) glibc) "debug")))
    (home-page "http://gnu.org")
    (synopsis "Dummy")
    (description "This is a dummy package.")
    (license license:gpl3+)))

(define-with-source pkg-with-origin-input pkg-with-origin-input-source
  (package
    (name "test")
    (version "1.2.3")
    (source (origin
              (method url-fetch)
              (uri (list (string-append "file:///tmp/test-"
                                        version ".tar.gz")
                         (string-append "http://example.org/test-"
                                        version ".tar.gz")))
              (sha256
               (base32
                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))
              (patches (search-patches "guile-linux-syscalls.patch"
                                       "guile-relocatable.patch"))))
    (build-system (@ (guix build-system gnu) gnu-build-system))
    (inputs
     `(("o" ,(origin
               (method url-fetch)
               (uri "http://example.org/somefile.txt")
               (sha256
                (base32
                 "0000000000000000000000000000000000000000000000000000"))))))
    (home-page "http://gnu.org")
    (synopsis "Dummy")
    (description "This is a dummy package.")
    (license license:gpl3+)))

(define-with-source pkg-with-origin-patch pkg-with-origin-patch-source
  (package
    (name "test")
    (version "1.2.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "file:///tmp/test-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))
              (patches
               (list (origin
                       (method url-fetch)
                       (uri "http://example.org/x.patch")
                       (sha256
                        (base32
                         "0000000000000000000000000000000000000000000000000000")))))))
    (build-system (@ (guix build-system gnu) gnu-build-system))
    (home-page "http://gnu.org")
    (synopsis "Dummy")
    (description "This is a dummy package.")
    (license license:gpl3+)))

(define-with-source pkg-with-arguments pkg-with-arguments-source
  (package
    (name "test")
    (version "1.2.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "file:///tmp/test-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
    (build-system (@ (guix build-system gnu) gnu-build-system))
    (arguments
     `(#:disallowed-references (,(@ (gnu packages base) coreutils))))
    (home-page "http://gnu.org")
    (synopsis "Dummy")
    (description "This is a dummy package.")
    (license license:gpl3+)))

(test-equal "simple package"
  `(define-public test ,pkg-source)
  (package->code pkg))

(test-equal "package with inputs"
  `(define-public test ,pkg-with-inputs-source)
  (package->code pkg-with-inputs))

(test-equal "package with origin input"
  `(define-public test ,pkg-with-origin-input-source)
  (package->code pkg-with-origin-input))

(test-equal "package with origin patch"
  `(define-public test ,pkg-with-origin-patch-source)
  (package->code pkg-with-origin-patch))

(test-equal "package with arguments"
  `(define-public test ,pkg-with-arguments-source)
  (package->code pkg-with-arguments))

(test-end "print")
(file-append glibc "/lib" "/debug")) (exp #~(foo #$fa:debug))) (and (match (gexp->sexp* exp) (('foo (? string? result)) (string=? result (string-append (derivation->output-path drv "debug") "/lib/debug")))) (match (gexp-inputs exp) ((input) (and (eq? (gexp-input-thing input) fa) (string=? (gexp-input-output input) "debug"))))))) (test-assert "file-append, nested" (let* ((drv (package-derivation %store glibc)) (dir (file-append glibc "/bin")) (slash (file-append dir "/")) (file (file-append slash "getent")) (exp #~(foo #$file))) (and (match (gexp->sexp* exp) (('foo (? string? result)) (string=? result (string-append (derivation->output-path drv) "/bin/getent")))) (match (gexp-inputs exp) ((input) (eq? (gexp-input-thing input) file)))))) (test-assert "file-append, raw store item" (let* ((obj (plain-file "example.txt" "Hello!")) (a (file-append obj "/a")) (b (file-append a "/b")) (c (file-append b "/c")) (exp #~(list #$c)) (item (run-with-store %store (lower-object obj))) (lexp (run-with-store %store (lower-gexp exp)))) (and (equal? (lowered-gexp-sexp lexp) `(list ,(string-append item "/a/b/c"))) (equal? (lowered-gexp-sources lexp) (list item)) (null? (lowered-gexp-inputs lexp))))) (test-assertm "with-parameters for %current-system" (mlet* %store-monad ((system -> (match (%current-system) ("aarch64-linux" "x86_64-linux") (_ "aarch64-linux"))) (drv (package->derivation coreutils system)) (obj -> (with-parameters ((%current-system system)) coreutils)) (result (lower-object obj))) (return (string=? (derivation-file-name drv) (derivation-file-name result))))) (test-assertm "with-parameters for %current-target-system" (mlet* %store-monad ((target -> "riscv64-linux-gnu") (drv (package->cross-derivation coreutils target)) (obj -> (with-parameters ((%current-target-system target)) coreutils)) (result (lower-object obj))) (return (string=? (derivation-file-name drv) (derivation-file-name result))))) (test-assert "with-parameters + file-append" (let* ((system (match (%current-system) ("aarch64-linux" "x86_64-linux") (_ "aarch64-linux"))) (drv (package-derivation %store coreutils system)) (param (make-parameter 7)) (exp #~(here we go #$(with-parameters ((%current-system system) (param 42)) (if (= (param) 42) (file-append coreutils "/bin/touch") %bootstrap-guile))))) (match (gexp->sexp* exp) (('here 'we 'go (? string? result)) (string=? result (string-append (derivation->output-path drv) "/bin/touch")))))) (test-equal "let-system" (list `(begin ,(%current-system) #t) '(system-binding) 'low '() '()) (let* ((exp #~(begin #$(let-system system system) #t)) (low (run-with-store %store (lower-gexp exp)))) (list (lowered-gexp-sexp low) (match (gexp-inputs exp) ((input) (and (eq? (struct-vtable (gexp-input-thing input)) (@@ (guix gexp) )) (string=? (gexp-input-output input) "out") '(system-binding))) (x x)) 'low (lowered-gexp-inputs low) (lowered-gexp-sources low)))) (test-equal "let-system, target" (list `(list ,(%current-system) #f) `(list ,(%current-system) "aarch64-linux-gnu")) (let ((exp #~(list #$@(let-system (system target) (list system target))))) (list (gexp->sexp* exp) (gexp->sexp* exp "aarch64-linux-gnu")))) (test-equal "let-system, ungexp-native, target" `(here it is: ,(%current-system) #f) (let ((exp #~(here it is: #+@(let-system (system target) (list system target))))) (gexp->sexp* exp "aarch64-linux-gnu"))) (test-equal "let-system, nested" (list `(system* ,(string-append "qemu-system-" (%current-system)) "-m" "256") '(system-binding)) (let ((exp #~(system* #+(let-system (system target) (file-append (@@ (gnu packages virtualization) qemu) "/bin/qemu-system-" system)) "-m" "256"))) (list (match (gexp->sexp* exp) (('system* command rest ...) `(system* ,(and (string-prefix? (%store-prefix) command) (basename command)) ,@rest)) (x x)) (match (gexp-inputs exp) ((input) (and (eq? (struct-vtable (gexp-input-thing input)) (@@ (guix gexp) )) (string=? (gexp-input-output input) "out") (gexp-input-native? input) '(system-binding))) (x x))))) (test-assert "let-system in file-append" (let ((mixed (file-append (let-system (system target) (if (not target) grep sed)) "/bin")) (grep (file-append grep "/bin")) (sed (file-append sed "/bin"))) (and (equal? (gexp->sexp* #~(list #$mixed)) (gexp->sexp* #~(list #$grep))) (equal? (gexp->sexp* #~(list #$mixed) "powerpc64le-linux-gnu") (gexp->sexp* #~(list #$sed) "powerpc64le-linux-gnu"))))) (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) (ungexp-native glibc) (ungexp binutils)))) (target "mips64el-linux-gnu") (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path (package-cross-derivation %store coreutils target))) (libc (derivation->output-path (package-derivation %store glibc))) (bu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? `((,%bootstrap-guile "out" #t) (,coreutils "out" #f) (,glibc "out" #t) (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) (test-equal "ungexp + ungexp-native, nested" `((,%bootstrap-guile "out" #f) (,coreutils "out" #t)) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) (ungexp %bootstrap-guile))))) (map gexp-input->tuple (gexp-inputs exp)))) (test-equal "ungexp + ungexp-native, nested, special mixture" `((,coreutils "out" #t)) (let* ((foo (gexp (foo (ungexp-native coreutils)))) (exp (gexp (bar (ungexp foo))))) (map gexp-input->tuple (gexp-inputs exp)))) (test-assert "input list" (let ((exp (gexp (display '(ungexp (list %bootstrap-guile coreutils))))) (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path (package-derivation %store coreutils)))) (and (lset= equal? `((,%bootstrap-guile "out" #f) (,coreutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display '(,guile ,cu)) (gexp->sexp* exp))))) (test-assert "input list + ungexp-native" (let* ((target "mips64el-linux-gnu") (exp (gexp (display (cons '(ungexp-native (list %bootstrap-guile coreutils)) '(ungexp (list glibc binutils)))))) (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path (package-derivation %store coreutils))) (xlibc (derivation->output-path (package-cross-derivation %store glibc target))) (xbu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? `((,%bootstrap-guile "out" #t) (,coreutils "out" #t) (,glibc "out" #f) (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (gexp->sexp* exp target))))) (test-assert "input list splicing" (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile)) (outputs (list (derivation->output-path (package-derivation %store glibc) "debug") (derivation->output-path (package-derivation %store %bootstrap-guile)))) (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug" #f) (,%bootstrap-guile "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) `(list ,@(cons 5 outputs)))))) (test-assert "input list splicing + ungexp-native-splicing" (let* ((inputs (list (gexp-input glibc "debug" #:native? #t) %bootstrap-guile)) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug" #t) (,%bootstrap-guile "out" #t)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-assert "gexp list splicing + ungexp-splicing" (let* ((inner (gexp (ungexp-native glibc))) (exp (gexp (list (ungexp-splicing (list inner)))))) (and (equal? `((,glibc "out" #t)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-equal "output list" 2 (let ((exp (gexp (begin (mkdir (ungexp output)) (mkdir (ungexp output "bar")))))) (length (gexp-outputs exp)))) ;XXX: is private (test-assert "output list, combined gexps" (let* ((exp0 (gexp (mkdir (ungexp output)))) (exp1 (gexp (mkdir (ungexp output "foo")))) (exp2 (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1))))) (and (lset= equal? (append (gexp-outputs exp0) (gexp-outputs exp1)) (gexp-outputs exp2)) (= 2 (length (gexp-outputs exp2)))))) (test-equal "output list, combined gexps, duplicate output" 1 (let* ((exp0 (gexp (mkdir (ungexp output)))) (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0)))) (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1))))) (length (gexp-outputs exp2)))) (test-assert "output list + ungexp-splicing list, combined gexps" (let* ((exp0 (gexp (mkdir (ungexp output)))) (exp1 (gexp (mkdir (ungexp output "foo")))) (exp2 (gexp (begin (display "hi!") (ungexp-splicing (list exp0 exp1)))))) (and (lset= equal? (append (gexp-outputs exp0) (gexp-outputs exp1)) (gexp-outputs exp2)) (= 2 (length (gexp-outputs exp2)))))) (test-assertm "gexp->file" (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) (guile (package-file %bootstrap-guile)) (sexp (gexp->sexp exp (%current-system) #f)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (refs (references* out))) (return (and (equal? sexp (call-with-input-file out read)) (equal? (list guile) refs))))) (test-assertm "gexp->file + file-append" (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile "/bin/guile")) (guile (package-file %bootstrap-guile)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (refs (references* out))) (return (and (equal? (string-append guile "/bin/guile") (call-with-input-file out read)) (equal? (list guile) refs))))) (test-assertm "gexp->file + #:splice?" (mlet* %store-monad ((exp -> (list #~(define foo 'bar) #~(define guile #$%bootstrap-guile))) (guile (package-file %bootstrap-guile)) (drv (gexp->file "splice" exp #:splice? #t)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (refs (references* out))) (pk 'splice out) (return (and (equal? `((define foo 'bar) (define guile ,guile) ,(call-with-input-string "" read)) (call-with-input-file out (lambda (port) (list (read port) (read port) (read port))))) (equal? (list guile) refs))))) (test-assertm "gexp->derivation" (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) (exp -> (gexp (begin (mkdir (ungexp output)) (chdir (ungexp output)) (symlink (string-append (ungexp %bootstrap-guile) "/bin/guile") "foo") (symlink (ungexp file) (ungexp output "2nd"))))) (drv (gexp->derivation "foo" exp)) (out -> (derivation->output-path drv)) (out2 -> (derivation->output-path drv "2nd")) (done (built-derivations (list drv))) (refs (references* out)) (refs2 (references* out2)) (guile (package-file %bootstrap-guile "bin/guile"))) (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) (equal? refs2 (list file)) (null? (derivation-properties drv)))))) (test-assertm "gexp->derivation properties" (mlet %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output) #:properties '((type . test))))) (return (equal? '((type . test)) (derivation-properties drv))))) (test-assertm "gexp->derivation vs. grafts" (mlet* %store-monad ((graft? (set-grafting #f)) (p0 -> (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)))) (r -> (package (inherit p0) (name "DuMMY"))) (p1 -> (package (inherit p0) (replacement r))) (exp0 -> (gexp (frob (ungexp p0) (ungexp output)))) (exp1 -> (gexp (frob (ungexp p1) (ungexp output)))) (void (set-guile-for-build %bootstrap-guile)) (drv0 (gexp->derivation "t" exp0 #:graft? #t)) (drv1 (gexp->derivation "t" exp1 #:graft? #t)) (drv1* (gexp->derivation "t" exp1 #:graft? #f)) (_ (set-grafting graft?))) (return (and (not (string=? (derivation->output-path drv0) (derivation->output-path drv1))) (string=? (derivation->output-path drv0) (derivation->output-path drv1*)))))) (test-assertm "gexp->derivation, composed gexps" (mlet* %store-monad ((exp0 -> (gexp (begin (mkdir (ungexp output)) (chdir (ungexp output))))) (exp1 -> (gexp (symlink (string-append (ungexp %bootstrap-guile) "/bin/guile") "foo"))) (exp -> (gexp (begin (ungexp exp0) (ungexp exp1)))) (drv (gexp->derivation "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) (guile (package-file %bootstrap-guile "bin/guile"))) (return (string=? (readlink (string-append out "/foo")) guile)))) (test-assertm "gexp->derivation, default system" ;; The default system should be the one at '>>=' time, not the one at ;; invocation time. See . (let ((system (%current-system)) (mdrv (parameterize ((%current-system "foobar64-linux")) (gexp->derivation "foo" (gexp (mkdir (ungexp output))))))) (mlet %store-monad ((drv mdrv)) (return (string=? system (derivation-system drv)))))) (test-assertm "gexp->derivation, local-file" (mlet* %store-monad ((file -> (search-path %load-path "guix.scm")) (intd (interned-file file #:recursive? #f)) (local -> (local-file file)) (exp -> (gexp (begin (stat (ungexp local)) (symlink (ungexp local) (ungexp output))))) (drv (gexp->derivation "local-file" exp))) (mbegin %store-monad (built-derivations (list drv)) (return (string=? (readlink (derivation->output-path drv)) intd))))) (test-assertm "gexp->derivation, cross-compilation" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp -> (gexp (list (ungexp coreutils) (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->derivation, ungexp-native" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp -> (gexp (list (ungexp-native coreutils) (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) (drv (gexp->derivation "foo" exp))) (return (string=? (derivation-file-name drv) (derivation-file-name xdrv))))) (test-assertm "gexp->derivation, ungexp + ungexp-native" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp -> (gexp (list (ungexp-native coreutils) (ungexp glibc) (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xglibc (package->cross-derivation glibc target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name cu) refs) (member (derivation-file-name xglibc) refs))))) (test-assertm "gexp->derivation, ungexp-native + composed gexps" (mlet* %store-monad ((target -> "mips64el-linux-gnu") (exp0 -> (gexp (list 1 2 (ungexp coreutils)))) (exp -> (gexp (list 0 (ungexp-native exp0)))) (xdrv (gexp->derivation "foo" exp #:target target)) (drv (gexp->derivation "foo" exp))) (return (string=? (derivation-file-name drv) (derivation-file-name xdrv))))) (test-assertm "gexp->derivation, store copy" (let ((build-one #~(call-with-output-file #$output (lambda (port) (display "This is the one." port)))) (build-two (lambda (one) #~(begin (mkdir #$output) (symlink #$one (string-append #$output "/one")) (call-with-output-file (string-append #$output "/two") (lambda (port) (display "This is the second one." port)))))) (build-drv #~(begin (use-modules (guix build store-copy) (guix build utils) (srfi srfi-1)) (define (canonical-file? file) ;; Copied from (guix tests). (let ((st (lstat file))) (or (not (string-prefix? (%store-directory) file)) (eq? 'symlink (stat:type st)) (and (= 1 (stat:mtime st)) (zero? (logand #o222 (stat:mode st))))))) (mkdir #$output) (populate-store '("graph") #$output #:deduplicate? #f) ;; Check whether 'populate-store' canonicalizes ;; permissions and timestamps. (unless (every canonical-file? (find-files #$output)) (error "not canonical!" #$output))))) (mlet* %store-monad ((one (gexp->derivation "one" build-one)) (two (gexp->derivation "two" (build-two one))) (drv (gexp->derivation "store-copy" build-drv #:references-graphs `(("graph" ,two)) #:modules '((guix build store-copy) (guix progress) (guix records) (guix sets) (guix build utils)))) (ok? (built-derivations (list drv))) (out -> (derivation->output-path drv))) (let ((one (derivation->output-path one)) (two (derivation->output-path two))) (return (and ok? (file-exists? (string-append out "/" one)) (file-exists? (string-append out "/" two)) (file-exists? (string-append out "/" two "/two")) (string=? (readlink (string-append out "/" two "/one")) one))))))) (test-assertm "imported-files" (mlet* %store-monad ((files -> `(("x" . ,(search-path %load-path "ice-9/q.scm")) ("a/b/c" . ,(search-path %load-path "guix/derivations.scm")) ("p/q" . ,(search-path %load-path "guix.scm")) ("p/z" . ,(search-path %load-path "guix/store.scm")))) (dir (imported-files files))) (mbegin %store-monad (return (every (match-lambda ((path . source) (equal? (call-with-input-file (string-append dir "/" path) get-bytevector-all) (call-with-input-file source get-bytevector-all)))) files))))) (test-assertm "imported-files with file-like objects" (mlet* %store-monad ((plain -> (plain-file "foo" "bar!")) (q-scm -> (search-path %load-path "ice-9/q.scm")) (files -> `(("a/b/c" . ,q-scm) ("p/q" . ,plain))) (drv (imported-files files))) (mbegin %store-monad (built-derivations (list (pk 'drv drv))) (mlet %store-monad ((dir -> (derivation->output-path drv)) (plain* (text-file "foo" "bar!")) (q-scm* (interned-file q-scm "c"))) (return (and (file=? (string-append dir "/a/b/c") q-scm* stat) (file=? (string-append dir "/p/q") plain* stat))))))) (test-equal "gexp-modules & ungexp" '((bar) (foo)) ((@@ (guix gexp) gexp-modules) #~(foo #$(with-imported-modules '((foo)) #~+) #+(with-imported-modules '((bar)) #~-)))) (test-equal "gexp-modules & ungexp-splicing" '((foo) (bar)) ((@@ (guix gexp) gexp-modules) #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) (test-assert "gexp-modules deletes duplicates" ; (let ((make-file (lambda () ;; Use 'eval' to make sure we get an object that's not ;; 'eq?' nor 'equal?' due to the closures it embeds. (eval '(scheme-file "bar.scm" #~(define-module (bar))) (current-module))))) (define result ((@@ (guix gexp) gexp-modules) (with-imported-modules `(((bar) => ,(make-file)) ((bar) => ,(make-file)) (foo) (foo)) #~+))) (match result (((('bar) '=> (? scheme-file?)) ('foo)) #t)))) (test-equal "gexp-modules and literal Scheme object" '() (gexp-modules #t)) (test-assert "gexp-modules, warning" (string-match "tests/gexp.scm:[0-9]+:[0-9]+: warning: \ importing.* \\(guix config\\) from the host" (call-with-output-string (lambda (port) (parameterize ((guix-warning-port port)) (let* ((x (with-imported-modules '((guix config)) #~(+ 1 2 3))) (y #~(+ 39 #$x))) (gexp-modules y))))))) (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin (use-modules (guix build utils)) (mkdir-p (string-append #$output "/guile/guix/nix")) #t)) (drv (gexp->derivation "test-with-modules" build #:modules '((guix build utils))))) (mbegin %store-monad (built-derivations (list drv)) (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) (test-assertm "gexp->derivation & with-imported-modules" ;; Same test as above, but using 'with-imported-modules'. (mlet* %store-monad ((build -> (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (mkdir-p (string-append #$output "/guile/guix/nix")) #t))) (drv (gexp->derivation "test-with-modules" build))) (mbegin %store-monad (built-derivations (list drv)) (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) (test-assertm "gexp->derivation & nested with-imported-modules" (mlet* %store-monad ((build1 -> (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (mkdir-p (string-append #$output "/guile/guix/nix")) #t))) (build2 -> (with-imported-modules '((guix build bournish)) #~(begin (use-modules (guix build bournish) (system base compile)) #+build1 (call-with-output-file (string-append #$output "/b") (lambda (port) (write (read-and-compile (open-input-string "cd /foo") #:from %bournish-language #:to 'scheme) port)))))) (drv (gexp->derivation "test-with-modules" build2))) (mbegin %store-monad (built-derivations (list drv)) (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix"))) (b (string-append p "/b"))) (return (and (eq? (stat:type s) 'directory) (equal? '(chdir "/foo") (call-with-input-file b read)))))))) (test-assertm "gexp->derivation & with-imported-module & computed module" (mlet* %store-monad ((module -> (scheme-file "x" #~(;; splice! (define-module (foo bar) #:export (the-answer)) (define the-answer 42)) #:splice? #t)) (build -> (with-imported-modules `(((foo bar) => ,module) (guix build utils)) #~(begin (use-modules (guix build utils) (foo bar)) mkdir-p (call-with-output-file #$output (lambda (port) (write the-answer port)))))) (drv (gexp->derivation "thing" build)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (= 42 (call-with-input-file out read)))))) (test-equal "gexp-extensions & ungexp" (list sed grep) ((@@ (guix gexp) gexp-extensions) #~(foo #$(with-extensions (list grep) #~+) #+(with-extensions (list sed) #~-)))) (test-equal "gexp-extensions & ungexp-splicing" (list grep sed) ((@@ (guix gexp) gexp-extensions) #~(foo #$@(list (with-extensions (list grep) #~+) (with-imported-modules '((foo)) (with-extensions (list sed) #~-)))))) (test-equal "gexp-extensions and literal Scheme object" '() ((@@ (guix gexp) gexp-extensions) #t)) (test-assertm "gexp->derivation & with-extensions" ;; Create a fake Guile extension and make sure it is accessible both to the ;; imported modules and to the derivation build script. (mlet* %store-monad ((extension -> %extension-package) (module -> (scheme-file "x" #~( ;; splice! (define-module (foo) #:use-module (hg2g) #:export (multiply)) (define (multiply x) (* the-answer x))) #:splice? #t)) (build -> (with-extensions (list extension) (with-imported-modules `((guix build utils) ((foo) => ,module)) #~(begin (use-modules (guix build utils) (hg2g) (foo)) (call-with-output-file #$output (lambda (port) (write (list the-answer (multiply 2)) port))))))) (drv (gexp->derivation "thingie" build ;; %BOOTSTRAP-GUILE is 2.0. #:effective-version "2.0")) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (equal? '(42 84) (call-with-input-file out read)))))) (test-assertm "lower-gexp" (mlet* %store-monad ((extension -> %extension-package) (extension-drv (package->derivation %extension-package)) (coreutils-drv (package->derivation coreutils)) (exp -> (with-extensions (list extension) (with-imported-modules `((guix build utils)) #~(begin (use-modules (guix build utils) (hg2g)) #$coreutils:debug mkdir-p the-answer)))) (lexp (lower-gexp exp #:effective-version "2.0"))) (define (matching-input drv output) (lambda (input) (and (eq? (derivation-input-derivation input) drv) (equal? (derivation-input-sub-derivations input) (list output))))) (mbegin %store-monad (return (and (find (matching-input extension-drv "out") (lowered-gexp-inputs (pk 'lexp lexp))) (find (matching-input coreutils-drv "debug") (lowered-gexp-inputs lexp)) (member (string-append (derivation->output-path extension-drv) "/share/guile/site/2.0") (lowered-gexp-load-path lexp)) (= 2 (length (lowered-gexp-load-path lexp))) (member (string-append (derivation->output-path extension-drv) "/lib/guile/2.0/site-ccache") (lowered-gexp-load-compiled-path lexp)) (= 2 (length (lowered-gexp-load-compiled-path lexp))) (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) (%guile-for-build))))))) (test-assertm "lower-gexp, raw-derivation-file" (mlet* %store-monad ((thing -> (program-file "prog" #~(display "hi!"))) (exp -> #~(list #$(raw-derivation-file thing))) (drv (lower-object thing)) (lexp (lower-gexp exp #:effective-version "2.0"))) (return (and (equal? `(list ,(derivation-file-name drv)) (lowered-gexp-sexp lexp)) (equal? (list (derivation-file-name drv)) (lowered-gexp-sources lexp)) (null? (lowered-gexp-inputs lexp)))))) (test-eq "lower-gexp, non-self-quoting input" + (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c))) (run-with-store %store (lower-gexp #~(foo #$+))))) (test-equal "lower-gexp, character literal" '(#\+) (lowered-gexp-sexp (run-with-store %store (lower-gexp #~(#\+))))) (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) (build -> (with-imported-modules '((guix build store-copy) (guix progress) (guix records) (guix sets) (guix build utils)) #~(begin (use-modules (guix build store-copy)) (with-output-to-file #$output (lambda () (write (map store-info-item (call-with-input-file "guile" read-reference-graph))))) (with-output-to-file #$output:one (lambda () (write (map store-info-item (call-with-input-file "one" read-reference-graph))))) (with-output-to-file #$output:two (lambda () (write (map store-info-item (call-with-input-file "two" read-reference-graph)))))))) (drv (gexp->derivation "ref-graphs" build #:references-graphs `(("one" ,one) ("two" ,two "chbouib") ("guile" ,%bootstrap-guile)))) (ok? (built-derivations (list drv))) (guile-drv (package->derivation %bootstrap-guile)) (bash (interned-file (search-bootstrap-binary "bash" (%current-system)) "bash" #:recursive? #t)) (g-one -> (derivation->output-path drv "one")) (g-two -> (derivation->output-path drv "two")) (g-guile -> (derivation->output-path drv))) (return (and ok? (equal? (call-with-input-file g-one read) (list one)) (lset= string=? (call-with-input-file g-two read) (list one (derivation->output-path two "chbouib"))) ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash. (lset= string=? (call-with-input-file g-guile read) (list (derivation->output-path guile-drv) bash)))))) (test-assertm "gexp->derivation #:references-graphs cross-compilation" ;; The objects passed in #:references-graphs implicitly refer to ;; cross-compiled derivations. Make sure this is the case. (mlet* %store-monad ((drv1 (lower-object coreutils (%current-system) #:target "i586-pc-gnu")) (drv2 (lower-object coreutils (%current-system) #:target #f)) (drv3 (gexp->derivation "three" #~(symlink #$coreutils #$output) #:target "i586-pc-gnu" #:references-graphs `(("coreutils" ,coreutils)))) (refs (references* (derivation-file-name drv3)))) (return (and (member (derivation-file-name drv1) refs) (not (member (derivation-file-name drv2) refs)))))) (test-assertm "gexp->derivation #:allowed-references" (mlet %store-monad ((drv (gexp->derivation "allowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$output "self") (symlink #$%bootstrap-guile "guile")) #:allowed-references (list "out" %bootstrap-guile)))) (built-derivations (list drv)))) (test-assertm "gexp->derivation #:allowed-references, specific output" (mlet* %store-monad ((in (gexp->derivation "thing" #~(begin (mkdir #$output:ok) (mkdir #$output:not-ok)))) (drv (gexp->derivation "allowed-refs" #~(begin (pk #$in:not-ok) (mkdir #$output) (chdir #$output) (symlink #$output "self") (symlink #$in:ok "ok")) #:allowed-references (list "out" (gexp-input in "ok"))))) (built-derivations (list drv)))) (test-assert "gexp->derivation #:allowed-references, disallowed" (let ((drv (run-with-store %store (gexp->derivation "allowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:allowed-references '())))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) (test-assertm "gexp->derivation #:disallowed-references, allowed" (mlet %store-monad ((drv (gexp->derivation "disallowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$output "self") (symlink #$%bootstrap-guile "guile")) #:disallowed-references '()))) (built-derivations (list drv)))) (test-assert "gexp->derivation #:disallowed-references" (let ((drv (run-with-store %store (gexp->derivation "disallowed-refs" #~(begin (mkdir #$output) (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:disallowed-references (list %bootstrap-guile))))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) ;; If we're going to hit the silly shebang limit (128 chars on Linux-based ;; systems), then skip the following test. (test-skip (if (> (string-length shebang) 127) 2 0)) (test-assertm "gexp->script" (mlet* %store-monad ((n -> (random (expt 2 50))) (exp -> (gexp (system* (string-append (ungexp %bootstrap-guile) "/bin/guile") "-c" (object->string '(display (expt (ungexp n) 2)))))) (drv (gexp->script "guile-thing" exp #:guile %bootstrap-guile)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv)))) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) (test-assert "gexp->script #:module-path" (call-with-temporary-directory (lambda (directory) (define str "Fake (guix base32) module!") (mkdir (string-append directory "/guix")) (call-with-output-file (string-append directory "/guix/base32.scm") (lambda (port) (write `(begin (define-module (guix base32)) (define-public %fake! ,str)) port))) (run-with-store %store (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32)) (gexp (begin (use-modules (guix base32)) (write (list %load-path %fake!)))))) (drv (gexp->script "guile-thing" exp #:guile %bootstrap-guile #:module-path (list directory))) (out -> (derivation->output-path drv)) (done (built-derivations (list drv)))) (let* ((pipe (open-input-pipe out)) (data (read pipe))) (return (and (zero? (close-pipe pipe)) (match data ((load-path str*) (and (string=? str* str) (not (member directory load-path))))))))))))) (test-assertm "program-file" (let* ((n (random (expt 2 50))) (exp (with-imported-modules '((guix build utils)) (gexp (begin (use-modules (guix build utils)) (display (ungexp n)))))) (file (program-file "program" exp #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (= n (string->number str))))))))) (test-assert "program-file #:module-path" (call-with-temporary-directory (lambda (directory) (define text (random-text)) (call-with-output-file (string-append directory "/stupid-module.scm") (lambda (port) (write `(begin (define-module (stupid-module)) (define-public %stupid-thing ,text)) port))) (let* ((exp (with-imported-modules '((stupid-module)) (gexp (begin (use-modules (stupid-module)) (display %stupid-thing))))) (file (program-file "program" exp #:guile %bootstrap-guile #:module-path (list directory)))) (run-with-store %store (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (string=? text str))))))))))) (test-assertm "program-file & with-extensions" (let* ((exp (with-extensions (list %extension-package) (gexp (begin (use-modules (hg2g)) (display the-answer))))) (file (program-file "program" exp #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe out)) (str (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (= 42 (string->number str))))))))) (test-assertm "program-file #:system" (let* ((exp (with-imported-modules '((guix build utils)) (gexp (begin (use-modules (guix build utils)) (display "hi!"))))) (system (if (string=? (%current-system) "x86_64-linux") "armhf-linux" "x86_64-linux")) (file (program-file "program" exp))) (mlet %store-monad ((drv (lower-object file system))) (return (and (string=? (derivation-system drv) system) (find (lambda (input) (let ((drv (pk (derivation-input-derivation input)))) (and (string=? (derivation-name drv) "module-import-compiled") (string=? (derivation-system drv) system)))) (derivation-inputs drv))))))) (test-assertm "scheme-file" (let* ((text (plain-file "foo" "Hello, world!")) (scheme (scheme-file "bar" #~(list "foo" #$text)))) (mlet* %store-monad ((drv (lower-object scheme)) (text (lower-object text)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((refs (references* out))) (return (and (equal? refs (list text)) (equal? `(list "foo" ,text) (call-with-input-file out read))))))))) (test-assertm "raw-derivation-file" (let* ((exp #~(let ((drv #$(raw-derivation-file coreutils))) (when (file-exists? drv) (symlink drv #$output))))) (mlet* %store-monad ((dep (lower-object coreutils)) (drv (gexp->derivation "drv-ref" exp)) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((refs (references* out))) (return (and (member (derivation-file-name dep) (derivation-sources drv)) (not (member (derivation-file-name dep) (map derivation-input-path (derivation-inputs drv)))) (equal? (readlink out) (derivation-file-name dep)) (equal? refs (list (derivation-file-name dep)))))))))) (test-assert "text-file*" (run-with-store %store (mlet* %store-monad ((drv (package->derivation %bootstrap-guile)) (guile -> (derivation->output-path drv)) (file (text-file "bar" "This is bar.")) (text (text-file* "foo" %bootstrap-guile "/bin/guile " (gexp-input %bootstrap-guile "out") "/bin/guile " drv "/bin/guile " file)) (done (built-derivations (list text))) (out -> (derivation->output-path text)) (refs (references* out))) ;; Make sure we get the right references and the right content. (return (and (lset= string=? refs (list guile file)) (equal? (call-with-input-file out get-string-all) (string-append guile "/bin/guile " guile "/bin/guile " guile "/bin/guile " file))))) #:guile-for-build (package-derivation %store %bootstrap-guile))) (test-assertm "mixed-text-file" (mlet* %store-monad ((file -> (mixed-text-file "mixed" #:guile %bootstrap-guile "export PATH=" %bootstrap-guile "/bin")) (drv (lower-object file)) (out -> (derivation->output-path drv)) (guile-drv (package->derivation %bootstrap-guile)) (guile -> (derivation->output-path guile-drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((refs (references* out))) (return (and (string=? (string-append "export PATH=" guile "/bin") (call-with-input-file out get-string-all)) (equal? refs (list guile)))))))) (test-assertm "file-union" (mlet* %store-monad ((union -> (file-union "union" `(("a" ,(plain-file "a" "1")) ("b/c/d" ,(plain-file "d" "2")) ("e" ,(plain-file "e" "3"))) #:guile %bootstrap-guile)) (drv (lower-object union)) (out -> (derivation->output-path drv))) (define (contents=? file str) (string=? (call-with-input-file (string-append out "/" file) get-string-all) str)) (mbegin %store-monad (built-derivations (list drv)) (return (and (contents=? "a" "1") (contents=? "b/c/d" "2") (contents=? "e" "3")))))) (test-assert "gexp->derivation vs. %current-target-system" (let ((mval (gexp->derivation "foo" #~(begin (mkdir #$output) (foo #+gnu-make)) #:target #f))) ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no ;; influence. (parameterize ((%current-target-system "fooooo")) (derivation? (run-with-store %store mval))))) (test-assertm "lower-object" (mlet %store-monad ((drv1 (lower-object %bootstrap-guile)) (drv2 (lower-object (package-source coreutils))) (item (lower-object (plain-file "foo" "Hello!")))) (return (and (derivation? drv1) (derivation? drv2) (store-path? item))))) (test-assertm "lower-object, computed-file" (let* ((text (plain-file "foo" "Hello!")) (exp #~(begin (mkdir #$output) (symlink #$%bootstrap-guile (string-append #$output "/guile")) (symlink #$text (string-append #$output "/text")))) (computed (computed-file "computed" exp #:guile %bootstrap-guile))) (mlet* %store-monad ((text (lower-object text)) (guile-drv (lower-object %bootstrap-guile)) (comp-drv (lower-object computed)) (comp -> (derivation->output-path comp-drv))) (mbegin %store-monad (built-derivations (list comp-drv)) (return (and (string=? (readlink (string-append comp "/guile")) (derivation->output-path guile-drv)) (string=? (readlink (string-append comp "/text")) text))))))) (test-assert "lower-object, computed-file + grafts" ;; The reference graph should refer to grafted packages when grafts are ;; enabled. See . (let* ((base (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir %output))))) (pkg (package (inherit base) (version "1.1") (replacement (package (inherit base) (version "9.9"))))) (exp #~(begin (use-modules (ice-9 rdelim)) (let ((item (call-with-input-file "graph" read-line))) (call-with-output-file #$output (lambda (port) (display item port)))))) (computed (computed-file "computed" exp #:options `(#:references-graphs (("graph" ,pkg))) #:guile %bootstrap-guile)) (drv0 (package-derivation %store pkg #:graft? #t)) (drv1 (parameterize ((%graft? #t)) (run-with-store %store (lower-object computed))))) (build-derivations %store (list drv1)) ;; The graph obtained in COMPUTED should refer to the grafted version of ;; PKG, not to PKG itself. (string=? (call-with-input-file (derivation->output-path drv1) get-string-all) (derivation->output-path drv0)))) (test-equal "lower-object, computed-file, #:system" '("mips64el-linux") (run-with-store %store (let* ((exp #~(symlink #$coreutils #$output)) (computed (computed-file "computed" exp #:guile %bootstrap-guile))) ;; Make sure that the SYSTEM argument to 'lower-object' is honored. (mlet* %store-monad ((drv (lower-object computed "mips64el-linux")) (refs (references* (derivation-file-name drv)))) (return (delete-duplicates (filter-map (lambda (file) (and (string-suffix? ".drv" file) (let ((drv (read-derivation-from-file file))) (derivation-system drv)))) (cons (derivation-file-name drv) refs)))))))) (test-assertm "lower-object, computed-file, #:target" (let* ((target "i586-pc-gnu") (computed (computed-file "computed-cross" #~(symlink #$coreutils output) #:guile (default-guile)))) ;; When lowered to TARGET, the derivation of COMPUTED should run natively, ;; using a native Guile, but it should refer to the target COREUTILS. (mlet* %store-monad ((drv (lower-object computed (%current-system) #:target target)) (refs (references* (derivation-file-name drv))) (guile (lower-object (default-guile) (%current-system) #:target #f)) (cross (lower-object coreutils #:target target)) (native (lower-object coreutils #:target #f))) (return (and (string=? (derivation-system (pk 'drv drv)) (%current-system)) (string=? (derivation-builder drv) (string-append (derivation->output-path guile) "/bin/guile")) (not (member (derivation-file-name native) refs)) (member (derivation-file-name cross) refs)))))) (test-assertm "references-file" (let* ((exp #~(symlink #$%bootstrap-guile #$output)) (computed (computed-file "computed" exp #:guile %bootstrap-guile)) (refs (references-file computed "refs" #:guile %bootstrap-guile))) (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile)) (drv1 (lower-object computed)) (drv2 (lower-object refs))) (mbegin %store-monad (built-derivations (list drv2)) (mlet %store-monad ((refs ((store-lift requisites) (list (derivation->output-path drv1))))) (return (lset= string=? (call-with-input-file (derivation->output-path drv2) read) refs))))))) (test-assert "lower-object & gexp-input-error?" (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c))) (run-with-store %store (lower-object (current-module)) #:guile-for-build (%guile-for-build)))) (test-assert "printer" (string-match "^#$" (with-output-to-string (lambda () (write (gexp (string-append (ungexp coreutils) "/bin/uname"))))))) (test-assert "printer vs. ungexp-splicing" (string-match "^#$" (with-output-to-string (lambda () ;; #~(begin #$@#~()) (write (gexp (begin (ungexp-splicing (gexp ()))))))))) (test-equal "sugar" '(gexp (foo (ungexp bar) (ungexp baz "out") (ungexp (chbouib 42)) (ungexp-splicing (list x y z)) (ungexp-native foo) (ungexp-native foo "out") (ungexp-native (chbouib 42)) (ungexp-native-splicing (list x y z)))) '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z) #+foo #+foo:out #+(chbouib 42) #+@(list x y z))) (test-assertm "gexp->file, cross-compilation" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->file "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->file, cross-compilation with default target" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (_ (set-current-target target)) (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->file "foo" exp)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->script, cross-compilation" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->script "foo" exp #:target target)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-assertm "gexp->script, cross-compilation with default target" (mlet* %store-monad ((target -> "aarch64-linux-gnu") (_ (set-current-target target)) (exp -> (gexp (list (ungexp coreutils)))) (xdrv (gexp->script "foo" exp)) (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) (cu (package->derivation coreutils))) (return (and (member (derivation-file-name xcu) refs) (not (member (derivation-file-name cu) refs)))))) (test-end "gexp") ;; Local Variables: ;; eval: (put 'test-assertm 'scheme-indent-function 1) ;; End: