#| 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 (scheme base)
        (mcgoron srfi 64)
        (SAHP)
        (srfi 64) (srfi 252))

(test-runner-factory factory)
(test-runner-current (test-runner-create))
(set-verbosity! '(fails group-stack))

(define iref (make-new-SAHP))
(set-global-SAHP! iref 'vector vector-ref)
(set-global-SAHP! iref 'bytevector bytevector-u8-ref)

(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)))))

(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"
      (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"
      (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"
      (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"
      (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"
      (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"
      (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))))))

(test-group "subtyping"
  (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))))
  (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 "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))))))
  (test-group "dynamic scope"
    (test-group "subtypes flow downwards"
      (parameterize-SAHP ((sub ('number (lambda (x) #t))))
        (test-for-all)))
    (test-group "subtypes do not flow upwards"
      (parameterize-SAHP ((sub ('rational (lambda (x) #t))))
        (test-for-some)))
    (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))))))
  (test-group "global scope"
    (define-global-SAHP (sub ('number x))
      1)
    (test-group "subtypes flow downwards"
      (test-for-all))
    (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))))
    (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)))))))