tests/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   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
  19 (define-module (test-gexp)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix gexp)
  23   #:use-module (guix grafts)
  24   #:use-module (guix derivations)
  25   #:use-module (guix packages)
  26   #:use-module (guix build-system trivial)
  27   #:use-module (guix tests)
  28   #:use-module ((guix build utils) #:select (with-directory-excursion))
  29   #:use-module ((guix utils) #:select (call-with-temporary-directory))
  30   #:use-module (gnu packages)
  31   #:use-module (gnu packages base)
  32   #:use-module (gnu packages bootstrap)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (srfi srfi-64)
  36   #:use-module (rnrs io ports)
  37   #:use-module (ice-9 match)
  38   #:use-module (ice-9 regex)
  39   #:use-module (ice-9 popen)
  40   #:use-module (ice-9 ftw))
  41
  42 ;; Test the (guix gexp) module.
  43
  44 (define %store
  45   (open-connection-for-tests))
  46
  47 ;; Globally disable grafts because they can trigger early builds.
  48 (%graft? #f)
  49
  50 ;; For white-box testing.
  51 (define (gexp-inputs x)
  52   ((@@ (guix gexp) gexp-inputs) x))
  53 (define (gexp-native-inputs x)
  54   ((@@ (guix gexp) gexp-native-inputs) x))
  55 (define (gexp-outputs x)
  56   ((@@ (guix gexp) gexp-outputs) x))
  57 (define (gexp->sexp . x)
  58   (apply (@@ (guix gexp) gexp->sexp) x))
  59
  60 (define* (gexp->sexp* exp #:optional target)
  61   (run-with-store %store (gexp->sexp exp
  62                                      #:target target)
  63                   #:guile-for-build (%guile-for-build)))
  64
  65 (define-syntax-rule (test-assertm name exp)
  66   (test-assert name
  67     (run-with-store %store exp
  68                     #:guile-for-build (%guile-for-build))))
  69
  70 (define %extension-package
  71   ;; Example of a package to use when testing 'with-extensions'.
  72   (dummy-package "extension"
  73                  (build-system trivial-build-system)
  74                  (arguments
  75                   `(#:guile ,%bootstrap-guile
  76                     #:modules ((guix build utils))
  77                     #:builder
  78                     (begin
  79                       (use-modules (guix build utils))
  80                       (let* ((out (string-append (assoc-ref %outputs "out")
  81                                                  "/share/guile/site/"
  82                                                  (effective-version))))
  83                         (mkdir-p out)
  84                         (call-with-output-file (string-append out "/hg2g.scm")
  85                           (lambda (port)
  86                             (write '(define-module (hg2g)
  87                                       #:export (the-answer))
  88                                    port)
  89                             (write '(define the-answer 42) port)))))))))
  90
  91 \f
  92 (test-begin "gexp")
  93
  94 (test-equal "no refs"
  95   '(display "hello!")
  96   (let ((exp (gexp (display "hello!"))))
  97     (and (gexp? exp)
  98          (null? (gexp-inputs exp))
  99          (gexp->sexp* exp))))
 100
 101 (test-equal "unquote"
 102   '(display `(foo ,(+ 2 3)))
 103   (let ((exp (gexp (display `(foo ,(+ 2 3))))))
 104     (and (gexp? exp)
 105          (null? (gexp-inputs exp))
 106          (gexp->sexp* exp))))
 107
 108 (test-assert "one input package"
 109   (let ((exp (gexp (display (ungexp coreutils)))))
 110     (and (gexp? exp)
 111          (match (gexp-inputs exp)
 112            (((p "out"))
 113             (eq? p coreutils)))
 114          (equal? `(display ,(derivation->output-path
 115                              (package-derivation %store coreutils)))
 116                  (gexp->sexp* exp)))))
 117
 118 (test-assert "one input package, dotted list"
 119   (let ((exp (gexp (coreutils . (ungexp coreutils)))))
 120     (and (gexp? exp)
 121          (match (gexp-inputs exp)
 122            (((p "out"))
 123             (eq? p coreutils)))
 124          (equal? `(coreutils . ,(derivation->output-path
 125                                  (package-derivation %store coreutils)))
 126                  (gexp->sexp* exp)))))
 127
 128 (test-assert "one input origin"
 129   (let ((exp (gexp (display (ungexp (package-source coreutils))))))
 130     (and (gexp? exp)
 131          (match (gexp-inputs exp)
 132            (((o "out"))
 133             (eq? o (package-source coreutils))))
 134          (equal? `(display ,(derivation->output-path
 135                              (package-source-derivation
 136                               %store (package-source coreutils))))
 137                  (gexp->sexp* exp)))))
 138
 139 (test-assert "one local file"
 140   (let* ((file  (search-path %load-path "guix.scm"))
 141          (local (local-file file))
 142          (exp   (gexp (display (ungexp local))))
 143          (intd  (add-to-store %store (basename file) #f
 144                               "sha256" file)))
 145     (and (gexp? exp)
 146          (match (gexp-inputs exp)
 147            (((x "out"))
 148             (eq? x local)))
 149          (equal? `(display ,intd) (gexp->sexp* exp)))))
 150
 151 (test-assert "one local file, symlink"
 152   (let ((file (search-path %load-path "guix.scm"))
 153         (link (tmpnam)))
 154     (dynamic-wind
 155       (const #t)
 156       (lambda ()
 157         (symlink (canonicalize-path file) link)
 158         (let* ((local (local-file link "my-file" #:recursive? #f))
 159                (exp   (gexp (display (ungexp local))))
 160                (intd  (add-to-store %store "my-file" #f
 161                                     "sha256" file)))
 162           (and (gexp? exp)
 163                (match (gexp-inputs exp)
 164                  (((x "out"))
 165                   (eq? x local)))
 166                (equal? `(display ,intd) (gexp->sexp* exp)))))
 167       (lambda ()
 168         (false-if-exception (delete-file link))))))
 169
 170 (test-equal "local-file, relative file name"
 171   (canonicalize-path (search-path %load-path "guix/base32.scm"))
 172   (let ((directory (dirname (search-path %load-path
 173                                          "guix/build-system/gnu.scm"))))
 174     (with-directory-excursion directory
 175         (let ((file (local-file "../guix/base32.scm")))
 176           (local-file-absolute-file-name file)))))
 177
 178 (test-assertm "local-file, #:select?"
 179   (mlet* %store-monad ((select? -> (lambda (file stat)
 180                                      (member (basename file)
 181                                              '("guix.scm" "tests"
 182                                                "gexp.scm"))))
 183                        (file -> (local-file ".." "directory"
 184                                             #:recursive? #t
 185                                             #:select? select?))
 186                        (dir (lower-object file)))
 187     (return (and (store-path? dir)
 188                  (equal? (scandir dir)
 189                          '("." ".." "guix.scm" "tests"))
 190                  (equal? (scandir (string-append dir "/tests"))
 191                          '("." ".." "gexp.scm"))))))
 192
 193 (test-assert "one plain file"
 194   (let* ((file     (plain-file "hi" "Hello, world!"))
 195          (exp      (gexp (display (ungexp file))))
 196          (expected (add-text-to-store %store "hi" "Hello, world!")))
 197     (and (gexp? exp)
 198          (match (gexp-inputs exp)
 199            (((x "out"))
 200             (eq? x file)))
 201          (equal? `(display ,expected) (gexp->sexp* exp)))))
 202
 203 (test-assert "same input twice"
 204   (let ((exp (gexp (begin
 205                      (display (ungexp coreutils))
 206                      (display (ungexp coreutils))))))
 207     (and (gexp? exp)
 208          (match (gexp-inputs exp)
 209            (((p "out"))
 210             (eq? p coreutils)))
 211          (let ((e `(display ,(derivation->output-path
 212                               (package-derivation %store coreutils)))))
 213            (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
 214
 215 (test-assert "two input packages, one derivation, one file"
 216   (let* ((drv (build-expression->derivation
 217                %store "foo" 'bar
 218                #:guile-for-build (package-derivation %store %bootstrap-guile)))
 219          (txt (add-text-to-store %store "foo" "Hello, world!"))
 220          (exp (gexp (begin
 221                       (display (ungexp coreutils))
 222                       (display (ungexp %bootstrap-guile))
 223                       (display (ungexp drv))
 224                       (display (ungexp txt))))))
 225     (define (match-input thing)
 226       (match-lambda
 227        ((drv-or-pkg _ ...)
 228         (eq? thing drv-or-pkg))))
 229
 230     (and (gexp? exp)
 231          (= 4 (length (gexp-inputs exp)))
 232          (every (lambda (input)
 233                   (find (match-input input) (gexp-inputs exp)))
 234                 (list drv coreutils %bootstrap-guile txt))
 235          (let ((e0 `(display ,(derivation->output-path
 236                                (package-derivation %store coreutils))))
 237                (e1 `(display ,(derivation->output-path
 238                                (package-derivation %store %bootstrap-guile))))
 239                (e2 `(display ,(derivation->output-path drv)))
 240                (e3 `(display ,txt)))
 241            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 242
 243 (test-assert "file-append"
 244   (let* ((drv (package-derivation %store %bootstrap-guile))
 245          (fa  (file-append %bootstrap-guile "/bin/guile"))
 246          (exp #~(here we go #$fa)))
 247     (and (match (gexp->sexp* exp)
 248            (('here 'we 'go (? string? result))
 249             (string=? result
 250                       (string-append (derivation->output-path drv)
 251                                      "/bin/guile"))))
 252          (match (gexp-inputs exp)
 253            (((thing "out"))
 254             (eq? thing fa))))))
 255
 256 (test-assert "file-append, output"
 257   (let* ((drv (package-derivation %store glibc))
 258          (fa  (file-append glibc "/lib" "/debug"))
 259          (exp #~(foo #$fa:debug)))
 260     (and (match (gexp->sexp* exp)
 261            (('foo (? string? result))
 262             (string=? result
 263                       (string-append (derivation->output-path drv "debug")
 264                                      "/lib/debug"))))
 265          (match (gexp-inputs exp)
 266            (((thing "debug"))
 267             (eq? thing fa))))))
 268
 269 (test-assert "file-append, nested"
 270   (let* ((drv   (package-derivation %store glibc))
 271          (dir   (file-append glibc "/bin"))
 272          (slash (file-append dir "/"))
 273          (file  (file-append slash "getent"))
 274          (exp   #~(foo #$file)))
 275     (and (match (gexp->sexp* exp)
 276            (('foo (? string? result))
 277             (string=? result
 278                       (string-append (derivation->output-path drv)
 279                                      "/bin/getent"))))
 280          (match (gexp-inputs exp)
 281            (((thing "out"))
 282             (eq? thing file))))))
 283
 284 (test-assert "ungexp + ungexp-native"
 285   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
 286                              (ungexp coreutils)
 287                              (ungexp-native glibc)
 288                              (ungexp binutils))))
 289          (target "mips64el-linux")
 290          (guile  (derivation->output-path
 291                   (package-derivation %store %bootstrap-guile)))
 292          (cu     (derivation->output-path
 293                   (package-cross-derivation %store coreutils target)))
 294          (libc   (derivation->output-path
 295                   (package-derivation %store glibc)))
 296          (bu     (derivation->output-path
 297                   (package-cross-derivation %store binutils target))))
 298     (and (lset= equal?
 299                 `((,%bootstrap-guile "out") (,glibc "out"))
 300                 (gexp-native-inputs exp))
 301          (lset= equal?
 302                 `((,coreutils "out") (,binutils "out"))
 303                 (gexp-inputs exp))
 304          (equal? `(list ,guile ,cu ,libc ,bu)
 305                  (gexp->sexp* exp target)))))
 306
 307 (test-equal "ungexp + ungexp-native, nested"
 308   (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
 309   (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
 310                           (ungexp %bootstrap-guile)))))
 311     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 312
 313 (test-equal "ungexp + ungexp-native, nested, special mixture"
 314   `(() <> ((,coreutils "out")))
 315
 316   ;; (gexp-native-inputs exp) used to return '(), wrongfully.
 317   (let* ((foo (gexp (foo (ungexp-native coreutils))))
 318          (exp (gexp (bar (ungexp foo)))))
 319     (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
 320
 321 (test-assert "input list"
 322   (let ((exp   (gexp (display
 323                       '(ungexp (list %bootstrap-guile coreutils)))))
 324         (guile (derivation->output-path
 325                 (package-derivation %store %bootstrap-guile)))
 326         (cu    (derivation->output-path
 327                 (package-derivation %store coreutils))))
 328     (and (lset= equal?
 329                 `((,%bootstrap-guile "out") (,coreutils "out"))
 330                 (gexp-inputs exp))
 331          (equal? `(display '(,guile ,cu))
 332                  (gexp->sexp* exp)))))
 333
 334 (test-assert "input list + ungexp-native"
 335   (let* ((target "mips64el-linux")
 336          (exp   (gexp (display
 337                        (cons '(ungexp-native (list %bootstrap-guile coreutils))
 338                              '(ungexp (list glibc binutils))))))
 339          (guile (derivation->output-path
 340                  (package-derivation %store %bootstrap-guile)))
 341          (cu    (derivation->output-path
 342                  (package-derivation %store coreutils)))
 343          (xlibc (derivation->output-path
 344                  (package-cross-derivation %store glibc target)))
 345          (xbu   (derivation->output-path
 346                  (package-cross-derivation %store binutils target))))
 347     (and (lset= equal?
 348                 `((,%bootstrap-guile "out") (,coreutils "out"))
 349                 (gexp-native-inputs exp))
 350          (lset= equal?
 351                 `((,glibc "out") (,binutils "out"))
 352                 (gexp-inputs exp))
 353          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
 354                  (gexp->sexp* exp target)))))
 355
 356 (test-assert "input list splicing"
 357   (let* ((inputs  (list (gexp-input glibc "debug") %bootstrap-guile))
 358          (outputs (list (derivation->output-path
 359                          (package-derivation %store glibc)
 360                          "debug")
 361                         (derivation->output-path
 362                          (package-derivation %store %bootstrap-guile))))
 363          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
 364     (and (lset= equal?
 365                 `((,glibc "debug") (,%bootstrap-guile "out"))
 366                 (gexp-inputs exp))
 367          (equal? (gexp->sexp* exp)
 368                  `(list ,@(cons 5 outputs))))))
 369
 370 (test-assert "input list splicing + ungexp-native-splicing"
 371   (let* ((inputs (list (gexp-input glibc "debug" #:native? #t)
 372                        %bootstrap-guile))
 373          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
 374     (and (lset= equal?
 375                 `((,glibc "debug") (,%bootstrap-guile "out"))
 376                 (gexp-native-inputs exp))
 377          (null? (gexp-inputs exp))
 378          (equal? (gexp->sexp* exp)                ;native
 379                  (gexp->sexp* exp "mips64el-linux")))))
 380
 381 (test-assert "gexp list splicing + ungexp-splicing"
 382   (let* ((inner (gexp (ungexp-native glibc)))
 383          (exp   (gexp (list (ungexp-splicing (list inner))))))
 384     (and (equal? `((,glibc "out")) (gexp-native-inputs exp))
 385          (null? (gexp-inputs exp))
 386          (equal? (gexp->sexp* exp)                ;native
 387                  (gexp->sexp* exp "mips64el-linux")))))
 388
 389 (test-equal "output list"
 390   2
 391   (let ((exp (gexp (begin (mkdir (ungexp output))
 392                           (mkdir (ungexp output "bar"))))))
 393     (length (gexp-outputs exp))))                ;XXX: <output-ref> is private
 394
 395 (test-assert "output list, combined gexps"
 396   (let* ((exp0  (gexp (mkdir (ungexp output))))
 397          (exp1  (gexp (mkdir (ungexp output "foo"))))
 398          (exp2  (gexp (begin (display "hi!") (ungexp exp0) (ungexp exp1)))))
 399     (and (lset= equal?
 400                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 401                 (gexp-outputs exp2))
 402          (= 2 (length (gexp-outputs exp2))))))
 403
 404 (test-equal "output list, combined gexps, duplicate output"
 405   1
 406   (let* ((exp0 (gexp (mkdir (ungexp output))))
 407          (exp1 (gexp (begin (mkdir (ungexp output)) (ungexp exp0))))
 408          (exp2 (gexp (begin (mkdir (ungexp output)) (ungexp exp1)))))
 409     (length (gexp-outputs exp2))))
 410
 411 (test-assert "output list + ungexp-splicing list, combined gexps"
 412   (let* ((exp0  (gexp (mkdir (ungexp output))))
 413          (exp1  (gexp (mkdir (ungexp output "foo"))))
 414          (exp2  (gexp (begin (display "hi!")
 415                              (ungexp-splicing (list exp0 exp1))))))
 416     (and (lset= equal?
 417                 (append (gexp-outputs exp0) (gexp-outputs exp1))
 418                 (gexp-outputs exp2))
 419          (= 2 (length (gexp-outputs exp2))))))
 420
 421 (test-assertm "gexp->file"
 422   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
 423                        (guile  (package-file %bootstrap-guile))
 424                        (sexp   (gexp->sexp exp))
 425                        (drv    (gexp->file "foo" exp))
 426                        (out -> (derivation->output-path drv))
 427                        (done   (built-derivations (list drv)))
 428                        (refs   (references* out)))
 429     (return (and (equal? sexp (call-with-input-file out read))
 430                  (equal? (list guile) refs)))))
 431
 432 (test-assertm "gexp->file + file-append"
 433   (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile
 434                                                 "/bin/guile"))
 435                        (guile  (package-file %bootstrap-guile))
 436                        (drv    (gexp->file "foo" exp))
 437                        (out -> (derivation->output-path drv))
 438                        (done   (built-derivations (list drv)))
 439                        (refs   (references* out)))
 440     (return (and (equal? (string-append guile "/bin/guile")
 441                          (call-with-input-file out read))
 442                  (equal? (list guile) refs)))))
 443
 444 (test-assertm "gexp->file + #:splice?"
 445   (mlet* %store-monad ((exp -> (list
 446                                 #~(define foo 'bar)
 447                                 #~(define guile #$%bootstrap-guile)))
 448                        (guile  (package-file %bootstrap-guile))
 449                        (drv    (gexp->file "splice" exp #:splice? #t))
 450                        (out -> (derivation->output-path drv))
 451                        (done   (built-derivations (list drv)))
 452                        (refs   (references* out)))
 453     (pk 'splice out)
 454     (return (and (equal? `((define foo 'bar)
 455                            (define guile ,guile)
 456                            ,(call-with-input-string "" read))
 457                          (call-with-input-file out
 458                            (lambda (port)
 459                              (list (read port) (read port) (read port)))))
 460                  (equal? (list guile) refs)))))
 461
 462 (test-assertm "gexp->derivation"
 463   (mlet* %store-monad ((file    (text-file "foo" "Hello, world!"))
 464                        (exp ->  (gexp
 465                                  (begin
 466                                    (mkdir (ungexp output))
 467                                    (chdir (ungexp output))
 468                                    (symlink
 469                                     (string-append (ungexp %bootstrap-guile)
 470                                                    "/bin/guile")
 471                                     "foo")
 472                                    (symlink (ungexp file)
 473                                             (ungexp output "2nd")))))
 474                        (drv     (gexp->derivation "foo" exp))
 475                        (out ->  (derivation->output-path drv))
 476                        (out2 -> (derivation->output-path drv "2nd"))
 477                        (done    (built-derivations (list drv)))
 478                        (refs    (references* out))
 479                        (refs2   (references* out2))
 480                        (guile   (package-file %bootstrap-guile "bin/guile")))
 481     (return (and (string=? (readlink (string-append out "/foo")) guile)
 482                  (string=? (readlink out2) file)
 483                  (equal? refs (list (dirname (dirname guile))))
 484                  (equal? refs2 (list file))))))
 485
 486 (test-assertm "gexp->derivation vs. grafts"
 487   (mlet* %store-monad ((graft?  (set-grafting #f))
 488                        (p0 ->   (dummy-package "dummy"
 489                                                (arguments
 490                                                 '(#:implicit-inputs? #f))))
 491                        (r  ->   (package (inherit p0) (name "DuMMY")))
 492                        (p1 ->   (package (inherit p0) (replacement r)))
 493                        (exp0 -> (gexp (frob (ungexp p0) (ungexp output))))
 494                        (exp1 -> (gexp (frob (ungexp p1) (ungexp output))))
 495                        (void    (set-guile-for-build %bootstrap-guile))
 496                        (drv0    (gexp->derivation "t" exp0 #:graft? #t))
 497                        (drv1    (gexp->derivation "t" exp1 #:graft? #t))
 498                        (drv1*   (gexp->derivation "t" exp1 #:graft? #f))
 499                        (_       (set-grafting graft?)))
 500     (return (and (not (string=? (derivation->output-path drv0)
 501                                 (derivation->output-path drv1)))
 502                  (string=? (derivation->output-path drv0)
 503                            (derivation->output-path drv1*))))))
 504
 505 (test-assertm "gexp->derivation, composed gexps"
 506   (mlet* %store-monad ((exp0 -> (gexp (begin
 507                                         (mkdir (ungexp output))
 508                                         (chdir (ungexp output)))))
 509                        (exp1 -> (gexp (symlink
 510                                        (string-append (ungexp %bootstrap-guile)
 511                                                       "/bin/guile")
 512                                        "foo")))
 513                        (exp  -> (gexp (begin (ungexp exp0) (ungexp exp1))))
 514                        (drv     (gexp->derivation "foo" exp))
 515                        (out ->  (derivation->output-path drv))
 516                        (done    (built-derivations (list drv)))
 517                        (guile   (package-file %bootstrap-guile "bin/guile")))
 518     (return (string=? (readlink (string-append out "/foo"))
 519                       guile))))
 520
 521 (test-assertm "gexp->derivation, default system"
 522   ;; The default system should be the one at '>>=' time, not the one at
 523   ;; invocation time.  See <http://bugs.gnu.org/18002>.
 524   (let ((system (%current-system))
 525         (mdrv   (parameterize ((%current-system "foobar64-linux"))
 526                   (gexp->derivation "foo"
 527                                     (gexp
 528                                      (mkdir (ungexp output)))))))
 529     (mlet %store-monad ((drv mdrv))
 530       (return (string=? system (derivation-system drv))))))
 531
 532 (test-assertm "gexp->derivation, local-file"
 533   (mlet* %store-monad ((file ->  (search-path %load-path "guix.scm"))
 534                        (intd     (interned-file file #:recursive? #f))
 535                        (local -> (local-file file))
 536                        (exp ->   (gexp (begin
 537                                          (stat (ungexp local))
 538                                          (symlink (ungexp local)
 539                                                   (ungexp output)))))
 540                        (drv      (gexp->derivation "local-file" exp)))
 541     (mbegin %store-monad
 542       (built-derivations (list drv))
 543       (return (string=? (readlink (derivation->output-path drv))
 544                         intd)))))
 545
 546 (test-assertm "gexp->derivation, cross-compilation"
 547   (mlet* %store-monad ((target -> "mips64el-linux")
 548                        (exp    -> (gexp (list (ungexp coreutils)
 549                                               (ungexp output))))
 550                        (xdrv      (gexp->derivation "foo" exp
 551                                                     #:target target))
 552                        (refs      (references*
 553                                    (derivation-file-name xdrv)))
 554                        (xcu       (package->cross-derivation coreutils
 555                                                              target))
 556                        (cu        (package->derivation coreutils)))
 557     (return (and (member (derivation-file-name xcu) refs)
 558                  (not (member (derivation-file-name cu) refs))))))
 559
 560 (test-assertm "gexp->derivation, ungexp-native"
 561   (mlet* %store-monad ((target -> "mips64el-linux")
 562                        (exp    -> (gexp (list (ungexp-native coreutils)
 563                                               (ungexp output))))
 564                        (xdrv      (gexp->derivation "foo" exp
 565                                                     #:target target))
 566                        (drv       (gexp->derivation "foo" exp)))
 567     (return (string=? (derivation-file-name drv)
 568                       (derivation-file-name xdrv)))))
 569
 570 (test-assertm "gexp->derivation, ungexp + ungexp-native"
 571   (mlet* %store-monad ((target -> "mips64el-linux")
 572                        (exp    -> (gexp (list (ungexp-native coreutils)
 573                                               (ungexp glibc)
 574                                               (ungexp output))))
 575                        (xdrv      (gexp->derivation "foo" exp
 576                                                     #:target target))
 577                        (refs      (references*
 578                                    (derivation-file-name xdrv)))
 579                        (xglibc    (package->cross-derivation glibc target))
 580                        (cu        (package->derivation coreutils)))
 581     (return (and (member (derivation-file-name cu) refs)
 582                  (member (derivation-file-name xglibc) refs)))))
 583
 584 (test-assertm "gexp->derivation, ungexp-native + composed gexps"
 585   (mlet* %store-monad ((target -> "mips64el-linux")
 586                        (exp0   -> (gexp (list 1 2
 587                                               (ungexp coreutils))))
 588                        (exp    -> (gexp (list 0 (ungexp-native exp0))))
 589                        (xdrv      (gexp->derivation "foo" exp
 590                                                     #:target target))
 591                        (drv       (gexp->derivation "foo" exp)))
 592     (return (string=? (derivation-file-name drv)
 593                       (derivation-file-name xdrv)))))
 594
 595 (test-assertm "gexp->derivation, store copy"
 596   (let ((build-one #~(call-with-output-file #$output
 597                        (lambda (port)
 598                          (display "This is the one." port))))
 599         (build-two (lambda (one)
 600                      #~(begin
 601                          (mkdir #$output)
 602                          (symlink #$one (string-append #$output "/one"))
 603                          (call-with-output-file (string-append #$output "/two")
 604                            (lambda (port)
 605                              (display "This is the second one." port))))))
 606         (build-drv #~(begin
 607                        (use-modules (guix build store-copy))
 608
 609                        (mkdir #$output)
 610                        (populate-store '("graph") #$output))))
 611     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
 612                          (two (gexp->derivation "two" (build-two one)))
 613                          (drv (gexp->derivation "store-copy" build-drv
 614                                                 #:references-graphs
 615                                                 `(("graph" ,two))
 616                                                 #:modules
 617                                                 '((guix build store-copy)
 618                                                   (guix progress)
 619                                                   (guix records)
 620                                                   (guix sets)
 621                                                   (guix build utils))))
 622                          (ok? (built-derivations (list drv)))
 623                          (out -> (derivation->output-path drv)))
 624       (let ((one (derivation->output-path one))
 625             (two (derivation->output-path two)))
 626         (return (and ok?
 627                      (file-exists? (string-append out "/" one))
 628                      (file-exists? (string-append out "/" two))
 629                      (file-exists? (string-append out "/" two "/two"))
 630                      (string=? (readlink (string-append out "/" two "/one"))
 631                                one)))))))
 632
 633 (test-assertm "imported-files"
 634   (mlet* %store-monad
 635       ((files -> `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
 636                    ("a/b/c" . ,(search-path %load-path
 637                                             "guix/derivations.scm"))
 638                    ("p/q"   . ,(search-path %load-path "guix.scm"))
 639                    ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
 640        (dir (imported-files files)))
 641     (mbegin %store-monad
 642       (return
 643        (every (match-lambda
 644                 ((path . source)
 645                  (equal? (call-with-input-file (string-append dir "/" path)
 646                            get-bytevector-all)
 647                          (call-with-input-file source
 648                            get-bytevector-all))))
 649               files)))))
 650
 651 (test-assertm "imported-files with file-like objects"
 652   (mlet* %store-monad ((plain -> (plain-file "foo" "bar!"))
 653                        (q-scm -> (search-path %load-path "ice-9/q.scm"))
 654                        (files -> `(("a/b/c" . ,q-scm)
 655                                    ("p/q"   . ,plain)))
 656                        (drv      (imported-files files)))
 657     (define (file=? file1 file2)
 658       ;; Assume deduplication is in place.
 659       (= (stat:ino (lstat file1))
 660          (stat:ino (lstat file2))))
 661
 662     (mbegin %store-monad
 663       (built-derivations (list drv))
 664       (mlet %store-monad ((dir -> (derivation->output-path drv))
 665                           (plain* (text-file "foo" "bar!"))
 666                           (q-scm* (interned-file q-scm "c")))
 667         (return
 668          (and (file=? (string-append dir "/a/b/c") q-scm*)
 669               (file=? (string-append dir "/p/q") plain*)))))))
 670
 671 (test-equal "gexp-modules & ungexp"
 672   '((bar) (foo))
 673   ((@@ (guix gexp) gexp-modules)
 674    #~(foo #$(with-imported-modules '((foo)) #~+)
 675           #+(with-imported-modules '((bar)) #~-))))
 676
 677 (test-equal "gexp-modules & ungexp-splicing"
 678   '((foo) (bar))
 679   ((@@ (guix gexp) gexp-modules)
 680    #~(foo #$@(list (with-imported-modules '((foo)) #~+)
 681                    (with-imported-modules '((bar)) #~-)))))
 682
 683 (test-assert "gexp-modules deletes duplicates"   ;<https://bugs.gnu.org/32966>
 684   (let ((make-file (lambda ()
 685                      ;; Use 'eval' to make sure we get an object that's not
 686                      ;; 'eq?' nor 'equal?' due to the closures it embeds.
 687                      (eval '(scheme-file "bar.scm" #~(define-module (bar)))
 688                            (current-module)))))
 689     (define result
 690       ((@@ (guix gexp) gexp-modules)
 691        (with-imported-modules `(((bar) => ,(make-file))
 692                                 ((bar) => ,(make-file))
 693                                 (foo) (foo))
 694          #~+)))
 695
 696     (match result
 697       (((('bar) '=> (? scheme-file?)) ('foo)) #t))))
 698
 699 (test-equal "gexp-modules and literal Scheme object"
 700   '()
 701   (gexp-modules #t))
 702
 703 (test-assertm "gexp->derivation #:modules"
 704   (mlet* %store-monad
 705       ((build ->  #~(begin
 706                       (use-modules (guix build utils))
 707                       (mkdir-p (string-append #$output "/guile/guix/nix"))
 708                       #t))
 709        (drv       (gexp->derivation "test-with-modules" build
 710                                     #:modules '((guix build utils)))))
 711     (mbegin %store-monad
 712       (built-derivations (list drv))
 713       (let* ((p (derivation->output-path drv))
 714              (s (stat (string-append p "/guile/guix/nix"))))
 715         (return (eq? (stat:type s) 'directory))))))
 716
 717 (test-assertm "gexp->derivation & with-imported-modules"
 718   ;; Same test as above, but using 'with-imported-modules'.
 719   (mlet* %store-monad
 720       ((build ->  (with-imported-modules '((guix build utils))
 721                     #~(begin
 722                         (use-modules (guix build utils))
 723                         (mkdir-p (string-append #$output "/guile/guix/nix"))
 724                         #t)))
 725        (drv       (gexp->derivation "test-with-modules" build)))
 726     (mbegin %store-monad
 727       (built-derivations (list drv))
 728       (let* ((p (derivation->output-path drv))
 729              (s (stat (string-append p "/guile/guix/nix"))))
 730         (return (eq? (stat:type s) 'directory))))))
 731
 732 (test-assertm "gexp->derivation & nested with-imported-modules"
 733   (mlet* %store-monad
 734       ((build1 ->  (with-imported-modules '((guix build utils))
 735                      #~(begin
 736                          (use-modules (guix build utils))
 737                          (mkdir-p (string-append #$output "/guile/guix/nix"))
 738                          #t)))
 739        (build2 ->  (with-imported-modules '((guix build bournish))
 740                      #~(begin
 741                          (use-modules (guix build bournish)
 742                                       (system base compile))
 743                          #+build1
 744                          (call-with-output-file (string-append #$output "/b")
 745                            (lambda (port)
 746                              (write
 747                               (read-and-compile (open-input-string "cd /foo")
 748                                                 #:from %bournish-language
 749                                                 #:to 'scheme)
 750                               port))))))
 751        (drv        (gexp->derivation "test-with-modules" build2)))
 752     (mbegin %store-monad
 753       (built-derivations (list drv))
 754       (let* ((p (derivation->output-path drv))
 755              (s (stat (string-append p "/guile/guix/nix")))
 756              (b (string-append p "/b")))
 757         (return (and (eq? (stat:type s) 'directory)
 758                      (equal? '(chdir "/foo")
 759                              (call-with-input-file b read))))))))
 760
 761 (test-assertm "gexp->derivation & with-imported-module & computed module"
 762   (mlet* %store-monad
 763       ((module -> (scheme-file "x" #~(;; splice!
 764                                        (define-module (foo bar)
 765                                          #:export (the-answer))
 766
 767                                        (define the-answer 42))
 768                                #:splice? #t))
 769        (build -> (with-imported-modules `(((foo bar) => ,module)
 770                                           (guix build utils))
 771                    #~(begin
 772                        (use-modules (guix build utils)
 773                                     (foo bar))
 774                        mkdir-p
 775                        (call-with-output-file #$output
 776                          (lambda (port)
 777                            (write the-answer port))))))
 778        (drv      (gexp->derivation "thing" build))
 779        (out ->   (derivation->output-path drv)))
 780     (mbegin %store-monad
 781       (built-derivations (list drv))
 782       (return (= 42 (call-with-input-file out read))))))
 783
 784 (test-equal "gexp-extensions & ungexp"
 785   (list sed grep)
 786   ((@@ (guix gexp) gexp-extensions)
 787    #~(foo #$(with-extensions (list grep) #~+)
 788           #+(with-extensions (list sed)  #~-))))
 789
 790 (test-equal "gexp-extensions & ungexp-splicing"
 791   (list grep sed)
 792   ((@@ (guix gexp) gexp-extensions)
 793    #~(foo #$@(list (with-extensions (list grep) #~+)
 794                    (with-imported-modules '((foo))
 795                      (with-extensions (list sed) #~-))))))
 796
 797 (test-equal "gexp-extensions and literal Scheme object"
 798   '()
 799   ((@@ (guix gexp) gexp-extensions) #t))
 800
 801 (test-assertm "gexp->derivation & with-extensions"
 802   ;; Create a fake Guile extension and make sure it is accessible both to the
 803   ;; imported modules and to the derivation build script.
 804   (mlet* %store-monad
 805       ((extension -> %extension-package)
 806        (module -> (scheme-file "x" #~( ;; splice!
 807                                       (define-module (foo)
 808                                         #:use-module (hg2g)
 809                                         #:export (multiply))
 810
 811                                       (define (multiply x)
 812                                         (* the-answer x)))
 813                                #:splice? #t))
 814        (build -> (with-extensions (list extension)
 815                    (with-imported-modules `((guix build utils)
 816                                             ((foo) => ,module))
 817                      #~(begin
 818                          (use-modules (guix build utils)
 819                                       (hg2g) (foo))
 820                          (call-with-output-file #$output
 821                            (lambda (port)
 822                              (write (list the-answer (multiply 2))
 823                                     port)))))))
 824        (drv      (gexp->derivation "thingie" build
 825                                    ;; %BOOTSTRAP-GUILE is 2.0.
 826                                    #:effective-version "2.0"))
 827        (out ->   (derivation->output-path drv)))
 828     (mbegin %store-monad
 829       (built-derivations (list drv))
 830       (return (equal? '(42 84) (call-with-input-file out read))))))
 831
 832 (test-assertm "gexp->derivation #:references-graphs"
 833   (mlet* %store-monad
 834       ((one (text-file "one" (random-text)))
 835        (two (gexp->derivation "two"
 836                               #~(symlink #$one #$output:chbouib)))
 837        (build -> (with-imported-modules '((guix build store-copy)
 838                                           (guix progress)
 839                                           (guix records)
 840                                           (guix sets)
 841                                           (guix build utils))
 842                    #~(begin
 843                        (use-modules (guix build store-copy))
 844                        (with-output-to-file #$output
 845                          (lambda ()
 846                            (write (map store-info-item
 847                                        (call-with-input-file "guile"
 848                                          read-reference-graph)))))
 849                        (with-output-to-file #$output:one
 850                          (lambda ()
 851                            (write (map store-info-item
 852                                        (call-with-input-file "one"
 853                                          read-reference-graph)))))
 854                        (with-output-to-file #$output:two
 855                          (lambda ()
 856                            (write (map store-info-item
 857                                        (call-with-input-file "two"
 858                                          read-reference-graph))))))))
 859        (drv (gexp->derivation "ref-graphs" build
 860                               #:references-graphs `(("one" ,one)
 861                                                     ("two" ,two "chbouib")
 862                                                     ("guile" ,%bootstrap-guile))))
 863        (ok? (built-derivations (list drv)))
 864        (guile-drv  (package->derivation %bootstrap-guile))
 865        (bash       (interned-file (search-bootstrap-binary "bash"
 866                                                            (%current-system))
 867                                   "bash" #:recursive? #t))
 868        (g-one   -> (derivation->output-path drv "one"))
 869        (g-two   -> (derivation->output-path drv "two"))
 870        (g-guile -> (derivation->output-path drv)))
 871     (return (and ok?
 872                  (equal? (call-with-input-file g-one read) (list one))
 873                  (lset= string=?
 874                         (call-with-input-file g-two read)
 875                         (list one (derivation->output-path two "chbouib")))
 876
 877                  ;; Note: %BOOTSTRAP-GUILE depends on the bootstrap Bash.
 878                  (lset= string=?
 879                         (call-with-input-file g-guile read)
 880                         (list (derivation->output-path guile-drv) bash))))))
 881
 882 (test-assertm "gexp->derivation #:allowed-references"
 883   (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
 884                                              #~(begin
 885                                                  (mkdir #$output)
 886                                                  (chdir #$output)
 887                                                  (symlink #$output "self")
 888                                                  (symlink #$%bootstrap-guile
 889                                                           "guile"))
 890                                              #:allowed-references
 891                                              (list "out" %bootstrap-guile))))
 892     (built-derivations (list drv))))
 893
 894 (test-assertm "gexp->derivation #:allowed-references, specific output"
 895   (mlet* %store-monad ((in  (gexp->derivation "thing"
 896                                               #~(begin
 897                                                   (mkdir #$output:ok)
 898                                                   (mkdir #$output:not-ok))))
 899                        (drv (gexp->derivation "allowed-refs"
 900                                               #~(begin
 901                                                   (pk #$in:not-ok)
 902                                                   (mkdir #$output)
 903                                                   (chdir #$output)
 904                                                   (symlink #$output "self")
 905                                                   (symlink #$in:ok "ok"))
 906                                               #:allowed-references
 907                                               (list "out"
 908                                                     (gexp-input in "ok")))))
 909     (built-derivations (list drv))))
 910
 911 (test-assert "gexp->derivation #:allowed-references, disallowed"
 912   (let ((drv (run-with-store %store
 913                (gexp->derivation "allowed-refs"
 914                                  #~(begin
 915                                      (mkdir #$output)
 916                                      (chdir #$output)
 917                                      (symlink #$%bootstrap-guile "guile"))
 918                                  #:allowed-references '()))))
 919     (guard (c ((nix-protocol-error? c) #t))
 920       (build-derivations %store (list drv))
 921       #f)))
 922
 923 (test-assertm "gexp->derivation #:disallowed-references, allowed"
 924   (mlet %store-monad ((drv (gexp->derivation "disallowed-refs"
 925                                              #~(begin
 926                                                  (mkdir #$output)
 927                                                  (chdir #$output)
 928                                                  (symlink #$output "self")
 929                                                  (symlink #$%bootstrap-guile
 930                                                           "guile"))
 931                                              #:disallowed-references '())))
 932     (built-derivations (list drv))))
 933
 934
 935 (test-assert "gexp->derivation #:disallowed-references"
 936   (let ((drv (run-with-store %store
 937                (gexp->derivation "disallowed-refs"
 938                                  #~(begin
 939                                      (mkdir #$output)
 940                                      (chdir #$output)
 941                                      (symlink #$%bootstrap-guile "guile"))
 942                                  #:disallowed-references (list %bootstrap-guile)))))
 943     (guard (c ((nix-protocol-error? c) #t))
 944       (build-derivations %store (list drv))
 945       #f)))
 946
 947 (define shebang
 948   (string-append "#!" (derivation->output-path (%guile-for-build))
 949                  "/bin/guile --no-auto-compile"))
 950
 951 ;; If we're going to hit the silly shebang limit (128 chars on Linux-based
 952 ;; systems), then skip the following test.
 953 (test-skip (if (> (string-length shebang) 127) 2 0))
 954
 955 (test-assertm "gexp->script"
 956   (mlet* %store-monad ((n ->   (random (expt 2 50)))
 957                        (exp -> (gexp
 958                                 (system*
 959                                  (string-append (ungexp %bootstrap-guile)
 960                                                 "/bin/guile")
 961                                  "-c" (object->string
 962                                        '(display (expt (ungexp n) 2))))))
 963                        (drv    (gexp->script "guile-thing" exp
 964                                              #:guile %bootstrap-guile))
 965                        (out -> (derivation->output-path drv))
 966                        (done   (built-derivations (list drv))))
 967     (let* ((pipe  (open-input-pipe out))
 968            (str   (get-string-all pipe)))
 969       (return (and (zero? (close-pipe pipe))
 970                    (= (expt n 2) (string->number str)))))))
 971
 972 (test-assert "gexp->script #:module-path"
 973   (call-with-temporary-directory
 974    (lambda (directory)
 975      (define str
 976        "Fake (guix base32) module!")
 977
 978      (mkdir (string-append directory "/guix"))
 979      (call-with-output-file (string-append directory "/guix/base32.scm")
 980        (lambda (port)
 981          (write `(begin (define-module (guix base32))
 982                         (define-public %fake! ,str))
 983                 port)))
 984
 985      (run-with-store %store
 986        (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32))
 987                                       (gexp (begin
 988                                               (use-modules (guix base32))
 989                                               (write (list %load-path
 990                                                            %fake!))))))
 991                             (drv    (gexp->script "guile-thing" exp
 992                                                   #:guile %bootstrap-guile
 993                                                   #:module-path (list directory)))
 994                             (out -> (derivation->output-path drv))
 995                             (done   (built-derivations (list drv))))
 996          (let* ((pipe  (open-input-pipe out))
 997                 (data  (read pipe)))
 998            (return (and (zero? (close-pipe pipe))
 999                         (match data
1000                           ((load-path str*)
1001                            (and (string=? str* str)
1002                                 (not (member directory load-path)))))))))))))
1003
1004 (test-assertm "program-file"
1005   (let* ((n      (random (expt 2 50)))
1006          (exp    (with-imported-modules '((guix build utils))
1007                    (gexp (begin
1008                            (use-modules (guix build utils))
1009                            (display (ungexp n))))))
1010          (file   (program-file "program" exp
1011                                #:guile %bootstrap-guile)))
1012     (mlet* %store-monad ((drv (lower-object file))
1013                          (out -> (derivation->output-path drv)))
1014       (mbegin %store-monad
1015         (built-derivations (list drv))
1016         (let* ((pipe  (open-input-pipe out))
1017                (str   (get-string-all pipe)))
1018           (return (and (zero? (close-pipe pipe))
1019                        (= n (string->number str)))))))))
1020
1021 (test-assert "program-file #:module-path"
1022   (call-with-temporary-directory
1023    (lambda (directory)
1024      (define text (random-text))
1025
1026      (call-with-output-file (string-append directory "/stupid-module.scm")
1027        (lambda (port)
1028          (write `(begin (define-module (stupid-module))
1029                         (define-public %stupid-thing ,text))
1030                 port)))
1031
1032      (let* ((exp    (with-imported-modules '((stupid-module))
1033                       (gexp (begin
1034                               (use-modules (stupid-module))
1035                               (display %stupid-thing)))))
1036             (file   (program-file "program" exp
1037                                   #:guile %bootstrap-guile
1038                                   #:module-path (list directory))))
1039        (run-with-store %store
1040          (mlet* %store-monad ((drv (lower-object file))
1041                               (out -> (derivation->output-path drv)))
1042            (mbegin %store-monad
1043              (built-derivations (list drv))
1044              (let* ((pipe  (open-input-pipe out))
1045                     (str   (get-string-all pipe)))
1046                (return (and (zero? (close-pipe pipe))
1047                             (string=? text str)))))))))))
1048
1049 (test-assertm "program-file & with-extensions"
1050   (let* ((exp    (with-extensions (list %extension-package)
1051                    (gexp (begin
1052                            (use-modules (hg2g))
1053                            (display the-answer)))))
1054          (file   (program-file "program" exp
1055                                #:guile %bootstrap-guile)))
1056     (mlet* %store-monad ((drv (lower-object file))
1057                          (out -> (derivation->output-path drv)))
1058       (mbegin %store-monad
1059         (built-derivations (list drv))
1060         (let* ((pipe  (open-input-pipe out))
1061                (str   (get-string-all pipe)))
1062           (return (and (zero? (close-pipe pipe))
1063                        (= 42 (string->number str)))))))))
1064
1065 (test-assertm "scheme-file"
1066   (let* ((text   (plain-file "foo" "Hello, world!"))
1067          (scheme (scheme-file "bar" #~(list "foo" #$text))))
1068     (mlet* %store-monad ((drv  (lower-object scheme))
1069                          (text (lower-object text))
1070                          (out -> (derivation->output-path drv)))
1071       (mbegin %store-monad
1072         (built-derivations (list drv))
1073         (mlet %store-monad ((refs (references* out)))
1074           (return (and (equal? refs (list text))
1075                        (equal? `(list "foo" ,text)
1076                                (call-with-input-file out read)))))))))
1077
1078 (test-assert "text-file*"
1079   (run-with-store %store
1080     (mlet* %store-monad
1081         ((drv  (package->derivation %bootstrap-guile))
1082          (guile -> (derivation->output-path drv))
1083          (file (text-file "bar" "This is bar."))
1084          (text (text-file* "foo"
1085                            %bootstrap-guile "/bin/guile "
1086                            (gexp-input %bootstrap-guile "out") "/bin/guile "
1087                            drv "/bin/guile "
1088                            file))
1089          (done (built-derivations (list text)))
1090          (out -> (derivation->output-path text))
1091          (refs (references* out)))
1092       ;; Make sure we get the right references and the right content.
1093       (return (and (lset= string=? refs (list guile file))
1094                    (equal? (call-with-input-file out get-string-all)
1095                            (string-append guile "/bin/guile "
1096                                           guile "/bin/guile "
1097                                           guile "/bin/guile "
1098                                           file)))))
1099     #:guile-for-build (package-derivation %store %bootstrap-guile)))
1100
1101 (test-assertm "mixed-text-file"
1102   (mlet* %store-monad ((file ->   (mixed-text-file "mixed"
1103                                                    "export PATH="
1104                                                    %bootstrap-guile "/bin"))
1105                        (drv       (lower-object file))
1106                        (out ->    (derivation->output-path drv))
1107                        (guile-drv (package->derivation %bootstrap-guile))
1108                        (guile ->  (derivation->output-path guile-drv)))
1109     (mbegin %store-monad
1110       (built-derivations (list drv))
1111       (mlet %store-monad ((refs (references* out)))
1112         (return (and (string=? (string-append "export PATH=" guile "/bin")
1113                                (call-with-input-file out get-string-all))
1114                      (equal? refs (list guile))))))))
1115
1116 (test-assertm "file-union"
1117   (mlet* %store-monad ((union -> (file-union "union"
1118                                              `(("a" ,(plain-file "a" "1"))
1119                                                ("b/c/d" ,(plain-file "d" "2"))
1120                                                ("e" ,(plain-file "e" "3")))))
1121                        (drv      (lower-object union))
1122                        (out ->   (derivation->output-path drv)))
1123     (define (contents=? file str)
1124       (string=? (call-with-input-file (string-append out "/" file)
1125                   get-string-all)
1126                 str))
1127
1128     (mbegin %store-monad
1129       (built-derivations (list drv))
1130       (return (and (contents=? "a" "1")
1131                    (contents=? "b/c/d" "2")
1132                    (contents=? "e" "3"))))))
1133
1134 (test-assert "gexp->derivation vs. %current-target-system"
1135   (let ((mval (gexp->derivation "foo"
1136                                 #~(begin
1137                                     (mkdir #$output)
1138                                     (foo #+gnu-make))
1139                                 #:target #f)))
1140     ;; The value of %CURRENT-TARGET-SYSTEM at bind-time should have no
1141     ;; influence.
1142     (parameterize ((%current-target-system "fooooo"))
1143       (derivation? (run-with-store %store mval)))))
1144
1145 (test-assertm "lower-object"
1146   (mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
1147                       (drv2 (lower-object (package-source coreutils)))
1148                       (item (lower-object (plain-file "foo" "Hello!"))))
1149     (return (and (derivation? drv1) (derivation? drv2)
1150                  (store-path? item)))))
1151
1152 (test-assertm "lower-object, computed-file"
1153   (let* ((text     (plain-file "foo" "Hello!"))
1154          (exp      #~(begin
1155                        (mkdir #$output)
1156                        (symlink #$%bootstrap-guile
1157                                 (string-append #$output "/guile"))
1158                        (symlink #$text (string-append #$output "/text"))))
1159          (computed (computed-file "computed" exp)))
1160     (mlet* %store-monad ((text      (lower-object text))
1161                          (guile-drv (lower-object %bootstrap-guile))
1162                          (comp-drv  (lower-object computed))
1163                          (comp ->   (derivation->output-path comp-drv)))
1164       (mbegin %store-monad
1165         (built-derivations (list comp-drv))
1166         (return (and (string=? (readlink (string-append comp "/guile"))
1167                                (derivation->output-path guile-drv))
1168                      (string=? (readlink (string-append comp "/text"))
1169                                text)))))))
1170
1171 (test-assert "lower-object & gexp-input-error?"
1172   (guard (c ((gexp-input-error? c)
1173              (gexp-error-invalid-input c)))
1174     (run-with-store %store
1175       (lower-object (current-module))
1176       #:guile-for-build (%guile-for-build))))
1177
1178 (test-assert "printer"
1179   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
1180  \"/bin/uname\"\\) [[:xdigit:]]+>$"
1181                 (with-output-to-string
1182                   (lambda ()
1183                     (write
1184                      (gexp (string-append (ungexp coreutils)
1185                                           "/bin/uname")))))))
1186
1187 (test-assert "printer vs. ungexp-splicing"
1188   (string-match "^#<gexp .* [[:xdigit:]]+>$"
1189                 (with-output-to-string
1190                   (lambda ()
1191                     ;; #~(begin #$@#~())
1192                     (write
1193                      (gexp (begin (ungexp-splicing (gexp ())))))))))
1194
1195 (test-equal "sugar"
1196   '(gexp (foo (ungexp bar) (ungexp baz "out")
1197               (ungexp (chbouib 42))
1198               (ungexp-splicing (list x y z))
1199               (ungexp-native foo) (ungexp-native foo "out")
1200               (ungexp-native (chbouib 42))
1201               (ungexp-native-splicing (list x y z))))
1202   '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
1203           #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
1204
1205 (test-end "gexp")
1206
1207 ;; Local Variables:
1208 ;; eval: (put 'test-assertm 'scheme-indent-function 1)
1209 ;; End: