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

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

diff --git a/tests/ui.scm b/tests/ui.scm
index 3d5c3e7..3dc6952 100644 (file)
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,9 +19,17 @@
 
 (define-module (test-ui)
   #:use-module (guix ui)
+  #:use-module (guix profiles)
+  #:use-module (guix store)
+  #:use-module (guix derivations)
+  #:use-module ((gnu packages) #:select (specification->package))
+  #:use-module (guix tests)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 regex))
 
 ;; Test the (guix ui) module.
 
@@ -33,6 +41,20 @@ R6RS, Guile includes a module system, full access to POSIX system calls,
 networking support, multiple threads, dynamic linking, a foreign function call
 interface, and powerful string processing.")
 
+(define guile-1.8.8
+  (manifest-entry
+    (name "guile")
+    (version "1.8.8")
+    (item "/gnu/store/...")
+    (output "out")))
+
+(define guile-2.0.9
+  (manifest-entry
+    (name "guile")
+    (version "2.0.9")
+    (item "/gnu/store/...")
+    (output "out")))
+
 \f
 (test-begin "ui")
 
@@ -65,6 +87,34 @@ interface, and powerful string processing.")
                    10)
    #\newline))
 
+(test-equal "fill-paragraph, two spaces after period"
+  "First line.  Second line"
+  (fill-paragraph "First line.
+Second line" 24))
+
+(test-equal "package-description-string vs. Unicode"
+  "b•ll•t\n\n"                                ;see <http://bugs.gnu.org/21536>
+  (with-fluids ((%default-port-encoding "ISO-8859-1"))
+    (package-description-string
+     (dummy-package "foo" (description "b•ll•t")))))
+
+(test-equal "package-specification->name+version+output"
+  '(("guile" #f "out")
+    ("guile" "2.0.9" "out")
+    ("guile" #f "debug")
+    ("guile" "2.0.9" "debug")
+    ("guile-cairo" "1.4.1" "out"))
+  (map (lambda (spec)
+         (call-with-values
+             (lambda ()
+               (package-specification->name+version+output spec))
+           list))
+       '("guile"
+         "guile@2.0.9"
+         "guile:debug"
+         "guile@2.0.9:debug"
+         "guile-cairo@1.4.1")))
+
 (test-equal "integer"
   '(1)
   (string->generations "1"))
@@ -141,6 +191,14 @@ interface, and powerful string processing.")
   (string->duration "1m")
   (string->duration "30d"))
 
+(test-equal "duration, 2 hours"
+  7200
+  (time-second (string->duration "2h")))
+
+(test-equal "duration, 1 second"
+  (make-time time-duration 0 1)
+  (string->duration "1s"))
+
 (test-equal "duration, integer"
   #f
   (string->duration "1"))
@@ -149,7 +207,89 @@ interface, and powerful string processing.")
   #f
   (string->duration "d"))
 
-(test-end "ui")
+(test-equal "size->number, bytes"
+  42
+  (size->number "42"))
 
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+(test-equal "size->number, MiB"
+  (* 42 (expt 2 20))
+  (size->number "42MiB"))
+
+(test-equal "size->number, GiB"
+  (* 3 (expt 2 30))
+  (size->number "3GiB"))
+
+(test-equal "size->number, 1.2GiB"
+  (inexact->exact (round (* 1.2 (expt 2 30))))
+  (size->number "1.2GiB"))
+
+(test-equal "size->number, 1T"
+  (expt 2 40)
+  (size->number "1T"))
+
+(test-equal "size->number, 1.M"
+  (expt 2 20)
+  (size->number "1.M"))
+
+(test-assert "size->number, invalid unit"
+  (catch 'quit
+    (lambda ()
+      (size->number "9X"))
+    (lambda args
+      #t)))
+
+(test-equal "show-what-to-build, zero outputs"
+  ""
+  (with-store store
+    (let ((drv (derivation store "zero" "/bin/sh" '()
+                           #:outputs '())))
+      (with-error-to-string
+       (lambda ()
+         ;; This should print nothing.
+         (show-what-to-build store (list drv)))))))
+
+(test-assert "show-manifest-transaction"
+  (let* ((m (manifest (list guile-1.8.8)))
+         (t (manifest-transaction (install (list guile-2.0.9)))))
+    (with-store store
+      (and (string-match "guile +1.8.8 → 2.0.9"
+                         (with-fluids ((%default-port-encoding "UTF-8"))
+                           (with-error-to-string
+                            (lambda ()
+                              (show-manifest-transaction store m t)))))
+           (string-match "guile +1.8.8 -> 2.0.9"
+                         (with-error-to-string
+                           (lambda ()
+                             ;; In Guile 2.2, %DEFAULT-PORT-ENCODING doesn't
+                             ;; influence the encoding of string ports.
+                             (set-port-encoding! (current-error-port)
+                                                 "ISO-8859-1")
+                             (show-manifest-transaction store m t))))))))
+
+(test-assert "package-relevance"
+  (let ((guile  (specification->package "guile"))
+        (gcrypt (specification->package "guile-gcrypt"))
+        (go     (specification->package "go"))
+        (gnugo  (specification->package "gnugo"))
+        (libb2  (specification->package "libb2"))
+        (rx     (cut make-regexp <> regexp/icase))
+        (>0     (cut > <> 0))
+        (=0     zero?))
+    (and (>0 (package-relevance guile
+                                (map rx '("scheme"))))
+         (>0 (package-relevance guile
+                                (map rx '("scheme" "implementation"))))
+         (>0 (package-relevance gcrypt
+                                (map rx '("guile" "crypto"))))
+         (=0 (package-relevance guile
+                                (map rx '("guile" "crypto"))))
+         (>0 (package-relevance go
+                                (map rx '("go"))))
+         (=0 (package-relevance go
+                                (map rx '("go" "game"))))
+         (>0 (package-relevance gnugo
+                                (map rx '("go" "game"))))
+         (>0 (package-relevance libb2
+                                (map rx '("crypto" "library")))))))
+
+(test-end "ui")