split up tests into different librariesHEADmaster

1 files changed, 303 insertions, 0 deletions

diff --git a/tests/basic.scm b/tests/basic.scm
new file mode 100644
index 0000000..5f2beea
--- /dev/null
+++ b/tests/basic.scm
@@ -0,0 +1,303 @@
+#| Copyright 2025 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.
+ |#
+
+(define (test-creating-SAHP)
+  (define iref (make-new-SAHP))
+  (define (iref-works-with-vector v)
+    (let loop ((i 0))
+      (cond
+        ((= i (vector-length v)) #t)
+        ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
+        (else #f))))
+  (define (iref-works-with-bytevector v)
+    (let loop ((i 0))
+      (cond
+        ((= i (bytevector-length v)) #t)
+        ((= (bytevector-u8-ref v i) (iref v i)) (loop (+ i 1)))
+        (else #f))))
+  (define (override-vector-in-dynamic-scope procedure)
+    (lambda (v)
+      (define cntr 0)
+      (parameterize-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+        (procedure v (lambda () cntr)))))
+  (set-global-SAHP! iref 'vector vector-ref)
+  (set-global-SAHP! iref 'bytevector bytevector-u8-ref)
+  (test-group "iref"
+    (test-group "global scope"
+      (test-group "on vectors"
+        (test-property iref-works-with-vector
+                       (list (vector-generator-of (exact-integer-generator)))))
+      (test-group "on bytevectors"
+        (test-property iref-works-with-bytevector
+                       (list (bytevector-generator))))
+      (test-group "undefined raises error"
+        (test-assert
+         (guard (c
+                 ((SAHP-implementation-not-found-error? c) #t)
+                 (else #f))
+           (iref '() 0)))))
+    (test-group "dynamic scope"
+      (test-group "override in dynamic scope"
+        (let ()
+          (define (impl v cntr)
+            (test-assert "works" (iref-works-with-vector v))
+            (test-equal "counted" (vector-length v) (cntr)))
+          (test-property (override-vector-in-dynamic-scope impl)
+                         (list (vector-generator-of (exact-integer-generator))))))
+      (test-group "override in dynamic scope does not affect other implementations"
+        (let ()
+          (define (impl bc cntr)
+            (test-assert "works" (iref-works-with-bytevector bc))
+            (test-equal "did not count" 0 (cntr)))
+          (test-property (override-vector-in-dynamic-scope impl)
+                         (list (bytevector-generator))))))
+    (test-group "local scope"
+      (test-group "override in local scope doesnt affect global scope"
+        (let ()
+          (define (override v)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (and (iref-works-with-vector v)
+                   (= cntr 0))))
+          (test-property override
+                         (list (vector-generator-of
+                                (exact-integer-generator))))))
+      (test-group "override in local scope affects lexical scope"
+        (let ()
+          (define (override v)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (let loop ((i 0))
+                (cond
+                  ((= i (vector-length v)) (= cntr i))
+                  ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
+                  (else #f)))))
+          (test-property override
+                         (list (vector-generator-of
+                                (exact-integer-generator))))))
+      (test-group "override in local scope overrides dynamic scope"
+        (let ()
+          (define (override v)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (parameterize-SAHP ((iref ('vector vector-ref)))
+                (let loop ((i 0))
+                  (cond
+                    ((= i (vector-length v)) (= cntr i))
+                    ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
+                    (else #f))))))
+          (test-property override
+                         (list (vector-generator-of
+                                (exact-integer-generator))))))
+      (test-group "override in local scope only affects that type"
+        (let ()
+          (define (override bv)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (let loop ((i 0))
+                (cond
+                  ((= i (bytevector-length bv)) (= cntr 0))
+                  ((= (bytevector-u8-ref bv i) (iref bv i)) (loop (+ i 1)))
+                  (else #f)))))
+          (test-property override (list (bytevector-generator))))))))
+
+(define (test-numeric-tower-subtyping)
+  (define sub (make-new-SAHP))
+  (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 "numeric tower subtyping"
+    (test-group "local scope"
+      (test-group "type expression flow downwards"
+        (letrec-SAHP ((sub ('number (lambda (x) #t))))
+          (test-all-numbers sub)))
+      (test-group "subtypes do not flow upwards"
+        (letrec-SAHP ((sub ('exact-rational (lambda (x) #t))))
+          (test-some-numbers sub))))
+    (test-group "dynamic scope"
+      (test-group "subtypes flow downwards"
+        (parameterize-SAHP ((sub ('number (lambda (x) #t))))
+          (test-all-numbers sub)))
+      (test-group "subtypes do not flow upwards"
+        (parameterize-SAHP ((sub ('exact-rational (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 ('exact-rational (lambda (x) 2))))
+            (let ()
+              (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 "local scope overrides dynamic scope subtyping even with overridable"
+        (parameterize-SAHP ((sub ('number (lambda (x) 1))))
+          (letrec-SAHP ((sub ('exact-rational '(overridable) (lambda (x) 2))))
+            (let ()
+              (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"
+      (let ()
+        (define (test-global n)
+          (= 1 (sub n)))
+        (define (test-dynamic n)
+          (= 2 (sub n)))
+        (define-global-SAHP (sub ('number x))
+          1)
+        (test-group "subtypes flow downwards"
+          (test-all-numbers))
+        (test-group "dynamic scope overrides global scope"
+          (parameterize-SAHP ((sub ('exact-rational (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 "dynamic scope overrides global scope even with overridable"
+          (parameterize-SAHP ((sub ('exact-rational '(overridable) (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 ('exact-rational (lambda (x) 2))))
+            (letrec-SAHP ((sub ('exact-integer (lambda (x) 3))))
+              (let ()
+                (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)))))))))
+        (test-group "local scope overrides dynamic scope overrides global scope even when overridable"
+          (parameterize-SAHP ((sub
+                               ('exact-rational
+                                '(overridable)
+                                (lambda (x) 2))))
+            (letrec-SAHP ((sub
+                           ('exact-integer
+                            '(overridable)
+                            (lambda (x) 3))))
+              (let ()
+                (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)))))))))))))
+
+(define (test-overrides)
+  (define sub (make-new-SAHP))
+  (test-group "overrides"
+    (define-global-SAHP (sub ('exact-rational x))
+      1)
+    (test-group "non-overridable in local scope has precedence over global scope"
+      (letrec-SAHP ((sub ('number (lambda (x) 2))))
+        (test-property (lambda (x) (= (sub x) 2))
+                       (list (gsampling
+                              (inexact-real-generator)
+                              (exact-rational-generator))))))
+    (test-group "override in local scope to global scope"
+      (letrec-SAHP ((sub ('number
+                          '(overridable)
+                          (lambda (x) 2))))
+        (let ()
+          (define (is-local-scope x)
+            (= (sub x) 2))
+          (define (is-global-scope x)
+            (= (sub x) 1))
+          (test-property is-local-scope
+                         (list (inexact-complex-generator)))
+          (test-property is-global-scope
+                         (list (exact-rational-generator))))))))
\ No newline at end of file