aboutsummaryrefslogtreecommitdiff
path: root/tests/test/util.scm
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 /tests/test/util.scm
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.
Diffstat (limited to 'tests/test/util.scm')
-rw-r--r--tests/test/util.scm375
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"))