gnu: linux-libre@4.14: Update to 4.14.198.

[jackhill/guix/guix.git] / tests / inferior.scm

diff --git a/tests/inferior.scm b/tests/inferior.scm
index 03170a1..5fddb1f 100644 (file)
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,11 +21,13 @@
   #:use-module (guix inferior)
   #:use-module (guix packages)
   #:use-module (guix store)
+  #:use-module (guix profiles)
   #:use-module (guix derivations)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages guile)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
@@ -38,6 +40,13 @@
 (define %store
   (open-connection-for-tests))
 
+(define (manifest-entry->list entry)
+  (list (manifest-entry-name entry)
+        (manifest-entry-version entry)
+        (manifest-entry-output entry)
+        (manifest-entry-search-paths entry)
+        (map manifest-entry->list (manifest-entry-dependencies entry))))
+
 \f
 (test-begin "inferior")
 
@@ -52,6 +61,20 @@
            (close-inferior inferior)
            (list a (inferior-object? b))))))
 
+(test-equal "&inferior-exception"
+  '(a b c d)
+  (let ((inferior (open-inferior %top-builddir
+                                 #:command "scripts/guix")))
+    (guard (c ((inferior-exception? c)
+               (close-inferior inferior)
+               (and (eq? inferior (inferior-exception-inferior c))
+                    (match (inferior-exception-stack c)
+                      (((_ (files lines columns)) ..1)
+                       (member "guix/repl.scm" files)))
+                    (inferior-exception-arguments c))))
+      (inferior-eval '(throw 'a 'b 'c 'd) inferior)
+      'badness)))
+
 (test-equal "inferior-packages"
   (take (sort (fold-packages (lambda (package lst)
                                (cons (list (package-name package)
@@ -81,6 +104,26 @@
            (close-inferior inferior)
            result))))
 
+(test-equal "inferior-available-packages"
+  (take (sort (fold-available-packages
+               (lambda* (name version result
+                              #:key supported? deprecated?
+                              #:allow-other-keys)
+                 (if (and supported? (not deprecated?))
+                     (alist-cons name version result)
+                     result))
+               '())
+              (lambda (x y)
+                (string<? (car x) (car y))))
+        10)
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix"))
+         (packages (inferior-available-packages inferior)))
+    (close-inferior inferior)
+    (take (sort packages (lambda (x y)
+                           (string<? (car x) (car y))))
+          10)))
+
 (test-equal "lookup-inferior-packages"
   (let ((->list (lambda (package)
                   (list (package-name package)
@@ -140,6 +183,36 @@
     (close-inferior inferior)
     result))
 
+(test-equal "inferior-package-search-paths"
+  (package-native-search-paths guile-3.0)
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix"))
+         (guile    (first (lookup-inferior-packages inferior "guile")))
+         (result   (inferior-package-native-search-paths guile)))
+    (close-inferior inferior)
+    result))
+
+(test-equal "inferior-eval-with-store"
+  (add-text-to-store %store "foo" "Hello, world!")
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix")))
+    (inferior-eval-with-store inferior %store
+                              '(lambda (store)
+                                 (add-text-to-store store "foo"
+                                                    "Hello, world!")))))
+
+(test-assert "inferior-eval-with-store, &store-protocol-error"
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix")))
+    (guard (c ((store-protocol-error? c)
+               (string-contains (store-protocol-error-message c)
+                                "invalid character")))
+      (inferior-eval-with-store inferior %store
+                                '(lambda (store)
+                                   (add-text-to-store store "we|rd/?!@"
+                                                      "uh uh")))
+      #f)))
+
 (test-equal "inferior-package-derivation"
   (map derivation-file-name
        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
@@ -155,4 +228,25 @@
          (list (inferior-package-derivation %store guile "x86_64-linux")
                (inferior-package-derivation %store guile "armhf-linux")))))
 
+(test-equal "inferior-package->manifest-entry"
+  (manifest-entry->list (package->manifest-entry
+                         (first (find-best-packages-by-name "guile" #f))))
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix"))
+         (guile    (first (lookup-inferior-packages inferior "guile")))
+         (entry    (inferior-package->manifest-entry guile)))
+    (close-inferior inferior)
+    (manifest-entry->list entry)))
+
+(test-equal "packages->manifest"
+  (map manifest-entry->list
+       (manifest-entries (packages->manifest
+                          (find-best-packages-by-name "guile" #f))))
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix"))
+         (guile    (first (lookup-inferior-packages inferior "guile")))
+         (manifest (packages->manifest (list guile))))
+    (close-inferior inferior)
+    (map manifest-entry->list (manifest-entries manifest))))
+
 (test-end "inferior")