summaryrefslogtreecommitdiff
path: root/tests/gexp.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-08-18 14:53:10 +0200
committerLudovic Courtès <ludo@gnu.org>2014-08-18 15:01:58 +0200
commit667b2508464374a01db3588504b981ec9266a2ea (patch)
tree64c495a3dda285cdfa3e89589864ec58a02c6042 /tests/gexp.scm
parent68a61e9ffb4d1c8b54db68d61a3669bda50f1bd2 (diff)
gexp: Add 'ungexp-native' and 'ungexp-native-splicing'.
* guix/gexp.scm (<gexp>)[natives]: New field. (write-gexp): Use both 'gexp-references' and 'gexp-native-references'. (gexp->derivation): Use both 'gexp-inputs' and 'gexp-native-inputs', and append them. (gexp-inputs): Add 'references' parameter and honor it. (gexp-native-inputs): New procedure. (gexp->sexp)[reference->sexp]: Add 'native?' parameter and honor it. Use it, and use 'gexp-native-references'. (gexp)[collect-native-escapes]: New procedure. [escape->ref]: Handle 'ungexp-native' and 'ungexp-native-splicing'. [substitute-ungexp, substitute-ungexp-splicing]: New procedures. [substitute-references]: Use them, and handle 'ungexp-native' and 'ungexp-native-splicing'. Adjust generated 'make-gexp' call to provide both normal references and native references. [read-ungexp]: Support 'ungexp-native' and 'ungexp-native-splicing'. Add reader extension for #+. * tests/gexp.scm (gexp-native-inputs): New procedure. (gexp->sexp*): Add 'target' parameter. ("ungexp + ungexp-native", "input list + ungexp-native", "input list splicing + ungexp-native-splicing", "gexp->derivation, ungexp-native", "gexp->derivation, ungexp + ungexp-native"): New tests. ("sugar"): Add tests for #+ and #+@. * doc/guix.texi (G-Expressions): Document 'ungexp-native' et al.
Diffstat (limited to 'tests/gexp.scm')
-rw-r--r--tests/gexp.scm103
1 files changed, 98 insertions, 5 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 9cc7d41547..694bd409bc 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -39,6 +39,7 @@
;; For white-box testing.
(define gexp-inputs (@@ (guix gexp) gexp-inputs))
+(define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
(define gexp->sexp (@@ (guix gexp) gexp->sexp))
(define guile-for-build
@@ -47,10 +48,8 @@
;; Make it the default.
(%guile-for-build guile-for-build)
-(define* (gexp->sexp* exp #:optional
- (system (%current-system)) target)
+(define* (gexp->sexp* exp #:optional target)
(run-with-store %store (gexp->sexp exp
- #:system system
#:target target)
#:guile-for-build guile-for-build))
@@ -137,6 +136,29 @@
(e3 `(display ,txt)))
(equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
+(test-assert "ungexp + ungexp-native"
+ (let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
+ (ungexp coreutils)
+ (ungexp-native glibc)
+ (ungexp binutils))))
+ (target "mips64el-linux")
+ (guile (derivation->output-path
+ (package-derivation %store %bootstrap-guile)))
+ (cu (derivation->output-path
+ (package-cross-derivation %store coreutils target)))
+ (libc (derivation->output-path
+ (package-derivation %store glibc)))
+ (bu (derivation->output-path
+ (package-cross-derivation %store binutils target))))
+ (and (lset= equal?
+ `((,%bootstrap-guile "out") (,glibc "out"))
+ (gexp-native-inputs exp))
+ (lset= equal?
+ `((,coreutils "out") (,binutils "out"))
+ (gexp-inputs exp))
+ (equal? `(list ,guile ,cu ,libc ,bu)
+ (gexp->sexp* exp target)))))
+
(test-assert "input list"
(let ((exp (gexp (display
'(ungexp (list %bootstrap-guile coreutils)))))
@@ -150,6 +172,28 @@
(equal? `(display '(,guile ,cu))
(gexp->sexp* exp)))))
+(test-assert "input list + ungexp-native"
+ (let* ((target "mips64el-linux")
+ (exp (gexp (display
+ (cons '(ungexp-native (list %bootstrap-guile coreutils))
+ '(ungexp (list glibc binutils))))))
+ (guile (derivation->output-path
+ (package-derivation %store %bootstrap-guile)))
+ (cu (derivation->output-path
+ (package-derivation %store coreutils)))
+ (xlibc (derivation->output-path
+ (package-cross-derivation %store glibc target)))
+ (xbu (derivation->output-path
+ (package-cross-derivation %store binutils target))))
+ (and (lset= equal?
+ `((,%bootstrap-guile "out") (,coreutils "out"))
+ (gexp-native-inputs exp))
+ (lset= equal?
+ `((,glibc "out") (,binutils "out"))
+ (gexp-inputs exp))
+ (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
+ (gexp->sexp* exp target)))))
+
(test-assert "input list splicing"
(let* ((inputs (list (list glibc "debug") %bootstrap-guile))
(outputs (list (derivation->output-path
@@ -164,6 +208,16 @@
(equal? (gexp->sexp* exp)
`(list ,@(cons 5 outputs))))))
+(test-assert "input list splicing + ungexp-native-splicing"
+ (let* ((inputs (list (list glibc "debug") %bootstrap-guile))
+ (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
+ (and (lset= equal?
+ `((,glibc "debug") (,%bootstrap-guile "out"))
+ (gexp-native-inputs exp))
+ (null? (gexp-inputs exp))
+ (equal? (gexp->sexp* exp) ;native
+ (gexp->sexp* exp "mips64el-linux")))))
+
(test-assertm "gexp->file"
(mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
(guile (package-file %bootstrap-guile))
@@ -240,6 +294,41 @@
(return (and (member (derivation-file-name xcu) refs)
(not (member (derivation-file-name cu) refs))))))
+(test-assertm "gexp->derivation, ungexp-native"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp -> (gexp (list (ungexp-native coreutils)
+ (ungexp output))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (drv (gexp->derivation "foo" exp)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name xdrv)))))
+
+(test-assertm "gexp->derivation, ungexp + ungexp-native"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp -> (gexp (list (ungexp-native coreutils)
+ (ungexp glibc)
+ (ungexp output))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (refs ((store-lift references)
+ (derivation-file-name xdrv)))
+ (xglibc (package->cross-derivation glibc target))
+ (cu (package->derivation coreutils)))
+ (return (and (member (derivation-file-name cu) refs)
+ (member (derivation-file-name xglibc) refs)))))
+
+(test-assertm "gexp->derivation, ungexp-native + composed gexps"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp0 -> (gexp (list 1 2
+ (ungexp coreutils))))
+ (exp -> (gexp (list 0 (ungexp-native exp0))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (drv (gexp->derivation "foo" exp)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name xdrv)))))
+
(define shebang
(string-append "#!" (derivation->output-path guile-for-build)
"/bin/guile --no-auto-compile"))
@@ -285,8 +374,12 @@
(test-equal "sugar"
'(gexp (foo (ungexp bar) (ungexp baz "out")
(ungexp (chbouib 42))
- (ungexp-splicing (list x y z))))
- '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)))
+ (ungexp-splicing (list x y z))
+ (ungexp-native foo) (ungexp-native foo "out")
+ (ungexp-native (chbouib 42))
+ (ungexp-native-splicing (list x y z))))
+ '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
+ #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
(test-end "gexp")