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
parent: define-record-type/destructor (diff)
5 files changed, 236 insertions, 60 deletions
diff --git a/doc/mcgoron.cond-thunk.values.scm b/doc/mcgoron.cond-thunk.values.scm
index 5f2265f..c319f3d 100644
--- a/doc/mcgoron.cond-thunk.values.scm
+++ b/doc/mcgoron.cond-thunk.values.scm
@@ -51,4 +51,19 @@ list is returned as values."))
   (desc "
 Evaluates `producer`. If `producer` evaluates to at least one value, then
 return a thunk that, when called, tail-calls `consumer` with the values
-that `producer` produced. Otherwise, return `#f~.")))
-\ No newline at end of file
+that `producer` produced. Otherwise, return `#f~."))
+ ((name . "define-record-type/destructor")
+  (signature syntax-rules () ((_ type-name
+                                 (cstr fields ...)
+                                 predicate?
+                                 destructor=>
+                                 field-spec ...)))
+  (desc "
+Creates a record type using `define-record-type`, and also creates a
+destructor procedure of a single argument named `destructor=>`. When
+`destructor=>` is called with a record of this type, it returns as values
+each field of the record as declared in the `field-spec`. Otherwise it
+returns no values.
+
+Note that the destructor will always return no values for a record type
+that has no fields.")))
+\ No newline at end of file
diff --git a/mcgoron.cond-thunk.values.scm b/mcgoron.cond-thunk.values.scm
index 8330ba1..7ca5236 100644
--- a/mcgoron.cond-thunk.values.scm
+++ b/mcgoron.cond-thunk.values.scm
@@ -45,7 +45,7 @@
     (after ((when (pair? x)))
       (values (car x) (cdr x)))))
 
-(define (list-length-destructor whole-list num final-call)
+(define (list-length-destructor whole-list num kont)
   (cond-thunk
     (when-ct (not (integer? num))
       (error "must be integer" num))
@@ -57,16 +57,17 @@
                 (num num))
        (cond-values
          (after ((when (= num 0)))
-           (final-call collected iterator))
+           (kont collected iterator))
          (after ((let (pair=> iterator) => (head rest)))
-           (loop (cdr rest) (cons head collected) (- num 1))))))))
+           (loop rest (cons head collected) (- num 1))))))))
 
 (define (length-at-least=> whole-list num)
   (list-length-destructor whole-list num
                           (lambda (reverse-seen rest)
-                            (when-ct (or (null? rest) (pair? rest))
-                              (apply values
-                                     (reverse (cons rest reverse-seen)))))))
+                            (cond-values
+                              (when-ct (or (null? rest) (pair? rest))
+                                (apply values
+                                       (reverse (cons rest reverse-seen))))))))
 
 (define (length=> whole-list num)
   (list-length-destructor whole-list num
@@ -77,13 +78,13 @@
 (define-syntax define-record-type/destructor
   (syntax-rules ()
     ((_ type-name cstr predicate? destructor=>
-        (arg-name accessor . rest)
+        (arg-name accessor setter ...)
         ...)
      (begin
        (define-record-type type-name
-         str
+         cstr
          predicate?
-         (arg-name accessor . rest)
+         (arg-name accessor setter ...)
          ...)
        (define (destructor=> record)
          (cond-values
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
parent	define-record-type/destructor (diff)