reorganize to remove subtype inheritance

1 files changed, 82 insertions, 66 deletions

diff --git a/tests/run.scm b/tests/run.scm
index f6ace47..cbc19f4 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -17,7 +17,7 @@
 (import (scheme base)
         (mcgoron srfi 64)
         (SAHP)
-        (srfi 64) (srfi 252))
+        (srfi 64) (srfi 194) (srfi 252))
 
 (test-runner-factory factory)
 (test-runner-current (test-runner-create))
@@ -135,80 +135,96 @@
               (else #f)))))
       (test-property override (list (bytevector-generator))))))
 
-(test-group "subtyping"
-  ;; TODO: property testing
+(test-group "numeric tower type expressions"
   (define sub (make-new-SAHP))
-  (define (test-for-all)
-    (test-assert "exact integer" (sub 0))
-    (test-assert "integer" (sub 1.0))
-    (test-assert "rational" (sub 1/2))
-    (test-assert "real" (sub +inf.0))
-    (test-assert "complex" (sub 1+2i))
-    (test-assert "not implemented"
-                 (guard (c
-                         (else
-                          (SAHP-implementation-not-found-error? c)))
-                   (sub "not a number")
-                   #f)))
-  (define (test-for-some)
-    (test-assert "exact integer" (sub 0))
-    (test-assert "integer" (sub 1.0))
-    (test-assert "rational" (sub 1/2))
-    (test-assert "not for complex"
-                 (guard (c
-                         (else
-                          (SAHP-implementation-not-found-error? c)))
-                   (sub +inf.0))))
+  (define test-all-numbers
+    (case-lambda
+      (() (test-all-numbers sub))
+      ((sub)
+       (test-group "implemented"
+         (test-property sub (list (gsampling (number-generator)))))
+       (test-assert "not implemented"
+                    (guard (c
+                            (else
+                             (SAHP-implementation-not-found-error? c)))
+                      (sub "not a number")
+                      #f)))))
+  (define test-some-numbers
+    (case-lambda
+      (() (test-some-numbers sub))
+      ((sub)
+       (test-group "exact rationals and integers"
+         (test-property sub
+                        (list (gsampling
+                               (exact-rational-generator)
+                               (exact-integer-generator)))))
+       (test-assert "not for complex"
+                    (guard (c
+                            (else
+                             (SAHP-implementation-not-found-error? c)))
+                      (sub +inf.0))))))
   (test-group "local scope"
-    (test-group "subtypes flow downwards"
-      (letrec-SAHP ((sub ('number (lambda (x) #t))))
-        (test-assert "exact integer" (sub 0))
-        (test-assert "integer" (sub 1.0))
-        (test-assert "rational" (sub 1/2))
-        (test-assert "real" (sub +inf.0))
-        (test-assert "complex" (sub 1+2i))
-        (test-assert "not implemented"
-                     (guard (c
-                             (else
-                              (SAHP-implementation-not-found-error? c)))
-                       (sub "not a number")
-                       #f))))
+    (test-group "type expression flow downwards"
+      (letrec-SAHP ((sub (all-numbers (lambda (x) #t))))
+        (test-all-numbers sub)))
     (test-group "subtypes do not flow upwards"
-      (letrec-SAHP ((sub ('rational (lambda (x) #t))))
-        (test-assert "exact integer" (sub 0))
-        (test-assert "integer" (sub 1.0))
-        (test-assert "rational" (sub 1/2))
-        (test-assert "not for complex"
-                     (guard (c
-                             (else
-                              (SAHP-implementation-not-found-error? c)))
-                       (sub +inf.0))))))
+      (letrec-SAHP ((sub (all-exact-rationals (lambda (x) #t))))
+        (test-some-numbers sub))))
   (test-group "dynamic scope"
     (test-group "subtypes flow downwards"
-      (parameterize-SAHP ((sub ('number (lambda (x) #t))))
-        (test-for-all)))
+      (parameterize-SAHP ((sub (all-numbers (lambda (x) #t))))
+        (test-all-numbers sub)))
     (test-group "subtypes do not flow upwards"
-      (parameterize-SAHP ((sub ('rational (lambda (x) #t))))
-        (test-for-some)))
+      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) #t))))
+        (test-some-numbers sub)))
     (test-group "local scope overrides dynamic scope subtyping"
-      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
-        (letrec-SAHP ((sub ('rational (lambda (x) 2))))
-          (test-equal 2 (sub 0))
-          (test-equal 2 (sub 1/2))
-          (test-equal 1 (sub 1+2i))))))
+      (parameterize-SAHP ((sub (all-numbers (lambda (x) 1))))
+        (letrec-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+          (define (test-local n)
+            (= 2 (sub n)))
+          (define (test-dynamic n)
+            (= 1 (sub n)))
+          (test-group "local"
+            (test-property test-local
+                           (list
+                            (gsampling (exact-rational-generator)))))
+          (test-group "dynamic"
+            (test-property test-dynamic
+                           (list
+                            (gsampling (inexact-complex-generator)))))))))
   (test-group "global scope"
-    (define-global-SAHP (sub ('number x))
+    (define-global-SAHP (sub (all-numbers x))
       1)
+    (define (test-global n)
+      (= 1 (sub n)))
+    (define (test-dynamic n)
+      (= 2 (sub n)))
     (test-group "subtypes flow downwards"
-      (test-for-all))
+      (test-all-numbers))
     (test-group "dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub ('rational (lambda (x) 2))))
-        (test-equal 2 (sub 0))
-        (test-equal 2 (sub 1/2))
-        (test-equal 1 (sub 1+2i))))
+      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+        (test-group "dynamic"
+          (test-property test-dynamic
+                         (list
+                          (gsampling (exact-rational-generator)))))
+        (test-group "global"
+          (test-property test-global
+                         (list
+                          (gsampling (inexact-complex-generator)))))))
     (test-group "local scope overrides dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub ('rational (lambda (x) 2))))
-        (letrec-SAHP ((sub ('integer (lambda (x) 3))))
-          (test-equal 3 (sub 0))
-          (test-equal 2 (sub 1/2))
-          (test-equal 1 (sub 1+2i)))))))
+      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+        (letrec-SAHP ((sub (all-exact-integers (lambda (x) 3))))
+          (define (test-local n)
+            (= 3 (sub n)))
+          (test-group "dynamic"
+            (test-property test-dynamic
+                           (list
+                            (gsampling (exact-rational-generator)))))
+          (test-group "global"
+            (test-property test-global
+                           (list
+                            (gsampling (inexact-complex-generator)))))
+          (test-group "local"
+            (test-property test-local
+                           (list
+                            (gsampling (exact-integer-generator))))))))))