#lang scheme/base

(require scheme/match
	 scheme/mpair
         scheme/control scheme/foreign
         (for-syntax scheme/base)
         (prefix-in m: mzlib/match)
         (only-in srfi/13 string-contains)
         rackunit)

(define-syntax (comp stx)
  (syntax-case stx ()
    [(mytest tst exp)
     #`(test-case (format "test: ~a" (syntax->datum (quote-syntax tst)))
                       #,(syntax/loc stx (check-equal? tst exp)))]))

(define-struct X (a b c))
(define-match-expander X:
  (lambda (stx)
    (syntax-case stx ()
      [(_ . args) #'(struct X args)])))

(define (f x y)
  (match*
   (x y)
   [((box a) (box b)) (+ a b)]
   [((vector x y z) (vector _)) (* x y z)]
   [((list a b c) (list d)) (+ a b c d)]
   [((cons a b) (cons c _))  (+ a b c)]))


(define (g x)
  (match x
    [1 'one]
    [(and x (? number?)) (list x 'num)]
    [(? boolean?) 'bool]
    [_ 'neither]))


(define (split l)
  (match l
    [(list (list a b) ...) (list a b)]
    [_ 'wrong]))

(define (split2 l)
  (match l
    [(list (list a b) ..2 rest) (list a b rest)]
    [_ 'wrong]))


(define-struct empt ())


(provide new-tests)

(define new-tests
  (test-suite
   "new tests for match"

   (comp
    1
    (match (list 1 2 3)
      [(list x ...) (=> unmatch)
                    (if (= (car x) 1)
                        (begin (+ 100 (unmatch))
                               (error 'bad))
                        0)]
      [_ 1]))

   (comp
    '(1 2 3)
    (match (vector 1 2 3)
      [(vector (? number? x) ...) x]
      [_ 2]))

   (comp
    2
    (match (vector 'a 1 2 3)
      [(vector (? number? x) ...) x]
      [_ 2]))

   (comp
    3
    (match (list 'a 1 2 3)
      [(vector (? number? x) ...) x]
      [_ 3]))


   (comp -1
         (match (vector 1 2 3)
           [(or (list x) x) -1]
           [(list a b c) 0]
           [(vector a) 1]
           [(vector a b) 2]
           [(vector a b c) 3]
           [(box _) 4]))

   (comp 12
         (match (list 12 12)
           [(list x x) x]
           [_ 13]))
   (comp 13
         (match (list 1 0)
           [(list x x) x]
           [_ 13]))


   (comp
    6
    (let ()
      (match (make-X 1 2 3)
        [(struct X (a b c)) (+ a b c)]
        [(box a) a]
        [(cons x y) (+ x y)]
        [_ 0])))

   (comp
    6
    (let ()
      (match (make-X 1 2 3)
        [(X a b c) (+ a b c)]
        [(box a) a]
        [(cons x y) (+ x y)]
        [_ 0])))


   (comp
    6
    (match (make-X 1 2 3)
      [(X: a b c) (+ a b c)]))



   (comp
    '(6 3 100 6)
    (list
     (f (cons 1 2) (cons 3 4))
     (f (box 1) (box 2))
     (f (list 10 20 30) (list 40))
     (f (vector 1 2 3) (vector 4))))

   (comp '(one (2 num) bool neither)
         (list
          (g 1)
          (g 2)
          (g #f)
          (g "foo")))

   (comp
    (split (list (list 1 2) (list 'a 'b) (list 'x 'y)))
    '((1 a x) (2 b y)))
   (comp
    (split2 (list (list 1 2) (list 'a 'b) (list 'x 'y)))
    '((1 a) (2 b) (x y)))

   (comp
    'yes
    (match (list (box 2) 2)
      [(list (or (box x) (list x)) x) 'yes]
      [_ 'no]))

   (comp
    'no
    (parameterize ([match-equality-test eq?])
      (match (list (cons 1 1) (cons 1 1))
        [(list x x) 'yes]
        [_ 'no])))

   (comp
    'no
    (match (list (box 2) 3)
      [(list (or (box x) (list x)) x) 'yes]
      [_ 'no]))

   (comp
    2
    (match (list 'one 'three)
      [(list 'one 'two) 1]
      [(list 'one 'three) 2]
      [(list 'two 'three) 3]))
   (comp
    2
    (match (list 'one 'three)
      [(cons 'one (cons 'two '())) 1]
      [(cons 'one (cons 'three '())) 2]
      [(cons 'two (cons 'three '())) 3]))

   (comp 'yes
         (match '(1 x 2 y 3 z)
           [(list-no-order 1 2 3 'x 'y 'z) 'yes]
           [_ 'no]))

   ;; NOT WORKING YET
   (comp '(x y z)
         (match '(1 x 2 y 3 z)
           [(list-no-order 1 2 3 r1 r2 r3) (list r1 r2 r3)]
           [_ 'no]))

   (comp '(x y z)
         (match '(1 x 2 y 3 z)
           [(list-no-order 1 2 3 rest ...) rest]
           [_ 'no]))

   (comp
    'yes
    (match '(a (c d))
      [(list-no-order 'a
                      (? pair?
                         (list-no-order 'c 'd)))
       'yes]
      [_ 'no]))


   (comp
    '((1 2) (a b 1 2))
    (let ()
      (define-syntax-rule (match-lambda . cl)
        (lambda (e) (match e . cl)))

      (define (make-nil)
        '())
      (define nil? null?)

      (define make-::
        (match-lambda
          ((list-no-order (list '|1| a) (list '|2| d))
           (cons a d))))
      (define ::? pair?)
      (define (::-content p)
        (list (list '|1| (car p))
              (list '|2| (cdr p))))

      (define my-append
        (match-lambda
          ((list-no-order (list '|1| (? nil?))
                          (list '|2| l))
           l)
          ((list-no-order (list '|1| (? ::?
                                        (app ::-content (list-no-order (list
                                                                        '|1| h) (list '|2| t)))))
                          (list '|2| l))
           (make-:: (list (list '|1| h)
                          (list '|2| (my-append (list (list '|1| t) (list '|2|
                                                                          l)))))))))
      (list
       (my-append (list (list '|1| '())
                        (list '|2| '(1 2))))

       (my-append (list (list '|1| '(a b))
                        (list '|2| '(1 2)))))))


   (comp
    'yes
    (match
        (make-immutable-hasheq '((|1| . (a b))))
      [(hash-table ('|1| (app (lambda (p)
                                (make-immutable-hasheq
                                 (list (cons '|1| (car p))
                                       (cons '|2| (cdr p)))))
                              (hash-table ('|1| _) ('|2| _))))) 'yes]
      [_ 'no]))

   ;; examples from docs

   (comp 'yes
         (match '(1 2 3)
           [(list (not 4) ...) 'yes]
           [_ 'no]))

   (comp 'no
         (match '(1 4 3)
           [(list (not 4) ...) 'yes]
           [_ 'no]))

   (comp 1
         (match '(1 2)
           [(or (list a 1) (list a 2)) a]
           [_ 'bad]))

   (comp '(2 3)
         (match '(1 (2 3) 4)
           [(list _ (and a (list _ ...)) _) a]
           [_ 'bad]))



   (comp
    'yes
    (match "apple"
      [(regexp #rx"p+(.)" (list _ "l")) 'yes]
      [_ 'no]))
   (comp
    'no
    (match "append"
      [(regexp #rx"p+(.)" (list _ "l")) 'yes]
      [_ 'no]))


   (comp
    'yes
    (match "apple"
      [(regexp #rx"p+" ) 'yes]
      [_ 'no]))
   (comp
    'no
    (match "banana"
      [(regexp #rx"p+") 'yes]
      [_ 'no]))

   (comp
    '(0 1)
    (let ()
      (define-struct tree (val left right))

      (match (make-tree 0 (make-tree 1 #f #f) #f)
        [(struct tree (a (struct tree (b  _ _)) _)) (list a b)]
        [_ 'no])))

   (comp 1
         (match #&1
           [(box a) a]
           [_ 'no]))
   (comp '(2 1)
         (match #hasheq(("a" . 1) ("b" . 2))
           [(hash-table ("b" b) ("a" a)) (list b a)]
           [_ 'no]))

   (comp #t
         (andmap string?
                 (match #hasheq(("b" . 2) ("a" . 1))
                   [(hash-table (key val) ...) key]
                   [_ 'no])))

   (comp
    (match #(1 (2) (2) (2) 5)
      [(vector 1 (list a) ..3 5) a]
      [_ 'no])
    '(2 2 2))

   (comp '(1 3 4 5)
         (match '(1 2 3 4 5 6)
           [(list-no-order 6 2 y ...) y]
           [_ 'no]))

   (comp 1
         (match '(1 2 3)
           [(list-no-order 3 2 x) x]))
   (comp '((1 2 3) 4)
         (match '(1 2 3 . 4)
           [(list-rest a ... d) (list a d)]))

   (comp 4
         (match '(1 2 3 . 4)
           [(list-rest a b c d) d]))

   ;; different behavior from the way match used to be
   (comp '(2 3 4)
         (match '(1 2 3 4 5)
           [(list 1 a ..3 5) a]
           [_ 'else]))

   (comp '((1 2 3 4) ())
         (match (list 1 2 3 4 5)
           [(list x ... y ... 5) (list x y)]
           [_ 'no]))

   (comp '((1 3 2) (4))
         (match (list 1 3 2 3 4 5)
           [(list x ... 3 y ... 5) (list x y)]
           [_ 'no]))

   (comp '(3 2 1)
         (match '(1 2 3)
           [(list a b c) (list c b a)]))

   (comp '(2 3)
         (match '(1 2 3)
           [(list 1 a ...) a]))

   (comp 'else
         (match '(1 2 3)
           [(list 1 a ..3) a]
           [_ 'else]))

   (comp '(2 3 4)
         (match '(1 2 3 4)
           [(list 1 a ..3) a]
           [_ 'else]))

   (comp
    '(2 2 2)
    (match '(1 (2) (2) (2) 5)
      [(list 1 (list a) ..3 5) a]
      [_ 'else]))

   (comp
    #t
    (match "yes"
      ["yes" #t]
      ["no" #f]))

   (comp 3
         (match '(1 2 3)
           [(list _ _ a) a]))
   (comp '(3 2 1)
         (match '(1 2 3)
           [(list a b a) (list a b)]
           [(list a b c) (list c b a)]))

   (comp '(2 '(x y z) 1)
         (match '(1 '(x y z) 2)
           [(list a b a) (list a b)]
           [(list a b c) (list c b a)]))

   (comp '(1 '(x y z))
         (match '(1 '(x y z) 1)
           [(list a b a) (list a b)]
           [(list a b c) (list c b a)]))

   (comp '(2 3)
         (match '(1 2 3)
           [`(1 ,a ,(? odd? b)) (list a b)]))

   (comp '(2 1 (1 2 3 4))
         (match-let ([(list a b) '(1 2)]
                     [(vector x ...) #(1 2 3 4)])
           (list b a x)))



   (comp '(1 2 3 4)
         (match-let* ([(list a b) '(#(1 2 3 4) 2)]
                      [(vector x ...) a])
           x))

   (comp 2
         (let ()
           (match-define (list a b) '(1 2))
           b))

   (comp 'yes
         (match '(number_1 . number_2)
           [`(variable-except ,@(list vars ...))
            'no]
           [(? list?)
            'no]
           [_ 'yes]))

   (comp "yes"
         (match
             '((555))
           ((list-no-order (and (list 555)
                                (list-no-order 555)))
            "yes")
           (_ "no"))) ;; prints "no"

   (comp "yes"
         (match
             '((555))
           ((list-no-order (and (list-no-order 555)
                                (list 555)))
            "yes")
           (_ "no"))) ;; prints "yes"

   (comp "yes"
         (match
             '((555))
           ((list (and (list 555)
                       (list-no-order 555)))
            "yes")
           (_ "no"))) ;; prints "yes"

   (comp  '("a") (match "a"  ((regexp #rx"a" x) x)))
   (comp  '(#"a")
          (match #"a"
            ((regexp #rx"a" x) x)
            [_ 'no]))

   (comp 'yes (match #"a" (#"a" 'yes)))

   (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand #'(match-lambda ((a ?) #f))) 'no))
   (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand #'(match-lambda ((?) #f))) 'no))

   (comp
    'yes
    (let ()

      (m:define-match-expander exp1
                               #:plt-match
                               (lambda (stx)
                                 (syntax-case stx ()
                                   ((_match (x y))
                                    #'(list (list x y))))))

      (m:define-match-expander exp2
                               #:plt-match
                               (lambda (stx)
                                 (syntax-case stx ()
                                   ((_match x y)
                                    #'(exp1 (x y))))))

      (define (test tp)
        (match tp ((exp2 x y) x)))
      'yes))
   (comp '(a b c)
         (match '(a b c)
           [(list-rest foo) foo]))
   (comp 2
         (let ()
           (define (foo x) (match x [1 (+ x x)]))
           (foo 1)))


   (comp 'yes
         (match (make-empt)
           [(struct empt ()) 'yes]
           [_ 'no]))

   (comp 'yes
         (m:match (make-empt)
                  [($ empt) 'yes]
                  [_ 'no]))

   (comp 3
         (match (mcons 1 2)
           [(mcons a b) (+ a b)]
           [_ 'no]))

   (comp 3
         (match (mlist 1 2)
           [(mlist a b) (+ a b)]
           [_ 'no]))

   (comp 3
         (match (mlist 1 2)
           [(mlist a ...) (apply + a)]
           [_ 'no]))

   (comp 1
         (match (box 'x) ('#&x 1) (else #f)))

   (comp 2
         (match (vector 1 2) ('#(1 2) 2) (else #f)))

   (comp 'yes
         (with-handlers ([exn:fail? (lambda _ 'yes)]
                         [values (lambda _ 'no)])
                (match 1)
                'no))

   (comp 'yes
         (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]
                         [values (lambda _ 'no)])
           (expand #'(let ()
                       (define-struct foo (bar))
                       (define the-bar (match (make-foo 42)
                                         [(struct foo bar) ;; note the bad syntax
                                          bar]))
                       0))))

   ;; raises error
   (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])
                (expand (quote-syntax (match '(1 x 2 y 3 z)
                                        [(list-no-order 1 2 3 rest ... e) rest]
                                        [_ 'no])))
                'no))
   (comp '((2 4) (2 1))
         (match '(3 2 4 3 2 1)
           [(list x y ... x z ...)
            (list y z)]))

   (comp '(1 2)
         (match-let ([(vector a b) (vector 1 2)])
                    (list a b)))

   (comp '(4 5)
         (let-values ([(x y)
                       (match 1
                         [(or (and x 2) (and x 3) (and x 4)) 3]
                         [_ (values 4 5)])])
           (list x y)))

   (comp 'bad
         (match #(1)
           [(vector a b) a]
           [else 'bad]))

   (comp '(1 2)
         (call-with-values
          (lambda ()
            (match 'foo [_ (=> skip) (skip)] [_ (values 1 2)]))
          list))
   (comp 0
         (let ([z (make-parameter 0)])
           (match 1
             [(? number?) (=> f) (parameterize ([z 1]) (f))]
             [(? number?) (z)])))

   ;; make sure the prompts don't interfere
   (comp 12
         (%
          (let ([z (make-parameter 0)])
            (match 1
              [(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))]
              [(? number?) (z)]))
          (lambda _ 12)))


   (comp 4
	 (match 3
	  [(or) 1]
	  [_ 4]))

   (comp '((1 2) 3)
         (match `(begin 1 2 3)
           [`(begin ,es ... ,en)
            (list es en)]))

   (comp '(a b c)
	 (let ()

	   (define-struct foo (a b c) #:prefab)
	   (match (make-foo 'a 'b 'c)
		  [`#s(foo ,x ,y ,z)
		   (list x y z)])))
   (comp '(a b c)
	 (let ()

	   (define-struct foo (a b c) #:prefab)
	   (define-struct (bar foo) (d) #:prefab)
	   (match (make-bar 'a 'b 'c 1)
		  [`#s((bar foo 3) ,x ,y ,z ,w)
		      (list x y z)])
	   ))
   (comp "Gotcha!"
         (let ()
           (define-cstruct _pose
             ([x _double*]
              [y _double*]
              [a _double*]))

           (match (make-pose 1 2 3)
             [(struct pose (x y a)) "Gotcha!"]
             [else "Epic fail!"])))

   (comp #f
         (match (list 'a 'b 'c)
           [(or (list a b)
                (and (app (lambda _ #f) b)
                     (or (and (app (lambda _ #f) a)
                              (list))
                         (list a))))
            #t]
           [_ #f]))

   (comp '(2 7)
         (let ()
           (define-match-expander foo
             (syntax-rules () [(_) 1])
             (syntax-id-rules (set!)
               [(set! _ v) v]
               [(_) 2]))
           (list (foo)
                 (set! foo 7))))

   (comp 0
         (let ()
           (define-match-expander foo
             (syntax-id-rules () [_ 10]))
           (match 10
             [(foo) 0]
             [_ 1])))

   (comp '(1 2 4)
         (call-with-values
           (λ () (match-let-values ([(x y) (values 1 2)] [(3 w) (values 3 4)])
                   (values x y w)))
           list))

   (comp '(1 3 4)
         (call-with-values
           (λ () (match-let*-values ([(x y) (values 1 2)] [(y w) (values 3 4)])
                   (values x y w)))
           list))

   (comp '(1 2 3)
         (match/values (values 1 2 3)
           [(x y z) (list x y z)]))

   (comp '(1 2)
         (let () (match-define-values (x y 3) (values 1 2 3))
              (list x y)))

   (comp '(1 2 3)
         (match-let ([(list x y) (list 1 2)] [(list y z) '(2 3)])
            (list x y z)))

   (comp 'yes (match/values (values 1 2) [(x y) 0 'yes] [(_ _) 'no]))

   (comp 'yes
         (with-handlers ([exn:fail? (lambda _ 'yes)]
                         [values (lambda _ 'no)])
           (match-let ([(list x y) (list 1 22)] [(list y z) '(2 3)])
                      (list x y z))))


))