aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/gexp.scm118
-rw-r--r--tests/monads.scm25
-rw-r--r--tests/profiles.scm21
-rw-r--r--tests/ui.scm5
4 files changed, 165 insertions, 4 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm
index bdea4b8563..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,8 +48,9 @@
;; Make it the default.
(%guile-for-build guile-for-build)
-(define (gexp->sexp* exp)
- (run-with-store %store (gexp->sexp exp)
+(define* (gexp->sexp* exp #:optional target)
+ (run-with-store %store (gexp->sexp exp
+ #:target target)
#:guile-for-build guile-for-build))
(define-syntax-rule (test-assertm name exp)
@@ -134,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)))))
@@ -147,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
@@ -161,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))
@@ -223,6 +280,55 @@
(mlet %store-monad ((drv mdrv))
(return (string=? system (derivation-system drv))))))
+(test-assertm "gexp->derivation, cross-compilation"
+ (mlet* %store-monad ((target -> "mips64el-linux")
+ (exp -> (gexp (list (ungexp coreutils)
+ (ungexp output))))
+ (xdrv (gexp->derivation "foo" exp
+ #:target target))
+ (refs ((store-lift references)
+ (derivation-file-name xdrv)))
+ (xcu (package->cross-derivation coreutils
+ target))
+ (cu (package->derivation coreutils)))
+ (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"))
@@ -268,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")
diff --git a/tests/monads.scm b/tests/monads.scm
index ea3e4006ab..b814b0f7c5 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -24,6 +24,7 @@
#:select (package-derivation %current-system))
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
+ #:use-module ((gnu packages base) #:select (coreutils))
#:use-module (ice-9 match)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
@@ -108,6 +109,30 @@
guile)))
#:guile-for-build (package-derivation %store %bootstrap-guile)))
+(test-assert "package-file, default system"
+ ;; The default system should be the one at '>>=' time, not the one at
+ ;; invocation time. See <http://bugs.gnu.org/18002>.
+ (run-with-store %store
+ (mlet* %store-monad
+ ((system -> (%current-system))
+ (file (parameterize ((%current-system "foobar64-linux"))
+ (package-file coreutils "bin/ls")))
+ (cu (package->derivation coreutils)))
+ (return (string=? file
+ (string-append (derivation->output-path cu)
+ "/bin/ls"))))
+ #:guile-for-build (package-derivation %store %bootstrap-guile)))
+
+(test-assert "package-file + package->cross-derivation"
+ (run-with-store %store
+ (mlet* %store-monad ((file (package-file coreutils "bin/ls"
+ #:target "foo64-gnu"))
+ (xcu (package->cross-derivation coreutils
+ "foo64-gnu")))
+ (let ((output (derivation->output-path xcu)))
+ (return (string=? file (string-append output "/bin/ls")))))
+ #:guile-for-build (package-derivation %store %bootstrap-guile)))
+
(test-assert "interned-file"
(run-with-store %store
(mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d405f6453e..b2919d7315 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -40,6 +40,13 @@
;; Example manifest entries.
+(define guile-1.8.8
+ (manifest-entry
+ (name "guile")
+ (version "1.8.8")
+ (item "/gnu/store/...")
+ (output "out")))
+
(define guile-2.0.9
(manifest-entry
(name "guile")
@@ -101,6 +108,20 @@
(null? (manifest-entries m3))
(null? (manifest-entries m4)))))))
+(test-assert "manifest-add"
+ (let* ((m0 (manifest '()))
+ (m1 (manifest-add m0 (list guile-1.8.8)))
+ (m2 (manifest-add m1 (list guile-2.0.9)))
+ (m3 (manifest-add m2 (list guile-2.0.9:debug)))
+ (m4 (manifest-add m3 (list guile-2.0.9:debug))))
+ (and (match (manifest-entries m1)
+ ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
+ (_ #f))
+ (match (manifest-entries m2)
+ ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
+ (_ #f))
+ (equal? m3 m4))))
+
(test-assert "profile-derivation"
(run-with-store %store
(mlet* %store-monad
diff --git a/tests/ui.scm b/tests/ui.scm
index 4bf7a779c5..7cc02649e1 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -67,6 +67,11 @@ interface, and powerful string processing.")
10)
#\newline))
+(test-equal "fill-paragraph, two spaces after period"
+ "First line. Second line"
+ (fill-paragraph "First line.
+Second line" 24))
+
(test-equal "package-specification->name+version+output"
'(("guile" #f "out")
("guile" "2.0.9" "out")