diff options
Diffstat (limited to '')
-rw-r--r-- | tests/test/util.scm | 379 |
1 files changed, 379 insertions, 0 deletions
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"))) |