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 derivations)
  25   #:use-module (gnu packages)
  26   #:use-module (gnu packages bootstrap)
  27   #:use-module (gnu packages guile)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-64)
  30   #:use-module (ice-9 match))
  31
  32 (define %top-srcdir
  33   (dirname (search-path %load-path "guix.scm")))
  34
  35 (define %top-builddir
  36   (dirname (search-path %load-compiled-path "guix.go")))
  37
  38 (define %store
  39   (open-connection-for-tests))
  40
  41 \f
  42 (test-begin "inferior")
  43
  44 (test-equal "open-inferior"
  45   '(42 #t)
  46   (let ((inferior (open-inferior %top-builddir
  47                                  #:command "scripts/guix")))
  48     (and (inferior? inferior)
  49          (let ((a (inferior-eval '(apply * '(6 7)) inferior))
  50                (b (inferior-eval '(@ (gnu packages base) coreutils)
  51                                  inferior)))
  52            (close-inferior inferior)
  53            (list a (inferior-object? b))))))
  54
  55 (test-equal "inferior-packages"
  56   (take (sort (fold-packages (lambda (package lst)
  57                                (cons (list (package-name package)
  58                                            (package-version package)
  59                                            (package-home-page package)
  60                                            (package-location package))
  61                                      lst))
  62                              '())
  63               (lambda (x y)
  64                 (string<? (car x) (car y))))
  65         10)
  66   (let* ((inferior (open-inferior %top-builddir
  67                                   #:command "scripts/guix"))
  68          (packages (inferior-packages inferior)))
  69     (and (every string? (map inferior-package-synopsis packages))
  70          (let ()
  71            (define result
  72              (take (sort (map (lambda (package)
  73                                 (list (inferior-package-name package)
  74                                       (inferior-package-version package)
  75                                       (inferior-package-home-page package)
  76                                       (inferior-package-location package)))
  77                               packages)
  78                          (lambda (x y)
  79                            (string<? (car x) (car y))))
  80                    10))
  81            (close-inferior inferior)
  82            result))))
  83
  84 (test-equal "lookup-inferior-packages"
  85   (let ((->list (lambda (package)
  86                   (list (package-name package)
  87                         (package-version package)
  88                         (package-location package)))))
  89     (list (map ->list (find-packages-by-name "guile" #f))
  90           (map ->list (find-packages-by-name "guile" "2.2"))))
  91   (let* ((inferior (open-inferior %top-builddir
  92                                   #:command "scripts/guix"))
  93          (->list   (lambda (package)
  94                      (list (inferior-package-name package)
  95                            (inferior-package-version package)
  96                            (inferior-package-location package))))
  97          (lst1     (map ->list
  98                         (lookup-inferior-packages inferior "guile")))
  99          (lst2     (map ->list
 100                         (lookup-inferior-packages inferior
 101                                                   "guile" "2.2"))))
 102     (close-inferior inferior)
 103     (list lst1 lst2)))
 104
 105 (test-assert "lookup-inferior-packages and eq?-ness"
 106   (let* ((inferior (open-inferior %top-builddir
 107                                   #:command "scripts/guix"))
 108          (lst1     (lookup-inferior-packages inferior "guile"))
 109          (lst2     (lookup-inferior-packages inferior "guile")))
 110     (close-inferior inferior)
 111     (every eq? lst1 lst2)))
 112
 113 (test-equal "inferior-package-inputs"
 114   (let ((->list (match-lambda
 115                   ((label (? package? package) . rest)
 116                    `(,label
 117                      (package ,(package-name package)
 118                               ,(package-version package)
 119                               ,(package-location package))
 120                      ,@rest)))))
 121     (list (map ->list (package-inputs guile-2.2))
 122           (map ->list (package-native-inputs guile-2.2))
 123           (map ->list (package-propagated-inputs guile-2.2))))
 124   (let* ((inferior (open-inferior %top-builddir
 125                                   #:command "scripts/guix"))
 126          (guile    (first (lookup-inferior-packages inferior "guile")))
 127          (->list   (match-lambda
 128                      ((label (? inferior-package? package) . rest)
 129                       `(,label
 130                         (package ,(inferior-package-name package)
 131                                  ,(inferior-package-version package)
 132                                  ,(inferior-package-location package))
 133                         ,@rest))))
 134          (result   (list (map ->list (inferior-package-inputs guile))
 135                          (map ->list
 136                               (inferior-package-native-inputs guile))
 137                          (map ->list
 138                               (inferior-package-propagated-inputs
 139                                guile)))))
 140     (close-inferior inferior)
 141     result))
 142
 143 (test-equal "inferior-package-search-paths"
 144   (package-native-search-paths guile-2.2)
 145   (let* ((inferior (open-inferior %top-builddir
 146                                   #:command "scripts/guix"))
 147          (guile    (first (lookup-inferior-packages inferior "guile")))
 148          (result   (inferior-package-native-search-paths guile)))
 149     (close-inferior inferior)
 150     result))
 151
 152 (test-equal "inferior-package-derivation"
 153   (map derivation-file-name
 154        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
 155              (package-derivation %store %bootstrap-guile "armhf-linux")))
 156   (let* ((inferior (open-inferior %top-builddir
 157                                   #:command "scripts/guix"))
 158          (packages (inferior-packages inferior))
 159          (guile    (find (lambda (package)
 160                            (string=? (package-name %bootstrap-guile)
 161                                      (inferior-package-name package)))
 162                          packages)))
 163     (map derivation-file-name
 164          (list (inferior-package-derivation %store guile "x86_64-linux")
 165                (inferior-package-derivation %store guile "armhf-linux")))))
 166
 167 (test-end "inferior")