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 8e80d4adbe..7a3228ec2e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1006,13 +1006,9 @@ derivations--e.g., code evaluated for its side effects." (guile (if guile-for-build (return guile-for-build) (default-guile-derivation system))) - (normals (lower-inputs (gexp-inputs exp) + (inputs (lower-inputs (gexp-inputs exp) #:system system #:target target)) - (natives (lower-inputs (gexp-native-inputs exp) - #:system system - #:target #f)) - (inputs -> (append normals natives)) (sexp (gexp->sexp exp #:system system #:target target)) @@ -1218,26 +1214,26 @@ The other arguments are as for 'derivation'." #:substitutable? substitutable? #:properties properties)))) -(define* (gexp-inputs exp #:key native?) - "Return the list of <gexp-input> for EXP. When NATIVE? is true, return only -native references; otherwise, return only non-native references." +(define (gexp-inputs exp) + "Return the list of <gexp-input> for EXP." + (define set-gexp-input-native? + (match-lambda + (($ <gexp-input> thing output) + (%gexp-input thing output #t)))) + (define (add-reference-inputs ref result) (match ref (($ <gexp-input> (? gexp? exp) _ #t) - (if native? - (append (gexp-inputs exp) - (gexp-inputs exp #:native? #t) - result) - result)) - (($ <gexp-input> (? gexp? exp) _ #f) - (append (gexp-inputs exp #:native? native?) + (append (map set-gexp-input-native? (gexp-inputs exp)) result)) + (($ <gexp-input> (? gexp? exp) _ #f) + (append (gexp-inputs exp) result)) (($ <gexp-input> (? string? str)) (if (direct-store-path? str) (cons ref result) result)) (($ <gexp-input> (? struct? thing) output n?) - (if (and (eqv? n? native?) (lookup-compiler thing)) + (if (lookup-compiler thing) ;; THING is a derivation, or a package, or an origin, etc. (cons ref result) result)) @@ -1261,9 +1257,6 @@ native references; otherwise, return only non-native references." '() (gexp-references exp))) -(define gexp-native-inputs - (cut gexp-inputs <> #:native? #t)) - (define (gexp-outputs exp) "Return the outputs referred to by EXP as a list of strings." (define (add-reference-output ref result) diff --git a/tests/gexp.scm b/tests/gexp.scm index f742c5db76..0bd1237316 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -51,8 +51,6 @@ ;; For white-box testing. (define (gexp-inputs x) ((@@ (guix gexp) gexp-inputs) x)) -(define (gexp-native-inputs x) - ((@@ (guix gexp) gexp-native-inputs) x)) (define (gexp-outputs x) ((@@ (guix gexp) gexp-outputs) x)) (define (gexp->sexp . x) @@ -64,7 +62,8 @@ #:guile-for-build (%guile-for-build))) (define (gexp-input->tuple input) - (list (gexp-input-thing input) (gexp-input-output input))) + (list (gexp-input-thing input) (gexp-input-output input) + (gexp-input-native? input))) (define %extension-package ;; Example of a package to use when testing 'with-extensions'. @@ -347,7 +346,7 @@ (string-append (derivation->output-path drv) "/bin/touch")))))) (test-equal "let-system" - (list `(begin ,(%current-system) #t) '(system-binding) '() + (list `(begin ,(%current-system) #t) '(system-binding) 'low '() '()) (let* ((exp #~(begin #$(let-system system system) @@ -361,7 +360,6 @@ (string=? (gexp-input-output input) "out") '(system-binding))) (x x)) - (gexp-native-inputs exp) 'low (lowered-gexp-inputs low) (lowered-gexp-sources low)))) @@ -383,7 +381,6 @@ (test-equal "let-system, nested" (list `(system* ,(string-append "qemu-system-" (%current-system)) "-m" "256") - '() '(system-binding)) (let ((exp #~(system* #+(let-system (system target) @@ -398,12 +395,12 @@ (basename command)) ,@rest)) (x x)) - (gexp-inputs exp) - (match (gexp-native-inputs exp) + (match (gexp-inputs exp) ((input) (and (eq? (struct-vtable (gexp-input-thing input)) (@@ (guix gexp) <system-binding>)) (string=? (gexp-input-output input) "out") + (gexp-input-native? input) '(system-binding))) (x x))))) @@ -422,31 +419,26 @@ (bu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,glibc "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (lset= equal? - `((,coreutils "out") (,binutils "out")) + `((,%bootstrap-guile "out" #t) + (,coreutils "out" #f) + (,glibc "out" #t) + (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) (test-equal "ungexp + ungexp-native, nested" - (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) + `((,%bootstrap-guile "out" #f) (,coreutils "out" #t)) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) (ungexp %bootstrap-guile))))) - (list (map gexp-input->tuple (gexp-inputs exp)) - '<> - (map gexp-input->tuple (gexp-native-inputs exp))))) + (map gexp-input->tuple (gexp-inputs exp)))) (test-equal "ungexp + ungexp-native, nested, special mixture" - `(() <> ((,coreutils "out"))) + `((,coreutils "out" #t)) - ;; (gexp-native-inputs exp) used to return '(), wrongfully. (let* ((foo (gexp (foo (ungexp-native coreutils)))) (exp (gexp (bar (ungexp foo))))) - (list (map gexp-input->tuple (gexp-inputs exp)) - '<> - (map gexp-input->tuple (gexp-native-inputs exp))))) + (map gexp-input->tuple (gexp-inputs exp)))) (test-assert "input list" (let ((exp (gexp (display @@ -456,7 +448,7 @@ (cu (derivation->output-path (package-derivation %store coreutils)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,coreutils "out")) + `((,%bootstrap-guile "out" #f) (,coreutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display '(,guile ,cu)) (gexp->sexp* exp))))) @@ -475,10 +467,8 @@ (xbu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,coreutils "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (lset= equal? - `((,glibc "out") (,binutils "out")) + `((,%bootstrap-guile "out" #t) (,coreutils "out" #t) + (,glibc "out" #f) (,binutils "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (gexp->sexp* exp target))))) @@ -492,7 +482,7 @@ (package-derivation %store %bootstrap-guile)))) (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? - `((,glibc "debug") (,%bootstrap-guile "out")) + `((,glibc "debug" #f) (,%bootstrap-guile "out" #f)) (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) `(list ,@(cons 5 outputs)))))) @@ -502,18 +492,16 @@ %bootstrap-guile)) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? - `((,glibc "debug") (,%bootstrap-guile "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (null? (gexp-inputs exp)) + `((,glibc "debug" #t) (,%bootstrap-guile "out" #t)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-assert "gexp list splicing + ungexp-splicing" (let* ((inner (gexp (ungexp-native glibc))) (exp (gexp (list (ungexp-splicing (list inner)))))) - (and (equal? `((,glibc "out")) - (map gexp-input->tuple (gexp-native-inputs exp))) - (null? (gexp-inputs exp)) + (and (equal? `((,glibc "out" #t)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) |