aboutsummaryrefslogtreecommitdiff
path: root/tests/test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/test')
-rw-r--r--tests/test/let-env.scm48
-rw-r--r--tests/test/srfi-41-util.scm20
-rw-r--r--tests/test/util.scm379
-rw-r--r--tests/test/uuid.scm13
-rw-r--r--tests/test/xdg-basedir.scm58
5 files changed, 508 insertions, 10 deletions
diff --git a/tests/test/let-env.scm b/tests/test/let-env.scm
new file mode 100644
index 00000000..a989776a
--- /dev/null
+++ b/tests/test/let-env.scm
@@ -0,0 +1,48 @@
+(define-module (test let-env)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module ((guile) :select (setenv getenv))
+ :use-module ((hnh util env) :select (let-env)))
+
+(setenv "CALP_TEST_ENV" "1")
+
+(test-equal
+ "Ensure we have set value beforehand"
+ "1"
+ (getenv "CALP_TEST_ENV"))
+
+(let-env
+ ((CALP_TEST_ENV "2"))
+ (test-equal
+ "Test our local override"
+ "2"
+ (getenv "CALP_TEST_ENV")))
+
+(test-equal
+ "Test that we have returned"
+ "1"
+ (getenv "CALP_TEST_ENV"))
+
+(catch 'test-error
+ (lambda ()
+ (let-env
+ ((CALP_TEST_ENV "2"))
+ (test-equal
+ "Test our local override again"
+ "2"
+ (getenv "CALP_TEST_ENV"))
+ (throw 'test-error)))
+ list)
+
+(test-equal
+ "Test restoration after non-local exit"
+ "1"
+ (getenv "CALP_TEST_ENV"))
+
+
+(test-group "Unsetting environment"
+ (setenv "TEST" "A")
+ (let-env ((TEST #f))
+ (test-assert (not (getenv "TEST"))))
+ (test-equal "A" (getenv "TEST")))
diff --git a/tests/test/srfi-41-util.scm b/tests/test/srfi-41-util.scm
index ff0e3cce..9a753b03 100644
--- a/tests/test/srfi-41-util.scm
+++ b/tests/test/srfi-41-util.scm
@@ -8,6 +8,7 @@
:use-module (srfi srfi-88)
:use-module (srfi srfi-41 util)
:use-module (srfi srfi-41)
+ :use-module ((srfi srfi-1) :select (circular-list))
:use-module ((ice-9 sandbox) :select (call-with-time-limit)))
(test-equal "Finite stream"
@@ -86,3 +87,22 @@
(test-equal "time limited stream"
'(1 2 3)
(stream->list strm))))
+
+
+(test-group "stream-split-by"
+ (let ((hello-chars-stream (stream-unfold
+ car
+ (const #t)
+ cdr
+ (apply circular-list
+ (string->list "Hello ")))))
+ (test-equal "Check that test list looks as expected"
+ (string->list "Hello Hell")
+ (stream->list 10 hello-chars-stream))
+ (test-equal "Check that it splits correctly"
+ '("Hello " "Hello " "Hello ")
+ (stream->list
+ 3
+ (stream-map list->string
+ (stream-split-by (lambda (c) (char=? c #\space))
+ hello-chars-stream))))))
diff --git a/tests/test/util.scm b/tests/test/util.scm
new file mode 100644
index 00000000..bdd6e98e
--- /dev/null
+++ b/tests/test/util.scm
@@ -0,0 +1,379 @@
+;;; Commentary:
+;; Checks some prodecuders from (hnh util)
+;;; Code:
+
+(define-module (test util)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (srfi srfi-1)
+ :use-module (hnh util)
+ :use-module (hnh util env)
+ :use-module ((hnh util path)
+ :select (path-append
+ path-split
+ file-hidden?
+ realpath
+ relative-to
+ filename-extension)))
+
+(test-group "Conditionals"
+ (test-equal "when"
+ 1 (when #t 1))
+
+ (test-equal "'() when #f"
+ '() (when #f 1))
+
+ (test-equal "unless"
+ 1 (unless #f 1))
+
+ (test-equal "'() unless #t"
+ '() (unless #t 1))
+
+ (test-equal "awhen it"
+ '(3 4 5)
+ (awhen (memv 2 '(1 2 3 4 5))
+ (cdr it)))
+
+ (test-equal "awhen not"
+ '()
+ (awhen (memv 0 '(1 2 3 4 5))
+ (cdr it))))
+
+(test-group "for"
+ (test-equal "for simple"
+ (iota 10)
+ (for x in (iota 10)
+ x))
+
+ (test-equal "for matching"
+ (iota 12)
+ (for (x c) in (zip (iota 12) (string->list "Hello, World"))
+ x))
+
+ (test-equal "for with improper list elements"
+ `(3 7)
+ (for (a . b) in '((1 . 2) (3 . 4))
+ (+ a b)))
+
+ (test-equal "for with longer improper list elements"
+ '(1 2 4)
+ (for (a b . c) in '((1 -1 . 1) (2 -2 . 2) (4 -4 . 4))
+ (* c (+ 1 a b))))
+
+ (test-equal "for break"
+ 'x
+ (for x in (iota 10)
+ (break 'x)
+ (test-assert "This should never happen" #f)))
+
+ (test-equal "for continue"
+ '(x #f 2)
+ (for x in (iota 3)
+ (case x
+ ((0)
+ (continue 'x)
+ (test-assert "Continue with value failed" #f))
+ ((1)
+ (continue)
+ (test-assert "Continue without value failed" #f))
+ (else x)))))
+
+(test-equal "procedure label"
+ 120
+ ((label factorial (lambda (n)
+ (if (zero? n)
+ 1 (* n (factorial (1- n))))))
+ 5))
+
+;; we can't test if sort*! destroys the list, since its only /allowed/ to do it,
+;; not required.
+(test-equal "sort*!"
+ '("a" "Hello" "Assparagus")
+ (sort*! '("Hello" "a" "Assparagus")
+ < string-length))
+
+(test-assert "not equal"
+ (!= 1 2))
+
+(test-equal "Take to"
+ '() (take-to '() 5))
+
+(test-equal "Enumerate"
+ '((0 #\H) (1 #\e) (2 #\l) (3 #\l) (4 #\o) (5 #\,) (6 #\space) (7 #\W) (8 #\o) (9 #\r) (10 #\l) (11 #\d) (12 #\!))
+ (enumerate (string->list "Hello, World!")))
+
+(test-equal "unval first"
+ 1
+ ((unval (lambda () (values 1 2 3)))))
+
+(test-equal "unval other"
+ 2
+ ((unval car+cdr 1)
+ (cons 1 2)))
+
+(test-group "Flatten"
+ (test-equal "flatten already flat"
+ (iota 10)
+ (flatten (iota 10)))
+
+ (test-equal "flatten really deep"
+ '(1)
+ (flatten '(((((((((((((((1)))))))))))))))))
+
+ (test-equal "flatten mixed"
+ '(1 2 3 4 5)
+ (flatten '((((((1(((((2((((3))))))4))))))))5))))
+
+;; TODO test let-lazy
+
+(test-group "map/dotted"
+ (test-equal "map/dotted without dot"
+ '(1 2 3 4)
+ (map/dotted 1+ '(0 1 2 3)))
+
+ (test-equal "map/dotted with dot"
+ '(1 2 3 . 4)
+ (map/dotted 1+ '(0 1 2 . 3)))
+
+ (test-equal "map/dotted direct value"
+ 1 (map/dotted 1+ 0)))
+
+
+(test-group "Arrows"
+ (test-equal "->" 9 (-> 1 (+ 2) (* 3)))
+ (test-equal "-> order dependant" -1 (-> 1 (- 2)))
+ (test-equal "->> order dependant" 1 (->> 1 (- 2))))
+
+;; TODO set and set->
+
+;; TODO and=>>
+
+(test-equal "Group"
+ '((0 1) (2 3) (4 5) (6 7) (8 9))
+ (group (iota 10) 2))
+
+;; TODO test failure when grouping isn't possible?
+
+(test-group "Associations"
+ (test-equal "assoc-ref-all" '(1 3) (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a))
+ (test-equal "assq-ref-all" '(1 3) (assq-ref-all '((a . 1) (b . 2) (a . 3)) 'a))
+ (test-equal "assv-ref-all "'(1 3) (assv-ref-all '((a . 1) (b . 2) (a . 3)) 'a))
+
+ ;; TODO assq-limit ?
+
+ (test-equal "assq merge"
+ '((k 2 1) (v 2))
+ (assq-merge '((k 1) (v 2)) '((k 2))))
+
+ (test-equal "kvlist->assq"
+ '((a . 1) (b . 2))
+ (kvlist->assq '(a: 1 b: 2)))
+
+
+ (test-equal "kvlist->assq repeated key"
+ '((a . 1) (b . 2) (a . 3))
+ (kvlist->assq '(a: 1 b: 2 a: 3))))
+
+(test-equal "vector-last"
+ 1 (vector-last #(0 2 3 1)))
+
+;; TODO test catch*
+
+(test-equal
+ "Filter sorted"
+ '(3 4 5)
+ (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10)))
+
+(test-equal
+ "set/r! = single"
+ #f
+ (let ((x #t)) (set/r! x = not)))
+
+(test-error
+ 'syntax-error
+ (test-read-eval-string "(set/r! x err not)"))
+
+(test-group "Find extremes"
+ (call-with-values
+ (lambda () (find-min (iota 10)))
+ (lambda (extreme rest)
+ (test-equal "Found correct minimum" 0 extreme)
+ (test-equal
+ "Removed \"something\" from the set"
+ 9
+ (length rest))))
+
+ (call-with-values
+ (lambda ()
+ (find-max
+ '("Hello" "Test" "Something long")
+ string-length))
+ (lambda (extreme rest)
+ (test-equal
+ "Found the longest string"
+ "Something long"
+ extreme)
+ (test-equal "Removed the string" 2 (length rest))
+ (test-assert
+ "Other members left 1"
+ (member "Hello" rest))
+ (test-assert
+ "Other members left 2"
+ (member "Test" rest))))
+
+ (test-error 'wrong-type-arg (find-extreme '())))
+
+(test-group "Span upto"
+ (call-with-values
+ (lambda ()
+ (span-upto
+ 2
+ char-numeric?
+ (string->list "123456")))
+ (lambda (head tail)
+ (test-equal '(#\1 #\2) head)
+ (test-equal '(#\3 #\4 #\5 #\6) tail)))
+
+ (call-with-values
+ (lambda ()
+ (span-upto
+ 2
+ char-numeric?
+ (string->list "H123456")))
+ (lambda (head tail)
+ (test-equal '() head)
+ (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail))))
+
+(test-group "Begin1"
+ (let ((value #f))
+ (test-equal
+ "begin1 return value"
+ "Hello"
+ (begin1 "Hello" (set! value "World")))
+ (test-equal "begin1 side effects" "World" value))
+
+ (let ((x 1))
+ (test-eqv "begin1 set! after return"
+ 1 (begin1 x (set! x 10)))
+ (test-eqv "Updates value"
+ 10 x)))
+
+(test-equal 0 (iterate 1- zero? 10))
+
+(test-equal "5" (->string 5))
+
+(test-equal "5" (->string "5"))
+
+(test-group "Path operations"
+ (test-equal
+ "no slashes"
+ "home/user"
+ (path-append "home" "user"))
+
+ (test-equal
+ "no slashes, absolute"
+ "/home/user"
+ (path-append "" "home" "user"))
+
+ (test-equal
+ "slashes in one component, absolute"
+ "/home/user"
+ (path-append "" "/home/" "user"))
+
+ (test-equal
+ "slashes in one component, absolute due to first"
+ "/home/user"
+ (path-append "/home/" "user"))
+
+ (test-equal
+ "Slashes in both"
+ "home/user"
+ (path-append "home/" "/user"))
+
+ (test-equal "root" "/" (path-append ""))
+
+ (test-equal
+ '("usr" "lib" "test")
+ (path-split "usr/lib/test"))
+
+ (test-equal
+ '("usr" "lib" "test")
+ (path-split "usr/lib/test/"))
+
+ (test-equal
+ '("" "usr" "lib" "test")
+ (path-split "/usr/lib/test"))
+
+ (test-equal
+ '("" "usr" "lib" "test")
+ (path-split "//usr////lib/test"))
+
+ (test-assert (file-hidden? ".just-filename"))
+ (test-assert (file-hidden? "/path/to/.hidden"))
+ (test-assert (not (file-hidden? "/visible/.in/hidden")))
+ (test-assert (not (file-hidden? "")))
+
+ ;; TODO test realpath with .. and similar
+
+ (test-equal "Realpath for path fragment"
+ "/home/hugo"
+ (with-working-directory
+ "/home"
+ (lambda () (realpath "hugo"))))
+
+ (test-equal "Realpath for already absolute path"
+ "/home/hugo"
+ (with-working-directory
+ "/tmp"
+ (lambda () (realpath "/home/hugo"))))
+
+
+ (test-group "Relative to"
+
+ (test-group "With relative child"
+ (test-equal "/some/path" (relative-to "/some" "path")))
+
+ ;; Relative parent just adds (getcwd) to start of parent,
+ ;; but this is "hard" to test.
+ ;; (test-group "With relative parent")
+
+ (test-group "With absolute child"
+ (test-error 'misc-error (relative-to "" "/some/path"))
+ (test-equal "some/path" (relative-to "/" "/some/path"))
+ (test-group "Without trailing slashes"
+ (test-equal "path" (relative-to "/some" "/some/path"))
+ (test-equal "../path" (relative-to "/some" "/other/path")))
+ (test-group "With trailing slashes"
+ (test-equal "path" (relative-to "/some" "/some/path/"))
+ (test-equal "../path" (relative-to "/some" "/other/path/"))))
+
+ (test-equal "/a/b" (relative-to "/a/b/c" "/a/b"))
+
+ )
+
+
+ (test-equal "Extension of simple file"
+ "txt" (filename-extension "file.txt"))
+
+ (test-equal "Extension of file with directory"
+ "txt" (filename-extension "/direcotry/file.txt"))
+
+ (test-equal "Extension of file with multiple"
+ "gz" (filename-extension "filename.tar.gz"))
+
+ (test-equal "Filename extension when none is present"
+ "" (filename-extension "filename"))
+
+ (test-equal "Filename extension when none is present, but directory has"
+ "" (filename-extension "config.d/filename"))
+
+ (test-equal "Filename extension of directory"
+ "d" (filename-extension "config.d/"))
+
+
+ (test-equal "Extension of hidden file"
+ "sh" (filename-extension ".bashrc.sh"))
+
+ (test-equal "Extension of hidden file without extension"
+ "bashrc" (filename-extension ".bashrc")))
diff --git a/tests/test/uuid.scm b/tests/test/uuid.scm
index b73db5f4..1cedb59e 100644
--- a/tests/test/uuid.scm
+++ b/tests/test/uuid.scm
@@ -6,13 +6,6 @@
(test-equal "UUIDv4 fixed seed"
- (let ((version (version)))
- (cond ((string=? version "2.2.7")
- "d19c9347-9a85-4432-a876-5fb9c0d24d2b")
- ((string=? version "3.0.9")
- "d19c9347-9a85-4432-a876-5fb9c0d24d2b")
- (else
- "Randomness isn't stable between guile versions")))
- (begin
- (parameterize ((seed (seed->random-state 0)))
- (uuid-v4))))
+ "d19c9347-9a85-4432-a876-5fb9c0d24d2b"
+ (parameterize ((seed (seed->random-state 0)))
+ (uuid-v4)))
diff --git a/tests/test/xdg-basedir.scm b/tests/test/xdg-basedir.scm
new file mode 100644
index 00000000..682c1347
--- /dev/null
+++ b/tests/test/xdg-basedir.scm
@@ -0,0 +1,58 @@
+(define-module (test xdg-basedir)
+ :use-module (srfi srfi-64)
+ :use-module ((xdg basedir) :prefix xdg-)
+ :use-module (srfi srfi-88)
+ :use-module ((hnh util env) :select (let-env))
+ )
+
+
+(let-env ((HOME "/home/user")
+ (XDG_DATA_HOME #f)
+ (XDG_CONFIG_HOME #f)
+ (XDG_STATE_HOME #f)
+ (XDG_DATA_DIRS #f)
+ (XDG_CONFIG_DIRS #f)
+ (XDG_CACHE_HOME #f)
+ (XDG_RUNTIME_DIR #f))
+ (test-group "Defaults"
+ (test-equal "XDG_DATA_HOME" "/home/user/.local/share"
+ (xdg-data-home))
+ (test-equal "XDG_CONFIG_HOME" "/home/user/.config"
+ (xdg-config-home))
+ (test-equal "XDG_STATE_HOME" "/home/user/.local/state"
+ (xdg-state-home))
+ (test-equal "XDG_DATA_DIRS" (xdg-data-dirs)
+ '("/usr/local/share" "/usr/share"))
+ (test-equal "XDG_CONFIG_DIRS" '("/etc/xdg")
+ (xdg-config-dirs))
+ (test-equal "XDG_CACHE_HOME" "/home/user/.cache"
+ (xdg-cache-home))
+ (let ((warning
+ (with-error-to-string
+ (lambda ()
+ (test-equal "XDG_RUNTIME_DIR"
+ "/tmp" (xdg-runtime-dir))))))
+ (test-assert "The warning actually contains something"
+ (< 0 (string-length warning)))))
+
+ (test-group "Custom values"
+ (let-env ((XDG_DATA_HOME "/a"))
+ (test-equal "XDG_DATA_HOME" "/a" (xdg-data-home)))
+ (let-env ((XDG_CONFIG_HOME "/b"))
+ (test-equal "XDG_CONFIG_HOME" "/b" (xdg-config-home)))
+ (let-env ((XDG_STATE_HOME "/c"))
+ (test-equal "XDG_STATE_HOME" "/c" (xdg-state-home)))
+ (let-env ((XDG_DATA_DIRS "/d:/e"))
+ (test-equal "XDG_DATA_DIRS" '("/d" "/e") (xdg-data-dirs)))
+ (let-env ((XDG_CONFIG_DIRS "/f:/g"))
+ (test-equal "XDG_CONFIG_DIRS" '("/f" "/g") (xdg-config-dirs)))
+ (let-env ((XDG_CACHE_HOME "/h"))
+ (test-equal "XDG_CACHE_HOME" "/h" (xdg-cache-home)))
+ (let ((warning
+ (with-error-to-string
+ (lambda ()
+ (let-env ((XDG_RUNTIME_DIR "/i"))
+ (test-equal "XDG_RUNTIME_DIR" "/i" (xdg-runtime-dir)))))))
+ (test-assert "No error was emitted"
+ (string-null? warning)))))
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 19:36:34 +0200