diff options
| -rw-r--r-- | guix/gexp.scm | 31 | ||||
| -rw-r--r-- | tests/gexp.scm | 54 |
2 files changed, 33 insertions, 52 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index 8e80d4adbe4..7a3228ec2e6 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm | |||
| @@ -1006,13 +1006,9 @@ derivations--e.g., code evaluated for its side effects." | |||
| 1006 | (guile (if guile-for-build | 1006 | (guile (if guile-for-build |
| 1007 | (return guile-for-build) | 1007 | (return guile-for-build) |
| 1008 | (default-guile-derivation system))) | 1008 | (default-guile-derivation system))) |
| 1009 | (normals (lower-inputs (gexp-inputs exp) | 1009 | (inputs (lower-inputs (gexp-inputs exp) |
| 1010 | #:system system | 1010 | #:system system |
| 1011 | #:target target)) | 1011 | #:target target)) |
| 1012 | (natives (lower-inputs (gexp-native-inputs exp) | ||
| 1013 | #:system system | ||
| 1014 | #:target #f)) | ||
| 1015 | (inputs -> (append normals natives)) | ||
| 1016 | (sexp (gexp->sexp exp | 1012 | (sexp (gexp->sexp exp |
| 1017 | #:system system | 1013 | #:system system |
| 1018 | #:target target)) | 1014 | #:target target)) |
| @@ -1218,26 +1214,26 @@ The other arguments are as for 'derivation'." | |||
| 1218 | #:substitutable? substitutable? | 1214 | #:substitutable? substitutable? |
| 1219 | #:properties properties)))) | 1215 | #:properties properties)))) |
| 1220 | 1216 | ||
| 1221 | (define* (gexp-inputs exp #:key native?) | 1217 | (define (gexp-inputs exp) |
| 1222 | "Return the list of <gexp-input> for EXP. When NATIVE? is true, return only | 1218 | "Return the list of <gexp-input> for EXP." |
| 1223 | native references; otherwise, return only non-native references." | 1219 | (define set-gexp-input-native? |
| 1220 | (match-lambda | ||
| 1221 | (($ <gexp-input> thing output) | ||
| 1222 | (%gexp-input thing output #t)))) | ||
| 1223 | |||
| 1224 | (define (add-reference-inputs ref result) | 1224 | (define (add-reference-inputs ref result) |
| 1225 | (match ref | 1225 | (match ref |
| 1226 | (($ <gexp-input> (? gexp? exp) _ #t) | 1226 | (($ <gexp-input> (? gexp? exp) _ #t) |
| 1227 | (if native? | 1227 | (append (map set-gexp-input-native? (gexp-inputs exp)) |
| 1228 | (append (gexp-inputs exp) | ||
| 1229 | (gexp-inputs exp #:native? #t) | ||
| 1230 | result) | ||
| 1231 | result)) | ||
| 1232 | (($ <gexp-input> (? gexp? exp) _ #f) | ||
| 1233 | (append (gexp-inputs exp #:native? native?) | ||
| 1234 | result)) | 1228 | result)) |
| 1229 | (($ <gexp-input> (? gexp? exp) _ #f) | ||
| 1230 | (append (gexp-inputs exp) result)) | ||
| 1235 | (($ <gexp-input> (? string? str)) | 1231 | (($ <gexp-input> (? string? str)) |
| 1236 | (if (direct-store-path? str) | 1232 | (if (direct-store-path? str) |
| 1237 | (cons ref result) | 1233 | (cons ref result) |
| 1238 | result)) | 1234 | result)) |
| 1239 | (($ <gexp-input> (? struct? thing) output n?) | 1235 | (($ <gexp-input> (? struct? thing) output n?) |
| 1240 | (if (and (eqv? n? native?) (lookup-compiler thing)) | 1236 | (if (lookup-compiler thing) |
| 1241 | ;; THING is a derivation, or a package, or an origin, etc. | 1237 | ;; THING is a derivation, or a package, or an origin, etc. |
| 1242 | (cons ref result) | 1238 | (cons ref result) |
| 1243 | result)) | 1239 | result)) |
| @@ -1261,9 +1257,6 @@ native references; otherwise, return only non-native references." | |||
| 1261 | '() | 1257 | '() |
| 1262 | (gexp-references exp))) | 1258 | (gexp-references exp))) |
| 1263 | 1259 | ||
| 1264 | (define gexp-native-inputs | ||
| 1265 | (cut gexp-inputs <> #:native? #t)) | ||
| 1266 | |||
| 1267 | (define (gexp-outputs exp) | 1260 | (define (gexp-outputs exp) |
| 1268 | "Return the outputs referred to by EXP as a list of strings." | 1261 | "Return the outputs referred to by EXP as a list of strings." |
| 1269 | (define (add-reference-output ref result) | 1262 | (define (add-reference-output ref result) |
diff --git a/tests/gexp.scm b/tests/gexp.scm index f742c5db763..0bd1237316e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm | |||
| @@ -51,8 +51,6 @@ | |||
| 51 | ;; For white-box testing. | 51 | ;; For white-box testing. |
| 52 | (define (gexp-inputs x) | 52 | (define (gexp-inputs x) |
| 53 | ((@@ (guix gexp) gexp-inputs) x)) | 53 | ((@@ (guix gexp) gexp-inputs) x)) |
| 54 | (define (gexp-native-inputs x) | ||
| 55 | ((@@ (guix gexp) gexp-native-inputs) x)) | ||
| 56 | (define (gexp-outputs x) | 54 | (define (gexp-outputs x) |
| 57 | ((@@ (guix gexp) gexp-outputs) x)) | 55 | ((@@ (guix gexp) gexp-outputs) x)) |
| 58 | (define (gexp->sexp . x) | 56 | (define (gexp->sexp . x) |
| @@ -64,7 +62,8 @@ | |||
| 64 | #:guile-for-build (%guile-for-build))) | 62 | #:guile-for-build (%guile-for-build))) |
| 65 | 63 | ||
| 66 | (define (gexp-input->tuple input) | 64 | (define (gexp-input->tuple input) |
| 67 | (list (gexp-input-thing input) (gexp-input-output input))) | 65 | (list (gexp-input-thing input) (gexp-input-output input) |
| 66 | (gexp-input-native? input))) | ||
| 68 | 67 | ||
| 69 | (define %extension-package | 68 | (define %extension-package |
| 70 | ;; Example of a package to use when testing 'with-extensions'. | 69 | ;; Example of a package to use when testing 'with-extensions'. |
| @@ -347,7 +346,7 @@ | |||
| 347 | (string-append (derivation->output-path drv) | 346 | (string-append (derivation->output-path drv) |
| 348 | "/bin/touch")))))) | 347 | "/bin/touch")))))) |
| 349 | (test-equal "let-system" | 348 | (test-equal "let-system" |
| 350 | (list `(begin ,(%current-system) #t) '(system-binding) '() | 349 | (list `(begin ,(%current-system) #t) '(system-binding) |
| 351 | 'low '() '()) | 350 | 'low '() '()) |
| 352 | (let* ((exp #~(begin | 351 | (let* ((exp #~(begin |
| 353 | #$(let-system system system) | 352 | #$(let-system system system) |
| @@ -361,7 +360,6 @@ | |||
| 361 | (string=? (gexp-input-output input) "out") | 360 | (string=? (gexp-input-output input) "out") |
| 362 | '(system-binding))) | 361 | '(system-binding))) |
| 363 | (x x)) | 362 | (x x)) |
| 364 | (gexp-native-inputs exp) | ||
| 365 | 'low | 363 | 'low |
| 366 | (lowered-gexp-inputs low) | 364 | (lowered-gexp-inputs low) |
| 367 | (lowered-gexp-sources low)))) | 365 | (lowered-gexp-sources low)))) |
| @@ -383,7 +381,6 @@ | |||
| 383 | (test-equal "let-system, nested" | 381 | (test-equal "let-system, nested" |
| 384 | (list `(system* ,(string-append "qemu-system-" (%current-system)) | 382 | (list `(system* ,(string-append "qemu-system-" (%current-system)) |
| 385 | "-m" "256") | 383 | "-m" "256") |
| 386 | '() | ||
| 387 | '(system-binding)) | 384 | '(system-binding)) |
| 388 | (let ((exp #~(system* | 385 | (let ((exp #~(system* |
| 389 | #+(let-system (system target) | 386 | #+(let-system (system target) |
| @@ -398,12 +395,12 @@ | |||
| 398 | (basename command)) | 395 | (basename command)) |
| 399 | ,@rest)) | 396 | ,@rest)) |
| 400 | (x x)) | 397 | (x x)) |
| 401 | (gexp-inputs exp) | 398 | (match (gexp-inputs exp) |
| 402 | (match (gexp-native-inputs exp) | ||
| 403 | ((input) | 399 | ((input) |
| 404 | (and (eq? (struct-vtable (gexp-input-thing input)) | 400 | (and (eq? (struct-vtable (gexp-input-thing input)) |
| 405 | (@@ (guix gexp) <system-binding>)) | 401 | (@@ (guix gexp) <system-binding>)) |
| 406 | (string=? (gexp-input-output input) "out") | 402 | (string=? (gexp-input-output input) "out") |
| 403 | (gexp-input-native? input) | ||
| 407 | '(system-binding))) | 404 | '(system-binding))) |
| 408 | (x x))))) | 405 | (x x))))) |
| 409 | 406 | ||
| @@ -422,31 +419,26 @@ | |||
| 422 | (bu (derivation->output-path | 419 | (bu (derivation->output-path |
| 423 | (package-cross-derivation %store binutils target)))) | 420 | (package-cross-derivation %store binutils target)))) |
| 424 | (and (lset= equal? | 421 | (and (lset= equal? |
| 425 | `((,%bootstrap-guile "out") (,glibc "out")) | 422 | `((,%bootstrap-guile "out" #t) |
| 426 | (map gexp-input->tuple (gexp-native-inputs exp))) | 423 | (,coreutils "out" #f) |
| 427 | (lset= equal? | 424 | (,glibc "out" #t) |
| 428 | `((,coreutils "out") (,binutils "out")) | 425 | (,binutils "out" #f)) |
| 429 | (map gexp-input->tuple (gexp-inputs exp))) | 426 | (map gexp-input->tuple (gexp-inputs exp))) |
| 430 | (equal? `(list ,guile ,cu ,libc ,bu) | 427 | (equal? `(list ,guile ,cu ,libc ,bu) |
| 431 | (gexp->sexp* exp target))))) | 428 | (gexp->sexp* exp target))))) |
| 432 | 429 | ||
| 433 | (test-equal "ungexp + ungexp-native, nested" | 430 | (test-equal "ungexp + ungexp-native, nested" |
| 434 | (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) | 431 | `((,%bootstrap-guile "out" #f) (,coreutils "out" #t)) |
| 435 | (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) | 432 | (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) |
| 436 | (ungexp %bootstrap-guile))))) | 433 | (ungexp %bootstrap-guile))))) |
| 437 | (list (map gexp-input->tuple (gexp-inputs exp)) | 434 | (map gexp-input->tuple (gexp-inputs exp)))) |
| 438 | '<> | ||
| 439 | (map gexp-input->tuple (gexp-native-inputs exp))))) | ||
| 440 | 435 | ||
| 441 | (test-equal "ungexp + ungexp-native, nested, special mixture" | 436 | (test-equal "ungexp + ungexp-native, nested, special mixture" |
| 442 | `(() <> ((,coreutils "out"))) | 437 | `((,coreutils "out" #t)) |
| 443 | 438 | ||
| 444 | ;; (gexp-native-inputs exp) used to return '(), wrongfully. | ||
| 445 | (let* ((foo (gexp (foo (ungexp-native coreutils)))) | 439 | (let* ((foo (gexp (foo (ungexp-native coreutils)))) |
| 446 | (exp (gexp (bar (ungexp foo))))) | 440 | (exp (gexp (bar (ungexp foo))))) |
| 447 | (list (map gexp-input->tuple (gexp-inputs exp)) | 441 | (map gexp-input->tuple (gexp-inputs exp)))) |
| 448 | '<> | ||
| 449 | (map gexp-input->tuple (gexp-native-inputs exp))))) | ||
| 450 | 442 | ||
| 451 | (test-assert "input list" | 443 | (test-assert "input list" |
| 452 | (let ((exp (gexp (display | 444 | (let ((exp (gexp (display |
| @@ -456,7 +448,7 @@ | |||
| 456 | (cu (derivation->output-path | 448 | (cu (derivation->output-path |
| 457 | (package-derivation %store coreutils)))) | 449 | (package-derivation %store coreutils)))) |
| 458 | (and (lset= equal? | 450 | (and (lset= equal? |
| 459 | `((,%bootstrap-guile "out") (,coreutils "out")) | 451 | `((,%bootstrap-guile "out" #f) (,coreutils "out" #f)) |
| 460 | (map gexp-input->tuple (gexp-inputs exp))) | 452 | (map gexp-input->tuple (gexp-inputs exp))) |
| 461 | (equal? `(display '(,guile ,cu)) | 453 | (equal? `(display '(,guile ,cu)) |
| 462 | (gexp->sexp* exp))))) | 454 | (gexp->sexp* exp))))) |
| @@ -475,10 +467,8 @@ | |||
| 475 | (xbu (derivation->output-path | 467 | (xbu (derivation->output-path |
| 476 | (package-cross-derivation %store binutils target)))) | 468 | (package-cross-derivation %store binutils target)))) |
| 477 | (and (lset= equal? | 469 | (and (lset= equal? |
| 478 | `((,%bootstrap-guile "out") (,coreutils "out")) | 470 | `((,%bootstrap-guile "out" #t) (,coreutils "out" #t) |
| 479 | (map gexp-input->tuple (gexp-native-inputs exp))) | 471 | (,glibc "out" #f) (,binutils "out" #f)) |
| 480 | (lset= equal? | ||
| 481 | `((,glibc "out") (,binutils "out")) | ||
| 482 | (map gexp-input->tuple (gexp-inputs exp))) | 472 | (map gexp-input->tuple (gexp-inputs exp))) |
| 483 | (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) | 473 | (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) |
| 484 | (gexp->sexp* exp target))))) | 474 | (gexp->sexp* exp target))))) |
| @@ -492,7 +482,7 @@ | |||
| 492 | (package-derivation %store %bootstrap-guile)))) | 482 | (package-derivation %store %bootstrap-guile)))) |
| 493 | (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) | 483 | (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) |
| 494 | (and (lset= equal? | 484 | (and (lset= equal? |
| 495 | `((,glibc "debug") (,%bootstrap-guile "out")) | 485 | `((,glibc "debug" #f) (,%bootstrap-guile "out" #f)) |
| 496 | (map gexp-input->tuple (gexp-inputs exp))) | 486 | (map gexp-input->tuple (gexp-inputs exp))) |
| 497 | (equal? (gexp->sexp* exp) | 487 | (equal? (gexp->sexp* exp) |
| 498 | `(list ,@(cons 5 outputs)))))) | 488 | `(list ,@(cons 5 outputs)))))) |
| @@ -502,18 +492,16 @@ | |||
| 502 | %bootstrap-guile)) | 492 | %bootstrap-guile)) |
| 503 | (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) | 493 | (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) |
| 504 | (and (lset= equal? | 494 | (and (lset= equal? |
| 505 | `((,glibc "debug") (,%bootstrap-guile "out")) | 495 | `((,glibc "debug" #t) (,%bootstrap-guile "out" #t)) |
| 506 | (map gexp-input->tuple (gexp-native-inputs exp))) | 496 | (map gexp-input->tuple (gexp-inputs exp))) |
| 507 | (null? (gexp-inputs exp)) | ||
| 508 | (equal? (gexp->sexp* exp) ;native | 497 | (equal? (gexp->sexp* exp) ;native |
| 509 | (gexp->sexp* exp "mips64el-linux"))))) | 498 | (gexp->sexp* exp "mips64el-linux"))))) |
| 510 | 499 | ||
| 511 | (test-assert "gexp list splicing + ungexp-splicing" | 500 | (test-assert "gexp list splicing + ungexp-splicing" |
| 512 | (let* ((inner (gexp (ungexp-native glibc))) | 501 | (let* ((inner (gexp (ungexp-native glibc))) |
| 513 | (exp (gexp (list (ungexp-splicing (list inner)))))) | 502 | (exp (gexp (list (ungexp-splicing (list inner)))))) |
| 514 | (and (equal? `((,glibc "out")) | 503 | (and (equal? `((,glibc "out" #t)) |
| 515 | (map gexp-input->tuple (gexp-native-inputs exp))) | 504 | (map gexp-input->tuple (gexp-inputs exp))) |
| 516 | (null? (gexp-inputs exp)) | ||
| 517 | (equal? (gexp->sexp* exp) ;native | 505 | (equal? (gexp->sexp* exp) ;native |
| 518 | (gexp->sexp* exp "mips64el-linux"))))) | 506 | (gexp->sexp* exp "mips64el-linux"))))) |
| 519 | 507 | ||
