#lang racket
  (require "../reduction-semantics.rkt"
           "test-util.rkt"
           (only-in "../private/matcher.rkt" make-bindings make-bind)
           racket/match
           racket/trace
           "../private/struct.rkt")
  
  (reset-count)

  (define-namespace-anchor this-namespace)
  (parameterize ([current-namespace syn-err-test-namespace])
    (eval (quote-syntax
           (define-language syn-err-lang
             (M (M M)
                number)
             (E hole
                (E M)
                (number E))
             (X (number any)
                (any number))
             (Q (Q ...)
                variable)
             (UN (add1 UN)
                 zero)))))
  
;                                                          
;                                                          
;    ;;                                                    
;     ;                                                    
;     ;     ;;;  ;; ;;    ;; ;;;;  ;;   ;;;    ;; ;;  ;;;  
;     ;    ;   ;  ;;  ;  ;  ;;  ;   ;  ;   ;  ;  ;;  ;   ; 
;     ;     ;;;;  ;   ;  ;   ;  ;   ;   ;;;;  ;   ;  ;;;;; 
;     ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;     
;     ;    ;   ;  ;   ;  ;   ;  ;  ;;  ;   ;  ;   ;  ;     
;   ;;;;;   ;;;;;;;; ;;;  ;;;;   ;; ;;  ;;;;;  ;;;;   ;;;; 
;                            ;                    ;        
;                         ;;;                  ;;;         
;                                                          
;                                                          

  
  (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 (let ([m (redex-match 
                  empty-language
                  (side-condition (any_1 ...) #t)
                  '())])
          (and m
               (= 1 (length m))
               (match-bindings (car m))))
        (list (make-bind 'any_1 '())))
  
  (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)
  
  (test (pair? (redex-match grammar (name not-an-nt_subscript 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)))
        '("...."))

  (let ()
    ; non-terminals added by extension can have underscores
    (define-extended-language L base-grammar
      (z () (1 z_1 z_1)))
    (test (redex-match L z (term (1 () (1 () ())))) #f))
  
  ;; 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)))
        "define-extended-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)))
        "define-extended-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")
  
  ;; underscores in literals
  (let ()
    (define-language L
      (x (variable-except a_b))
      (y (variable-prefix a_b)))
    (test (pair? (redex-match L x (term a_c))) #t)
    (test (pair? (redex-match L y (term a_bc))) #t))
  
  ; underscores allowed on built-in non-terminals and names bound
  (let ([m (redex-match 
            grammar 
            (any_1 number_1 natural_1 integer_1
                   real_1 string_1 variable_1
                   variable-not-otherwise-mentioned_1)
            '(1 2 3 4 5 "s" s t))])
    (test (if m
              (map bind-exp
                   (sort (match-bindings (car m))
                         string<=?
                         #:key (compose symbol->string bind-name)))
              '())
          '(1 4 3 2 5 "s" t s)))

  (let ()
    (define-language L
      (e (e e) number))
    ;; not a syntax error since first e is not a binder
    (test (pair? (redex-match L ((cross e) e ...) (term ((hole 2) 1)))) #t))
  
  ;; match structures do not report ..._x bindings
  (test (map match-bindings (redex-match grammar (a ..._1) (term (a a a))))
        '(()))
  
  (define-syntax (test-match stx)
    (syntax-case stx ()
      [(_ actual (((var val) ...) ...))
       (syntax/loc stx
         (test (apply
                set
                (for/list ([match actual])
                  (for/list ([bind (match-bindings match)])
                    (list (bind-name bind) (bind-exp bind)))))
               (apply set (list (list (list 'var (term val)) ...) ...))))]))
  
  ;; cross
  (let ()
    (define-language L
      (e (e e)
         (cont (hide-hole E))
         number
         x)
      (E hole
         (e ... E e ...))
      (x variable-not-otherwise-mentioned))
    (test-match 
     (redex-match 
      L 
      (in-hole (cross e) e)
      (term (cont (1 hole))))
     (((e (cont (1 hole))))
      ((e 1)))))
  (let ()
    (define-language L
      (e (e e ...)
         x
         v)
      (v (λ (x ...) e)
         cont-val
         number)
      (cont-val (cont (hide-hole E)))
      (E hole
         (in-hole L E))
      (L (v ... hole e ...))
      (x variable-not-otherwise-mentioned))
    
    ;; no "found two holes" error
    (test (redex-match L (cross e) (term (cont ((λ (x) x) hole)))) #f)
    
    (test-match 
     (redex-match 
      L 
      (in-hole (cross e) e)
      (term ((cont ((λ (x) x) hole)) (λ (y) y))))
     (((e x))
      ((e ((cont ((λ (x) x) hole)) (λ (y) y))))
      ((e y))
      ((e (λ (y) y)))
      ((e (cont ((λ (x) x) hole)))))))
  
  ;; 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))
  
  (let ()
    (define-language L)
    (define-extended-language E L
      (v ((bar X_1) X_1))
      ((X Y) any))
    (test (and (redex-match E v (term ((bar 1) 1))) #t) #t)
    (test (redex-match E v (term ((bar 1) 2))) #f))
  
  (let ()
    (define-language L
      (M N ::= (M N) (λ (x) M) x)
      (x ::= variable-not-otherwise-mentioned))
    (test (and (redex-match L M '(λ (x) (x x))) #t) #t)
    (test (and (redex-match L N '(λ (x) (x x))) #t) #t)
    (define-extended-language L+ L
      (M ::= .... n)
      (n m ::= number))
    (test (and (redex-match L+ M '(λ (x) 7)) #t) #t)
    (test (and (redex-match L+ m 7) #t) #t)
    (let ([::= void])
      (define-language L
        (::= () (number ::=)))
      (test (and (redex-match L ::= '(1 ())) #t) #t)))
  
  (exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
;                                                                                             
;                                                                                             
;                                 ;;;                                ;                        
;                  ;             ;                           ;                                
;  ;;; ;    ;;;   ;;;;;   ;;;   ;;;;; ;;  ;; ;; ;;    ;;;;  ;;;;;  ;;;     ;;;  ;; ;;    ;;;; 
;   ; ; ;  ;   ;   ;     ;   ;   ;     ;   ;  ;;  ;  ;   ;   ;       ;    ;   ;  ;;  ;  ;   ; 
;   ; ; ;  ;;;;;   ;      ;;;;   ;     ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;   ;;;  
;   ; ; ;  ;       ;     ;   ;   ;     ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;      ; 
;   ; ; ;  ;       ;   ; ;   ;   ;     ;  ;;  ;   ;  ;   ;   ;   ;   ;    ;   ;  ;   ;  ;   ; 
;  ;;;;;;;  ;;;;    ;;;   ;;;;; ;;;;;   ;; ;;;;; ;;;  ;;;     ;;;  ;;;;;   ;;;  ;;; ;;; ;;;;  
;                                                                                             
;                                                                                             
;                                                                                             
;                                                                                             

  
  (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)

  ;; test redex-match in RHS and side-condition
  (let ()
    (define-metafunction empty-language
      [(f)
       ,(and (redex-match empty-language number 7) #t)
       (side-condition (redex-match empty-language number 7))])
    (test (term (f)) #t))
  
  (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))
  
  ; Extension reinterprets the base meta-function's contract
  ; according to the new language.
  (let ()
    (define-language L (x 1))
    (define-extended-language M L (x 2))
    (define-metafunction L
      f : x -> x
      [(f x) x])
    (define-metafunction/extension f M
      [(g q) q])
    
    (with-handlers ([(λ (x) 
                       (and (exn:fail? x)
                            (regexp-match? #rx"no clauses matched"
                                           (exn-message x))))
                     (λ (_) #f)])
      (test (begin (term (g 2)) #t) #t))
    
    (test (in-domain? (g 2)) #t))
  
  ; in-domain? interprets base meta-function LHSs according to
  ; the new language.
  (let ()
    (define-language L (x 1))
    (define-extended-language M L (x 2))
    (define-metafunction L
      [(f x) x])
    (define-metafunction/extension f M
      [(g q) q])
    (test (in-domain? (g 2)) #t))
  
  ;; 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-language L 
      (v 1))
    (define-extended-language M
      L
      (v .... 2))
    (define-metafunction L
      [(f v) v])
    (define-metafunction/extension f M
      [(g 17) 17])
    (test (term (g 2)) 2))
  
  (let ()
    (define-metafunction empty-language
      [(f any) 1])
    (define-metafunction/extension f empty-language
      [(g any) 2])
    (test (term (g 0)) 2))
  
  (let ()
    (define-language L 
      (v 1 (v)))
    (define-metafunction L
      f : v -> v
      [(f (v)) 
       any_1
       (where any_1 (f v))])
    
    (define-extended-language M
      L
      (v .... 2))
    (define-metafunction/extension f M
      g : v -> v
      [(g 2) 2])

    (test (term (g (2))) 2))
  
  (let ()
    (define-language L (x 1))
    (define-extended-language M L (x 2))
    (define-metafunction L 
      [(f)
       yes
       (where x 2)]
      [(f)
       no])
    (define-metafunction/extension f M
      g : -> any)
    (test (term (g)) 'yes))
  
  (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]
                     [print-as-expression #f])
        (term (f 1)))
      (test (get-output-string sp) "c>(f 1)\n <0\n"))
    
    (let ([sp (open-output-string)])
      (parameterize ([current-output-port sp]
                     [current-traced-metafunctions 'all]
                     [print-as-expression #f]
                     [caching-enabled? #f])
        (term (f 1)))
      (test (get-output-string sp) " >(f 1)\n > (f 0)\n < 0\n <0\n"))
    
    (let ([sp (open-output-string)])
      (parameterize ([current-output-port sp]
                     [current-traced-metafunctions '(f)]
                     [print-as-expression #f])
        (term (f 1)))
      (test (get-output-string sp) "c>(f 1)\n <0\n"))
    
    
    (define-metafunction empty-language
      [(g (any)) ((g any) (g any))]
      [(g 1) 1])
    
    (let ([sp (open-output-string)])
      (parameterize ([current-output-port sp]
                     [current-traced-metafunctions '(g)]
                     [print-as-expression #f])
        (term (g (1))))
      (test (get-output-string sp) " >(g (1))\n > (g 1)\n < 1\nc> (g 1)\n < 1\n <(1 1)\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-metafunction empty-language
      [(f number_1 number_2 ... (number_s ...) ...)
       yes
       (where number_1 1)
       (where (number_3 ...) ,(cdr (term (number_2 ...))))
       (where (number_3 ...) (3 4 5))
       (where (number_1 (number_s ...) ...)
              ,(if (null? (term ((number_s ...) ...)))
                   (term (number_1))
                   (term (number_1 () (6) (7 8) (9 10 11)))))]
      [(f any ...)
       no])
    (test (term (f 1 2 3 4 5)) 'yes)
    (test (term (f 1 2 3 4)) 'no)
    (test (term (f 0 2 3 4 5)) 'no)
    (test (term (f 1 2 3 4 5 () (6) (7 8) (9 10 11))) 'yes))
  
  (let ()
    (define-language L 
      [bool #t #f])
    (define-metafunction L
      f : any -> bool or number
      [(f any) any])
    (test (term (f 1)) (term 1))
    (test (term (f #f)) (term #f)))
  
  (let ()
    (define-language L 
      [bool #t #f])
    (define-metafunction L
      f : any -> bool ∪ number
      [(f any) any])
    (test (term (f 1)) (term 1))
    (test (term (f #f)) (term #f)))
  
  (let ()
    (define-language L 
      [bool #t #f]
      [abc a b c]
      [def d e f])
    (define-metafunction L
      f : any -> bool ∨ number ∪ abc or def
      [(f any) any])
    (test (term (f 1)) (term 1))
    (test (term (f #f)) (term #f))
    (test (term (f c)) (term c))
    (test (term (f e)) (term e)))
  
  ;; test that the contracts are called in order (or else 'car' fails)
  (let ()
    (define x '())
    (define-language L
      [seq (any any ...)])
    (define-metafunction L
      g : any -> 
      (side-condition any_1 (begin (set! x (cons 1 x)) #f))
      or (side-condition any_1 (begin (set! x (cons 2 x)) #f))
      or any
      [(g any) any])
    (test (begin (term (g whatever))
                 x)
          '(2 1)))
  
  (let ()
    (define-language L
      (n z (s n)))
    
    (define-metafunction L
      [(f n)
       n_1
       (judgment-holds (p n n_1))])
    
    (define-judgment-form L
      #:mode (p I O)
      #:contract (p n n)
      [(p z z)]
      [(p (s n) n)]
      [(p (s n) z)])
    
    (test (term (f (s z)))
          (term z))
    (test (with-handlers ([exn:fail:redex? exn-message])
            (term (f (s (s z))))
            "")
          #rx"different ways and returned different results"))
  
  (parameterize ([current-namespace (make-base-namespace)])
    (eval '(require redex/reduction-semantics))
    (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd"))
  
  ;; errors for not-yet-defined metafunctions
  (test (parameterize ([current-namespace (make-empty-namespace)])
          (namespace-attach-module (namespace-anchor->namespace this-namespace) 'redex/reduction-semantics)
          (namespace-require 'racket)
          (eval '(module m racket
                   (require redex/reduction-semantics)
                   (term (q))
                   (define-language L)
                   (define-metafunction L [(q) ()])))
          (with-handlers ([exn:fail:redex? exn-message])
            (eval '(require 'm))
            #f))
        "reference to metafunction q before its definition")
  (test (with-handlers ([exn:fail:redex? exn-message])
          (let ()
            (term (q))
            (define-language L)
            (define-metafunction L [(q) ()])
            #f))
        "reference to metafunction q before its definition")
  
  (exec-syntax-error-tests "syn-err-tests/metafunction-definition.rktd")
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;                                                                                                 
;       ;;           ;;; ;;                                   ;;           ;;  ;;                 
;       ;;          ;;;  ;;                                   ;;          ;;;  ;;                 
;    ;;;;;   ;;;;  ;;;;; ;;  ;; ;;;   ;;;;       ;;;;  ;;;;   ;;   ;;;;  ;;;;; ;;   ;;;;   ;; ;;; 
;   ;;;;;;  ;;  ;; ;;;;  ;;  ;;;;;;  ;;  ;;      ;;;; ;;  ;;  ;;  ;;  ;;  ;;;; ;;  ;;;;;;  ;;;;;; 
;  ;;;  ;; ;;;;;;;; ;;   ;;  ;;  ;; ;;;;;;;;;;;; ;;  ;;;;;;;; ;;    ;;;;  ;;;  ;; ;;;  ;;; ;;  ;; 
;  ;;;  ;; ;;;      ;;   ;;  ;;  ;; ;;;     ;;;; ;;  ;;;      ;;  ;;; ;;  ;;;  ;; ;;;  ;;; ;;  ;; 
;   ;;;;;;  ;;; ;;  ;;   ;;  ;;  ;;  ;;; ;;      ;;   ;;; ;;  ;; ;;;  ;;  ;;;; ;;  ;;;;;;  ;;  ;; 
;    ;;;;;   ;;;;   ;;   ;;  ;;  ;;   ;;;;       ;;    ;;;;   ;;  ;;;;;;   ;;; ;;   ;;;;   ;;  ;; 
;                                                                                                 
;                                                                                                 
;                                                                                                 

  
  (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))
  
  (let ()
    (define-relation empty-language
      d ⊆ any × any
      [(d (any) (any)) (d any any)]
      [(d () ())])
    
    (test (term (d ((())) ((())))) #t)
    (test (term (d ((())) ())) #f))
  
  (let ()
    (define-relation empty-language
      d ⊂ any x any
      [(d (any) (any)) (d any any)]
      [(d () ())])
    
    (test (term (d ((())) ((())))) #t)
    (test (term (d ((())) ())) #f))
  
  (let ()
    (define-relation empty-language
      d ⊂ (any)
      [(d (1))])
    
    (test (term (d (1))) #t)
    (test (term (d (2))) #f)
    (test (with-handlers ((exn:fail? (λ (x) 'passed)))
            (term (d 1))
            'failed)
          'passed))
  
  (let ()
    (define-language types
      ((τ σ) int
             num
             (τ ... → τ)))
    
    (define-relation types
      subtype ⊆ τ × τ
      [(subtype int num)]
      [(subtype (τ_1 ..._1 → τ_2) (σ_1 ..._1 → σ_2))
       (subtype σ_1 τ_1) ...
       (subtype τ_2 σ_2)]
      [(subtype τ τ)])
    
    (test (term (subtype int int)) #t)
    (test (term (subtype int num)) #t)
    (test (term (subtype (int int int → int) (int int → int))) #f)
    (test (term (subtype (int int → int) (int num → int))) #f)
    (test (term (subtype (int num → int) (int int → int))) #t)
    (test (term (subtype (int int → int) (int int → num))) #t))
  
  (let ()
    (define-relation empty-language
      [(R () ())]
      [(R (any_a) (any_b)) 
       (R any_c any_d) 
       (where any_c any_a)
       (where any_d any_b)])
    
    (test (term (R () ())) #t)
    (test (term (R (()) (()))) #t)
    (test (term (R (()) ())) #f))
  
  (let ()
    (define-relation empty-language
      [(R () ())]
      [(R (any_a) (any_b)) 
       (R any_c any_d) 
       (where/hidden any_c any_a)
       (where/hidden any_d any_b)])
    
    (test (term (R () ())) #t)
    (test (term (R (()) (()))) #t)
    (test (term (R (()) ())) #f))
  
  (let ()
    (define-relation empty-language
      [(R any_a any_b)
       (side-condition (equal? (term any_a)
                               (term any_b)))])
    
    (test (term (R (xx) (xx))) #t)
    (test (term (R (()) ())) #f))
  
  (let ()
    (define-relation empty-language
      [(R any_a any_b)
       (side-condition/hidden
        (equal? (term any_a)
                (term any_b)))])
    
    (test (term (R (xx) (xx))) #t)
    (test (term (R (()) ())) #f))

  
  (exec-syntax-error-tests "syn-err-tests/relation-definition.rktd")
  
;                    ;;                         ;                                        ;;                    ;                 
;                     ;                 ;                                                 ;            ;                         
;   ;; ;;   ;;;    ;; ; ;;  ;;   ;;;;  ;;;;;  ;;;     ;;;  ;; ;;          ;; ;;   ;;;     ;     ;;;   ;;;;;  ;;;     ;;;  ;; ;;  
;    ;;    ;   ;  ;  ;;  ;   ;  ;   ;   ;       ;    ;   ;  ;;  ;          ;;    ;   ;    ;    ;   ;   ;       ;    ;   ;  ;;  ; 
;    ;     ;;;;;  ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;  ;;;;;   ;     ;;;;;    ;     ;;;;   ;       ;    ;   ;  ;   ; 
;    ;     ;      ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;          ;     ;        ;    ;   ;   ;       ;    ;   ;  ;   ; 
;    ;     ;      ;   ;  ;  ;;  ;   ;   ;   ;   ;    ;   ;  ;   ;          ;     ;        ;    ;   ;   ;   ;   ;    ;   ;  ;   ; 
;   ;;;;;   ;;;;   ;;;;;  ;; ;;  ;;;     ;;;  ;;;;;   ;;;  ;;; ;;;        ;;;;;   ;;;;  ;;;;;   ;;;;;   ;;;  ;;;;;   ;;;  ;;; ;;;
;                                                                                                                                
;                                                                                                                                
;                                                                                                                                
;                                                                                                                                

  
  
  (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))))
  
  ; The scope of a `where' clause includes the left-hand sides
  ; of subsequent `where' clauses.
  (test (apply-reduction-relation
         (reduction-relation
          grammar
          (--> any
               1
               (where number_1 2)
               (where (side-condition any (number? (term number_1))) dontcare)))
         'dontcare)
        '(1))
  
  ; 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 multiply matching `where' with failing `where' inside
  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> ()
               ()
               (where (number_1 ... number_i number_i+1 ...)
                      (1 2 3))
               (where number_i 2)))
         '())
        '(()))
  
  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> (in-hole (name E
                              (in-hole ((hide-hole hole) hole)
                                       hole))
                        number)
               (in-hole E ,(add1 (term number)))))
         (term (hole 2)))
        (list (term (hole 3))))
  
  (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/tag-with-names
         (reduction-relation
          grammar
          (--> any
               (number_i number_i*)
               (where (number_0 ... number_i number_i+1 ...) any)
               (where (number_0* ... number_i* number_i+1* ...) any)
               pick-two
               (computed-name
                (format "(~s, ~s)"
                        (length (term (number_0 ...)))
                        (length (term (number_0* ...)))))))
         '(9 7))
        '(("(1, 1)" (7 7)) ("(1, 0)" (7 9)) ("(0, 1)" (9 7)) ("(0, 0)" (9 9))))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation grammar (--> 1 2 (computed-name 3))) 1)
        '(("3" 2)))
  
  (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))
  
  
  (let ([R (reduction-relation empty-language #:domain number (--> 1 a "first"))]
        [S (reduction-relation empty-language (--> 2 a "second"))])
    (test (apply-reduction-relation (union-reduction-relations R S) 2)
          (list 'a))
    (test (apply-reduction-relation (union-reduction-relations S R) 2)
          (list 'a)))
  
  (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 an unnamed rule, 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 wrt the new language
    (test (apply-reduction-relation r2 3)
          '(3)))
  
  (let ()
    (define-language L)
    (define R
      (reduction-relation L #:domain 1 (--> any any)))
    (define S
      (extend-reduction-relation R L #:domain 2))
    
    ;; test that the new domain applies to inherited rules
    (test (apply-reduction-relation S 2)
          '(2))
    (test (with-handlers ([exn:fail? exn-message])
            (apply-reduction-relation S 1))
          #rx"not defined"))
  
  (let ()
    (define-language L)
    (define R
      (reduction-relation L (--> 1 1 "a")))
    (define S
      (extend-reduction-relation R L (--> 2 2 "a")))
    
    ;; test that overridden rules do not appear (twice)
    (test (reduction-relation->rule-names S)
          '(a)))
  
  (let ()
    (define-language L)
    
    ;; test that symbol-named rules replace string-named rules
    (test (apply-reduction-relation
           (extend-reduction-relation
            (reduction-relation L (--> 1 1 "a"))
            L (--> 1 2 a))
           1)
          '(2))
    ;; and vice versa
    (test (apply-reduction-relation
           (extend-reduction-relation
            (reduction-relation L (--> 1 1 a))
            L (--> 1 2 "a"))
           1)
          '(2)))
  
  (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)))
  
  (let ([R (reduction-relation
            grammar
            (--> (number_1 number_2 ... (number_s ...) ...)
                 yes
                 (where number_1 1)
                 (where (number_3 ...) ,(cdr (term (number_2 ...))))
                 (where (number_3 ...) (3 4 5))
                 (where (number_1 (number_s ...) ...)
                        ,(if (null? (term ((number_s ...) ...)))
                             (term (number_1))
                             (term (number_1 () (6) (7 8) (9 10 11)))))))])
    (test (apply-reduction-relation R (term (1 2 3 4 5))) '(yes))
    (test (apply-reduction-relation R (term (1 2 3 4))) '())
    (test (apply-reduction-relation R (term (0 2 3 4 5))) '())
    (test (apply-reduction-relation R (term (1 2 3 4 5 () (6) (7 8) (9 10 11)))) '(yes)))
  
  (exec-syntax-error-tests "syn-err-tests/reduction-relation-definition.rktd")
  
  ;; 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))
  
  (test (apply-reduction-relation
         (extend-reduction-relation
          (reduction-relation empty-language (--> 1 2 (computed-name 1)))
          empty-language
          (--> 1 3 (computed-name 1)))
         1)
        '(3 2))
  
  (test (apply-reduction-relation
         (extend-reduction-relation
          (reduction-relation empty-language (--> 1 2 (computed-name 1) x))
          empty-language
          (--> 1 3 (computed-name 1) x))
         1)
        '(3))
  
  (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
         (reduction-relation
          empty-language
          (--> x y a (computed-name "x to y"))
          (--> y z (computed-name "y to z"))))
        '(a))
  
  (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))
    
    (let ()
      (define-judgment-form empty-language
        #:mode (R I O)
        [(R a a)]
        [(R a b)])
      (test (apply-reduction-relation
             (reduction-relation
              empty-language
              (--> a any
                   (judgment-holds (R a any))))
             'a)
            '(a b)))
    
    ; a call to a metafunction that looks like a pattern variable
    (let ()
      (define result 'result)
      (define-language L
        (f any))
      (define-judgment-form L
        #:mode (J O)
        [(J (f_2))])
      (define-metafunction L
        [(f_2) ,result])
      (test (judgment-holds (J any) any)
            (list result)))
  
    ;                                                                 
    ;                                                                 
    ;                    ;;                        ;;                 
    ;                     ;                         ;            ;    
    ;   ;; ;;   ;;;    ;; ;   ;;;  ;;  ;;           ;     ;;;   ;;;;; 
    ;    ;;    ;   ;  ;  ;;  ;   ;  ;  ;            ;    ;   ;   ;    
    ;    ;     ;;;;;  ;   ;  ;;;;;   ;;    ;;;;;    ;    ;;;;;   ;    
    ;    ;     ;      ;   ;  ;       ;;             ;    ;       ;    
    ;    ;     ;      ;   ;  ;      ;  ;            ;    ;       ;   ;
    ;   ;;;;;   ;;;;   ;;;;;  ;;;; ;;  ;;         ;;;;;   ;;;;    ;;; 
    ;                                                                 
    ;                                                                 
    ;                                                                 
    ;                                                                 
  
    (let ()
      (define-language L
        (n number)
        (x variable))
      
      (test (redex-let L ([(n_1 n_2) '(1 2)])
                       (term (n_2 n_1)))
            (term (2 1)))
      (test (redex-let L ([(x_i ([x_0 n_0] ... [x_i n_i] [x_i+1 n_i+1] ...))
                           '(b ([a 1] [b 2] [c 3]))])
                       (term n_i))
            2)
      (test (with-handlers ([exn:fail:redex? exn-message])
              (redex-let L ([(n) 1]) 'no-exn))
            "redex-let: term 1 does not match pattern (n)")
      (test (with-handlers ([exn:fail:redex? exn-message])
              (redex-let L ([(n_1 ... n_i n_i+1 ...) '(1 2 3)]) 'no-exn))
            "redex-let: pattern (n_1 ... n_i n_i+1 ...) matched term (1 2 3) multiple ways")
      (test (redex-let L ([n_1 1])
                       (redex-let L ([n_1 2] [n_2 (term n_1)])
                                  (term (n_1 n_2))))
            (term (2 1)))
      (test (redex-let L ([n_1 1])
                       (redex-let* L ([n_1 2] [n_2 (term n_1)])
                                   (term (n_1 n_2))))
            (term (2 2)))
      
      (test (redex-let L ([(n_1 n_1) '(1 1)]) (term n_1))
            1)
      (test
       (redex-let* L ([(n_1) '(1)] [n_1 1]) (term n_1))
       1)
      (exec-syntax-error-tests "syn-err-tests/redex-let.rktd"))
  

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

    (exec-syntax-error-tests "syn-err-tests/judgment-form-definition.rktd")
    (exec-syntax-error-tests "syn-err-tests/judgment-holds.rktd")
    
    (let ()
      (define-language nats
        (n z (s n)))
      
      (define-judgment-form nats
        #:mode (sumi I I O)
        #:contract (sumi n n n)
        [(sumi z n n)]
        [(sumi (s n_1) n_2 (s n_3))
         (sumi n_1 n_2 n_3)])
      (test (judgment-holds (sumi z (s z) n) n)
            (list (term (s z))))
      (test (judgment-holds (sumi (s (s z)) (s z) n) n)
            (list (term (s (s (s z))))))
      (test (judgment-holds (sumi ,'z (s z) (s z))) #t)
      
      (define-judgment-form nats
        #:mode (sumo O O I)
        #:contract (sumo n n n)
        [(sumo z n n)]
        [(sumo (s n_1) n_2 (s n_3))
         (sumo n_1 n_2 n_3)])
      (test (judgment-holds (sumo n_1 n_2 z) ([,'n_1 n_1] [,'n_2 n_2]))
            (list (term ([n_1 z] [n_2 z]))))
      (test (judgment-holds (sumo n_1 n_2 (s z)) ([,'n_1 n_1] [,'n_2 n_2]))
            (list (term ([n_1 (s z)] [n_2 z]))
                  (term ([n_1 z] [n_2 (s z)]))))
      
      (define-judgment-form nats
        #:mode (sumo-ls O O I)
        [(sumo-ls (s n_1) n_2 n_3)
         (sumo (s n_1) n_2 n_3)])
      (test (judgment-holds (sumo-ls n_1 n_2 (s z)) ([,'n_1 n_1] [,'n_2 n_2]))
            (list (term ([n_1 (s z)] [n_2 z]))))
      (test (judgment-holds (sumo-ls (s n_1) n_2 (s z))) #t)
      (test (judgment-holds (sumo-ls z n_2 (s z))) #f)
      (test (judgment-holds (sumo-ls z n_2 (s z)) whatever) (list))
      
      (define-judgment-form nats
        #:mode (sumo-lz O O I)
        [(sumo-lz z n_2 n_3)
         (sumo z n_2 n_3)])
      (test (judgment-holds (sumo-lz n_1 n_2 (s z)) ([,'n_1 n_1] [,'n_2 n_2]))
            (list (term ([n_1 z] [n_2 (s z)]))))
      
      (define-judgment-form nats
        #:mode (member O I)
        [(member n_i (n_0 ... n_i n_i+1 ...))])
      
      (test (judgment-holds (member n (z (s z) z (s (s z)))) n)
            (list (term (s (s z))) (term (s z)) (term z)))
      
      (define-judgment-form nats
        #:mode (has-zero I)
        [(has-zero (n ...))
         (member z (n ...))])
      
      (test (judgment-holds (has-zero ((s z) z (s (s z))))) #t)
      
      (define-judgment-form nats
        #:mode (le2 I)
        [(le2 n)
         (le (add2 n) (s (s (s (s z)))))])
      
      (define-judgment-form nats
        #:mode (le I I)
        [(le z n)]
        [(le (s n_1) (s n_2))
         (le n_1 n_2)])
      
      (define-metafunction nats
        add2 : n -> n
        [(add2 n) (s (s n))])
      
      (test (judgment-holds (le2 (s (s z)))) #t)
      (test (judgment-holds (le2 (s (s (s z))))) #f)
      
      (define-judgment-form nats
        #:mode (uses-add2 I O)
        #:contract (uses-add2 n n)
        [(uses-add2 n_1 n_2)
         (sumo n_2 n_3 n_1)
         (where n_2 (add2 n_3))])
      
      (test (judgment-holds (uses-add2 (s (s (s (s z)))) n) n)
            (list (term (s (s (s z))))))
      
      (define-judgment-form nats
        #:mode (add1 I O)
        #:contract (add1 n n)
        [(add1 n (s n))])
      
      (define-judgment-form nats
        #:mode (map-add1 I O)
        #:contract (map-add1 (n ...) (n ...))
        [(map-add1 (n ...) (n_+ ...))
         (add1 n n_+) ...])
      
      (test (judgment-holds (map-add1 () (n ...))
                            (n ...))
            (list (term ())))
      
      (test (judgment-holds (map-add1 (z (s z) (s (s z))) (n ...))
                            (n ...))
            (list (term ((s z) (s (s z)) (s (s (s z)))))))

      (define-judgment-form nats
        #:mode (map-add1-check I O)
        #:contract (map-add1-check (n ...) (n ...))
        [(map-add1-check (n ...) ((s n) ...))
         (add1 n (s n)) ...])
      
      (test (judgment-holds (map-add1-check (z (s z) (s (s z))) (n ...))
                            (n ...))
            (list (term ((s z) (s (s z)) (s (s (s z)))))))
      
      (define-judgment-form nats
        #:mode (add-some-noz I O)
        #:contract (add-some-noz n n)
        [(add-some-noz z z)]
        [(add-some-noz (s n) (s n))]
        [(add-some-noz (s n) (s (s n)))])
      
      (define-judgment-form nats
        #:mode (map-add-some-noz I O)
        #:contract (map-add-some-noz (n ...) (n ...))
        [(map-add-some-noz (n ...) (n_+ ...))
         (add-some-noz n n_+) ...])
      
      (test (sort (judgment-holds (map-add-some-noz (z (s z) (s (s z))) (n ...))
                                  (n ...))
                  string<=?
                  #:key (λ (x) (format "~s" x)))
            (list (term (z (s (s z)) (s (s (s z)))))
                  (term (z (s (s z)) (s (s z))))
                  (term (z (s z) (s (s (s z)))))
                  (term (z (s z) (s (s z))))))
      
      (define-judgment-form nats
        #:mode (add-some I O)
        #:contract (add-some n n)
        [(add-some n n)]
        [(add-some n (s n))])
      
      (define-judgment-form nats
        #:mode (map-add-some-one I O)
        #:contract (map-add-some-one (n ...) (n ...))
        [(map-add-some-one (n ...) ((s n) ...))
         (add-some n (s n)) ...])
      
      (test (judgment-holds (map-add-some-one (z (s z) (s (s z))) (n ...))
                            (n ...))
            (list (term ((s z) (s (s z)) (s (s (s z)))))))      
      
      (define-judgment-form nats
        #:mode (hyphens I)
        [(hyphens b)
         -----------
         (hyphens a)]
        [(hyphens c)
         -
         (hyphens b)]
        [(hyphens c)])
      (test (judgment-holds (hyphens a)) #t)
      
      (let-syntax ([test-trace 
                    (syntax-rules ()
                      [(_ expr trace-spec expected)
                       (test (let ([trace (open-output-string)])
                               (parameterize ([current-output-port trace]
                                              [current-traced-metafunctions trace-spec])
                                 expr)
                               (get-output-string trace))
                             expected)])])
        (test-trace (judgment-holds (sumi (s z) (s (s z)) n) n)
                    '(sumi)
                    #reader scribble/reader
                    @string-append{>(sumi '(s z) '(s (s z)) '_)
                                   > (sumi 'z '(s (s z)) '_)
                                   < '((sumi z (s (s z)) (s (s z))))
                                   <'((sumi (s z) (s (s z)) (s (s (s z)))))
                            
                                  })
        (test-trace (judgment-holds (sumo n_1 n_2 (s z)))
                    'all
                    #reader scribble/reader
                    @string-append{>(sumo '_ '_ '(s z))
                                   > (sumo '_ '_ 'z)
                                   < '((sumo z z z))
                                   <'((sumo (s z) z (s z)) (sumo z (s z) (s z)))
                            
                                  })
        (test-trace (letrec ([f (match-lambda
                                  ['z #t]
                                  [`(s ,n) (f n)])])
                      (define-judgment-form nats
                        #:mode (ext-trace I I)
                        [(ext-trace z (side-condition n (f (term n))))]
                        [(ext-trace (s n_1) n_2)
                         (ext-trace n_1 n_2)])
                      (trace f)
                      (judgment-holds (ext-trace (s z) (s z))))
                    'all
                    #reader scribble/reader
                    @string-append{>(ext-trace '(s z) '(s z))
                                   > (ext-trace 'z '(s z))
                                   > >(f '(s z))
                                   > >(f 'z)
                                   < <#t
                                   < '((ext-trace z (s z)))
                                   <'((ext-trace (s z) (s z)))
                                  
                                  })))
    
    (parameterize ([current-namespace (make-base-namespace)])
      (eval '(require errortrace))
      (eval '(require redex/reduction-semantics))
      (eval '(define-language L))
      (eval '(define-judgment-form L
               #:mode (J I)
               [(J a)
                (J b)]
               [(J b)]))
      (test (eval '(judgment-holds (J a))) #t))
    
    (parameterize ([current-namespace (make-base-namespace)])
      (eval '(require redex/reduction-semantics))
      (eval '(define-language L
               (s a b c)))
      (eval '(define-judgment-form L
               #:mode (ctc-fail I O)
               #:contract (ctc-fail s s)
               [(ctc-fail a q)]
               [(ctc-fail b s)
                (ctc-fail q s)]
               [(ctc-fail c s)
                (ctc-fail a s)]))
      (exec-runtime-error-tests "run-err-tests/judgment-form-contracts.rktd")
      (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")
      (exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd"))
    
  
;                                                                               
;                                                                               
;                                                                               
;       ;            ;;    ;                                                    
;       ;           ;      ;                          ;                         
;       ;           ;                                 ;                         
;    ;;;;   ;;;    ;;;     ;    ;;;;    ;;;          ;;;     ;;;   ; ;;   ;;;;; 
;   ;   ;  ;   ;    ;      ;    ;   ;  ;   ;  ;;;;;   ;     ;   ;  ;;  ;  ; ; ; 
;   ;   ;  ;;;;;    ;      ;    ;   ;  ;;;;;          ;     ;;;;;  ;   ;  ; ; ; 
;   ;   ;  ;        ;      ;    ;   ;  ;              ;     ;      ;      ; ; ; 
;   ;   ;  ;   ;    ;      ;    ;   ;  ;   ;          ;     ;   ;  ;      ; ; ; 
;    ;;;;   ;;;     ;      ;    ;   ;   ;;;            ;;    ;;;   ;      ; ; ; 
;                                                                               
;                                                                               
;                                                                               
  
  (test (let ()
          (define-term x 1)
          (term (x x)))
        (term (1 1)))
  (test (let ()
          (define-term x 1)
          (let ([x 'whatever])
            (term (x x))))
        (term (x 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 mzlib/list)
  (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 ((term-match/single empty-language [() 'a] [() 'b])
         '())
        'a)

  (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))
        '((1 2 3) . 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))
  
  (test (let ([not-and
               (λ () #f)])
          (redex-match empty-language
                       (side-condition any_1 (not-and))
                       1))
        #f)

  (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 (cadar (cddadr 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)
            [`(list (list (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 ()
      (define-language L
        (e (e e)
           (delay e)
           +inf.0
           I)
        (v (delay e)
           +inf.0
           I))
      
      (define red
        (compatible-closure
         (reduction-relation
          L
          (--> (+inf.0 +inf.0) (+inf.0 +inf.0))
          (--> (I e) e))
         L
         e))
      
      (test (apply-reduction-relation* 
             red
             (term (I (delay (+inf.0 +inf.0))))
             #:stop-when (redex-match L v))
            (list (term (delay (+inf.0 +inf.0)))))
      
      (test (apply-reduction-relation* 
             red
             (term (I (delay (+inf.0 +inf.0)))))
            '()))
    
    (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.(?:.+):\\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.(?:.+):\\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.(?:.+):[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.(?:.+):[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n"))
  
  (let ()
    (define subred (reduction-relation empty-language (--> natural ,(- (term natural) 1))))
    (test (capture-output (test-->> subred #:pred (λ (x) #t) 1 -1) (test-results))
          "One test passed.\n")
    (test (capture-output (test-->> subred #:pred number? 1 -1) (test-results))
          "One test passed.\n")
    (test (capture-output (test-->> subred #:pred odd? 1 -1) (test-results))
         #rx"FAILED tl-test.rkt:[0-9.]+\nfound a term that failed #:pred: 0\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"))
  
  (let ()
    (define-language L
      (i integer))
    
    (define R
      (reduction-relation
       L
       (--> i i)
       (--> i ,(add1 (term i)))))
    
    (define (mod2=? i j)
      (= (modulo i 2) (modulo j 2)))
    
    (test (capture-output (test--> R #:equiv mod2=? 7 1 0) (test-results))
          "One test passed.\n")
    (test (capture-output (test--> R #:equiv mod2=? 7 1) (test-results))
          #rx"FAILED tl-test\\.(?:.+):[0-9.]+\nexpected: 1\n  actual: 8\n  actual: 7\n1 test failed \\(out of 1 total\\).\n"))
  
  (let-syntax ([test-bad-equiv-arg
                (λ (stx)
                  (syntax-case stx ()
                    [(_ test-form)
                     (syntax/loc stx
                       (test-contract-violation
                        (test-form (reduction-relation empty-language (--> any any))
                                   #:equiv 1 2)
                        #:blaming "tl-test"))]))])
    (test-bad-equiv-arg test-->)
    (test-bad-equiv-arg test-->>))

  (let ()
    (capture-output (test-results))
    (define-language L)
    
    (define 1+
      (reduction-relation 
       L
       (--> number ,(add1 (term number)))))
    
    (define (equal-to-7 x) (= x 7))
    (test (capture-output (test-->>∃ #:steps 5 1+ 0 equal-to-7))
          #rx"^FAILED .*\nno term satisfying #<procedure:equal-to-7> reachable from 0 \\(within 5 steps\\)\n$")
    
    (test (capture-output (test-->>∃ 1+ 0 7)) "")
    (test (capture-output (test-->>E 1+ 0 7)) "")
    (test (capture-output (test-->>∃ #:steps +inf.0 1+ 0 7)) "")
    (test (capture-output (test-->>∃ 1+ 0 equal-to-7)) "")
    
    (define identity
      (reduction-relation
       L
       (--> any any)))
    
    (test (capture-output (test-->>∃ identity 0 1))
          #rx"^FAILED .*\nterm 1 not reachable from 0\n$")
    
    (test (capture-output (test-results)) "2 tests failed (out of 6 total).\n")
    
    (test-contract-violation
     (test-->>∃ 1+ 0 (λ (x y) x))
     #:blaming "tl-test"
     #:message "goal expression")
    (test-contract-violation
     (test-->>∃ 1 0 1)
     #:blaming "tl-test"
     #:message "reduction relation expression")
    (test-contract-violation
     (test-->>∃ #:steps 1.1 1+ 0 1)
     #:blaming "tl-test"
     #:message "steps expression"))
  
  (print-tests-passed 'tl-test.rkt)
