private/tl-test.ss
(module tl-test mzscheme
  (require "../reduction-semantics.ss")
  
  (define-syntax (test stx)
    (syntax-case stx ()
      [(_ expected got)
       (with-syntax ([line (syntax-line stx)]
                     [col (syntax-column stx)])
         (syntax (test/proc (λ () expected) got line col)))]))
  
  (define tests 0)
  (define (test/proc run expected line col)
    (let ([got (run)])
      (set! tests (+ tests 1))
      (unless (equal? got expected)
        (error 'test/proc "line ~a col ~a got ~s expected ~s" 
               line col
               got
               expected))))
  
  (define grammar
    (language (M (M M)
                 number)
              (E hole
                 (E M)
                 (number E))
              (X (number any)
                 (any number))))
  
  (define add (reduction grammar
                         (number_1 number_2)
                         (+ (term number_1) (term number_2))))
  
  (test (reduce (list add) '(2 3)) (list 5))
  (test (reduce (list (context-closure add grammar 'E))
                '(2 3))
        (list 5))
  (test (reduce (list (compatible-closure add grammar 'M))
                '(2 3))
        (list 5))
  (test (reduce (list (compatible-closure add grammar 'M))
                '((2 3) (4 5)))
        (list '(5 (4 5))
              '((2 3) 9)))
 
  (test (reduce/tag-with-reduction (list add) '(2 3))
        (list (list add '5)))
  
  (test ((language->predicate grammar 'M) '(1 2))
        #t)
  
  (test ((language->predicate grammar 'M) '(3))
        #f)

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

  (test (f '(1 17)) 'x)
  (test (f '(11 1)) 'y)
  (test (f '(11 2)) 13)
  
  ;; match two clauess => take first one
  (test (f '(4 4)) 'q)
  
  ;; match one clause two ways => error
  (test (with-handlers ((exn? (λ (x) 'exn-raised))) (g '(4 4)) 'no-exn)
        'exn-raised)
  
  ;; match no ways => error
  (test (with-handlers ((exn? (λ (x) 'exn-raised))) (f 'mis-match) 'no-exn)
        'exn-raised)

  (test (object-name g) 'g)

  (test (pair? (test-match grammar M '(1 1))) #t)
  (test (pair? (test-match grammar M '(1 1 1))) #f)
  (test (pair? (test-match grammar
                           (side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
                           '(1 1)))
        #t)
  (test (pair? (test-match grammar
                           (side-condition (M_1 M_2) (equal? (term M_1) (term M_2))) 
                           '(1 2)))
        #f)
  
  (test (pair? ((test-match grammar M) '(1 1)))
        #t)
  
  (printf "tl-test.ss: all ~a tests passed.\n" tests))