; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

(define-test-suite interfaces-tests)

(define-test-case interface-ref interfaces-tests
  (let ((int (make-simple-interface 'names-only '(foo bar baz))))
    (receive (base-name type) (interface-ref int 'foo 0)
      (check base-name => 'foo))
    (receive (base-name type) (interface-ref int 'bar 0)
      (check base-name => 'bar))
    (receive (base-name type) (interface-ref int 'baz 0)
      (check base-name => 'baz))
    (receive (base-name type) (interface-ref int 'bla 0)
      (check base-name => #f))))

; for all-phase-0 interfaces only
; lis has pairs (name . base-name)
(define (check-interface-names int lis)
  (let ((actual '()))
    (for-each-declaration (lambda (name base-name phase type)
			    (set! actual (cons (cons name base-name) actual)))
			  int)
    (for-each (lambda (p)
		(let ((count 0))
		  (for-each-phase (lambda (base-name phase type)
				    (check phase => 0)
				    (set! count (+ 1 count)))
				  int
				  (car p))
		  (check count => 1)))
	      actual)
    (check-that actual
 		(is (cut lset= equal? <> <>)
		    lis))))

(define-test-case for-each-declaration interfaces-tests
  (check-interface-names (make-simple-interface 'names-only '(foo bar baz))
			 '((foo . foo)
			   (bar . bar)
			   (baz . baz))))

(define-test-case compound interfaces-tests
  (let ((int1 (make-simple-interface 'int1 '(foo bar)))
	(int2 (make-simple-interface 'int2 '(bla baz))))
    (check-interface-names (make-compound-interface 'int int1 int2)
			   '((foo . foo)
			     (bar . bar)
			     (baz . baz)
			     (bla . bla)))))

(define-test-case prefix interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((prefix foo:)))
			  (make-simple-interface 'int '(bla baz)))
			 '((foo:bla . bla)
			   (foo:baz . baz))))

(define-test-case prefix-prefix interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((prefix foo:) (prefix bar:)))
			  (make-simple-interface 'int '(bla baz)))
			 '((bar:foo:bla . bla)
			   (bar:foo:baz . baz))))

(define-test-case expose interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((expose bla)))
			  (make-simple-interface 'int '(bla baz)))
			 '((bla . bla))))

(define-test-case hide interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((hide bla)))
			  (make-simple-interface 'int '(bla baz)))
			 '((baz . baz))))

(define-test-case alias interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((alias (bla bam))))
			  (make-simple-interface 'int '(bla baz)))
			 '((bla . bla)
			   (bam . bla)
			   (baz . baz))))

(define-test-case rename interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((rename (bla bam))))
			  (make-simple-interface 'int '(bla baz)))
			 '((bam . bla)
			   (baz . baz))))

(define-test-case rename-rename interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((rename (bra bam)) (rename (bla bra))))
			  (make-simple-interface 'int '(bla baz)))
			 '((bam . bla)
			   (baz . baz))))

(define-test-case rename-prefix interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((rename (foo:bla bam)) (prefix foo:)))
			  (make-simple-interface 'int '(bla baz)))
			 '((bam . bla)
			   (foo:baz . baz))))

(define-test-case rename-alias interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((rename (bla bra)) (alias (bla bam))))
			  (make-simple-interface 'int '(bla baz)))
			 '((bam . bla)
			   (bra . bla)
			   (baz . baz))))

