#| 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 194) (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 "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 "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))))
          (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))))
          (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))
      1)
    (define (test-global n)
      (= 1 (sub n)))
    (define (test-dynamic n)
      (= 2 (sub n)))
    (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))))
          (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))))
          (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 "overrides"
  (define sub (make-new-SAHP))
  (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))))
      (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))))))

;;; TODO: tests of override