aboutsummaryrefslogtreecommitdiff
path: root/tests/test/util.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/test/util.scm')
-rw-r--r--tests/test/util.scm379
1 files changed, 0 insertions, 379 deletions
diff --git a/tests/test/util.scm b/tests/test/util.scm
deleted file mode 100644
index bdd6e98e..00000000
--- a/tests/test/util.scm
+++ /dev/null
@@ -1,379 +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-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")))