(define-test-case rename-hide interfaces-tests
  (check-interface-names ((make-modified-interface-maker '((rename (bla bra)) (hide baz)))
			  (make-simple-interface 'int '(bla baz)))
			 '((bra . bla))))


(define-test-case type interfaces-tests
  (let ((int (make-simple-interface 'int `(bla (baz ,:integer) ((foo bar) ,:string)))))
    (check-interface-names int '((bla . bla)
				 (baz . baz)
				 (foo . foo)
				 (bar . bar)))
    (receive (base-name type) (interface-ref int 'bla 0)
      (check type => undeclared-type))
    (receive (base-name type) (interface-ref int 'baz 0)
      (check type => :integer))
    (receive (base-name type) (interface-ref int 'foo 0)
      (check type => :string))
    (receive (base-name type) (interface-ref int 'bar 0)
      (check type => :string))))

(define (check-interface-names+phases int lis)
  (let ((actual '()))
    (for-each-declaration (lambda (name base-name phase type)
			    (set! actual (cons (list name base-name phase) actual)))
			  int)
    (for-each (lambda (lis)
		(apply (lambda (name base-name phase)
			 (let ((count 0))
			   (for-each-phase (lambda (a-base-name a-phase type)
					     (check a-base-name => base-name)
					     (set! count (+ 1 count)))
					   int
					   name)
			   (check (positive? count))
			   (receive (base-name type) (interface-ref int name phase)
			     (check base-name))))
		       lis))
	      actual)
    (check-that actual
 		(is (cut lset= equal? <> <>)
		    lis))))

(define-test-case phases interfaces-tests
  (check-interface-names+phases (make-simple-interface 'phases '(foo bar baz))
				'((foo foo 0)
				  (bar bar 0)
				  (baz baz 0)))
  (check-interface-names+phases (make-simple-interface 'phases '((foo 0) (bar 1) (baz 2)))
				'((foo foo 0)
				  (bar bar 1)
				  (baz baz 2)))
  (check-interface-names+phases (make-simple-interface 'phases '((foo 0) (bar 0) (bar 1) (baz 2)))
				'((foo foo 0)
				  (bar bar 0)
				  (bar bar 1)
				  (baz baz 2))))


(define-test-case compound/phases interfaces-tests
  (let ((int1 (make-simple-interface 'int1 '((foo 0) (bar 1))))
	(int2 (make-simple-interface 'int2 '((foo 1) (bla 0) (baz 2)))))
    (let ((int (make-compound-interface 'int int1 int2)))
      (check-interface-names+phases int
				    '((foo foo 0)
				      (foo foo 1)
				      (bar bar 1)
				      (baz baz 2)
				      (bla bla 0)))
      (let ((phases '()))
	(for-each-phase (lambda (base-name phase type)
			  (set! phases (cons phase phases)))
			int 'foo)
	(check-that phases (is (cut lset= equal? <> <>) '(0 1)))))))


(define-test-case prefix/phases interfaces-tests
  (check-interface-names+phases ((make-modified-interface-maker '((prefix foo:)))
				 (make-simple-interface 'int '((bla 0) (baz 1))))
				'((foo:bla bla 0)
				  (foo:baz baz 1))))

(define-test-case expose/phases interfaces-tests
  (check-interface-names+phases ((make-modified-interface-maker '((expose bla)))
				 (make-simple-interface 'int '((bla 1) (baz 0))))
				'((bla bla 1))))

(define-test-case hide/phases interfaces-tests
  (check-interface-names+phases ((make-modified-interface-maker '((hide bla)))
				 (make-simple-interface 'int '((bla 0) (baz 1))))
				'((baz baz 1))))

(define-test-case alias/phases interfaces-tests
  (check-interface-names+phases ((make-modified-interface-maker '((alias (bla bam))))
				 (make-simple-interface 'int '((bla 1) (baz 0))))
				'((bla bla 1)
				  (bam bla 1)
				  (baz baz 0))))


(define-test-case type/phases interfaces-tests
  (let ((int (make-simple-interface 'int `((bla 0) (baz 2 ,:integer) ((foo bar) 1 ,:string)))))
    (check-interface-names+phases int '((bla bla 0)
					(baz baz 2)
					(foo foo 1)
					(bar bar 1)))
    (receive (base-name type) (interface-ref int 'bla 0)
      (check type => undeclared-type))
    (receive (base-name type) (interface-ref int 'baz 2)
      (check type => :integer))
    (receive (base-name type) (interface-ref int 'foo 1)
      (check type => :string))
    (receive (base-name type) (interface-ref int 'bar 1)
      (check type => :string))))
