#lang racket/base

(require "test-utils.rkt"
         rackunit racket/format
         (typecheck tc-metafunctions tc-subst)
         (rep prop-rep type-rep object-rep)
         (types abbrev union prop-ops tc-result numeric-tower)
         (for-syntax racket/base syntax/parse))

(provide tests)
(gen-test-main)

(define-syntax (test-combine-props stx)
  (syntax-parse stx
    [(_ new:expr existing:expr expected:expr box-v:expr)
     (quasisyntax/loc stx
       (test-case (~a '(new + existing = expected))
         (define success
           (let/ec exit
             (define-values (res-formulas res-props) (combine-props new existing exit))
             #,(syntax/loc stx (check-equal? (append res-formulas res-props) expected))
             #t))
         #,(syntax/loc stx (check-equal? success box-v))))]))


(define tests
  (test-suite "Metafunctions"

    (test-suite "combine-props"

      (test-combine-props
        (list (-or (-not-type #'x -String) (-not-type #'y -String)))
        (list (-is-type #'x (Un -String -Symbol)) (-is-type #'y (Un -String -Symbol)))
        (list (-or (-not-type #'y -String) (-not-type #'x -String))
              (-is-type #'y (Un -String -Symbol)) (-is-type #'x (Un -String -Symbol)))
        #t)

      (test-combine-props
        (list (-or (-is-type #'x -String) (-is-type #'y -String)))
        (list (-is-type #'x (Un -String -Symbol)) (-is-type #'y (Un -String -Symbol)))
        (list (-or (-is-type #'y -String) (-is-type #'x -String))
              (-is-type #'y (Un -String -Symbol)) (-is-type #'x (Un -String -Symbol)))
        #t)
    )

    (test-suite "merge-tc-results"
      (check-equal?
        (merge-tc-results (list))
        (ret -Bottom))
      (check-equal?
        (merge-tc-results (list (ret Univ)))
        (ret Univ))
      (check-equal?
        (merge-tc-results (list (ret Univ -tt-propset (make-Path null #'x))))
        (ret Univ -tt-propset (make-Path null #'x)))
      (check-equal?
        (merge-tc-results (list (ret -Bottom) (ret -Symbol -tt-propset (make-Path null #'x))))
        (ret -Symbol -tt-propset (make-Path null #'x)))
      (check-equal?
        (merge-tc-results (list (ret -String) (ret -Symbol)))
        (ret (Un -Symbol -String)))
      (check-equal?
        (merge-tc-results (list (ret -String -true-propset) (ret -Symbol -true-propset)))
        (ret (Un -Symbol -String) -true-propset))
      (check-equal?
        (merge-tc-results (list (ret (-val #f) -false-propset) (ret -Symbol -true-propset)))
        (ret (Un -Symbol (-val #f)) -tt-propset))
      (check-equal?
        (merge-tc-results (list (ret (list (-val 0) (-val 1))) (ret (list (-val 1) (-val 2)))))
        (ret (list (Un (-val 0) (-val 1)) (Un (-val 1) (-val 2)))))
      (check-equal?
        (merge-tc-results (list (ret null null null -Symbol 'x) (ret null null null -String 'x)))
        (ret null null null (Un -Symbol -String) 'x))
    )


    (test-suite "values->tc-results"
      (check-equal?
        (values->tc-results (make-Values (list (-result -Symbol))) (list -empty-obj) (list Univ))
        (ret -Symbol))

      (check-equal?
        (values->tc-results (make-Values (list (-result -Symbol) (-result -String))) 
                            (list -empty-obj -empty-obj) (list Univ Univ))
        (ret (list -Symbol -String)))

      (check-equal?
        (values->tc-results (make-Values (list (-result -Symbol (-PS -tt -ff)))) (list -empty-obj) (list Univ))
        (ret -Symbol (-PS -tt -ff)))

      (check-equal?
        (values->tc-results (make-Values (list (-result -Symbol (-PS -tt -ff) (make-Path null '(0 0)))))
                            (list -empty-obj) (list Univ))
        (ret -Symbol (-PS -tt -ff)))

      (check-equal?
        (values->tc-results (make-Values (list (-result (-opt -Symbol) (-PS (-is-type '(0 0) -String) -tt))))
                            (list -empty-obj) (list Univ))
        (ret (-opt -Symbol) -tt-propset))

      (check-equal?
        (values->tc-results (make-Values (list (-result (-opt -Symbol) (-PS (-not-type '(0 0) -String) -tt))))
                            (list -empty-obj) (list Univ))
        (ret (-opt -Symbol) -tt-propset))

      (check-equal?
        (values->tc-results (make-Values (list (-result (-opt -Symbol) (-PS (-not-type '(0 0) -String) -tt)
                                                 (make-Path null '(0 0)))))
                            (list (make-Path null #'x)) (list Univ))
        (ret (-opt -Symbol) (-PS (-not-type #'x -String) -tt) (make-Path null #'x)))

      ;; Check additional props
      (check-equal?
        (values->tc-results (make-Values (list (-result (-opt -String) (-PS -tt (-not-type '(0 0) -String))
                                                 (make-Path null '(0 0)))))
                            (list (make-Path null #'x)) (list -String))
        (ret -String -true-propset (make-Path null #'x)))

      ;; Substitute into ranges correctly
      (check-equal?
        (values->tc-results (make-Values (list (-result (-opt (-> Univ -Boolean : (-PS (-is-type '(0 0) -Symbol) -tt))))))
                            (list (make-Path null #'x)) (list Univ))
        (ret (-opt (-> Univ -Boolean : (-PS (-is-type '(0 0) -Symbol) -tt)))))

      (check-equal?
        (values->tc-results (make-Values (list (-result (-opt (-> Univ -Boolean : (-PS (-is-type '(1 0) -Symbol) -tt))))))
                            (list (make-Path null #'x)) (list Univ))
        (ret (-opt (-> Univ -Boolean : (-PS (-is-type #'x -Symbol) -tt)))))

      ;; Substitute into prop of any values
      (check-equal?
        (values->tc-results (make-AnyValues (-is-type '(0 0) -String))
                            (list (make-Path null #'x)) (list Univ))
        (tc-any-results (-is-type #'x -String)))


      (check-equal?
        (values->tc-results (-values-dots null (-> Univ -Boolean : (-PS (-is-type '(1 0) -String) -tt)) 'b)
                            (list (make-Path null #'x)) (list Univ))
        (ret null null null (-> Univ -Boolean : (-PS (-is-type #'x -String) -tt)) 'b))

      ;; Prop is restricted by type of object
      (check-equal?
        (values->tc-results (make-Values (list (-result -Boolean (-PS (-is-type '(0 0) -PosReal) (-is-type '(0 0) -NonPosReal)))))
                            (list (make-Path null #'x)) (list -Integer))
        (ret -Boolean (-PS (-is-type #'x -PosInt) (-is-type #'x -NonPosInt))))

      ;; Prop restriction accounts for paths
      (check-equal?
        (values->tc-results
         (make-Values
          (list (-result -Boolean
                         (-PS (make-TypeProp (make-Path (list -car) '(0 0))
                                             -PosReal)
                              (make-TypeProp (make-Path (list -car) '(0 0))
                                             -NonPosReal)))))
         (list (make-Path null #'x))
         (list (-lst -Integer)))
        (ret -Boolean
             (-PS (make-TypeProp (make-Path (list -car) #'x) -PosInt)
                  (make-TypeProp (make-Path (list -car) #'x) -NonPosInt))))
    )

    (test-suite "replace-names"
      (check-equal?
        (replace-names (list (list #'x (make-Path null (list 0 0))))
                       (ret Univ -tt-propset (make-Path null #'x)))
        (ret Univ -tt-propset (make-Path null (list 0 0))))
      (check-equal?
        (replace-names (list (list #'x (make-Path null (list 0 0))))
                       (ret (-> Univ Univ : -tt-propset : (make-Path null #'x))))
        (ret (-> Univ Univ : -tt-propset : (make-Path null (list 1 0)))))
    )
  ))