tests run in CHICKEN 5

1 files changed, 222 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..7610959
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,222 @@
+;; Tests for property-test library.
+;; SPDX-License-Identifier: MIT
+;; Copyright 2024 Antero Mejr <mail@antr.me>
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(import (scheme base)
+        (scheme complex)
+        (scheme read)
+        (srfi 1)
+        (srfi 27)
+        (srfi 64)
+        (srfi 158)
+        (srfi 194)
+        (srfi 252))
+
+
+(test-begin "property-test")
+
+(define (three x) 3)
+(define (wrong-three x) x)
+(define (three-property x) (= (three x) 3))
+(define (wrong-three-property x) (= (wrong-three x) 3))
+(define (error-three-property x) (string-append 1 2))
+(define (make-read-error x) (read (open-input-string (string-append ")" x))))
+(define (make-read-error-property x) (symbol? (make-read-error x)))
+(define (bad-generator) (gmap (lambda (x)
+                                (string-append 1 2)
+                                x)
+                              (boolean-generator)))
+
+(test-group "test-property"
+  (test-property three-property (list (integer-generator)))
+  (test-property three-property (list (real-generator)))
+  (test-property three-property (list (integer-generator)) 10))
+
+(test-group "test-property-expect-fail"
+  (test-property-expect-fail wrong-three-property (list (integer-generator)))
+  (test-property-expect-fail wrong-three-property (list (integer-generator)) 10))
+
+(test-group "test-property-skip" ; shouldn't run
+  (test-property-skip three-property (list (bad-generator)))
+  (test-property-skip three-property (list (bad-generator)) 10))
+
+(test-group "test-property-error"
+  (test-property-error error-three-property (list (integer-generator)))
+  (test-property-error error-three-property (list (integer-generator)) 10))
+
+#;(cond-expand
+ ((library (srfi 36))
+  (test-group "test-property-error-type"
+              (test-property-error-type &read-error make-read-error-property
+                                        (list (string-generator)))))
+ (else))
+
+(test-group "test-property/with-2-arguments"
+  (test-property (lambda (x y)
+                   (and (boolean? x) (integer? y)))
+                 (list (boolean-generator) (integer-generator))))
+
+;; Testing basic generators
+
+(test-group "boolean-generator"
+  (test-property boolean? (list (boolean-generator))))
+
+(test-group "bytevector-generator"
+  (test-property bytevector? (list (bytevector-generator))))
+
+(test-group "char-generator"
+  (test-property char? (list (char-generator))))
+
+(test-group "string-generator"
+  (test-property string? (list (string-generator))))
+
+(test-group "symbol-generator"
+  (test-property symbol? (list (symbol-generator))))
+
+;; Testing exact generators
+
+(cond-expand
+ (exact-complex
+  (test-group "exact-complex-generator"
+    (test-property (lambda (x)
+                     (and (complex? x)
+                          (exact? (real-part x))
+                          (exact? (imag-part x))))
+                   (list (exact-complex-generator)))))
+ (else))
+
+(test-group "exact-integer-generator"
+  (test-property (lambda (x)
+                   (and (integer? x) (exact? x)))
+                 (list (exact-integer-generator))))
+
+(test-group "exact-number-generator"
+  (test-property exact? (list (exact-number-generator))))
+
+(test-group "exact-rational-generator"
+  (test-property (lambda (x)
+                   (and (exact? x) (rational? x)))
+                 (list (exact-rational-generator))))
+
+(test-group "exact-real-generator"
+  (test-property (lambda (x)
+                   (and (exact? x) (real? x)))
+                 (list (exact-real-generator))))
+
+(test-group "exact-integer-complex-generator"
+  (cond-expand
+   (exact-complex
+    (test-property (lambda (x)
+                     (and (complex? x)
+                          (exact? (real-part x))
+                          (exact? (imag-part x))
+                          (integer? (real-part x))
+                          (integer? (imag-part x))))
+                   (list (exact-integer-complex-generator))))
+   (else)))
+
+;; Testing inexact generators
+
+(test-group "inexact-complex-generator"
+  (test-property (lambda (x)
+                   (and (complex? x)
+                        (inexact? (real-part x))
+                        (inexact? (imag-part x))))
+                 (list (inexact-complex-generator))))
+
+(test-group "inexact-integer-generator"
+  (test-property (lambda (x)
+                   (and (inexact? x) (integer? x)))
+                 (list (inexact-integer-generator))))
+
+(test-group "inexact-number-generator"
+  (test-property inexact? (list (inexact-number-generator))))
+
+(test-group "inexact-rational-generator"
+  (test-property (lambda (x)
+                   (and (inexact? x) (rational? x)))
+                 (list (inexact-rational-generator))))
+
+(test-group "inexact-integer-generator"
+  (test-property (lambda (x)
+                   (and (inexact? x) (real? x)))
+                 (list (inexact-real-generator))))
+
+;; Testing union generators
+
+(test-group "complex-generator"
+  (test-property complex? (list (complex-generator))))
+
+(test-group "integer-generator"
+  (test-property integer? (list (integer-generator))))
+
+(test-group "number-generator"
+  (test-property number? (list (number-generator))))
+
+(test-group "rational-generator"
+  (test-property rational? (list (rational-generator))))
+
+(test-group "real-generator"
+  (test-property real? (list (real-generator))))
+
+;; Testing special generators
+
+(test-group "list-generator-of"
+  (test-property (lambda (x)
+                   (and (list? x) (<= (length x) 1001)
+                        (every integer? x)))
+                 (list (list-generator-of (integer-generator)))))
+
+(test-group "pair-generator-of"
+  (test-property (lambda (x)
+                   (pair? x) (integer? (car x)) (boolean? (cdr x)))
+                 (list (pair-generator-of (integer-generator)
+                                          (boolean-generator)))))
+
+(test-group "procedure-generator-of"
+  (test-property (lambda (x)
+                   (procedure? x) (integer? (x)))
+                 (list (procedure-generator-of (integer-generator)))))
+
+(test-group "vector-generator-of"
+  (test-property (lambda (x)
+                   (vector? x)
+                   (<= (vector-length x) 1001)
+                   (every integer? (vector->list x)))
+                 (list (vector-generator-of (integer-generator)))))
+
+(test-group "non-determinism"
+  (let ((gen1 (gdrop (exact-number-generator) 30)) ;skip the initial sequence
+        (gen2 (gdrop (exact-number-generator) 30)))
+    (test-property (lambda (x y)
+                     (not (= x y)))
+                   (list gen1 gen2))))
+
+(test-group "determinism"
+  (parameterize ((current-random-source (make-random-source)))
+    (let ((gen1 (gdrop (exact-number-generator) 30)))
+      (parameterize ((current-random-source (make-random-source)))
+        (let ((gen2 (gdrop (exact-number-generator) 30)))
+          (test-property = (list gen1 gen2)))))))
+
+(test-end)