aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2023-04-04 14:39:29 +0200
committerHugo Hörnquist <hugo@lysator.liu.se>2023-04-10 23:45:29 +0200
commitfc6759c3596b695634466330e37baa4d16222b0c (patch)
tree1e2b0ea4715ebe7afa3d0a8cf5ba95a223f24a77
parentBorrow state-monad from guile-dns. (diff)
downloadcalp-fc6759c3596b695634466330e37baa4d16222b0c.tar.gz
calp-fc6759c3596b695634466330e37baa4d16222b0c.tar.xz
Reorder (util .*) tests.
Added test groups for each exported procedure (meaning that the TODOs are now updated (at least for (hnh util))). Split path tests out into own file. Also rename those files so they map 1-1 onto their core module names.
-rw-r--r--tests/test/hnh-util-env.scm47
-rw-r--r--tests/test/hnh-util-path.scm124
-rw-r--r--tests/test/hnh-util.scm357
-rw-r--r--tests/test/let-env.scm43
-rw-r--r--tests/test/util.scm375
5 files changed, 528 insertions, 418 deletions
diff --git a/tests/test/hnh-util-env.scm b/tests/test/hnh-util-env.scm
new file mode 100644
index 00000000..93f72bc9
--- /dev/null
+++ b/tests/test/hnh-util-env.scm
@@ -0,0 +1,47 @@
+(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)))
+
+
+(test-group "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 "with-working-directory"
+ 'TODO)
+
diff --git a/tests/test/hnh-util-path.scm b/tests/test/hnh-util-path.scm
new file mode 100644
index 00000000..de4bf8e3
--- /dev/null
+++ b/tests/test/hnh-util-path.scm
@@ -0,0 +1,124 @@
+(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"))
diff --git a/tests/test/hnh-util.scm b/tests/test/hnh-util.scm
new file mode 100644
index 00000000..72b3c60e
--- /dev/null
+++ b/tests/test/hnh-util.scm
@@ -0,0 +1,357 @@
+;;; 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)
+ :use-module (hnh util env)
+ )
+
+
+;;; Changed core bindings
+
+(test-group "set!"
+ 'TODO)
+
+(test-group "define-syntax"
+ 'TODO)
+
+(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"
+ 'TODO)
+
+(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"
+ 'TODO)
+
+(test-group "swap"
+ 'TODO)
+
+(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 "take-to"
+ (test-equal "Take to"
+ '() (take-to '() 5)))
+
+(test-group "string-take-to"
+ 'TODO)
+
+(test-group "string-first"
+ 'TODO)
+
+(test-group "string-last"
+ 'TODO)
+
+(test-group "as-symb"
+ 'TODO)
+
+
+(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 _ (/ 0)) '())))
+
+(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"
+ 'TODO)
+
+(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)
+
diff --git a/tests/test/let-env.scm b/tests/test/let-env.scm
deleted file mode 100644
index e3dc5927..00000000
--- a/tests/test/let-env.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-(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"))
-
-
diff --git a/tests/test/util.scm b/tests/test/util.scm
deleted file mode 100644
index 9a203f50..00000000
--- a/tests/test/util.scm
+++ /dev/null
@@ -1,375 +0,0 @@
-;;; 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-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-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 "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-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-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-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)))
-
-;; TODO assq-limit ?
-
-(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 _ (/ 0)) '())))
-
-(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-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-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)"))
-
-(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 '()))
-
-(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)))
-
-(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-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"))