(module tl-test scheme
  (require "../reduction-semantics.ss"
           "test-util.ss"
           (only-in "../private/matcher.ss" make-bindings make-bind)
           scheme/match
           "../private/struct.ss")
  
  (reset-count)
  
  
;                                                          
;                                                          
;    ;;                                                    
;     ;                                                    
;     ;     ;;;  ;; ;;    ;; ;;;;  ;;   ;;;    ;; ;;  ;;;  
;     ;    ;   ;  ;;  ;  ;  ;;  ;   ;  ;   ;  ;  ;;  ;   ; 
;     ;     ;;;;  ;   ;  ;   ;  ;   ;   ;;;;  ;   ;  ;;;;; 
;     ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;     
;     ;    ;   ;  ;   ;  ;   ;  ;  ;;  ;   ;  ;   ;  ;     
;   ;;;;;   ;;;;;;;; ;;;  ;;;;   ;; ;;  ;;;;;  ;;;;   ;;;; 
;                            ;                    ;        
;                         ;;;                  ;;;         
;                                                          
;                                                          

  
  (define-language empty-language)
  
  (define-language grammar
    (M (M M)
       number)
    (E hole
       (E M)
       (number E))
    (X (number any)
       (any number))
    (Q (Q ...)
       variable)
    (UN (add1 UN)
        zero))
  
  (test (pair? (redex-match grammar M '(1 1))) #t)
  (test (pair? (redex-match grammar M '(1 1 1))) #f)
  (test (pair? (redex-match grammar
                            (side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
                            '(1 1)))
        #t)
  (test (pair? (redex-match grammar
                           (side-condition (M_1 M_2) (equal? (term M_1) (term M_2))) 
                           '(1 2)))
        #f)
  
  (test (pair? ((redex-match grammar M) '(1 1)))
        #t)

  ;; next 3: test naming of subscript-less non-terminals
  (test (pair? (redex-match grammar (M M) (term (1 1)))) #t)
  (test (pair? (redex-match grammar (M M) (term (1 2)))) #f)
  (test (pair? (redex-match grammar (M_1 M_2) (term (1 2)))) #t)
  
  (define-language base-grammar
    (q 1)
    (e (+ e e) number)
    (x (variable-except +)))
  
  (define-extended-language extended-grammar
    base-grammar 
    (e .... (* e e))
    (x (variable-except + *))
    (r 2))
  
  (test (pair? (redex-match extended-grammar e '(+ 1 1))) #t)
  (test (pair? (redex-match extended-grammar e '(* 2 2))) #t)
  (test (pair? (redex-match extended-grammar r '2)) #t)
  (test (pair? (redex-match extended-grammar q '1)) #t)
  (test (pair? (redex-match extended-grammar x '*)) #f)
  (test (pair? (redex-match extended-grammar x '+)) #f)
  (test (pair? (redex-match extended-grammar e '....)) #f)
  
  ;; make sure that `language' with a four period ellipses signals an error
  (test (regexp-match #rx"[.][.][.][.]" (with-handlers ([exn? exn-message]) 
                                          (let ()
                                            (define-language x (e ....))
                                            12)))
        '("...."))
  

  
  ;; test multiple variable non-terminals
  (let ()
    (define-language lang
      ((l m) (l m) x)
      (x variable-not-otherwise-mentioned))
    (test (pair? (redex-match lang m (term x)))
          #t))
  
  ;; test multiple variable non-terminals
  (let ()
    (define-language lang
      ((l m) (l m) x)
      (x variable-not-otherwise-mentioned))
    (test (pair? (redex-match lang l (term x)))
          #t))
  
  (let ()
    (define-language lang
      ((x y) 1 2 3))
    (define-extended-language lang2 lang
      (x .... 4))
    (test (pair? (redex-match lang2 x 4)) #t)
    (test (pair? (redex-match lang2 y 4)) #t)
    (test (pair? (redex-match lang2 x 1)) #t)
    (test (pair? (redex-match lang2 y 2)) #t))
  
  ;; test that the variable "e" is not bound in the right-hand side of a side-condition
  ;; this one signaled an error at some point
  (let ()
    (define-language bad
      (e 2 (side-condition (e) #t)))
    (test (pair? (redex-match bad e '(2)))
          #t))

  ;; test that the variable "e" is not bound in the right-hand side of a side-condition
  ;; this one tests to make sure it really isn't bound
  (let ([x #f])
    (define-language bad
      (e 2 (side-condition (e) (set! x (term e)))))
    (redex-match bad e '(2))
    (test x 'e))
  
  ;; test multiple variable non-terminals being extended
  (let ()
    (define-language lang
      ((x y) 1 2 3))
    (define-extended-language lang2 lang
      (x .... 4))
    (test (pair? (redex-match lang2 x 4)) #t)
    (test (pair? (redex-match lang2 y 4)) #t)
    (test (pair? (redex-match lang2 x 1)) #t)
    (test (pair? (redex-match lang2 y 2)) #t))
  
  ;; test multiple variable non-terminals in an extended language
  (let ()
    (define-language lang
      ((x y) 1 2 3))
    (define-extended-language lang2 lang
      ((z w) 5 6 7))
    (test (pair? (redex-match lang2 z 5)) #t)
    (test (pair? (redex-match lang2 w 6)) #t))
  
  ;; test cases that ensure that extending any one of a
  ;; multiply defined non-terminal gets extended properly
  (let ()
    (define-language iswim
      ((V U W) AA))

    (define-extended-language iswim-cont
      iswim
      (W .... QQ))

    (test (pair? (redex-match iswim-cont U (term QQ)))
          #t))
  
  (let ()
    (define-language iswim
      ((V U W) AA))

    (define-extended-language iswim-cont
      iswim
      (W .... QQ))

    (test (pair? (redex-match iswim-cont V (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont U (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont W (term QQ)))
          #t))
  
  (let ()
    (define-language iswim
      ((V U W) AA))
    
    (define-extended-language iswim-cont
      iswim
      (V .... QQ))
    
    (test (pair? (redex-match iswim-cont V (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont U (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont W (term QQ)))
          #t))
  
  (let ()
    (define-language okay
      [(X Y) z])
    
    (define-extended-language replace-both
      okay
      [(X Y) q])
    
    ;; this test ran into an infinite loop in an earlier version of redex.
    (test (redex-match replace-both X (term explode)) #f))
  
  (test (with-handlers ([exn? exn-message])
          (let () 
            (define-language main
              [(X Y) z])
            (define-extended-language new
              main
              [(X Y Z) q])
            (void)))
        "extend-language: new language extends old non-terminal X and also adds new shortcut Z")
  
  (test (with-handlers ([exn? exn-message])
          (let () 
            (define-language main
              [(X Y) z]
              [(P Q) w])
            (define-extended-language new
              main
              [(X P) q])
            (void)))
        "extend-language: new language does not have the same non-terminal aliases as the old, non-terminal P was not in the same group as X in the old language")
  
  ;; test caching
  (let ()
    (define match? #t)
    
    (define-language lang
      (x (side-condition any match?)))
    
    (test (pair? (redex-match lang x 1)) #t)
    (set! match? #f)
    (test (pair? (redex-match lang x 1)) #t)
    (parameterize ([caching-enabled? #f])
      (test (pair? (redex-match lang x 1)) #f)))
  
  
  (let ()
    (define sc-eval-count 0)
    (define-language lang
      (x (side-condition any (begin (set! sc-eval-count (+ sc-eval-count 1))
                                    #t))))
    
    (redex-match lang x 1)
    (redex-match lang x 1)
    (parameterize ([caching-enabled? #f])
      (redex-match lang x 1))
    (test sc-eval-count 2))
  
  (let ()
    (define rhs-eval-count 0)
    (define-metafunction empty-language
      [(f any) ,(begin (set! rhs-eval-count (+ rhs-eval-count 1))
                       1)])
    
    (term (f 1))
    (term (f 1))
    (parameterize ([caching-enabled? #f])
      (term (f 1)))
    (test rhs-eval-count 2))
  
  (define-namespace-anchor here)
  (define ns (namespace-anchor->namespace here))
  
  (let ([src 'bad-underscore])
    (test 
     (parameterize ([current-namespace ns])
       (syntax-error-sources
        '(define-language L (n m_1))
        src))
     (list src)))
  
;                                                                                             
;                                                                                             
;                                 ;;;                                ;                        
;                  ;             ;                           ;                                
;  ;;; ;    ;;;   ;;;;;   ;;;   ;;;;; ;;  ;; ;; ;;    ;;;;  ;;;;;  ;;;     ;;;  ;; ;;    ;;;; 
;   ; ; ;  ;   ;   ;     ;   ;   ;     ;   ;  ;;  ;  ;   ;   ;       ;    ;   ;  ;;  ;  ;   ; 
;   ; ; ;  ;;;;;   ;      ;;;;   ;     ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;   ;;;  
;   ; ; ;  ;       ;     ;   ;   ;     ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;      ; 
;   ; ; ;  ;       ;   ; ;   ;   ;     ;  ;;  ;   ;  ;   ;   ;   ;   ;    ;   ;  ;   ;  ;   ; 
;  ;;;;;;;  ;;;;    ;;;   ;;;;; ;;;;;   ;; ;;;;; ;;;  ;;;     ;;;  ;;;;;   ;;;  ;;; ;;; ;;;;  
;                                                                                             
;                                                                                             
;                                                                                             
;                                                                                             

  
  (define-metafunction grammar
    [(f (side-condition (number_1 number_2)
                        (< (term number_1)
                           (term number_2))))
     x]
    [(f (number 1)) y]
    [(f (number_1 2)) ,(+ (term number_1) 2)]
    [(f (4 4)) q]
    [(f (4 4)) r])

  (define-metafunction grammar
    [(g X) x])
  
  (test (term (f (1 17))) 'x)
  (test (term (f (11 1))) 'y)
  (test (term (f (11 2))) 13)
  
  
  ;; match two clauess => take first one
  (test (term (f (4 4))) 'q)
  
  ;; match one clause two ways => error
  (let ()
    (define-metafunction empty-language
      [(ll (number_1 ... number_2 ...)) (number_1 ...)])
    (test (with-handlers ((exn? (λ (x) 'exn-raised))) 
            (term (ll ()))
            'no-exn)
          'no-exn)
    (test (with-handlers ((exn? (λ (x) 'exn-raised))) 
            (term (ll (4 4)))
            'no-exn)
          'exn-raised))
  
  ;; match no ways => error
  (test (with-handlers ((exn? (λ (x) 'exn-raised))) (term (f mis-match)) 'no-exn)
        'exn-raised)

  (define-metafunction grammar
    [(h (M_1 M_2)) ((h M_2) (h M_1))]
    [(h number_1) ,(+ (term number_1) 1)])
  
  (test (term (h ((1 2) 3)))
        (term (4 (3 2))))
  
  (define-metafunction grammar
    [(h2 (Q_1 ...)) ((h2 Q_1) ...)]
    [(h2 variable) z])
  
  (test (term (h2 ((x y) a b c)))
        (term ((z z) z z z)))
  
  (let ()
    (define-metafunction empty-language
      [(f (1)) 1]
      [(f (2)) 2]
      [(f 3) 3])
    (test (in-domain? (f 1)) #f)
    (test (in-domain? (f (1))) #t)
    (test (in-domain? (f ((1)))) #f)
    (test (in-domain? (f 3)) #t)
    (test (in-domain? (f 4)) #f))
  
  (let ()
    (define-metafunction empty-language
      f : number -> number
      [(f 1) 1])
    (test (in-domain? (f 1)) #t)
    (test (in-domain? (f 2)) #t)
    (test (in-domain? (f x)) #f))
  
  (let ()
    (define-metafunction empty-language
      [(f x) x])
    (test 
     (term-let ((y 'x))
               (in-domain? (f y)))
     #t)
    (test 
     (term-let ((y 'z))
               (in-domain? (f y)))
     #f))
  
  ;; mutually recursive metafunctions
  (define-metafunction grammar
    [(odd zero) #f]
    [(odd (add1 UN_1)) (even UN_1)])
  
  (define-metafunction grammar
    [(even zero) #t]
    [(even (add1 UN_1)) (odd UN_1)])
  
  (test (term (odd (add1 (add1 (add1 (add1 zero))))))
        (term #f))
    
  (let ()
    (define-metafunction empty-language
      [(pRe xxx) 1])
    
    (define-metafunction empty-language
      [(Merge-Exns any_1) any_1])
    
    (test (term (pRe (Merge-Exns xxx)))
          1))
  
  (let ()
    (define-metafunction empty-language
      [(f (x)) ,(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup)))]
      [(f y) y]
      [(f var-should-be-lookedup) var-should-be-lookedup]) ;; taking this case is bad!
    
    (test (term (f (x))) (term y)))
  
  (let ()
    (define-metafunction empty-language
      [(f (x)) (x ,@(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup))) x)]
      [(f y) (y)]
      [(f var-should-be-lookedup) (var-should-be-lookedup)]) ;; taking this case is bad!
    
    (test (term (f (x))) (term (x y x))))
  
  (let ()
    (define-metafunction empty-language
      [(f (any_1 any_2))
       case1
       (side-condition (not (equal? (term any_1) (term any_2))))
       (side-condition (not (equal? (term any_1) 'x)))]
      [(f (any_1 any_2))
       case2
       (side-condition (not (equal? (term any_1) (term any_2))))]
      [(f (any_1 any_2))
       case3])
    (test (term (f (q r))) (term case1))
    (test (term (f (x y))) (term case2))
    (test (term (f (x x))) (term case3)))

  (let ()
    (define-metafunction empty-language
      [(f (n number)) (n number)]
      [(f (a any)) (a any)]
      [(f (v variable)) (v variable)]
      [(f (s string)) (s string)])
    (test (term (f (n 1))) (term (n 1)))
    (test (term (f (a (#f "x" whatever)))) (term (a (#f "x" whatever))))
    (test (term (f (v x))) (term (v x)))
    (test (term (f (s "x"))) (term (s "x"))))
  
  ;; test ..._1 patterns
  (let ()
    (define-metafunction empty-language
      [(zip ((variable_id ..._1) (number_val ..._1)))
       ((variable_id number_val) ...)])
    
    (test (term (zip ((a b) (1 2)))) (term ((a 1) (b 2)))))
  
  (let ()
    (define-metafunction empty-language
      [(f any_1 any_2 any_3) (any_3 any_2 any_1)])
    (test (term (f 1 2 3)) 
          (term (3 2 1))))
  
  (let ()
    (define-metafunction empty-language
      [(f (any_1 any_2 any_3)) 3])
    (define-metafunction/extension f empty-language
      [(g (any_1 any_2)) 2])
    (define-metafunction/extension g empty-language
      [(h (any_1)) 1])
    (test (term (h (1))) 1)
    (test (term (h (1 2))) 2)
    (test (term (h (1 2 3))) 3))
  
  (let ()
    (define-metafunction empty-language
      [(f any_1 any_2 any_3) 3])
    (define-metafunction/extension f empty-language
      [(g any_1 any_2) 2])
    (define-metafunction/extension g empty-language
      [(h any_1) 1])
    (test (term (h 1)) 1)
    (test (term (h 1 2)) 2)
    (test (term (h 1 2 3)) 3))
  
  (let ()
    (define-metafunction empty-language
      [(f number_1 number_2) (f number_1)])
    (define-metafunction/extension f empty-language
      [(g number_1) number_1])
    (define-metafunction empty-language
      [(h number_1 number_2) (h number_1)]
      [(h number_1) number_1])
    (test (term (g 11 17)) 11)
    (test (term (h 11 17)) 11))
  
  (let ()
    (define-metafunction empty-language
      [(f (number_1 number_2))
       number_3
       (where number_3 ,(+ (term number_1) (term number_2)))])
    (test (term (f (11 17))) 28))
  
  (let ()
    (define-metafunction empty-language
      [(f variable) 
       (any_x any_x)
       (where any_x (variable variable))])
    (test (term (f z)) 
          (term ((z z) (z z)))))
  
  (let ()
    (define-metafunction empty-language
      [(f number_1)
       number_1
       (where number_2 ,(add1 (term number_1)))
       (where number_3 ,(add1 (term number_2)))
       (side-condition (and (number? (term number_3))
                            (= (term number_3) 4)))]
      [(f any) 0])
    (test (term (f 2)) 2))
  
  (let ()
    (define-language x-lang
      (x variable))
    (define-metafunction x-lang
      f : x x -> x
      [(f x_1 x_2) x_1])
    (test (term (f p q)) (term p))
    (test (in-domain? (f p q)) #t))
  
  (let ()
    (define-metafunction empty-language
      [(err number_1 ... number_2 ...) (number_1 ...)])
    (test (term (err)) (term ()))
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 2))
            'no-exn)
          'right-exn))
  
  (let ()
    (define-metafunction empty-language
      err : number ... -> number
      [(err number ...) 1])
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err #f #t))
            'no-exn)
          'right-exn))
  
  (let ()
    (define-metafunction empty-language
      err : number ... -> number
      [(err number ...) #f])
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 2))
            'no-exn)
          'right-exn))
  
  (let ()
    (define-metafunction empty-language
      err : number ... -> (number number)
      [(err number ...) (number ...)])
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 2))
            'no-exn)
          'no-exn)
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 1))
            'no-exn)
          'no-exn))
    
  (let ()
    ;; test that 'where' clauses can contain recursive calls.
    (define-metafunction empty-language
      [(f (any)) 
       x
       (where x (f any))]
      [(f any) any])
    (test (term (f ((((x))))))
          (term x)))
  
  (let ()
    (define-language lamv
      (z variable hole))

    (define-metafunction lamv
      foo : z  -> any
      [(foo hole) dontcare]
      [(foo variable) docare])

    (test (term (foo hole))
          (term dontcare))
    (test (term (foo y))
          (term docare)))
  
  (let ()
    (define f-called? #f)
    (define-metafunction empty-language
      f : (side-condition any_1 (begin (set! f-called? #t) #t)) -> any
      [(f any_1) any_1])
    (test (term (f 1)) 1)
    (test f-called? #t))
    
  (let ()
    (define g-called? #f)
    (define-metafunction empty-language
      g : any -> (side-condition any_1 (begin (set! g-called? #t) #t))
      [(g any_1) any_1])
    (test (term (g 1)) 1)
    (test g-called? #t))
  
  ;; test that tracing works properly
  ;; note that caching comes into play here (which is why we don't see the recursive calls)
  (let ()
    (define-metafunction empty-language
      [(f 0) 0]
      [(f number) (f ,(- (term number) 1))])
    
    (let ([sp (open-output-string)])
      (parameterize ([current-output-port sp])
        (term (f 1)))
      (test (get-output-string sp) ""))
    
    (let ([sp (open-output-string)])
      (parameterize ([current-output-port sp]
                     [current-traced-metafunctions 'all])
        (term (f 1)))
      (test (get-output-string sp) ">(f 1)\n<0\n"))
    
    (let ([sp (open-output-string)])
      (parameterize ([current-output-port sp]
                     [current-traced-metafunctions '(f)])
        (term (f 1)))
      (test (get-output-string sp) ">(f 1)\n<0\n")))
  
  (let ()
    (define-language var-lang [(x y z w) variable])
    
    ;; this should produce the second case, 
    ;; since the where clause (should) fail to match 
    ;; in the first case.
    (define-metafunction var-lang
      [(f x)
       first-case
       (where (AnotherAtom y) (Atom x))]
      [(f x)
       second-case])
    
    (test (term (f a)) (term second-case)))
  
  (let ()
    
    ;; this is an ambiguous function 
    ;; and should signal an error if it is ever called
    ;; with multiple different arguments, but if the
    ;; arguments are all the same, it will return
    ;; the same result for any parse, and thus should be allowed.
    (define-metafunction empty-language
      [(f any_x ... any_y any_z ...)
       any_y])
    
    (test (term (f 1 1 1 1 1)) (term 1)))
  
  (let ()
    (define-metafunction empty-language
      [(ex variable_x) 
       variable_x
       (where quote variable_x)])
    
    (test (term (ex quote)) (term quote)))
  
  (let ()
    (define-metafunction empty-language
      [(f any ...)
       (any ...)
       (where variable_1 x)
       (side-condition #f)
       (where (number ...) y)]
      [(f any ...)
       12345])
    
    (test (term (f 8)) 12345))
  
  
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;       ;;           ;;; ;;                                   ;;           ;;  ;;                 
;       ;;          ;;;  ;;                                   ;;          ;;;  ;;                 
;    ;;;;;   ;;;;  ;;;;; ;;  ;; ;;;   ;;;;       ;;;;  ;;;;   ;;   ;;;;  ;;;;; ;;   ;;;;   ;; ;;; 
;   ;;;;;;  ;;  ;; ;;;;  ;;  ;;;;;;  ;;  ;;      ;;;; ;;  ;;  ;;  ;;  ;;  ;;;; ;;  ;;;;;;  ;;;;;; 
;  ;;;  ;; ;;;;;;;; ;;   ;;  ;;  ;; ;;;;;;;;;;;; ;;  ;;;;;;;; ;;    ;;;;  ;;;  ;; ;;;  ;;; ;;  ;; 
;  ;;;  ;; ;;;      ;;   ;;  ;;  ;; ;;;     ;;;; ;;  ;;;      ;;  ;;; ;;  ;;;  ;; ;;;  ;;; ;;  ;; 
;   ;;;;;;  ;;; ;;  ;;   ;;  ;;  ;;  ;;; ;;      ;;   ;;; ;;  ;; ;;;  ;;  ;;;; ;;  ;;;;;;  ;;  ;; 
;    ;;;;;   ;;;;   ;;   ;;  ;;  ;;   ;;;;       ;;    ;;;;   ;;  ;;;;;;   ;;; ;;   ;;;;   ;;  ;; 
;                                                                                                 
;                                                                                                 
;                                                                                                 

  
  (let ()
    (define-relation empty-language
      [(<: any any) #t])
    
    (test (term (<: 1 1)) #t)
    (test (term (<: 1 2)) #f))
  
  (let ()
    (define-relation empty-language
      [(<: number_1 number_2) ,(< (term number_1) (term number_2))]
      [(<: number_1 number_1) #t])
    
    (test (term (<: 1 2)) #t)
    (test (term (<: 1 1)) #t)
    (test (term (<: 2 1)) #f))
  
  (let ()
    (define-relation empty-language
      [(<: number_1 ... number_2 number_3 ... number_2 number_4 ...) #t])
    
    (test (term (<: 1 2 3 4)) #f)
    (test (term (<: 1 1 2 3 4)) #t)
    (test (term (<: 1 2 1 3 4)) #t)
    (test (term (<: 1 2 3 1 4)) #t)
    (test (term (<: 1 2 3 4 1)) #t))
  
  (let ()
    (define-relation empty-language
      [(<: number_1 number_1)])
    (test (term (<: 1 1)) #t)
    (test (term (<: 1 2)) #f))
  
  (let ()
    (define-relation empty-language
      [(<: number_1 number_2 number_3)
       ,(= (term number_1) (term number_2))
       ,(= (term number_2) (term number_3))])
    (test (term (<: 1 2 3)) #f)
    (test (term (<: 1 1 2)) #f)
    (test (term (<: 1 2 2)) #f)
    (test (term (<: 1 1 1)) #t))
  
 
;                    ;;                         ;                                        ;;                    ;                 
;                     ;                 ;                                                 ;            ;                         
;   ;; ;;   ;;;    ;; ; ;;  ;;   ;;;;  ;;;;;  ;;;     ;;;  ;; ;;          ;; ;;   ;;;     ;     ;;;   ;;;;;  ;;;     ;;;  ;; ;;  
;    ;;    ;   ;  ;  ;;  ;   ;  ;   ;   ;       ;    ;   ;  ;;  ;          ;;    ;   ;    ;    ;   ;   ;       ;    ;   ;  ;;  ; 
;    ;     ;;;;;  ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;  ;;;;;   ;     ;;;;;    ;     ;;;;   ;       ;    ;   ;  ;   ; 
;    ;     ;      ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;          ;     ;        ;    ;   ;   ;       ;    ;   ;  ;   ; 
;    ;     ;      ;   ;  ;  ;;  ;   ;   ;   ;   ;    ;   ;  ;   ;          ;     ;        ;    ;   ;   ;   ;   ;    ;   ;  ;   ; 
;   ;;;;;   ;;;;   ;;;;;  ;; ;;  ;;;     ;;;  ;;;;;   ;;;  ;;; ;;;        ;;;;;   ;;;;  ;;;;;   ;;;;;   ;;;  ;;;;;   ;;;  ;;; ;;;
;                                                                                                                                
;                                                                                                                                
;                                                                                                                                
;                                                                                                                                

  
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (--> (in-hole E_1 (number_1 number_2))
               (in-hole E_1 ,(* (term number_1) (term number_2)))))
         '((2 3) (4 5)))
        (list '(6 (4 5))))

  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (~~> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (in-hole E_1 a) (in-hole E_1 b)) (~~> a b)])
         '((2 3) (4 5)))
        (list '(6 (4 5))))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (==> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (M_1 a) (M_1 b)) (~~> a b)]
          [(~~> (M_1 a) (M_1 b)) (==> a b)])
         '((1 2) ((2 3) (4 5))))
        (list '((1 2) ((2 3) 20))))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (~~> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          (==> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (M_1 a) (M_1 b)) (~~> a b)]
          [(--> (a M_1) (b M_1)) (==> a b)])
         '((2 3) (4 5)))
        (list '(6 (4 5))
              '((2 3) 20)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (--> (M_1 (number_1 number_2))
               (M_1 ,(* (term number_1) (term number_2))))
          (==> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (a M_1) (b M_1)) (==> a b)])
         '((2 3) (4 5)))
        (list '((2 3) 20)
              '(6 (4 5))))
  
  ; shortcuts like this fail if compilation fails to preserve
  ; lexical context for side-conditions expressions.
  (test (let ([x #t])
          (apply-reduction-relation
           (reduction-relation
            grammar
            (==> variable variable)
            with
            [(--> (a (side-condition number x)) b)
             (==> a b)])
           '(x 4)))
        '(x))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (--> (number_1 number_2) 
               ,(* (term number_1) (term number_2))
               mul))
         '(4 5))
        (list (list "mul" 20)))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (--> (number_1 number_2) 
               ,(* (term number_1) (term number_2))
               "mul"))
         '(4 5))
        (list (list "mul" 20)))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (--> (number_1 number_2) 
               ,(* (term number_1) (term number_2))))
         '(4 5))
        (list (list #f 20)))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (==> (number_1 number_2) 
               ,(* (term number_1) (term number_2))
               mult)
          with
          [(--> (M_1 a) (M_1 b)) (==> a b)])
         '((2 3) (4 5)))
        (list (list "mult" '((2 3) 20))))
  
  (test (apply-reduction-relation
         (union-reduction-relations
          (reduction-relation empty-language
                              (--> x a)
                              (--> x b))
          (reduction-relation empty-language
                              (--> x c)
                              (--> x d)))
         'x)
        (list 'a 'b 'c 'd))
  
  (test (apply-reduction-relation
         (union-reduction-relations
          (reduction-relation empty-language (--> x a))
          (reduction-relation empty-language (--> x b))
          (reduction-relation empty-language (--> x c))
          (reduction-relation empty-language (--> x d)))
         'x)
        (list 'a 'b 'c 'd))
  
  (test (apply-reduction-relation
         (reduction-relation 
          empty-language
          (--> (number_1 number_2) 
               number_2
               (side-condition (< (term number_1) (term number_2))))
          (--> (number_1 number_2) 
               number_1
               (side-condition (< (term number_2) (term number_1)))))
         '(1 2))
        (list 2))
  
  (test (apply-reduction-relation
         (reduction-relation 
          empty-language
          (--> x #f))
         (term x))
        (list #f))
  
  (define-language x-language
    (x variable))
  
  (test (apply-reduction-relation
         (reduction-relation 
          x-language
          (--> x (x x)))
         'y)
        (list '(y y)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          x-language
          (--> (x ...) ((x ...))))
         '(p q r))
        (list '((p q r))))

  #;
  (test (apply-reduction-relation
         (reduction-relation 
          empty-language
          #:main-arrow :->
          (:-> 1 2))
         1)
        '(2))
  
  (test (apply-reduction-relation
         (reduction-relation 
          empty-language
          #:domain number
          (--> 1 2))
         1)
        '(2))
  
  
  (test (let ([red
               (reduction-relation 
                empty-language
                #:domain number
                (--> 1 2))])
          (with-handlers ((exn? exn-message))
            (apply-reduction-relation red 'x)
            'no-exception-raised))
        "reduction-relation: relation not defined for x")

  (test (let ([red
               (reduction-relation 
                empty-language
                #:domain number
                (--> 1 x))])
          (with-handlers ((exn? exn-message))
            (apply-reduction-relation red 1)
            'no-exception-raised))
        "reduction-relation: relation reduced to x via rule #0 (counting from 0), which is outside its domain")

  (let* ([red1
          (reduction-relation 
           empty-language
           #:domain (side-condition number_1 (even? (term number_1)))
           (--> number number))]
         [red2
          (reduction-relation 
           empty-language
           #:domain (side-condition number_1 (odd? (term number_1)))
           (--> number number))]
         [red-c
          (union-reduction-relations red1 red2)])
    
    ;; ensure first branch of 'union' is checked  
    (test (with-handlers ((exn? exn-message))
            (apply-reduction-relation red-c 1)
            'no-exception-raised)
          "reduction-relation: relation not defined for 1")

    ;; ensure second branch of 'union' is checked
    (test (with-handlers ((exn? exn-message))
            (apply-reduction-relation red-c 2)
            'no-exception-raised)
          "reduction-relation: relation not defined for 2"))

  (let ()
    (define-language l1
      (D 0 1 2))
    (define r1
      (reduction-relation 
       l1
       #:domain D
       (--> D D)))
    (define-language l2
      (D 0 1 2 3))
    (define r2
      (extend-reduction-relation r1 l2))
    
    ;; test that the domain is re-interpreted for the extended reduction-relation
    (test (apply-reduction-relation r2 3)
          '(3)))
  
  (let ()
    (define-language l1
      (D 0 1 2))
    (define r1
      (reduction-relation 
       l1
       #:domain (D D)
       (--> (D_1 D_2) (D_2 D_1))))
    
    ;; test that duplicated identifiers in the domain contract do not have to be equal
    (test (apply-reduction-relation r1 (term (1 2)))
          (list (term (2 1)))))
  
  ;;test that #:arrow keyword works
  (test (apply-reduction-relation 
         (reduction-relation 
          empty-language
          #:arrow :->
          (:-> 1 2))
         1)
        '(2))

  (let ()
    (define-language n-lang
      [n number])
    (test (apply-reduction-relation
           (reduction-relation n-lang [--> any ,(length (redex-match n-lang n 1))])
           11)
          '(1)))
  
  (parameterize ([current-namespace syn-err-test-namespace])
    (eval (quote-syntax
           (define-language grammar
             (M (M M)
                number)
             (E hole
                (E M)
                (number E))
             (X (number any)
                (any number))
             (Q (Q ...)
                variable)
             (UN (add1 UN)
                 zero)))))
  
  (test-syn-err (reduction-relation 
                 grammar
                 (~~> (number_1 number_2)
                      ,(* (term number_1) (term number_2)))
                 with
                 [(--> (M a) (M b)) (~~> a b)]
                 [(~~> (M a) (M b)) (==> a b)])
                #rx"no rules")
  
  (test-syn-err (reduction-relation grammar)
                #rx"no rules use -->")
  
  (test-syn-err (reduction-relation 
                 grammar
                 (~~> (number_1 number_2)
                      ,(* (term number_1) (term number_2))))
                #rx"~~> relation is not defined")
  
  (test-syn-err (reduction-relation 
                 grammar
                 (--> (number_1 number_2) 
                      ,(* (term number_1) (term number_2))
                      mult)
                 (--> (number_1 number_2) 
                      ,(* (term number_1) (term number_2))
                      mult))
                #rx"same name on multiple rules")
  
  (test-syn-err (reduction-relation 
                 grammar
                 (--> 1 2)
                 (==> 3 4))
                #rx"not defined.*==>")
  
  (test-syn-err  (reduction-relation 
                  empty-language
                  (--> 1 2)
                  (==> 3 4)
                  with
                  [(~> a b) (==> a b)])
                 #rx"not defined.*~>")
  
  (test-syn-err (define-language bad-lang1 (e name)) #rx"name")
  (test-syn-err (define-language bad-lang2 (name x)) #rx"name")
  (test-syn-err (define-language bad-lang3 (x_y x)) #rx"x_y")
  (test-syn-err (define-language bad-lang4 (a 1 2) (b)) #rx"no productions")
  (test-syn-err (let ()
                  (define-language good-lang (a 1 2))
                  (define-extended-language bad-lang5 good-lang (a) (b 2)))
                #rx"no productions")
  
  ;; expect union with duplicate names to fail
  (test (with-handlers ((exn? (λ (x) 'passed)))
          (union-reduction-relations
           (reduction-relation 
            grammar
            (--> (number_1 number_2) 
                 ,(* (term number_1) (term number_2))
                 mult))
           (reduction-relation 
            grammar
            (--> (number_1 number_2) 
                 ,(* (term number_1) (term number_2))
                 mult)))
          'failed)
        'passed)
  
  (test (with-handlers ((exn? (λ (x) 'passed)))
          (union-reduction-relations
           (union-reduction-relations
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult))
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult3)))
           
           (union-reduction-relations
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult))
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult2))))
          'passed)
        'passed)
  
  ;; sorting in this test case is so that the results come out in a predictable manner.
  (test (sort
         (apply-reduction-relation
          (compatible-closure 
           (reduction-relation 
            grammar
            (--> (number_1 number_2) 
                 ,(* (term number_1) (term number_2))
                 mult))
           grammar
           M)
          '((2 3) (4 5)))
         (λ (x y) (string<=? (format "~s" x) (format "~s" y))))
        (list '((2 3) 20)
              '(6 (4 5))))
  
  (test (apply-reduction-relation
         (compatible-closure 
          (reduction-relation 
           grammar
           (--> (number_1 number_2) 
                ,(* (term number_1) (term number_2))
                mult))
          grammar
          M)
         '(4 2))
        (list '8))
  
  (test (apply-reduction-relation
         (context-closure 
          (context-closure 
           (reduction-relation grammar (--> 1 2))
           grammar
           (y hole))
          grammar
          (x hole))
         '(x (y 1)))
        (list '(x (y 2))))

  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (--> (variable_1 variable_2) 
               (variable_1 variable_2 x)
               mul
               (fresh x)))
         '(x x1))
        (list '(x x1 x2)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (~~> number 
               x
               (fresh x))
          with 
          [(--> (variable_1 variable_2 a) (variable_1 variable_2 b)) (~~> a b)])
         '(x x1 2))
        (list '(x x1 x2)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          x-language
          (--> (x_1 ...)
               (x ...)
               (fresh ((x ...) (x_1 ...)))))
         '(x y x1))
        (list '(x2 x3 x4)))

  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> (variable_1 ...)
               (x ... variable_1 ...)
               (fresh ((x ...) (variable_1 ...) (variable_1 ...)))))
         '(x y z))
        (list '(x1 y1 z1 x y z)))

  (test (apply-reduction-relation 
         (reduction-relation 
          empty-language
          (--> any (any_y x)
               (where any_y x)
               (fresh x)))
         (term junk))
        (list '(x x1)))
  
  (test (apply-reduction-relation 
         (reduction-relation 
          empty-language
          (--> (variable ...) (variable_0 ... variable_1 ...)
               (fresh ((variable_0 ...) (variable ...)))
               (fresh ((variable_1 ...) (variable ...)))))
         (term (x y)))
        (list '(variable_0 variable_1 variable_2 variable_3)))

  
  ;; test that redex match can be used in a side-condition 
  ;; with the same language that is used to define the 
  ;; reduction relation.
  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> any_1 3
               (side-condition (redex-match empty-language (any_1 any_2) (term any_1)))))
         '(a b))
        '(3))
  
  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> variable_1
               (x variable_1)
               (fresh (x variable_1))))
         'q)
        (list '(q1 q)))
  
  (test (apply-reduction-relation
         (extend-reduction-relation (reduction-relation empty-language (--> 1 2))
                                    empty-language
                                    (--> 1 3))
         1)
        '(3 2))
  
  (let ()
    (define-language e1
      (e 1))
    (define-language e2
      (e 2))
    (define red1 (reduction-relation e1 (--> e (e e))))
    (define red2 (extend-reduction-relation red1 e2 (--> ignoreme ignoreme)))
    (test (apply-reduction-relation red1 1) '((1 1)))
    (test (apply-reduction-relation red1 2) '())
    (test (apply-reduction-relation red2 1) '())
    (test (apply-reduction-relation red2 2) '((2 2))))
  
  (let ()
    (define red1 (reduction-relation empty-language
                                     (--> a (a a) 
                                          a)
                                     (--> b (b b) 
                                          b)
                                     (--> q x)))
    (define red2 (extend-reduction-relation red1
                                            empty-language
                                            (--> a (c c)
                                                 a)
                                            (--> q z)))
    (test (apply-reduction-relation red1 (term a)) (list (term (a a))))
    (test (apply-reduction-relation red1 (term b)) (list (term (b b))))
    (test (apply-reduction-relation red1 (term q)) (list (term x)))
    (test (apply-reduction-relation red2 (term a)) (list (term (c c))))
    (test (apply-reduction-relation red2 (term b)) (list (term (b b))))
    (test (apply-reduction-relation red2 (term q)) (list (term z) (term x))))
  
  (let ()
    (define red1 
      (reduction-relation
       empty-language
       (==> a (a a) 
            a)
       (==> b (b b) 
            b)
       (==> q w)
       with
       [(--> (X a) (X b)) (==> a b)]))
    
    (define red2 
      (extend-reduction-relation
       red1
       empty-language
       (==> a (c c)
            a)
       (==> q z)
       with
       [(--> (X a) (X b)) (==> a b)]))
    
    (test (apply-reduction-relation red1 (term (X a))) (list (term (X (a a)))))
    (test (apply-reduction-relation red1 (term (X b))) (list (term (X (b b)))))
    (test (apply-reduction-relation red1 (term (X q))) (list (term (X w))))
    (test (apply-reduction-relation red2 (term (X a))) (list (term (X (c c)))))
    (test (apply-reduction-relation red2 (term (X b))) (list (term (X (b b)))))
    (test (apply-reduction-relation red2 (term (X q))) (list (term (X z)) 
                                                             (term (X w)))))
  
  (test (reduction-relation->rule-names
         (reduction-relation
          empty-language
          (--> x y a)))
        '(a))
  
  (test (reduction-relation->rule-names
         (reduction-relation
          empty-language
          (--> x y a)
          (--> y z b)
          (--> z w c)))
        '(a b c))
  
  (test (reduction-relation->rule-names
         (reduction-relation
          empty-language
          (--> x y a)
          (--> y z b)
          (--> z w c)
          (--> p q z)
          (--> q r y)
          (--> r p x)))
        '(a b c z y x))
  
  (test (reduction-relation->rule-names
         (extend-reduction-relation
          (reduction-relation
           empty-language
           (--> x y a)
           (--> y z b)
           (--> z w c))
          empty-language
          (--> p q z)
          (--> q r y)
          (--> r p x)))
        '(a b c z y x))
  
    (test (reduction-relation->rule-names
           (union-reduction-relations
            (reduction-relation
             empty-language
             (--> x y a)
             (--> y z b)
             (--> z w c))
            (reduction-relation
             empty-language
             (--> p q z)
             (--> q r y)
             (--> r p x))))
        '(a b c z y x))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; examples from doc.txt
  ;;
  
  (define-language lc-lang
    (e (e e ...)
       x
       v)
    (c (v ... c e ...)
       hole)
    (v (lambda (x ...) e))
    (x variable-not-otherwise-mentioned))
  
  (test (let ([m (redex-match lc-lang e (term (lambda (x) x)))])
          (and m (length m)))
        1)
  
  (define-extended-language qabc-lang lc-lang (q a b c))
  
  (test (redex-match qabc-lang
                     e
                     (term (lambda (a) a)))
        #f)
  
  (test (let ([m (redex-match qabc-lang
                              e
                              (term (lambda (z) z)))])
          (and m (length m)))
        1)
  
  (require (lib "list.ss"))
  (let ()
    (define-metafunction lc-lang
      free-vars : e -> (x ...)
      [(free-vars (e_1 e_2 ...))
       (∪ (free-vars e_1) (free-vars e_2) ...)]
      [(free-vars x) (x)]
      [(free-vars (lambda (x ...) e))
       (- (free-vars e) (x ...))])
    
    (define-metafunction lc-lang
      ∪ : (x ...) ... -> (x ...)
      [(∪ (x_1 ...) (x_2 ...) (x_3 ...) ...)
       (∪ (x_1 ... x_2 ...) (x_3 ...) ...)]
      [(∪ (x_1 ...))
       (x_1 ...)]
      [(∪) ()])
    
    (define-metafunction lc-lang
      - : (x ...) (x ...) -> (x ...)
      [(- (x ...) ()) (x ...)]
      [(- (x_1 ... x_2 x_3 ...) (x_2 x_4 ...))
       (- (x_1 ... x_3 ...) (x_2 x_4 ...))
       (side-condition (not (memq (term x_2) (term (x_3 ...)))))]
      [(- (x_1 ...) (x_2 x_3 ...))
       (- (x_1 ...) (x_3 ...))])
    
    (test (term (∪)) (term ()))
    (test (term (∪ (x y) (z a) (b c))) (term (x y z a b c)))
    
    (test (term (- (x y) ())) (term (x y)))
    (test (term (- (x y) (x))) (term (y)))
    (test (term (- (y x) (x))) (term (y)))
    (test (term (- (x x x x x) (x))) (term ()))
    
    (test (term (free-vars (lambda (x) (x y)))) (list 'y))
    (test (term (free-vars (a (b (c (d e)))))) (term (a b c d e))))

  (test (variable-not-in (term (x y z)) 'x)
        (term x1))
  
  (test (variable-not-in (term (y z)) 'x)
        (term x))
  (test (variable-not-in (term (x x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) 'x)
        (term x11))
  (test (variable-not-in (term (x x11)) 'x)
        (term x1))
  (test (variable-not-in (term (x x1 x2 x3)) 'x1)
        (term x4))
  (test (variable-not-in (term (x x1 x1 x2 x2)) 'x)
        (term x3))
  
  (test (variables-not-in (term (x y z)) '(x))
        '(x1))
  (test (variables-not-in (term (x2 y z)) '(x x x))
        '(x x1 x3))
  
  (test ((term-match/single empty-language
                            [(variable_x variable_y)
                             (cons (term variable_x)
                                   (term variable_y))])
         '(x y))
        '(x . y))
  
  (test ((term-match/single empty-language
                            [(side-condition (variable_x variable_y)
                                             (eq? (term variable_x) 'x))
                             (cons (term variable_x)
                                   (term variable_y))])
         '(x y))
        '(x . y))
  

  (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                        ((λ (x) #t) (λ (x) 'wrong-exn)))
          ((term-match/single empty-language
                              [(number_1 ... number_2 ...) 1])
           '(1 2 3))
          'no-exn)
        'right-exn)
  
  (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                        ((λ (x) #t) (λ (x) 'wrong-exn)))
          ((term-match/single empty-language
                              [(number_1 ... number_2 ...) 1])
           'x)
          'no-exn)
        'right-exn)
  
  (test ((term-match empty-language
                     [(number_1 ... number_2 ...) 1])
         'x)
        '())
                             
  (define-language x-is-1-language
    [x 1])
  
  (test ((term-match/single x-is-1-language
                            [(x x)
                             1])
         '(1 1))
        1)
  
  (test (call-with-values
         (λ () 
           ((term-match/single empty-language
                               [() (values 1 2)])
            '()))
         list)
        '(1 2))
  
  (test (let ([x 0])
          (cons ((term-match empty-language
                             [(any_a ... number_1 any_b ...)
                              (begin (set! x (+ x 1))
                                     (term number_1))])
                 '(1 2 3))
                x))
        '((3 2 1) . 3))
  
  (test ((term-match empty-language
                     [number_1
                      (term number_1)]
                     [number_1
                      (term number_1)])
         '1)
        '(1 1))
  
  (test (apply-reduction-relation
         (reduction-relation
          x-language
          (--> (x_one x_!_one x_!_one x_!_one)
               (x_one x_!_one)))
         (term (a a b c)))
        (list (term (a x_!_one))))
  
  ;; tests `where' clauses in reduction relation
  (test (apply-reduction-relation
         (reduction-relation empty-language
                             (--> number_1 
                                  any_y
                                  (where any_y ,(+ 1 (term number_1)))))
         3)
        '(4))
  
  ;; tests `where' clauses scoping
  (test (let ([x 5])
          (apply-reduction-relation
           (reduction-relation empty-language
                               (--> any 
                                    any_z
                                    (where any_y ,x)
                                    (where any_x 2)
                                    (where any_z ,(+ (term any_y) (term any_x)))))
           'whatever))
        '(7))
  
  ;; tests `where' clauses bind in side-conditions
  (test (let ([x 'unk])
          (apply-reduction-relation
           (reduction-relation empty-language
                               (--> any 
                                    the-result
                                    (where any_y any)
                                    (side-condition (eq? (term any_y) 'whatever))))
           'whatever))
        '(the-result))
  
  ;; test that where clauses bind in side-conditions that follow
  (let ([save1 #f]
        [save2 #f])
    (term-let ([any_y (term outer-y)])
              (test (begin (apply-reduction-relation
                            (reduction-relation empty-language
                                                (--> number_1 
                                                     any_y
                                                     (side-condition (set! save1 (term any_y)))
                                                     (where any_y inner-y)
                                                     (side-condition (set! save2 (term any_y)))))
                            3)
                           (list save1 save2))
                    (list 'outer-y 'inner-y))))
  
  (test (apply-reduction-relation
         (reduction-relation empty-language
                             (--> any 
                                  any_y
                                  (fresh x)
                                  (where any_y x)))
         'x)
        '(x1))

  (let ()
    ;; tests where's ability to have redex patterns, not just syntax-case patterns
    (define-language var-lang [(x y z w) variable])
    
    (define red
      (reduction-relation
       var-lang
       (--> (x ...)
            (y ... z ...)
            (where (y ... w z ...) (x ...)))))
    
    (test (apply-reduction-relation red (term (a b c)))
          (list (term (a b)) (term (a c)) (term (b c)))))
  
  
  (let ([r (reduction-relation
            grammar
            (->1 1 2)
            (->2 3 4)
            (->4 5 6)
            with
            [(--> (side-condition (a number) (even? (term number))) b)
             (->1 a b)]
            [(--> (X 
                   (number number)
                   (X_1 X_1)
                   (M_!_1 M_!_1)
                   (1 ..._1 1 ..._1)
                   (1 ..._!_1 1 ..._!_1))
                  b)
             (->2 X b)]
            [(--> (a 1) b)
             (->3 a b)]
            [(->3 (a 2) b)
             (->4 a b)])])
    
    ; test that names are properly bound for side-conditions in shortcuts
    (let* ([lhs ((rewrite-proc-lhs (first (reduction-relation-make-procs r))) grammar)]
           [proc (third lhs)]
           [name (cadadr lhs)]
           [bind (λ (n) (make-bindings (list (make-bind name n))))])
      (test (and (proc (bind 4)) (not (proc (bind 3)))) #t))
    
    ; test binder renaming
    (let ([sym-mtch? (λ (rx) (λ (s) (and (symbol? s) (regexp-match? rx (symbol->string s)))))])
      (match (rewrite-proc-lhs (second (reduction-relation-make-procs r)))
        [`(3
           (,(and n1 (? (sym-mtch? #px"^number_\\d+$"))) ,n1)
           (,(and n2 (? (sym-mtch? #px"^X_1\\d+$"))) ,n2)
           (,(and m1 (? (sym-mtch? #px"^M_!_1\\d+$"))) ,m1)
           (1 ,(and ...1 (? (sym-mtch? #px"^\\.\\.\\._1\\d+$"))) 1 ,...1)
           (1 ,(and ...!1 (? (sym-mtch? #px"^\\.\\.\\._!_1\\d+$"))) 1 ,...!1))
         #t]
        [else #f]))
    
    ; test shortcut in terms of shortcut
    (test (match ((rewrite-proc-lhs (third (reduction-relation-make-procs r))) grammar)
            [`(((side-condition 5 ,(? procedure?) ,_) 2) 1) #t]
            [else #f])
          #t))
  
  (let ([< (λ (c d) (string<? (car c) (car d)))])
    
    (let* ([R (reduction-relation
               empty-language
               (--> number (q ,(add1 (term number)))
                    (side-condition (odd? (term number)))
                    side-condition)
               (--> 1 4 plain)
               (==> 2 t
                    shortcut)
               with
               [(--> (q a) b)
                (==> a b)])]
           [c (make-coverage R)])
      (parameterize ([relation-coverage (list c)])
        (apply-reduction-relation R 4)
        (test (sort (covered-cases c) <)
              '(("plain" . 0) ("shortcut" . 0) ("side-condition" . 0)))
        
        (apply-reduction-relation R 3)
        (test (sort (covered-cases c) <)
              '(("plain" . 0) ("shortcut" . 0) ("side-condition" . 1)))
        
        (apply-reduction-relation* R 1)
        (test (sort (covered-cases c) <)
              '(("plain" . 1) ("shortcut" . 1) ("side-condition" . 2)))))
    
    (let* ([S (reduction-relation
               empty-language
               (--> 1 1 uno))]
           [S+ (extend-reduction-relation
                S empty-language
                (--> 2 2 dos))])
      (let ([c (make-coverage S+)])
        (parameterize ([relation-coverage (list c)])
          (apply-reduction-relation S (term 1))
          (test (sort (covered-cases c) <)
                '(("dos" . 0) ("uno" . 1)))))
      (let ([c (make-coverage S)])
        (parameterize ([relation-coverage (list c)])
          (apply-reduction-relation S+ (term 1))
          (test (sort (covered-cases c) <)
                '(("uno" . 1))))))
    
    (let* ([T (reduction-relation empty-language (--> any any))]
           [c (make-coverage T)])
      (parameterize ([relation-coverage (list c)])
        (apply-reduction-relation T (term q))
        (test (and (regexp-match #px"tl-test.ss:\\d+:\\d+" (caar (covered-cases c))) #t)
              #t))))
  
  (let* ([R (reduction-relation
             empty-language
             (--> any any id))]
         [c (make-coverage R)]
         [c* (make-coverage R)])
    (parameterize ([relation-coverage (list c c*)])
      (apply-reduction-relation R 4)
      (test (covered-cases c) '(("id" . 1)))
      (test (covered-cases c*) '(("id" . 1)))))
  
  (let* ([< (λ (c d) 
              (let ([line-no (compose
                              string->number
                              second
                              (curry regexp-match #px".*:(\\d+):\\d+"))])
                (< (line-no (car c)) (line-no (car d)))))]
         [src-ok? (curry regexp-match? #px"tl-test.ss:\\d+:\\d+")]
         [sorted-counts (λ (cc) (map cdr (sort (covered-cases cc) <)))])
    (define-metafunction empty-language
      [(f 1) 1]
      [(f 2) 2])
    (define-metafunction/extension f empty-language
      [(g 3) 3])
    (define-relation empty-language
      [(R number)
       ,(even? (term number))]
      [(R number)
       ,(= 3 (term number))])
    
    (let ([fc (make-coverage f)]
          [rc (make-coverage (reduction-relation empty-language (--> any any)))])
      (parameterize ([relation-coverage (list rc fc)])
        (term (f 2))
        (test (andmap (compose src-ok? car) (covered-cases fc))
              #t)
        (test (sorted-counts fc) '(0 1))
        
        (term (f 1))
        (term (f 1))
        (test (sorted-counts fc) '(2 1))))
    
    (let ([c (make-coverage f)])
      (parameterize ([relation-coverage (list c)])
        (term (g 1))
        (test (sorted-counts c) '(1 0))))
    (let ([c (make-coverage g)])
      (parameterize ([relation-coverage (list c)])
        (term (f 1))
        (test (sorted-counts c) '(1 0 0))))
    
    (let ([c (make-coverage R)])
      (parameterize ([relation-coverage (list c)])
        (term (R 2))
        (term (R 3))
        (term (R 5))
        (test (sorted-counts c) '(1 1))))
    
    (let ([c (make-coverage f)]
          [c* (make-coverage f)])
      (parameterize ([relation-coverage (list c* c)])
        (term (f 1))
        (test (sorted-counts c) '(1 0))
        (test (sorted-counts c*) '(1 0)))))

;                                                                       
;                                                                       
;                                                                       
;                                                                       
;                                                 ;;;                   
;   ;;                ;;           ;             ;; ;;                  
;   ;;                ;;            ;            ;; ;;                  
;  ;;;;;  ;;;    ;;; ;;;;;           ;;           ;;;      ;;;;   ;;;;  
;   ;;   ;; ;;  ;; ;  ;;  ;;;;;;;;     ;;        ;;;      ;; ;   ;;  ;; 
;   ;;   ;;;;;  ;;;   ;;              ;;;       ;;  ;  ;; ;;     ;;  ;; 
;   ;;   ;;       ;;  ;;            ;;;         ;;  ;;;;  ;;     ;;  ;; 
;   ;;   ;;  ;  ; ;;  ;;           ;;           ;;   ;;   ;; ;   ;;  ;; 
;   ;;;;  ;;;   ;;;   ;;;;         ;             ;;;;; ;;  ;;;;   ;;;;  
;                                                                       
;                                                                       
;                                                                       

  
  (define-syntax-rule 
    (capture-output arg1 args ...)
    (let ([p (open-output-string)])
      (parameterize ([current-output-port p]
                     [current-error-port p])
        arg1 args ...)
      (get-output-string p)))
  
  (let ()
    (define red (reduction-relation empty-language (--> 1 2)))
    (test (capture-output (test-->> red 1 2) (test-results))
          "One test passed.\n")
    (test (capture-output (test-->> red 2 3) (test-results))
          #rx"FAILED tl-test.ss:[0-9.]+\nexpected: 3\n  actual: 2\n1 test failed \\(out of 1 total\\).\n"))
    
  (let ()
    (define red-share (reduction-relation 
                       empty-language
                       (--> a b)
                       (--> a c)
                       (--> c d)
                       (--> b d)))
    (test (capture-output (test-->> red-share (term a) (term d)) (test-results))
          "One test passed.\n"))
  
  (let ()
    (define red-cycle (reduction-relation 
                       empty-language
                       (--> a a)))
    (test (capture-output (test-->> red-cycle #:cycles-ok (term a)) (test-results))
          "One test passed.\n")
    (test (capture-output (test-->> red-cycle (term a)) (test-results))
          #rx"FAILED tl-test.ss:[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n"))
  
  (let ()
    (define-metafunction empty-language [(f any) ((any))])
    (test (capture-output (test-equal (term (f 1)) (term ((1))))
                          (test-results))
          "One test passed.\n"))
  
  (let ()
    (test (capture-output (test-predicate odd? 1)
                          (test-results))
          "One test passed.\n"))
  
  (let ()
    (define red (reduction-relation empty-language (--> any (any))))
    (test (capture-output (test--> red (term (1 2 3)) (term ((1 2 3)))) (test-results))
          "One test passed.\n"))
  
  (let ()
    (define red (reduction-relation empty-language 
                                    (--> any (any))
                                    (--> (any) any)))
    (test (capture-output (test--> red (term (x)) (term ((x))) (term x)) (test-results))
          "One test passed.\n")
    (test (capture-output (test--> red (term (x)) (term x) (term ((x)))) (test-results))
          "One test passed.\n"))

  (print-tests-passed 'tl-test.ss))