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