diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-10-02 19:26:40 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-10-02 19:28:44 +0200 |
commit | 712654d4c023a2ab13190c6905d313e0ba897965 (patch) | |
tree | b8505b420d6621022fa6a46271340071d8881322 /tests/unit/util | |
parent | Made displayln into a library export. (diff) | |
download | calp-712654d4c023a2ab13190c6905d313e0ba897965.tar.gz calp-712654d4c023a2ab13190c6905d313e0ba897965.tar.xz |
Rewrite test running system.
Diffstat (limited to '')
-rw-r--r-- | tests/unit/util/base64.scm (renamed from tests/test/base64.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/crypto.scm (renamed from tests/test/crypto.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/hnh-util-env.scm (renamed from tests/test/hnh-util-env.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/hnh-util-lens.scm (renamed from tests/test/hnh-util-lens.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/hnh-util-path.scm (renamed from tests/test/hnh-util-path.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/hnh-util-state-monad.scm (renamed from tests/test/hnh-util-state-monad.scm) | 1 | ||||
-rw-r--r-- | tests/unit/util/hnh-util.scm (renamed from tests/test/hnh-util.scm) | 374 | ||||
-rw-r--r-- | tests/unit/util/object.scm (renamed from tests/test/object.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/srfi-41-util.scm (renamed from tests/test/srfi-41-util.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/sxml-namespaced.scm (renamed from tests/test/sxml-namespaced.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/uuid.scm (renamed from tests/test/uuid.scm) | 2 | ||||
-rw-r--r-- | tests/unit/util/xdg-basedir.scm (renamed from tests/test/xdg-basedir.scm) | 1 | ||||
-rw-r--r-- | tests/unit/util/xml-namespace.scm (renamed from tests/test/xml-namespace.scm) | 2 |
13 files changed, 219 insertions, 177 deletions
diff --git a/tests/test/base64.scm b/tests/unit/util/base64.scm index b24d2e8b..7fac883c 100644 --- a/tests/test/base64.scm +++ b/tests/unit/util/base64.scm @@ -41,3 +41,5 @@ (test-equal "AAECAw==" (bytevector->base64-string #vu8(0 1 2 3))) (test-equal #vu8(0 1 2 3) (base64-string->bytevector "AAECAw==")) + +'((base64)) diff --git a/tests/test/crypto.scm b/tests/unit/util/crypto.scm index 0dbf8867..7be301a0 100644 --- a/tests/test/crypto.scm +++ b/tests/unit/util/crypto.scm @@ -20,3 +20,5 @@ (test-error 'wrong-type-arg (sha256 'something-which-is-not-a-string-or-bytevector)) + +'((crypto)) diff --git a/tests/test/hnh-util-env.scm b/tests/unit/util/hnh-util-env.scm index c1e0161f..74ab3b79 100644 --- a/tests/test/hnh-util-env.scm +++ b/tests/unit/util/hnh-util-env.scm @@ -45,3 +45,5 @@ (let-env ((TEST #f)) (test-assert (not (getenv "TEST")))) (test-equal "A" (getenv "TEST"))) + +'((hnh util env)) diff --git a/tests/test/hnh-util-lens.scm b/tests/unit/util/hnh-util-lens.scm index 0508553a..0f4af6cb 100644 --- a/tests/test/hnh-util-lens.scm +++ b/tests/unit/util/hnh-util-lens.scm @@ -57,3 +57,5 @@ ;; ref car* cdr* ;; each + +'((hnh util lens)) diff --git a/tests/test/hnh-util-path.scm b/tests/unit/util/hnh-util-path.scm index de4bf8e3..e5f65505 100644 --- a/tests/test/hnh-util-path.scm +++ b/tests/unit/util/hnh-util-path.scm @@ -122,3 +122,5 @@ (test-equal "Extension of hidden file without extension" "bashrc" (filename-extension ".bashrc")) + +'((hnh util path)) diff --git a/tests/test/hnh-util-state-monad.scm b/tests/unit/util/hnh-util-state-monad.scm index 353c47e9..4180a53f 100644 --- a/tests/test/hnh-util-state-monad.scm +++ b/tests/unit/util/hnh-util-state-monad.scm @@ -118,3 +118,4 @@ 0 1)) +'((hnh util state-monad)) diff --git a/tests/test/hnh-util.scm b/tests/unit/util/hnh-util.scm index c4a20443..8586b6d9 100644 --- a/tests/test/hnh-util.scm +++ b/tests/unit/util/hnh-util.scm @@ -8,7 +8,6 @@ :use-module (srfi srfi-88) :use-module (srfi srfi-1) :use-module (hnh util) - :use-module (hnh util env) ) (define (unreachable) @@ -45,18 +44,19 @@ ;; (test-group "define-syntax" ;; ) -(test-group "Conditionals" +(test-group "when" (test-equal "when" 1 (when #t 1)) (test-equal "'() when #f" - '() (when #f 1)) + '() (when #f 1))) +(test-group "unless" (test-equal "unless" 1 (unless #f 1)) (test-equal "'() unless #t" - '() (unless #t 1)) + '() (unless #t 1))) @@ -71,6 +71,7 @@ (unreachable) (test-assert #t))) +(test-group "awhen" (test-equal "awhen it" '(3 4 5) (awhen (memv 2 '(1 2 3 4 5)) @@ -100,26 +101,21 @@ (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))))) - + (* 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" (let ((p (open-output-string))) @@ -135,31 +131,82 @@ '(3 2 1) ((swap list) 1 2 3))) +(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-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-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-assert "not equal" - (!= 1 2)) +(test-group "init+last" + 'TODO) -(test-equal "Take to" - '() (take-to '() 5)) +(test-group "take-to" + (test-equal "Take to" + '() (take-to '() 5))) (test-group "string-take-to" (test-equal "Hello" @@ -178,20 +225,24 @@ '() (as-symb '()))) -(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 "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 first" - 1 - ((unval (lambda () (values 1 2 3))))) + (test-equal "unval other" + 2 + ((unval car+cdr 1) + (cons 1 2)))) -(test-equal "unval other" - 2 - ((unval car+cdr 1) - (cons 1 2))) -(test-group "Flatten" +(test-group "flatten" (test-equal "flatten already flat" (iota 10) (flatten (iota 10))) @@ -204,20 +255,38 @@ '(1 2 3 4 5) (flatten '((((((1(((((2((((3))))))4))))))))5)))) -;; TODO test let-lazy +(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 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 "map/dotted with dot" - '(1 2 3 . 4) - (map/dotted 1+ '(0 1 2 . 3))) +(test-group "assq-merge" + (test-equal "assq merge" + '((k 2 1) (v 2)) + (assq-merge '((k 1) (v 2)) '((k 2))))) - (test-equal "map/dotted direct value" - 1 (map/dotted 1+ 0))) +(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" @@ -243,6 +312,28 @@ '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" (test-equal "Basic case" @@ -273,136 +364,65 @@ '(3 4) '(5 6)))) -(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=>> - -;; downcase-symbol - - - -;; 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)) - -;; 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-group "string-flatten" + 'TODO) - (test-equal "assq merge" - '((k 2 1) (v 2)) - (assq-merge '((k 1) (v 2)) '((k 2)))) +(test-group "intersperse" + 'TODO) - (test-equal "kvlist->assq" - '((a . 1) (b . 2)) - (kvlist->assq '(a: 1 b: 2))) +(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-equal "kvlist->assq repeated key" - '((a . 1) (b . 2) (a . 3)) - (kvlist->assq '(a: 1 b: 2 a: 3)))) +(test-group "set" + 'TODO) -(test-equal "vector-last" - 1 (vector-last #(0 2 3 1))) +(test-group "set->" + 'TODO) -;; TODO test catch* +(test-group "and=>" + 'TODO) -(test-equal - "Filter sorted" - '(3 4 5) - (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))) +(test-group "downcase-symbol" + 'TODO) -(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 "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 "Find extremes" - (test-error 'wrong-type-arg (find-extreme '())) +(test-group "iterate" + (test-equal 0 (iterate 1- zero? 10))) - (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 "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 "valued-map" + 'TODO) -(test-group "Begin1" - (let ((value #f)) - (test-equal - "begin1 return value" - "Hello" - (begin1 "Hello" (set! value "World"))) - (test-equal "begin1 side effects" "World" value)) +(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))) - (let ((x 1)) - (test-eqv "begin1 set! after return" - 1 (begin1 x (set! x 10))) - (test-eqv "Updates value" - 10 x))) +(test-group "unique" + 'TODO) -(test-equal 0 (iterate 1- zero? 10)) +(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) + +'((hnh util)) diff --git a/tests/test/object.scm b/tests/unit/util/object.scm index 701c45c0..4f3aeb4f 100644 --- a/tests/test/object.scm +++ b/tests/unit/util/object.scm @@ -78,3 +78,5 @@ ;; - printer: (define-type (f4 printer: (lambda (r p) (display "something" p)))) (test-equal "something" (with-output-to-string (lambda () (write (f4))))) + +'((hnh util object)) diff --git a/tests/test/srfi-41-util.scm b/tests/unit/util/srfi-41-util.scm index 9a753b03..79c607c5 100644 --- a/tests/test/srfi-41-util.scm +++ b/tests/unit/util/srfi-41-util.scm @@ -106,3 +106,5 @@ (stream-map list->string (stream-split-by (lambda (c) (char=? c #\space)) hello-chars-stream)))))) + +'((srfi srfi-41 util)) diff --git a/tests/test/sxml-namespaced.scm b/tests/unit/util/sxml-namespaced.scm index 55d52798..b2d55028 100644 --- a/tests/test/sxml-namespaced.scm +++ b/tests/unit/util/sxml-namespaced.scm @@ -168,3 +168,5 @@ (xml->namespaced-sxml "<x:a xmlns:y=\"http://example.com/1\"><x:b/></x:a>" ; `((x . ,(ns 1))) )) + +'((sxml namespaced)) diff --git a/tests/test/uuid.scm b/tests/unit/util/uuid.scm index 1cedb59e..7d68e38e 100644 --- a/tests/test/uuid.scm +++ b/tests/unit/util/uuid.scm @@ -9,3 +9,5 @@ "d19c9347-9a85-4432-a876-5fb9c0d24d2b" (parameterize ((seed (seed->random-state 0))) (uuid-v4))) + +'((hnh util uuid)) diff --git a/tests/test/xdg-basedir.scm b/tests/unit/util/xdg-basedir.scm index 682c1347..5731b581 100644 --- a/tests/test/xdg-basedir.scm +++ b/tests/unit/util/xdg-basedir.scm @@ -56,3 +56,4 @@ (test-assert "No error was emitted" (string-null? warning))))) +'((xdg basedir)) diff --git a/tests/test/xml-namespace.scm b/tests/unit/util/xml-namespace.scm index 09402ceb..2b6ea174 100644 --- a/tests/test/xml-namespace.scm +++ b/tests/unit/util/xml-namespace.scm @@ -34,3 +34,5 @@ "Remove specific namespace" '(a:a (b)) (move-to-namespace '(a:a (b:b)) '((b . #f)))) + +'((sxml namespace)) |