aboutsummaryrefslogtreecommitdiff
path: root/tests/unit/util
diff options
context:
space:
mode:
Diffstat (limited to 'tests/unit/util')
-rw-r--r--tests/unit/util/base64.scm45
-rw-r--r--tests/unit/util/crypto.scm24
-rw-r--r--tests/unit/util/hnh-util-env.scm49
-rw-r--r--tests/unit/util/hnh-util-lens.scm61
-rw-r--r--tests/unit/util/hnh-util-path.scm126
-rw-r--r--tests/unit/util/hnh-util-state-monad.scm121
-rw-r--r--tests/unit/util/hnh-util.scm428
-rw-r--r--tests/unit/util/object.scm82
-rw-r--r--tests/unit/util/srfi-41-util.scm110
-rw-r--r--tests/unit/util/sxml-namespaced.scm172
-rw-r--r--tests/unit/util/uuid.scm13
-rw-r--r--tests/unit/util/xdg-basedir.scm59
-rw-r--r--tests/unit/util/xml-namespace.scm38
13 files changed, 1328 insertions, 0 deletions
diff --git a/tests/unit/util/base64.scm b/tests/unit/util/base64.scm
new file mode 100644
index 00000000..7fac883c
--- /dev/null
+++ b/tests/unit/util/base64.scm
@@ -0,0 +1,45 @@
+;;; Commentary:
+;; Test that Base64 encoding and decoding works
+;; Examples from RFC4648
+;;; Code:
+
+(define-module (test base64)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (base64))
+
+(test-group "Tests from RFC 4648"
+ (test-group "Decoding tests"
+ (test-equal "" (base64encode ""))
+ (test-equal "Zg==" (base64encode "f"))
+ (test-equal "Zm8=" (base64encode "fo"))
+ (test-equal "Zm9v" (base64encode "foo"))
+ (test-equal "Zm9vYg==" (base64encode "foob"))
+ (test-equal "Zm9vYmE=" (base64encode "fooba"))
+ (test-equal "Zm9vYmFy" (base64encode "foobar")))
+ (test-group "Encoding tests"
+ (test-equal "" (base64decode ""))
+ (test-equal "f" (base64decode "Zg=="))
+ (test-equal "fo" (base64decode "Zm8="))
+ (test-equal "foo" (base64decode "Zm9v"))
+ (test-equal "foob" (base64decode "Zm9vYg=="))
+ (test-equal "fooba" (base64decode "Zm9vYmE="))
+ (test-equal "foobar" (base64decode "Zm9vYmFy"))))
+
+
+;; Other tests
+
+(test-error "Invalid base64"
+ 'decoding-error
+ (base64decode "@@@@"))
+
+(test-error "To short base64"
+ 'decoding-error
+ (base64decode "="))
+
+(test-equal "AAECAw==" (bytevector->base64-string #vu8(0 1 2 3)))
+
+(test-equal #vu8(0 1 2 3) (base64-string->bytevector "AAECAw=="))
+
+'((base64))
diff --git a/tests/unit/util/crypto.scm b/tests/unit/util/crypto.scm
new file mode 100644
index 00000000..7be301a0
--- /dev/null
+++ b/tests/unit/util/crypto.scm
@@ -0,0 +1,24 @@
+(define-module (test crypto)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module ((crypto) :select (sha256 checksum->string)))
+
+(test-equal "sha256"
+ #vu8(24 95 141 179 34 113 254 37 245 97 166 252 147 139 46 38 67 6 236 48 78 218 81 128 7 209 118 72 38 56 25 105)
+ (sha256 "Hello"))
+
+(test-equal "sha256 string digest"
+ "185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969"
+ (checksum->string (sha256 "Hello")))
+
+(let ((port (open-output-string)))
+ (checksum->string (sha256 "Hello") port)
+ (test-equal "sha256 string digest to port"
+ "185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969"
+ (get-output-string port)))
+
+(test-error 'wrong-type-arg
+ (sha256 'something-which-is-not-a-string-or-bytevector))
+
+'((crypto))
diff --git a/tests/unit/util/hnh-util-env.scm b/tests/unit/util/hnh-util-env.scm
new file mode 100644
index 00000000..74ab3b79
--- /dev/null
+++ b/tests/unit/util/hnh-util-env.scm
@@ -0,0 +1,49 @@
+(define-module (test hnh-util-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")))
+
+'((hnh util env))
diff --git a/tests/unit/util/hnh-util-lens.scm b/tests/unit/util/hnh-util-lens.scm
new file mode 100644
index 00000000..0f4af6cb
--- /dev/null
+++ b/tests/unit/util/hnh-util-lens.scm
@@ -0,0 +1,61 @@
+(define-module (test hnh-util-lens)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (hnh util lens))
+
+
+(define first (ref 0))
+
+(test-equal '((1)) (first '(((1)))))
+(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2))
+(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2))
+
+
+;; (list-change (iota 10) 5 'Hello)
+;; => (0 1 2 3 4 Hello 6 7 8 9)
+
+(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10))
+(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10))
+
+;; (set (list (iota 10)) first first 11)
+
+(define cadr* (compose-lenses cdr* car*))
+
+(test-group "Primitive lenses get and set"
+ (define lst '(1 2 3 4 5))
+ (test-equal 1 (car* lst))
+ (test-equal '(2 3 4 5) (cdr* lst))
+
+ (test-equal '(10 2 3 4 5)
+ (car* lst 10)))
+
+(test-group "Primitive lens composition"
+ (define lst '(1 2 3 4 5))
+ (test-equal 2 (cadr* lst))
+ (test-equal '(1 10 3 4 5) (cadr* lst 10)))
+
+(test-group "Modify"
+ (define lst '(1 2 3 4 5))
+ (test-equal '(10 2 3 4 5) (modify lst car* * 10))
+ (test-equal '(1 20 3 4 5) (modify lst cadr* * 10))
+ )
+
+(test-group "Modify*"
+ (define lst '(1 2 3 4 5))
+ (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+)))
+
+;; modify
+;; modify*
+;; set
+;; get
+
+;; identity-lens
+;; compose-lenses
+;; lens-compose
+
+;; ref car* cdr*
+
+;; each
+
+'((hnh util lens))
diff --git a/tests/unit/util/hnh-util-path.scm b/tests/unit/util/hnh-util-path.scm
new file mode 100644
index 00000000..e5f65505
--- /dev/null
+++ b/tests/unit/util/hnh-util-path.scm
@@ -0,0 +1,126 @@
+(define-module (test hnh-util-path)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module ((hnh util env) :select (with-working-directory))
+ :use-module (hnh util path))
+
+(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-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"))
+
+'((hnh util path))
diff --git a/tests/unit/util/hnh-util-state-monad.scm b/tests/unit/util/hnh-util-state-monad.scm
new file mode 100644
index 00000000..4180a53f
--- /dev/null
+++ b/tests/unit/util/hnh-util-state-monad.scm
@@ -0,0 +1,121 @@
+(define-module (test hnh-util-state-monad)
+ :use-module (srfi srfi-64)
+ :use-module (hnh util state-monad))
+
+
+(call-with-values (lambda () ((return 1) 2))
+ (lambda (value state)
+ (test-equal "Return returns the value unmodified" 1 value)
+ (test-equal "Return also returns the state as a second value" 2 state)))
+
+(test-equal "Get returns the current state as primary value, while kepping the state"
+ '(state state)
+ (call-with-values (lambda () ((get) 'state)) list))
+
+;; Return value of put untested, since it's undefined
+(test-equal "Put replaces the old state with a new one, and return old one"
+ '(old-state new-state)
+ (call-with-values (lambda () ((put 'new-state) 'old-state))
+ list))
+
+(test-equal "A simple do is effectively a `values' call"
+ '(value initial-state)
+ (call-with-values (lambda () ((do (return 'value)) 'initial-state))
+ list))
+
+(test-equal "Let statement in do"
+ '(10 state)
+ (call-with-values (lambda () ((do x = 10
+ (return x))
+ 'state))
+ list))
+
+;; TODO let statement with multiple binds
+;; (do let (a b) = (values 10 20) ...)
+
+(test-equal "Set and get through do, along with <- in do."
+ '(5 1)
+ (call-with-values (lambda () ((do old <- (get)
+ (put (1+ old))
+ (return 5))
+ 0))
+ list))
+
+
+
+(test-equal "<$> Updates stuff before being removed from the monad context"
+ '(11 10)
+ (call-with-values (lambda ()
+ ((do x <- (<$> 1+ (get))
+ (return x))
+ 10))
+ list))
+
+(test-equal "Sequence should update the state accordingly"
+ 3
+ (call-with-values
+ (lambda ()
+ ((sequence
+ (list (mod 1+)
+ (mod 1+)
+ (mod 1+)))
+ 0))
+ (lambda (_ st) st)))
+
+(test-equal "Sequence should also act as map on the primary value"
+ '((0 1 2) 3)
+ (call-with-values
+ (lambda ()
+ ((sequence
+ (list (mod 1+)
+ (mod 1+)
+ (mod 1+)))
+ 0))
+ list))
+
+(test-equal "Get returns a single value when only a single value is in the state"
+ '(1 1) (call-with-values (lambda () ((get) 1))
+ list))
+
+(test-equal "Get returns a list of values when multiple items are in the state"
+ '((1 2 3) 1 2 3)
+ (call-with-values (lambda () ((get) 1 2 3))
+ list))
+
+(test-equal "Get with multiple values"
+ '((1 2) 1 2)
+ (call-with-values (lambda () ((get) 1 2))
+ list))
+
+(test-equal "Get with multiple values in do"
+ '((1 2) 1 2)
+ (call-with-values (lambda ()
+ ((do (a b) <- (get)
+ (return (list a b)))
+ 1 2))
+ list))
+
+((do (put 0)
+ (with-temp-state
+ (list 10)
+ (do a <- (get)
+ (return (test-equal "Temporary state is set"
+ 10 a))
+ (put 20)))
+ a <- (get)
+ (return (test-equal "Pre-temp state is restored" 0 a)))
+ 'init)
+
+
+;; TODO test for do where the number of implicit arguments changes
+
+(test-equal "Something" 30
+ ((do (with-temp-state
+ '(10 20)
+ ;; todo (lift +)
+ (do (a b) <- (get)
+ (return (+ a b)))))
+ 0 1))
+
+
+'((hnh util state-monad))
diff --git a/tests/unit/util/hnh-util.scm b/tests/unit/util/hnh-util.scm
new file mode 100644
index 00000000..8586b6d9
--- /dev/null
+++ b/tests/unit/util/hnh-util.scm
@@ -0,0 +1,428 @@
+;;; Commentary:
+;; Checks some prodecuders from (hnh util)
+;;; Code:
+
+(define-module (test hnh-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)
+ )
+
+(define (unreachable)
+ (throw 'unreachable))
+
+
+;;; Changed core bindings
+
+(test-group "set!"
+ (let ((x 10))
+ (set! x 20)
+ (test-eqv "Regular set! still works" 20 x))
+
+ (test-group "Multiple set! at once works"
+ (let ((x 10) (y 20))
+ (set! x 20
+ y 30)
+ (test-eqv x 20)
+ (test-eqv y 30)))
+
+ (test-group "Set! is ordered"
+ (let ((x 10))
+ (set! x 20
+ x (* x 2))
+ (test-eqv x 40)))
+
+ ;; TODO
+ ;; (test-group "set! ="
+ ;; )
+
+ )
+
+;;; Nonscensical to test
+;; (test-group "define-syntax"
+;; )
+
+(test-group "when"
+ (test-equal "when"
+ 1 (when #t 1))
+
+ (test-equal "'() when #f"
+ '() (when #f 1)))
+
+(test-group "unless"
+ (test-equal "unless"
+ 1 (unless #f 1))
+
+ (test-equal "'() unless #t"
+ '() (unless #t 1)))
+
+
+
+;;; New bindings
+
+(test-group "aif"
+ (aif (+ 1 2)
+ (test-eqv 3 it)
+ (unreachable))
+
+ (aif #f
+ (unreachable)
+ (test-assert #t)))
+
+(test-group "awhen"
+ (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-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-group "print-and-return"
+ (let ((p (open-output-string)))
+ (let ((v (with-error-to-port p
+ (lambda () (print-and-return (+ 1 2))))))
+ (test-equal "Printed value"
+ "3 [(+ 1 2)]\n" (get-output-string p))
+ (test-eqv "Returned value"
+ 3 v))))
+
+(test-group "swap"
+ (test-equal
+ '(3 2 1)
+ ((swap list) 1 2 3)))
+
+(test-group "set/r!"
+ (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 "label"
+ (test-equal "procedure label"
+ 120
+ ((label factorial (lambda (n)
+ (if (zero? n)
+ 1 (* n (factorial (1- n))))))
+ 5)))
+
+(test-group "sort*"
+ ;; 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-group "find-extreme"
+ (test-error 'wrong-type-arg (find-extreme '()))
+
+ (test-group "find-min"
+ (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)))))
+
+ (test-group "find-max"
+ (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-group "filter-sorted"
+ (test-equal
+ "Filter sorted"
+ '(3 4 5)
+ (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))))
+
+
+(test-group "!="
+ (test-assert "not equal"
+ (!= 1 2)))
+
+(test-group "init+last"
+ 'TODO)
+
+(test-group "take-to"
+ (test-equal "Take to"
+ '() (take-to '() 5)))
+
+(test-group "string-take-to"
+ (test-equal "Hello"
+ (string-take-to "Hello, World!" 5)))
+
+(test-group "string-first"
+ (test-eqv #\H (string-first "Hello, World!")))
+
+(test-group "string-last"
+ (test-eqv #\! (string-last "Hello, World!")))
+
+(test-group "as-symb"
+ (test-eq "From string" 'hello (as-symb "hello"))
+ (test-eq "From symbol" 'hello (as-symb 'hello))
+ (test-eq "NOTE that others pass right through"
+ '() (as-symb '())))
+
+
+(test-group "enumerate"
+ (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-group "unval"
+ (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))))
+
+(test-group "let-lazy"
+ 'TODO)
+
+(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 "assq-merge"
+ (test-equal "assq merge"
+ '((k 2 1) (v 2))
+ (assq-merge '((k 1) (v 2)) '((k 2)))))
+
+
+(test-group "kvlist->assq"
+ (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-group "assq-limit"
+ 'TODO)
+
+
+(test-group "group-by"
+ ;; Extra roundabout tests since groups-by doesn't guarantee order of the keys
+ (test-group "Two simple groups"
+ (let ((groups (group-by even? (iota 10))))
+ (test-assert (lset= eq? '(#f #t) (map car groups)))
+ (test-assert (lset= = '(0 2 4 6 8) (assq-ref groups #t)))
+ (test-assert (lset= = '(1 3 5 7 9) (assq-ref groups #f)))))
+
+ (test-group "Identity groups"
+ (let ((groups (group-by identity (iota 5))))
+ (test-assert "Correct keys"
+ (lset= = (iota 5) (map car groups)))
+ (test-group "Correct amount in each group"
+ (for-each (lambda (g) (test-equal 1 (length (cdr g)))) groups))))
+
+ (test-equal "Null case"
+ '()
+ (group-by (lambda _ (unreachable)) '())))
+
+(test-group "split-by"
+ 'TODO)
+
+
+(test-group "span-upto"
+ (test-group "Case 1"
+ (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))))
+
+ (test-group "Case 2"
+ (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 "cross-product"
+ (test-equal "Basic case"
+ '((1 4)
+ (1 5)
+ (1 6)
+ (2 4)
+ (2 5)
+ (2 6)
+ (3 4)
+ (3 5)
+ (3 6))
+ (cross-product
+ '(1 2 3)
+ '(4 5 6)))
+
+ (test-equal "Single input list"
+ '((1) (2) (3))
+ (cross-product '(1 2 3)))
+
+ (test-equal "More than two"
+ '((1 3 5) (1 3 6)
+ (1 4 5) (1 4 6)
+ (2 3 5) (2 3 6)
+ (2 4 5) (2 4 6))
+ (cross-product
+ '(1 2)
+ '(3 4)
+ '(5 6))))
+
+(test-group "string-flatten"
+ 'TODO)
+
+(test-group "intersperse"
+ 'TODO)
+
+(test-group "insert-ordered"
+ 'TODO)
+
+(test-group "-> (arrows)"
+ (test-equal "->" 9 (-> 1 (+ 2) (* 3)))
+ (test-equal "-> order dependant" -1 (-> 1 (- 2)))
+ (test-equal "->> order dependant" 1 (->> 1 (- 2))))
+
+(test-group "set"
+ 'TODO)
+
+(test-group "set->"
+ 'TODO)
+
+(test-group "and=>"
+ 'TODO)
+
+(test-group "downcase-symbol"
+ 'TODO)
+
+
+(test-group "group"
+ ;; TODO test failure when grouping isn't possible?
+ (test-equal "Group"
+ '((0 1) (2 3) (4 5) (6 7) (8 9))
+ (group (iota 10) 2)))
+
+(test-group "iterate"
+ (test-equal 0 (iterate 1- zero? 10)))
+
+(test-group "valued-map"
+ 'TODO)
+
+(test-group "assoc-ref-all"
+ (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)))
+
+(test-group "unique"
+ 'TODO)
+
+(test-group "vector-last"
+ (test-equal "vector-last"
+ 1 (vector-last #(0 2 3 1))))
+
+(test-group "->string"
+ (test-equal "5" (->string 5))
+ (test-equal "5" (->string "5")))
+
+(test-group "catch*"
+ 'TODO)
+
+'((hnh util))
diff --git a/tests/unit/util/object.scm b/tests/unit/util/object.scm
new file mode 100644
index 00000000..4f3aeb4f
--- /dev/null
+++ b/tests/unit/util/object.scm
@@ -0,0 +1,82 @@
+(define-module (test object)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (hnh util object)
+ :use-module ((hnh util) :select (->)))
+
+(define-type (f) x)
+
+(test-group "Created procedures"
+ (test-assert "Constructor" (procedure? f))
+ (test-assert "Predicate" (procedure? f?))
+ (test-assert "Field access" (procedure? x)))
+
+;; (f)
+;; (f x: 10)
+;; (f? (f))
+
+(test-equal "Accessors are getters"
+ 10 (x (f x: 10)))
+(test-assert "Accessors update, returning a object of the original type"
+ (f? (x (f x: 10) 20)))
+(test-equal "A get after an update returns the new value"
+ 20 (-> (f x: 10)
+ (x 20)
+ x))
+
+
+(define-type (g) x)
+
+(test-assert "Second type can be created"
+ (g x: 10))
+
+(test-assert "Second type isn't first type"
+ (not (f? (g x: 10))))
+
+(test-assert "First type isn't second type"
+ (not (g? (f x: 10))))
+
+;; Tests that the old x gets shadowed
+;; (test-equal 10 (x (f x: 10)))
+;; (test-equal 10 (x (g x: 10)))
+
+;; field-level arguments
+;; - init:
+(define-type (f2) (f2-x default: 0 type: integer?))
+(test-equal 0 (f2-x (f2)))
+
+;; - type:
+
+(test-error "Giving an invalid type to the constructor throws an error"
+ 'wrong-type-arg (f2 f2-x: 'hello))
+(test-error "Giving an invalid type to a setter throws an error"
+ 'wrong-type-arg (f2-x (f2) 'hello))
+(test-equal "The error includes the name of the field, the expected type, and the given value"
+ '(f2-x integer? hello)
+ (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello))
+ (lambda (err proc fmt args data) args)))
+
+(test-equal "Typed setter updates the value"
+ (f2 f2-x: 10) (f2-x (f2) 10))
+
+;; type-level arguments
+;; - constructor:
+(define-type (f3 constructor: (lambda (make check)
+ (lambda* (#:key f3-x f3-y)
+ (check f3-x f3-y)
+ (make f3-x f3-y))))
+ (f3-x type: integer?)
+ (f3-y type: string?))
+
+(test-assert "Custom constructors create objcets"
+ (f3? (f3 f3-x: 10 f3-y: "Hello")))
+
+(test-error "Bad arguments to custom constructor"
+ 'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world))
+
+;; - printer:
+(define-type (f4 printer: (lambda (r p) (display "something" p))))
+(test-equal "something" (with-output-to-string (lambda () (write (f4)))))
+
+'((hnh util object))
diff --git a/tests/unit/util/srfi-41-util.scm b/tests/unit/util/srfi-41-util.scm
new file mode 100644
index 00000000..79c607c5
--- /dev/null
+++ b/tests/unit/util/srfi-41-util.scm
@@ -0,0 +1,110 @@
+;;; Commentary:
+;; Tests (srfi srfi-41 util).
+;; Currently only tests stream-paginate.
+;;; Code:
+
+(define-module (test srfi-41-util)
+ :use-module (srfi srfi-64)
+ :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"
+ '((0 1 2) (3 4 5) (6 7 8) (9))
+ (let ((strm (stream-paginate (stream 0 1 2 3 4 5 6 7 8 9) 3)))
+ (map stream->list (stream->list strm))))
+
+(test-equal "slice of infinite"
+ '(1000 1001 1002 1003 1004 1005 1006 1007 1008 1009)
+ (let ((strm (stream-paginate (stream-from 0))))
+ (stream->list (stream-ref strm 100))))
+
+(define unique-symbol (gensym))
+
+(test-equal "time out on infinite 'empty' stream"
+ unique-symbol
+ ;; defined outside time limit since creation should always
+ ;; succeed. Only reference is expected to fail.
+ (let ((strm (stream-paginate
+ ;; easy way to get stream which never finds
+ ;; any elements.
+ (stream-filter negative? (stream-from 0)))))
+ (call-with-time-limit
+ 0.1
+ (lambda () (stream-car strm))
+ (lambda _ unique-symbol))))
+
+
+
+
+(test-equal "stream insert"
+ '(1 4 5 7 8)
+ (stream->list (stream-insert < 5 (stream 1 4 7 8))))
+
+
+(test-equal "Filter sorted stream"
+ '(4 6 8)
+ (stream->list (filter-sorted-stream even? (stream 1 3 4 6 8 9 11))))
+
+(test-equal "Filter sorted stream (which actually is unsorted)"
+ '(4 6 8)
+ (stream->list (filter-sorted-stream even? (stream 1 3 4 6 8 9 11 12))))
+
+;; TODO filter-sorted-stream*
+
+(test-equal
+ "Get stream interval"
+ '(5 6 7 8 9)
+ (stream->list (get-stream-interval (lambda (x) (< 4 x))
+ (lambda (x) (< x 10))
+ (stream 1 2 3 4 5 6 7 8 9 10 11 12))))
+
+
+
+(test-equal "stream find" 2 (stream-find even? (stream-from 1)))
+
+
+(test-equal
+ "repeating naturals"
+ '(1 1 1 2 2 2 3 3 3 4)
+ (stream->list 10 (repeating-naturals 1 3)))
+
+
+;; sleep will return early if a singal arrives, this just resumes sleeping until
+;; the wanted time is hit.
+;; Might sleep longer since sleep always returns a whole number of seconds remaining
+(define (true-sleep n)
+ (let loop ((remaining n))
+ (unless (zero? remaining)
+ (loop (sleep remaining)))))
+
+(test-skip "time limited stream")
+
+(let ((strm (stream-map (lambda (x) (when (zero? (modulo x 4)) (true-sleep 1)) x) (stream-from 1))))
+ (let ((strm (stream-timeslice-limit strm 0.1)))
+ (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))))))
+
+'((srfi srfi-41 util))
diff --git a/tests/unit/util/sxml-namespaced.scm b/tests/unit/util/sxml-namespaced.scm
new file mode 100644
index 00000000..b2d55028
--- /dev/null
+++ b/tests/unit/util/sxml-namespaced.scm
@@ -0,0 +1,172 @@
+(define-module (test sxml-namespaced)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (ice-9 match)
+ :use-module (sxml namespaced)
+ :use-module (hnh util state-monad)
+ )
+
+;;; TODO tests with attributes
+
+(define (ns x)
+ (string->symbol (format #f "http://example.com/~a" x)))
+
+(define (namespaced-symbol ns symb)
+ (string->symbol (format #f "~a:~a" ns symb)))
+
+
+
+(test-group "XML constructor utility procedure"
+ (test-equal "3 args"
+ (make-xml-element 'tagname 'namespace 'attributes)
+ (xml 'namespace 'tagname 'attributes))
+
+ (test-equal "2 args"
+ (make-xml-element 'tagname 'namespace '())
+ (xml 'namespace 'tagname))
+
+ (test-equal "1 args"
+ (make-xml-element 'tagname #f '())
+ (xml 'tagname)))
+
+
+
+(test-group "xml->namespaced-sxml"
+
+ (test-equal
+ `(*TOP* (,(xml 'tag)))
+ (xml->namespaced-sxml "<tag/>"))
+
+ (test-equal
+ `(*TOP* (,(xml 'ns1 'tag)))
+ (xml->namespaced-sxml "<tag xmlns='ns1'/>"))
+
+ (test-equal
+ `(*TOP* (,(xml 'ns2 'tag)))
+ (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'/>"))
+
+ (test-equal
+ `(*TOP* (,(xml 'ns2 'tag)
+ (,(xml 'ns1 'tag))))
+ (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'><tag/></x:tag>"))
+
+ (test-equal "PI are passed directly"
+ `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"")
+ (,(xml 'tag)))
+ (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>"))
+
+ (test-equal "Document with whitespace in it"
+ `(*TOP* ,(make-pi-element 'xml "")
+ (,(xml 'root)
+ " "
+ (,(xml 'a))
+ ))
+ (xml->namespaced-sxml "<?xml?><root> <a/></root>"
+ trim-whitespace?: #f))
+
+ ;; TODO is this expected? xml->sxml discards it.
+ (test-equal "Whitespace before root is kept"
+ `(*TOP* ,(make-pi-element 'xml "")
+ (,(xml 'root)))
+ (xml->namespaced-sxml "<?xml?> <root/>")))
+
+
+
+;;; NOTE that sxml->namespaced-sxml currently ignores any existing xmlns
+;;; attributes, since xml->sxml doesn't have those.
+(test-group "sxml->namespaced-sxml"
+ (test-equal "Simplest"
+ `(,(xml 'a)) (sxml->namespaced-sxml '(a) '()))
+ (test-equal "With *TOP*"
+ `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '()))
+ (test-equal "Simplest with namespace"
+ `(,(xml (ns 1) 'a))
+ (sxml->namespaced-sxml '(x:a)
+ `((x . ,(ns 1)))))
+ (test-equal "With pi"
+ `(*TOP* ,(make-pi-element 'xml "test")
+ (,(xml 'a)))
+ (sxml->namespaced-sxml
+ `(*TOP*
+ (*PI* xml "test")
+ (a))
+ '()))
+ (test-error "With unknown namespace"
+ 'missing-namespace
+ (sxml->namespaced-sxml '(x:a) '())))
+
+
+
+(test-group "namespaced-sxml->*"
+
+ ;; /namespaces is the most "primitive" one
+ (test-group "/namespaces"
+ (test-group "Without namespaces"
+ (call-with-values
+ (lambda ()
+ (namespaced-sxml->sxml/namespaces
+ `(*TOP*
+ (,(xml 'a)))))
+ (lambda (tree namespaces)
+ (test-equal `(*TOP* (a)) tree)
+ (test-equal '() namespaces))))
+
+ (test-group "With namespaces"
+ (call-with-values
+ (lambda ()
+ (namespaced-sxml->sxml/namespaces
+ `(*TOP*
+ (,(xml (ns 1) 'a)
+ (,(xml (ns 2) 'a))
+ (,(xml 'a))))))
+ (lambda (tree nss)
+ (test-eqv 2 (length nss))
+ (test-equal
+ `(*TOP*
+ (,(namespaced-symbol (assoc-ref nss (ns 1)) 'a)
+ (,(namespaced-symbol (assoc-ref nss (ns 2)) 'a))
+ (a)))
+ tree))))
+
+ (test-group "*PI*"
+ (call-with-values
+ (lambda ()
+ (namespaced-sxml->sxml/namespaces
+ `(*TOP*
+ ,(make-pi-element 'xml "test")
+ (,(xml 'a)))))
+ (lambda (tree namespaces)
+ (test-equal '() namespaces)
+ (test-equal `(*TOP* (*PI* xml "test")
+ (a))
+ tree)))))
+
+ (test-group "namespaced-sxml->sxml"
+ (test-equal "Without namespaces"
+ '(*TOP* (a (@)))
+ (namespaced-sxml->sxml `(*TOP* (,(xml 'a)))))
+
+ (test-group "With namespaces"
+ (match (namespaced-sxml->sxml `(*TOP* (,(xml (ns 1) 'a))))
+ ;; (ns 1) hard coded to work with match
+ (`(*TOP* (,el (@ (,key "http://example.com/1"))))
+ (let ((el-pair (string-split (symbol->string el) #\:))
+ (key-pair (string-split (symbol->string key) #\:)))
+ (test-equal "a" (cadr el-pair))
+ (test-equal "xmlns" (car key-pair))
+ (test-equal (car el-pair) (cadr key-pair))))
+ (any
+ (test-assert (format #f "Match failed: ~s" any) #f))))))
+
+;; (namespaced-sxml->xml)
+;; Literal strings
+
+
+(test-error "Namespaces x is missing, note error"
+ 'parser-error
+ (xml->namespaced-sxml "<x:a xmlns:y=\"http://example.com/1\"><x:b/></x:a>"
+ ; `((x . ,(ns 1)))
+ ))
+
+'((sxml namespaced))
diff --git a/tests/unit/util/uuid.scm b/tests/unit/util/uuid.scm
new file mode 100644
index 00000000..7d68e38e
--- /dev/null
+++ b/tests/unit/util/uuid.scm
@@ -0,0 +1,13 @@
+(define-module (test uuid)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (hnh util uuid))
+
+
+(test-equal "UUIDv4 fixed seed"
+ "d19c9347-9a85-4432-a876-5fb9c0d24d2b"
+ (parameterize ((seed (seed->random-state 0)))
+ (uuid-v4)))
+
+'((hnh util uuid))
diff --git a/tests/unit/util/xdg-basedir.scm b/tests/unit/util/xdg-basedir.scm
new file mode 100644
index 00000000..5731b581
--- /dev/null
+++ b/tests/unit/util/xdg-basedir.scm
@@ -0,0 +1,59 @@
+(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)))))
+
+'((xdg basedir))
diff --git a/tests/unit/util/xml-namespace.scm b/tests/unit/util/xml-namespace.scm
new file mode 100644
index 00000000..2b6ea174
--- /dev/null
+++ b/tests/unit/util/xml-namespace.scm
@@ -0,0 +1,38 @@
+(define-module (test xml-namespace)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-88)
+ :use-module ((sxml namespace) :select (move-to-namespace)))
+
+(test-equal
+ "Move unnamespaced to namespace"
+ '(NEW:test)
+ (move-to-namespace '(test) '((#f . NEW))))
+
+(test-equal
+ "Swap namespaces"
+ '(b:a (a:b))
+ (move-to-namespace
+ '(a:a (b:b))
+ '((a . b) (b . a))))
+
+(test-equal
+ "Remove all namespaces"
+ '(a (b))
+ (move-to-namespace '(a:a (b:b)) #f))
+
+(test-equal
+ "Move everything to one namespace"
+ '(c:a (c:b))
+ (move-to-namespace '(a:a (b:b)) 'c))
+
+(test-equal
+ "Partial namespace change"
+ '(c:a (b:b))
+ (move-to-namespace '(a:a (b:b)) '((a . c))))
+
+(test-equal
+ "Remove specific namespace"
+ '(a:a (b))
+ (move-to-namespace '(a:a (b:b)) '((b . #f))))
+
+'((sxml namespace))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 15:30:35 +0200