#|
  Original and corrected test suite for SRFI 53 Reference Implementation, 
  transcribed to work with SchemeUnit.

  http://srfi.schemers.org/srfi-53/srfi-53.html

  Note that the original reference implementation and test suite have 
  bugs which are purposely not fixed here.  See notes below for details.

  To run the tests:

     (require (planet "tests/srfi-53-tests.ss" ("dvanhorn" "srfi-53.plt" 1 0))
              (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 8)))

     (test/text-ui srfi-53-tests-original)
     (test/text-ui srfi-53-tests-corrected)
|#

(module srfi-53-tests mzscheme
  
  (provide srfi-53-tests-original
           srfi-53-tests-corrected)
  
  (require "../srfi-53.ss")
  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8)))
  
  ;; Auxillary definitions needed in test cases.
  ;; ===========================================
  
  (define-syntax-computation test1
    (computation-rules ()
      ((test1 exp var)
       (syntax-do (new-var <- (syntax-return var))
                  (syntax-return    
                   (let ((new-var 1)) exp))))))
  
  (define-syntax-computation test2
    (computation-rules ()
      ((test2 var)
       (syntax-do (body <- (syntax-return (cons var var)))
                  (syntax-return    
                   (let ((var 1)) body))))))
  
  (define-syntax-computation test3
    (computation-rules ()
      ((test3 a) ((computation-rules ()
                    ((_ x) (syntax-return '(x a))))
                  1))))
  
  (define-syntax-computation all-true?
    (computation-rules ()
      ((all-true? ls)
       (syntax-let/cc break
                      (syntax-foldl (computation-rules ()
                                      ((_ #f seed) (syntax-invoke/c break
                                                                    (syntax-return #f)))
                                      ((_ #t seed) (syntax-return #t)))
                                    #t
                                    ls)))))
  
  (define-syntax-computation first1 
    (computation-rules ()
      ((first1 (h . t)) (syntax-return h))
      ((first1 other)   (syntax-do (quit <- (syntax-root/c))
                                   (syntax-invoke/c quit
                                                    (syntax-return "First of non-pair"))))))
  
  (define-syntax-computation first2
    (computation-rules ()
      ((first2 (h . t)) (syntax-return h))
      ((first2 other)   (syntax-error "First of non-pair " other))))
  
  
  ;; Test Suites.
  ;; ============ 
  
  (define (make-srfi-53-tests-original)
    (apply 
     test-suite
     "Original tests for srfi-53."
     
     ;; NOTE: This is a buggy test.  The SRFI does not specifies a different behavior, but it is included
     ;; in the original test cases and the reference implementation passes this test, which is itself a bug.
     
     ;; The proper expected value should be 'x.
     (test-equal? "Notice the scopings here - syntax-do can be flattened without changing the semantics:"
                  (syntax-inspect (syntax-if (syntax-do (x <- (syntax-return #t))
                                                        (syntax-return x))
                                             (syntax-return x)
                                             (syntax-return 2)))
                  #t)
     
     ;; NOTE: This is a buggy test.  The SRFI specifies a different behavior.  The reference implementation
     ;; fails this test by returning 2, however, this is a bug as well.
     
     ;; The proper expected value should be 'y.
     (test-equal? "Notice the scopings here - syntax-do can be flattened without changing the semantics:"
                  (syntax-inspect (syntax-do (x <- (syntax-do (y <- (syntax-return 1))
                                                              (syntax-return 2)))
                                             (syntax-return y)))          
                  1)
     
     ;; NOTE: This is a buggy test.  The SRFI specifies a different behavior.  The reference implementation
     ;; passes this test, which is itself a bug.
     
     ;; The proper expected value should be 'x.
     (test-equal? "Notice the scopings here - syntax-do can be flattened without changing the semantics:"
                  (syntax-inspect (syntax-if (syntax-do (x <- (syntax-return #t))
                                                        (syntax-return x))
                                             (syntax-return x)
                                             (syntax-return 2)))   
                  #t)
     
     srfi-53-common-cases))
  
  (define (make-srfi-53-tests-corrected)
    (apply 
     test-suite
     "Corrected tests for srfi-53."
     
     (test-equal? "CORRECTED: scope of do bound variable is only the body of the do form."
                  (syntax-inspect (syntax-if (syntax-do (x <- (syntax-return #t))
                                                        (syntax-return x))
                                             (syntax-return x)
                                             (syntax-return 2)))
                  'x)
     
     (test-equal? "CORRECTED: scope of do bound variable is only the body of the do form."
                  (syntax-inspect (syntax-do (x <- (syntax-do (y <- (syntax-return 1))
                                                              (syntax-return 2)))
                                             (syntax-return y)))          
                  'y)
     
     (test-equal? "CORRECTED: scope of do bound variable is only the body of the do form."
                  (syntax-inspect (syntax-if (syntax-do (x <- (syntax-return #t))
                                                        (syntax-return x))
                                             (syntax-return x)
                                             (syntax-return 2)))   
                  'x)
     
     srfi-53-common-cases))
  
  
  (define srfi-53-common-cases
    (list
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-run (syntax-do (x <- (syntax-return 1))
                                         (syntax-return x)))
                  1)
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-run (syntax-do (x <- (syntax-return 1))
                                         (syntax-do (x <- (syntax-return 2))
                                                    (syntax-return x))))
                  2)
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-run (syntax-do (x <- (syntax-return 1))
                                         (x <- (syntax-return 2))
                                         (syntax-return x)))
                  2)
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-run (syntax-do (x <- (syntax-return 1))
                                         (syntax-do (y <- (syntax-return x))
                                                    (syntax-return y))))
                  1)
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-run (syntax-do (x <- (syntax-return 1))
                                         (y <- (syntax-return x))
                                         (syntax-return y))) 
                  1)
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-inspect (syntax-do (x <- (syntax-return 1))
                                             (y <- (syntax-return 2))
                                             (syntax-return (x y))))
                  '(1 2))
     
     (test-equal? "Test proper shadowing, etc. in syntax-do. " 
                  (syntax-run (syntax-do (x <- (syntax-return 1))
                                         (syntax-do (y <- (syntax-return 2))
                                                    (syntax-return x))))
                  1)
     
     (test-equal? "Test correct binding of colored identifiers."
                  (syntax-run (test1 x x))
                  1)
     
     (test-equal? "Test correct binding of colored identifiers."
                  (syntax-run (test2 x))    
                  '(1 . 1))
     
     (test-equal? "Another test of hygiene, here with an anonymous computation. The inner x should not capture the outer x:"
                  (syntax-run (test3 x))
                  '(1 x))
     
     
     (test-equal? "A simple use of an anonymous computation"
                  (syntax-inspect ((computation-rules ()
                                     ((_ x) (syntax-return (x x))))
                                   1))
                  '(1 1))
     
     (test-equal? "Anonymous computations - note the scoping here - this tests whether the argument is a symbol"
                  (syntax-inspect
                   ((computation-rules ()
                      ((_ x) ((computation-rules ()
                                ((_ x) (syntax-return #t))
                                ((_ y) (syntax-return #f)))
                              foo)))
                    symbol))
                  #t)
     
     (test-equal? "Computation-rules does introduce a new color scope"  
                  (syntax-inspect ((computation-rules ()
                                     ((_ a) (syntax-do (x <- (syntax-return 1))
                                                       (syntax-return (x a)))))
                                   x))
                  '(1 x))
     
     (test-equal? "Simple test of let-syntax-computation:"
                  (syntax-run
                   (let-syntax-computation
                    ((atom?
                      (computation-rules ()
                        ((atom? (x . y))        (syntax-return #f))
                        ;      ((atom? #(x (... ...))) (syntax-return #f))    ; non-standard
                        ((atom? x)              (syntax-return #t)))))
                    (atom? (x y))))
                  #f)
     
     (test-equal? "Simple test of syntax-atom?:"
                  (syntax-run (syntax-atom? x)) 
                  #t)
     
     (test-equal? "Simple test of syntax-atom?:"
                  (syntax-run (syntax-atom? (1 . 2))) 
                  #f)
     
     (test-equal? "Simple tests of list primitives"
                  (syntax-run (syntax-append (list 1 2) (4 5 7)))
                  '(1 2 4 5 7))
     
     (test-equal? "Simple tests of list primitives"
                  (syntax-run (syntax-reverse (1 2 3 5 list))) 
                  '(5 3 2 1))
     
     (test-equal? "syntax-eq?"
                  (syntax-run (syntax-eq? x x))              
                  #t)
     
     (test-equal? "syntax-eq?"
                  (syntax-run (syntax-eq? x y))              
                  #f)
     
     (test-equal? "syntax-eq?"
                  (syntax-run (syntax-eq? x 1))              
                  #f)
     
     (test-equal? "syntax-eq?"
                  (syntax-run (syntax-eq? #t x))             
                  #f)
     
     (test-equal? "syntax-eq?"
                  (syntax-run (syntax-eq? #t #t))            
                  #t)
     
     (test-equal? "syntax-eq?"
                  (syntax-run (syntax-eq? (x . y) (x . y)))  
                  #f)
     
     (test-equal? "conditionals"
                  (syntax-run (syntax-if (syntax-return #f)
                                         (syntax-return 1)
                                         (syntax-return 2)))  
                  2)
     
     (test-equal? "conditionals"
                  (syntax-run (syntax-if (syntax-eq? x x)
                                         (syntax-return 1)
                                         (syntax-return 2))) 
                  1)
     
     (test-equal? "conditionals"
                  (syntax-inspect (syntax-match* (a b c)
                                                 ((h . t) (syntax-return t))
                                                 (other   (syntax-error "Not a list"))))  
                  '(b c))
     
     ;; This test case is not easily transcribed into SchemeUnit.
     #;
     (test-equal? "Temporaries"
                  (syntax-inspect (syntax-temporaries (x y z))) 
                  '(temp~1 temp~2 temp~3))
     
     (test-equal? "Predicates"
                  (syntax-run (syntax-symbol? x))    
                  #t)
     
     (test-equal? "Predicates"
                  (syntax-run (syntax-symbol? 1))     
                  #f)
     
     (test-equal? "Predicates"
                  (syntax-run (syntax-symbol? (x y)))
                  #f)
     
     (test-equal? "Predicates"
                  (syntax-run (syntax-atom? 1))       
                  #t)
     
     (test-equal? "Predicates"
                  (syntax-run (syntax-atom? (1 . 2))) 
                  #f)
     
     (test-equal? "Using first-order computations"
                  (syntax-inspect (syntax-map syntax-atom? (x y (z u) v)))
                  '(#t #t #f #t))
     
     (test-equal? "Using first-order computations"
                  (syntax-inspect (syntax-map syntax-reverse ((1 2) (3 4))))
                  '((2 1) (4 3)))
     
     (test-equal? "Using first-order computations"
                  (syntax-inspect (syntax-map 
                                   (computation-rules ()
                                     ((_ x) (syntax-return (x x))))
                                   (1 2 3))) 
                  '((1 1) (2 2) (3 3)))
     
     (test-equal? "Using first-order computations"
                  (syntax-inspect (syntax-map syntax-reverse
                                              ((1 2) (3 4))))   
                  '((2 1) (4 3)))
     
     (test-equal? "Using first-order computations"
                  (syntax-inspect (syntax-foldl syntax-append
                                                ()
                                                ((1 2) (3 4)))) 
                  '(3 4 1 2))
     
     (test-equal? "Using first-order computations"
                  (syntax-inspect (syntax-foldr syntax-append
                                                ()
                                                ((1 2) (3 4)))) 
                  '(1 2 3 4))
     
     (test-equal? "Capturing and invoking continuations to break loop"
                  (syntax-run (all-true? (#t #f #t #t)))
                  #f)
     
     (test-equal? "Using root-continuation to escape altogether"
                  (syntax-inspect (syntax-map first1 ((a b) (c d))))
                  '(a c))
     
     (test-equal? "Using root-continuation to escape altogether"   
                  (syntax-inspect (syntax-map first1 (a (b c))))
                  "First of non-pair")
     
     (test-equal? "Using syntax-error"
                  (syntax-inspect (syntax-map first2 ((a b) (c d))))  
                  '(a c))
     
     ;; This test case is not easily transcribed into SchemeUnit.
     #;
     (test-equal? "Using syntax-error"
                  (syntax-inspect (syntax-map first (a (b c))))
                  error: bad syntax in: (error "First of non-pair " a))
     
     )) ; end of common cases
  
  (define srfi-53-tests-original (make-srfi-53-tests-original))
  (define srfi-53-tests-corrected (make-srfi-53-tests-corrected))
  
  ) ; end of module srfi-53-tests