tests/inferior.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-inferior)
  20   #:use-module (guix tests)
  21   #:use-module (guix inferior)
  22   #:use-module (guix packages)
  23   #:use-module (guix store)
  24   #:use-module (guix profiles)
  25   #:use-module (guix derivations)
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages bootstrap)
  28   #:use-module (gnu packages guile)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-64)
  31   #:use-module (ice-9 match))
  32
  33 (define %top-srcdir
  34   (dirname (search-path %load-path "guix.scm")))
  35
  36 (define %top-builddir
  37   (dirname (search-path %load-compiled-path "guix.go")))
  38
  39 (define %store
  40   (open-connection-for-tests))
  41
  42 (define (manifest-entry->list entry)
  43   (list (manifest-entry-name entry)
  44         (manifest-entry-version entry)
  45         (manifest-entry-output entry)
  46         (manifest-entry-search-paths entry)
  47         (map manifest-entry->list (manifest-entry-dependencies entry))))
  48
  49 \f
  50 (test-begin "inferior")
  51
  52 (test-equal "open-inferior"
  53   '(42 #t)
  54   (let ((inferior (open-inferior %top-builddir
  55                                  #:command "scripts/guix")))
  56     (and (inferior? inferior)
  57          (let ((a (inferior-eval '(apply * '(6 7)) inferior))
  58                (b (inferior-eval '(@ (gnu packages base) coreutils)
  59                                  inferior)))
  60            (close-inferior inferior)
  61            (list a (inferior-object? b))))))
  62
  63 (test-equal "inferior-packages"
  64   (take (sort (fold-packages (lambda (package lst)
  65                                (cons (list (package-name package)
  66                                            (package-version package)
  67                                            (package-home-page package)
  68                                            (package-location package))
  69                                      lst))
  70                              '())
  71               (lambda (x y)
  72                 (string<? (car x) (car y))))
  73         10)
  74   (let* ((inferior (open-inferior %top-builddir
  75                                   #:command "scripts/guix"))
  76          (packages (inferior-packages inferior)))
  77     (and (every string? (map inferior-package-synopsis packages))
  78          (let ()
  79            (define result
  80              (take (sort (map (lambda (package)
  81                                 (list (inferior-package-name package)
  82                                       (inferior-package-version package)
  83                                       (inferior-package-home-page package)
  84                                       (inferior-package-location package)))
  85                               packages)
  86                          (lambda (x y)
  87                            (string<? (car x) (car y))))
  88                    10))
  89            (close-inferior inferior)
  90            result))))
  91
  92 (test-equal "inferior-available-packages"
  93   (take (sort (fold-available-packages
  94                (lambda* (name version result
  95                               #:key supported? deprecated?
  96                               #:allow-other-keys)
  97                  (if (and supported? (not deprecated?))
  98                      (alist-cons name version result)
  99                      result))
 100                '())
 101               (lambda (x y)
 102                 (string<? (car x) (car y))))
 103         10)
 104   (let* ((inferior (open-inferior %top-builddir
 105                                   #:command "scripts/guix"))
 106          (packages (inferior-available-packages inferior)))
 107     (close-inferior inferior)
 108     (take (sort packages (lambda (x y)
 109                            (string<? (car x) (car y))))
 110           10)))
 111
 112 (test-equal "lookup-inferior-packages"
 113   (let ((->list (lambda (package)
 114                   (list (package-name package)
 115                         (package-version package)
 116                         (package-location package)))))
 117     (list (map ->list (find-packages-by-name "guile" #f))
 118           (map ->list (find-packages-by-name "guile" "2.2"))))
 119   (let* ((inferior (open-inferior %top-builddir
 120                                   #:command "scripts/guix"))
 121          (->list   (lambda (package)
 122                      (list (inferior-package-name package)
 123                            (inferior-package-version package)
 124                            (inferior-package-location package))))
 125          (lst1     (map ->list
 126                         (lookup-inferior-packages inferior "guile")))
 127          (lst2     (map ->list
 128                         (lookup-inferior-packages inferior
 129                                                   "guile" "2.2"))))
 130     (close-inferior inferior)
 131     (list lst1 lst2)))
 132
 133 (test-assert "lookup-inferior-packages and eq?-ness"
 134   (let* ((inferior (open-inferior %top-builddir
 135                                   #:command "scripts/guix"))
 136          (lst1     (lookup-inferior-packages inferior "guile"))
 137          (lst2     (lookup-inferior-packages inferior "guile")))
 138     (close-inferior inferior)
 139     (every eq? lst1 lst2)))
 140
 141 (test-equal "inferior-package-inputs"
 142   (let ((->list (match-lambda
 143                   ((label (? package? package) . rest)
 144                    `(,label
 145                      (package ,(package-name package)
 146                               ,(package-version package)
 147                               ,(package-location package))
 148                      ,@rest)))))
 149     (list (map ->list (package-inputs guile-2.2))
 150           (map ->list (package-native-inputs guile-2.2))
 151           (map ->list (package-propagated-inputs guile-2.2))))
 152   (let* ((inferior (open-inferior %top-builddir
 153                                   #:command "scripts/guix"))
 154          (guile    (first (lookup-inferior-packages inferior "guile")))
 155          (->list   (match-lambda
 156                      ((label (? inferior-package? package) . rest)
 157                       `(,label
 158                         (package ,(inferior-package-name package)
 159                                  ,(inferior-package-version package)
 160                                  ,(inferior-package-location package))
 161                         ,@rest))))
 162          (result   (list (map ->list (inferior-package-inputs guile))
 163                          (map ->list
 164                               (inferior-package-native-inputs guile))
 165                          (map ->list
 166                               (inferior-package-propagated-inputs
 167                                guile)))))
 168     (close-inferior inferior)
 169     result))
 170
 171 (test-equal "inferior-package-search-paths"
 172   (package-native-search-paths guile-2.2)
 173   (let* ((inferior (open-inferior %top-builddir
 174                                   #:command "scripts/guix"))
 175          (guile    (first (lookup-inferior-packages inferior "guile")))
 176          (result   (inferior-package-native-search-paths guile)))
 177     (close-inferior inferior)
 178     result))
 179
 180 (test-equal "inferior-eval-with-store"
 181   (add-text-to-store %store "foo" "Hello, world!")
 182   (let* ((inferior (open-inferior %top-builddir
 183                                   #:command "scripts/guix")))
 184     (inferior-eval-with-store inferior %store
 185                               '(lambda (store)
 186                                  (add-text-to-store store "foo"
 187                                                     "Hello, world!")))))
 188
 189 (test-equal "inferior-package-derivation"
 190   (map derivation-file-name
 191        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
 192              (package-derivation %store %bootstrap-guile "armhf-linux")))
 193   (let* ((inferior (open-inferior %top-builddir
 194                                   #:command "scripts/guix"))
 195          (packages (inferior-packages inferior))
 196          (guile    (find (lambda (package)
 197                            (string=? (package-name %bootstrap-guile)
 198                                      (inferior-package-name package)))
 199                          packages)))
 200     (map derivation-file-name
 201          (list (inferior-package-derivation %store guile "x86_64-linux")
 202                (inferior-package-derivation %store guile "armhf-linux")))))
 203
 204 (test-equal "inferior-package->manifest-entry"
 205   (manifest-entry->list (package->manifest-entry
 206                          (first (find-best-packages-by-name "guile" #f))))
 207   (let* ((inferior (open-inferior %top-builddir
 208                                   #:command "scripts/guix"))
 209          (guile    (first (lookup-inferior-packages inferior "guile")))
 210          (entry    (inferior-package->manifest-entry guile)))
 211     (close-inferior inferior)
 212     (manifest-entry->list entry)))
 213
 214 (test-equal "packages->manifest"
 215   (map manifest-entry->list
 216        (manifest-entries (packages->manifest
 217                           (find-best-packages-by-name "guile" #f))))
 218   (let* ((inferior (open-inferior %top-builddir
 219                                   #:command "scripts/guix"))
 220          (guile    (first (lookup-inferior-packages inferior "guile")))
 221          (manifest (packages->manifest (list guile))))
 222     (close-inferior inferior)
 223     (map manifest-entry->list (manifest-entries manifest))))
 224
 225 (test-end "inferior")