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