tests/inferior.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 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 "lookup-inferior-packages"
  93   (let ((->list (lambda (package)
  94                   (list (package-name package)
  95                         (package-version package)
  96                         (package-location package)))))
  97     (list (map ->list (find-packages-by-name "guile" #f))
  98           (map ->list (find-packages-by-name "guile" "2.2"))))
  99   (let* ((inferior (open-inferior %top-builddir
 100                                   #:command "scripts/guix"))
 101          (->list   (lambda (package)
 102                      (list (inferior-package-name package)
 103                            (inferior-package-version package)
 104                            (inferior-package-location package))))
 105          (lst1     (map ->list
 106                         (lookup-inferior-packages inferior "guile")))
 107          (lst2     (map ->list
 108                         (lookup-inferior-packages inferior
 109                                                   "guile" "2.2"))))
 110     (close-inferior inferior)
 111     (list lst1 lst2)))
 112
 113 (test-assert "lookup-inferior-packages and eq?-ness"
 114   (let* ((inferior (open-inferior %top-builddir
 115                                   #:command "scripts/guix"))
 116          (lst1     (lookup-inferior-packages inferior "guile"))
 117          (lst2     (lookup-inferior-packages inferior "guile")))
 118     (close-inferior inferior)
 119     (every eq? lst1 lst2)))
 120
 121 (test-equal "inferior-package-inputs"
 122   (let ((->list (match-lambda
 123                   ((label (? package? package) . rest)
 124                    `(,label
 125                      (package ,(package-name package)
 126                               ,(package-version package)
 127                               ,(package-location package))
 128                      ,@rest)))))
 129     (list (map ->list (package-inputs guile-2.2))
 130           (map ->list (package-native-inputs guile-2.2))
 131           (map ->list (package-propagated-inputs guile-2.2))))
 132   (let* ((inferior (open-inferior %top-builddir
 133                                   #:command "scripts/guix"))
 134          (guile    (first (lookup-inferior-packages inferior "guile")))
 135          (->list   (match-lambda
 136                      ((label (? inferior-package? package) . rest)
 137                       `(,label
 138                         (package ,(inferior-package-name package)
 139                                  ,(inferior-package-version package)
 140                                  ,(inferior-package-location package))
 141                         ,@rest))))
 142          (result   (list (map ->list (inferior-package-inputs guile))
 143                          (map ->list
 144                               (inferior-package-native-inputs guile))
 145                          (map ->list
 146                               (inferior-package-propagated-inputs
 147                                guile)))))
 148     (close-inferior inferior)
 149     result))
 150
 151 (test-equal "inferior-package-search-paths"
 152   (package-native-search-paths guile-2.2)
 153   (let* ((inferior (open-inferior %top-builddir
 154                                   #:command "scripts/guix"))
 155          (guile    (first (lookup-inferior-packages inferior "guile")))
 156          (result   (inferior-package-native-search-paths guile)))
 157     (close-inferior inferior)
 158     result))
 159
 160 (test-equal "inferior-package-derivation"
 161   (map derivation-file-name
 162        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
 163              (package-derivation %store %bootstrap-guile "armhf-linux")))
 164   (let* ((inferior (open-inferior %top-builddir
 165                                   #:command "scripts/guix"))
 166          (packages (inferior-packages inferior))
 167          (guile    (find (lambda (package)
 168                            (string=? (package-name %bootstrap-guile)
 169                                      (inferior-package-name package)))
 170                          packages)))
 171     (map derivation-file-name
 172          (list (inferior-package-derivation %store guile "x86_64-linux")
 173                (inferior-package-derivation %store guile "armhf-linux")))))
 174
 175 (test-equal "inferior-package->manifest-entry"
 176   (manifest-entry->list (package->manifest-entry
 177                          (first (find-best-packages-by-name "guile" #f))))
 178   (let* ((inferior (open-inferior %top-builddir
 179                                   #:command "scripts/guix"))
 180          (guile    (first (lookup-inferior-packages inferior "guile")))
 181          (entry    (inferior-package->manifest-entry guile)))
 182     (close-inferior inferior)
 183     (manifest-entry->list entry)))
 184
 185 (test-equal "packages->manifest"
 186   (map manifest-entry->list
 187        (manifest-entries (packages->manifest
 188                           (find-best-packages-by-name "guile" #f))))
 189   (let* ((inferior (open-inferior %top-builddir
 190                                   #:command "scripts/guix"))
 191          (guile    (first (lookup-inferior-packages inferior "guile")))
 192          (manifest (packages->manifest (list guile))))
 193     (close-inferior inferior)
 194     (map manifest-entry->list (manifest-entries manifest))))
 195
 196 (test-end "inferior")