#lang racket/base
(require "test-util.rkt"
         racket/list)

(parameterize ([current-contract-namespace
                (make-basic-contract-namespace)])
(define (test-obligations quoted-expr expected-props)
  
  (define ((cleanup key stx) obj)
    (case key
      [(racket/contract:contract)
       (define (cleanup-ent x)
         (sort (map syntax->datum (vector-ref obj x)) string<=? #:key (λ (x) (format "~s" x))))
       (list key (cleanup-ent 1) (cleanup-ent 2))]
      [(racket/contract:positive-position racket/contract:negative-position)
       (list key (syntax->datum stx))]
      [(racket/contract:contract-on-boundary) 
       `(racket/contract:contract-on-boundary ,(syntax->datum stx))]
      [(racket/contract:internal-contract)
       `(racket/contract:internal-contract ,(syntax->datum stx))]
      [else
       (error 'test-obligations "unknown property ~s" key)]))
  
  (let ([props '()])
    (let ([stx (contract-expand quoted-expr)])
      (let loop ([stx stx])
        (cond
          [(syntax? stx)
           (syntax-case stx (#%top)
             [(#%top . x)
              (void)]
             [_
              (for ([key (in-list (syntax-property-symbol-keys stx))])
                (when (regexp-match #rx"^racket/contract:" (symbol->string key))
                  (set! props (append (map (cleanup key stx) (flatten (syntax-property stx key)))
                                      props))))])
           (loop (syntax-e stx))]
          [(pair? stx)
           (loop (car stx))
           (loop (cdr stx))])))
    (test expected-props
          `(obligations-for ,quoted-expr)
          (remove-duplicates (sort props string<=? #:key (λ (x) (format "~s" x)))))))

  (test-obligations '(-> a b)
                    '((racket/contract:contract (->) ())
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position b)))
  (test-obligations '(-> #:a a b)
                    '((racket/contract:contract (->) ())
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position b)))
  (test-obligations '(->i ([x a]) any)
                    '((racket/contract:contract (->i) ())
                      (racket/contract:contract-on-boundary a)
                      (racket/contract:negative-position a)))
  (test-obligations '(->i ([x a]) [res b])
                    '((racket/contract:contract (->i) ())
                      (racket/contract:contract-on-boundary a)
                      (racket/contract:contract-on-boundary b)
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position b)))
  (test-obligations '(->i ([x a]) #:pre () #t [res b] #:post () #t)
                    '((racket/contract:contract (#:post ->i) (#:pre))
                      (racket/contract:contract-on-boundary a)
                      (racket/contract:contract-on-boundary b)
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position b)))
  (test-obligations '(listof a)
                    '((racket/contract:contract (listof) ())
                      (racket/contract:positive-position a)))
  (test-obligations '(hash/c a b)
                    '((racket/contract:contract (hash/c) ())
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position b)))
  (test-obligations '(box/c a)
                    '((racket/contract:contract (box/c) ())
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position a)))
  (test-obligations '(box-immutable/c a)
                    '((racket/contract:contract (box-immutable/c) ())
                      (racket/contract:positive-position a)))
  (test-obligations '(vectorof a)
                    '((racket/contract:contract (vectorof) ())
                      (racket/contract:negative-position a)
                      (racket/contract:positive-position a)))
  (test-obligations '(vector-immutableof a)
                    '((racket/contract:contract (vector-immutableof) ())
                      (racket/contract:positive-position a)))
  (test-obligations '(vector/c a b c)
                    '((racket/contract:contract (vector/c) ())
                      (racket/contract:negative-position a)
                      (racket/contract:negative-position b)
                      (racket/contract:negative-position c)
                      (racket/contract:positive-position a)
                      (racket/contract:positive-position b)
                      (racket/contract:positive-position c)))
  (test-obligations '(vector-immutable/c a b c)
                    '((racket/contract:contract (vector-immutable/c) ())
                      (racket/contract:positive-position a)
                      (racket/contract:positive-position b)
                      (racket/contract:positive-position c)))
  (test-obligations '(or/c a b)
                    '((racket/contract:contract (or/c) ())
                      (racket/contract:positive-position a)
                      (racket/contract:positive-position b)))
  (test-obligations '(first-or/c a b)
                    '((racket/contract:contract (first-or/c) ())
                      (racket/contract:positive-position a)
                      (racket/contract:positive-position b))))
