(mkdir-p out)
(call-with-output-file (string-append out "/hg2g.scm")
(lambda (port)
- (write '(define-module (hg2g)
+ (define defmod 'define-module) ;fool Geiser
+ (write `(,defmod (hg2g)
#:export (the-answer))
port)
(write '(define the-answer 42) port)))))))))
(((thing "out"))
(eq? thing file))))))
+(test-assert "file-append, raw store item"
+ (let* ((obj (plain-file "example.txt" "Hello!"))
+ (a (file-append obj "/a"))
+ (b (file-append a "/b"))
+ (c (file-append b "/c"))
+ (exp #~(list #$c))
+ (item (run-with-store %store (lower-object obj)))
+ (lexp (run-with-store %store (lower-gexp exp))))
+ (and (equal? (lowered-gexp-sexp lexp)
+ `(list ,(string-append item "/a/b/c")))
+ (equal? (lowered-gexp-sources lexp)
+ (list item))
+ (null? (lowered-gexp-inputs lexp)))))
+
+(test-assertm "with-parameters for %current-system"
+ (mlet* %store-monad ((system -> (match (%current-system)
+ ("aarch64-linux" "x86_64-linux")
+ (_ "aarch64-linux")))
+ (drv (package->derivation coreutils system))
+ (obj -> (with-parameters ((%current-system system))
+ coreutils))
+ (result (lower-object obj)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name result)))))
+
+(test-assertm "with-parameters for %current-target-system"
+ (mlet* %store-monad ((target -> "riscv64-linux-gnu")
+ (drv (package->cross-derivation coreutils target))
+ (obj -> (with-parameters
+ ((%current-target-system target))
+ coreutils))
+ (result (lower-object obj)))
+ (return (string=? (derivation-file-name drv)
+ (derivation-file-name result)))))
+
+(test-assert "with-parameters + file-append"
+ (let* ((system (match (%current-system)
+ ("aarch64-linux" "x86_64-linux")
+ (_ "aarch64-linux")))
+ (drv (package-derivation %store coreutils system))
+ (param (make-parameter 7))
+ (exp #~(here we go #$(with-parameters ((%current-system system)
+ (param 42))
+ (if (= (param) 42)
+ (file-append coreutils "/bin/touch")
+ %bootstrap-guile)))))
+ (match (gexp->sexp* exp)
+ (('here 'we 'go (? string? result))
+ (string=? result
+ (string-append (derivation->output-path drv)
+ "/bin/touch"))))))
+(test-equal "let-system"
+ (list `(begin ,(%current-system) #t) '(system-binding) '()
+ 'low '() '())
+ (let* ((exp #~(begin
+ #$(let-system system system)
+ #t))
+ (low (run-with-store %store (lower-gexp exp))))
+ (list (lowered-gexp-sexp low)
+ (match (gexp-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x))
+ (gexp-native-inputs exp)
+ 'low
+ (lowered-gexp-inputs low)
+ (lowered-gexp-sources low))))
+
+(test-equal "let-system, target"
+ (list `(list ,(%current-system) #f)
+ `(list ,(%current-system) "aarch64-linux-gnu"))
+ (let ((exp #~(list #$@(let-system (system target)
+ (list system target)))))
+ (list (gexp->sexp* exp)
+ (gexp->sexp* exp "aarch64-linux-gnu"))))
+
+(test-equal "let-system, ungexp-native, target"
+ `(here it is: ,(%current-system) #f)
+ (let ((exp #~(here it is: #+@(let-system (system target)
+ (list system target)))))
+ (gexp->sexp* exp "aarch64-linux-gnu")))
+
+(test-equal "let-system, nested"
+ (list `(system* ,(string-append "qemu-system-" (%current-system))
+ "-m" "256")
+ '()
+ '(system-binding))
+ (let ((exp #~(system*
+ #+(let-system (system target)
+ (file-append (@@ (gnu packages virtualization)
+ qemu)
+ "/bin/qemu-system-"
+ system))
+ "-m" "256")))
+ (list (match (gexp->sexp* exp)
+ (('system* command rest ...)
+ `(system* ,(and (string-prefix? (%store-prefix) command)
+ (basename command))
+ ,@rest))
+ (x x))
+ (gexp-inputs exp)
+ (match (gexp-native-inputs exp)
+ (((($ (@@ (guix gexp) <system-binding>)) "out"))
+ '(system-binding))
+ (x x)))))
+
(test-assert "ungexp + ungexp-native"
(let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
(ungexp coreutils)
'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
#+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
+(test-assertm "gexp->file, cross-compilation"
+ (mlet* %store-monad ((target -> "aarch64-linux-gnu")
+ (exp -> (gexp (list (ungexp coreutils))))
+ (xdrv (gexp->file "foo" exp #:target target))
+ (refs (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->file, cross-compilation with default target"
+ (mlet* %store-monad ((target -> "aarch64-linux-gnu")
+ (_ (set-current-target target))
+ (exp -> (gexp (list (ungexp coreutils))))
+ (xdrv (gexp->file "foo" exp))
+ (refs (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->script, cross-compilation"
+ (mlet* %store-monad ((target -> "aarch64-linux-gnu")
+ (exp -> (gexp (list (ungexp coreutils))))
+ (xdrv (gexp->script "foo" exp #:target target))
+ (refs (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->script, cross-compilation with default target"
+ (mlet* %store-monad ((target -> "aarch64-linux-gnu")
+ (_ (set-current-target target))
+ (exp -> (gexp (list (ungexp coreutils))))
+ (xdrv (gexp->script "foo" exp))
+ (refs (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-end "gexp")
;; Local Variables:
HCoop / jackhill / guix / guix.git / blobdiff