fix define-record-type/destructor and refactor tests

author: Peter McGoron 2024-12-30 09:52:23 -0500
committer: Peter McGoron 2024-12-30 09:52:23 -0500
commit: 27eaddbc13849e5b0e214bca956048c22fadb1c8 (patch)
tree: 1eff0fa16a776b43d5dccd8fb44fee85e0795722 /tests
parent: define-record-type/destructor (diff)
3 files changed, 210 insertions, 50 deletions
diff --git a/tests/basic.scm b/tests/basic.scm
new file mode 100644
index 0000000..fdcc0d7
--- /dev/null
+++ b/tests/basic.scm
@@ -0,0 +1,70 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(test-begin "(mcgoron cond-thunk base)")
+
+(test-assert
+ "cond-thunk basic"
+ (cond-thunk
+   (if #t
+       (lambda ()
+         #t)
+       #f)
+   (else #f)))
+
+(test-assert
+ "when-ct true"
+ (cond-thunk
+   (when-ct #t #t)
+   (else #f)))
+
+(test
+ "cond-thunk multiple branches"
+ 'two
+ (cond-thunk
+   (when-ct (pair? #f) 'one)
+   (when-ct (boolean? #f) 'two)
+   (when-ct (boolean? #f) 'three)
+   (else #f)))
+
+(let ((on-pair
+       (lambda-ct (x) (pair? x)
+         'pair))
+      (on-boolean
+       (lambda-ct (x) (boolean? x)
+         'boolean)))
+  (test
+   "lambda-ct basic"
+   'boolean
+   (cond-thunk
+     (on-pair #f)
+     (on-boolean #f)
+     (else #f))))
+
+(let ()
+  (define-ct (on-pair x) (pair? x)
+    'pair)
+  (define-ct (on-boolean x) (boolean? x)
+    'boolean)
+  (test
+   "define-ct basic"
+   'boolean
+   (cond-thunk
+     (on-pair #f)
+     (on-boolean #f)
+     (else #f))))
+
+(test-end "(mcgoron cond-thunk base)")
diff --git a/tests/run.scm b/tests/run.scm
index c98e76f..261b224 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -18,57 +18,9 @@
  (chicken (import test r7rs))
  (else (import (srfi 64))))
 
-(load "../mcgoron.cond-thunk.sld")
 (import (mcgoron cond-thunk))
 
-(test-assert
- "cond-thunk basic"
- (cond-thunk
-   (if #t
-       (lambda ()
-         #t)
-       #f)
-   (else #f)))
+(include "basic.scm")
+(include "values.scm")
 
-(test-assert
- "when-ct true"
- (cond-thunk
-   (when-ct #t #t)
-   (else #f)))
-
-(test
- "cond-thunk multiple branches"
- 'two
- (cond-thunk
-   (when-ct (pair? #f) 'one)
-   (when-ct (boolean? #f) 'two)
-   (when-ct (boolean? #f) 'three)
-   (else #f)))
-
-(let ((on-pair
-       (lambda-ct (x) (pair? x)
-         'pair))
-      (on-boolean
-       (lambda-ct (x) (boolean? x)
-         'boolean)))
-  (test
-   "lambda-ct basic"
-   'boolean
-   (cond-thunk
-     (on-pair #f)
-     (on-boolean #f)
-     (else #f))))
-
-(let ()
-  (define-ct (on-pair x) (pair? x)
-    'pair)
-  (define-ct (on-boolean x) (boolean? x)
-    'boolean)
-  (test
-   "define-ct basic"
-   'boolean
-   (cond-thunk
-     (on-pair #f)
-     (on-boolean #f)
-     (else #f))))
 (test-exit)
diff --git a/tests/values.scm b/tests/values.scm
new file mode 100644
index 0000000..f1d63f7
--- /dev/null
+++ b/tests/values.scm
@@ -0,0 +1,138 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(import (mcgoron cond-thunk values) (scheme write))
+
+(test-begin "(mcgoron cond-thunk values)")
+(test-assert
+ "like cond-thunk 1"
+ (cond-values
+   (when-ct #t #t)
+   (else #f)))
+
+(test-assert
+ "like cond-thunk 2"
+ (cond-values
+   (when-ct #f #f)
+   (else #t)))
+
+(define-syntax case-receive
+  (syntax-rules ()
+    ((case-receive generator clauses ...)
+     (call-with-values (lambda () generator)
+       (case-lambda clauses ...)))))
+
+(test-assert
+ "delivering no values 1"
+ (case-receive (cond-values (when-ct #f #f))
+   (() #t)
+   (_ #f)))
+(test-assert
+ "delivering no values 2"
+ (case-receive (cond-values (when-ct #t #t))
+   (() #f)
+   ((x) #t)
+   (_ #f)))
+
+(test-assert
+ "after 1"
+ (case-receive (cond-values
+                 (after ((when #t))
+                   #t))
+   (() #f)
+   ((x) #t)
+   (_ #f)))
+
+(test-assert
+ "after 2"
+ (case-receive (cond-values
+                 (after ((when #f))
+                   #f))
+   (() #t)
+   (_ #f)))
+
+(test
+ "pair=>"
+ '(2 3 4)
+ (cond-values
+   (after ((let (pair=> #f) => (head tail)))
+     'boolean)
+   (after ((let (pair=> 5) => (head tail)))
+     'number)
+   (after ((let (pair=> "xy") => (head tail)))
+     'string)
+   (after ((let (pair=> '(1 2 3 4)) => (head tail)))
+     tail)
+   (else #f)))
+
+(test-assert
+ "length-at-least=> 1"
+ (cond-values
+   (after ((let (length-at-least=> '(1 2 3 4) 5)
+             => _))
+     #f)
+   (after ((let (length-at-least=> '(1 2 3 4) 4)
+             => returned))
+     #t)
+   (else #f)))
+
+(cond-values
+  (after ((let (length-at-least=> '(1 2 3 4) 4)
+            => (a b c d rest)))
+    (test "length-at-least=> 2.1" 1 a)
+    (test "length-at-least=> 2.2" 2 b)
+    (test "length-at-least=> 2.3" 3 c)
+    (test "length-at-least=> 2.4" 4 d)
+    (test-assert "length-at-least=> 2.5" (null? rest)))
+  (else (error "length-at-least=> 2" #f)))
+
+(cond-values
+  (after ((let (length-at-least=> '(1 2 3 4) 3)
+            => (a b c rest)))
+    (test "length-at-least=> 3.1" 1 a)
+    (test "length-at-least=> 3.2" 2 b)
+    (test "length-at-least=> 3.3" 3 c)
+    (test-assert "length-at-least=> 3.4" (equal? rest '(4))))
+  (else (error "length-at-least=> 3" #f)))
+
+(define-syntax with-catch-predicate
+  (syntax-rules ()
+    ((with-catch-predicate predicate? body ...)
+     (guard (x ((predicate? x) #t)
+               (else #f))
+       body ...))))
+
+(define-record-type/destructor <test-object>
+  (test-object x y z)
+  test-object?
+  test-object=>
+  (x get-x)
+  (y get-y)
+  (z get-z))
+
+(let ((obj (test-object 1 2 3)))
+  (test-assert
+   "define-record-type/destructor"
+   (cond-thunk
+     (after ((let (test-object=> obj) => (a b c))
+             (when (= a 1))
+             (when (= b 2))
+             (when (= c 3)))
+       #t))))
+
+
+(test-end "(mcgoron cond-thunk values)")
+
author	Peter McGoron	2024-12-30 09:52:23 -0500
committer	Peter McGoron	2024-12-30 09:52:23 -0500
commit	27eaddbc13849e5b0e214bca956048c22fadb1c8 (patch)
tree	1eff0fa16a776b43d5dccd8fb44fee85e0795722 /tests
parent	define-record-type/destructor (diff)