(load "../common")

(mtest
  (if-match 1 1 'yes 'no) yes
  (if-match 1 0 'yes 'no) no)

(test (let ((sym 'a))
        (list (if-match a sym 'yes 'no)
              (if-match b sym 'yes 'no)))
      (yes no))

(mtest
  (when-match @a 42 (list a)) (42)
  (when-match (@nil) '(1) 'yes) yes
  (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1)
  (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1))

(test (if-match (@(oddp @a) @b @c . @d) '(2 x y z)
        (list a b c d)
        :no-match)
      :no-match)

(mtest
  (if-match (1 2 . @a) '(1 2 3 4) a) (3 4)
  (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) (3 4)
  (if-match #() #() :yes :no) :yes
  (if-match #() #(1) :yes :no) :no
  (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b)) (2 4))

(test (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1)
        m)
      1)

(defstruct widget ()
  name
  value)

(defstruct grommet ()
  name
  value)

(vtest (append-each ((obj (list (new grommet name "foo" value :grom)
                                (new widget name "foo" value :widg))))
         (when-match @(struct @type name "foo" value @v) obj
           (list (list type v))))
       ^((,(find-struct-type 'grommet) :grom)
         (,(find-struct-type 'widget) :widg)))

(mtest
  (when-match @(as w (@a @b @c)) '(1 2 3) (list w a b c)) ((1 2 3) 1 2 3)
  (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b)) (z z))

(test (if-match @(require (+ @a @b) (equal a b)) '(+ y z)
        (list a b)
        :no-match)
      :no-match)

(test (when-match @(all (x @a @b)) '((x 1 a) (x 2 b) (x 3 c))
        (list a b))
      ((1 2 3) (a b c)))

(test (when-match (@x @(all @x)) '(1 (1 1 1 1)) x) 1)

(test (when-match (@x @(all @x)) '(1 (1 1 1 2)) x) nil)

(test (when-match @(some (x @a @b)) '((y 1 a) (x 2 b) (z 3 c))
        (list a b))
      (2 b))

(test (when-match @(coll (x @a @b)) '((y 1 a) (x 2 b) (z 3 c) (x 4 d))
            (list a b))
      ((2 4) (b d)))

(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
        (list x y z))
      (1 2 3))

(test (if-match @(and (@x 1) (1 @x)) '(1 1) x) 1)
(test (if-match @(and (@x 1) (1 @x)) '(1 2) x) nil)

(test (when-match @(all @(or (@x @y) @z)) '((1 2) (3 4)) (list x y z))
      ((1 3) (2 4) (nil nil)))

(test (let ((a 1) (b 2) (c 3))
        (if-match @(or @a @b @c) 2
          (list a b c)))
      (1 2 3))

(test (when-match @(or @(all @x)) '(1 2 3) x) (1 2 3))

(test (when-match (foo @(all @x)) '(bar (1 2 . 3)) x) nil)

(test (when-match (@(or foo) @(all @x)) '(bar (1 2 . 3)) x) nil)

(test (when-match (@(oddp) @(all @x)) '(2 (1 2 . 3)) x) nil)

(mtest
  (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2
  (if-match @(<= 10 @a 13) 11 :yes :no) :yes
  (when-match @(as x @(<= 10 @a 13)) 11 x) 11
  (when-match (@(evenp) @(oddp @x)) '(2 3) x) 3
  (when-match @(<= 1 @x 10) 4 x) 4
  (when-match @(@d (chr-digit @c)) #\5 (list d c)) (5 #\5)
  (when-match @(or @(require @a (oddp a)) @b @c) 2 (list a b c)) (nil 2 nil)
  (when-match @(@x (< . @sym)) '(1 2 3) (list x sym)) (t (1 2 3))
  (when-match @(@x (< . @sym)) '(3 2 1) (list x sym)) nil
  (let ((x t))
    (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) (t (1 2 3))
  (let ((x nil))
    (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) nil
  (if-match (@(or @a) @a) '(1 2) a :no) :no
  (if-match (@(and @a) @a) '(1 2) a :no) :no)


(test
  (collect-each ((obj (list '(1 2 3)
                            '(4 5)
                            '(3 5)
                            #S(time year 2021 month 1 day 1)
                            #(vec tor))))
    (match-case obj
      (@(struct time year @y) y)
      (#(@x @y) (list x y))
      ((@nil @nil @x) x)
      ((4 @x) x)
      ((@x 5) x)))
  (3 5 3 2021 (vec tor)))

(test (when-match (@(and @a @b) (x . @c)) '(1 (x 2 3 4)) c) (2 3 4))

(test (when-match (@(some @a) . @b) '((1 2 3) 2) (list a b)) (1 (2)))

(set *print-circle* t)

(test (when-match @(as a @(some @a)) '#1=(1 2 #1# 3) :yes) :yes)

(test (when-match (@a @(as a @(some @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)

(test (when-match (@a @(as a @(or x @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)

(test (when-match (@(with @a x 42) @b @c) '(1 2 3) (list a b c x))
      (1 2 3 42))

(test (let ((o 3))
        (when-match (@(evenp @x) @(with @z @(oddp @y) o)) '(4 6)
          (list x y z)))
      (4 3 6))

(test (let ((o 3))
        (when-match (@(evenp @x) @(with @(oddp @y) o)) '(4 6)
          (list x y)))
      (4 3))

(defstruct node ()
  left right)

(mlet ((n (lnew node left (new node left n))))
  (test (when-match @(as x @(struct node
                                     left @(struct node left @x)))
                    n :yes)
        :yes))

(test
  (collect-each ((obj (list '(1 2 3)
                            '(4 5)
                            '(3 5)
                            '(6 2 6)
                            #(11 12)
                            #S(time year 2021 month 1 day 2)
                            #S(time year 2020 month 1 day 1)
                            #(vec tor))))
    (match-case obj
      (@(struct @s year 2021 day @d) (list d (struct-type-name s)))
      (@(struct time year @y month @x day @x) (list y x))
      (#(@(integerp @x) @(require @y (succ x))) (list x y))
      (#(@x @y) (list x y))
      ((@x @nil @x) x)
      ((@nil @nil @x) x)
      ((4 @x) x)
      ((@x 5) x)))
  (3 5 3 6 (11 12) (2 time) (2020 1) (vec tor)))

(test (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
      42)

(test (when-match @(hash (x @y) (@(symbolp @y) @datum)) #H(() (x k) (k 42)) datum)
      (42))

(mtest
  (when-match @(hash (a)) #H(() (a b)) t) t
  (when-match @(hash (c)) #H(() (a b)) t) nil
  (let ((x 'a)) (when-match @(hash (@x)) #H(() (a b)) t)) t
  (let ((x 'd)) (when-match @(hash (@x)) #H(() (a b)) t)) nil
  (when-match @(hash (@x)) #H(() (a b)) x) (a))

(mtest
  (if-match #R(10 20) 10..20 :yes :no) :yes
  (if-match #R(10 20) #R(10 20) :yes :no) :yes
  (if-match #R(10 20) #R(1 2) :yes :no) :no
  (when-match #R(@a @b) 1..2 (list a b)) (1 2)
  (when-match #R(@a 2) 1..2 a) 1
  (when-match #R(1 @a) 1..2 a) 2
  (when-match #R(2 @a) 1..2 a) nil
  (when-match #R(@a 1) 1..2 a) nil)

(mtest
  (when-match @a..@b '1..2 (list a b)) (1 2)
  (when-match (rcons @a @b) '(rcons 1 2) (list a b)) (1 2))

(test (let ((h #H(() (a 1) (b 2))))
        (when-match @[h @x] 'a x))
      a)

(test (let ((h #H(() (a 1) (b 2))))
        (when-match @(@y [h @x]) 'a (list x y)))
      (a 1))

(test
  (let ((f (lambda-match
             (() (list 0 :args))
             ((@a) (list 1 :arg a))
             ((@a @b) (list 2 :args a b))
             ((@a @b . @c) (list* '> 2 :args a b c)))))
    (list [f] [f 1] [f 1 2] [f 1 2 3]))
  ((0 :args) (1 :arg 1) (2 :args 1 2) (> 2 :args 1 2 3)))

(test
  [(lambda-match
     ((0 1) :zero-one)
     ((1 0) :one-zero)
     ((@x @y) :no-match)) 1 0]
  :one-zero)

(test
  [(lambda-match
     ((0 1) :zero-one)
     ((1 0) :one-zero)
     ((@x @y) :no-match)) 1 1]
  :no-match)

(compile-only
  (eval-only
    (test
      [(lambda-match
         ((0 1) :zero-one)
         ((1 0) :one-zero)
         ((@x @y) :no-match)) 1 2 3]
      :error)))

(defun-match fib
  ((0) 1)
  ((1) 1)
  ((@x) (+ (fib (pred x)) (fib (ppred x)))))

(mtest
  (fib 0) 1
  (fib 1) 1
  (fib 2) 2
  (fib 3) 3
  (fib 4) 5
  (fib 5) 8)

(defun-match ack
  ((0 @n) (+ n 1))
  ((@m 0) (ack (- m 1) 1))
  ((@m @n) (ack (- m 1) (ack m (- n 1)))))

(mtest
  (ack 1 1) 3
  (ack 2 2) 7)

(defun x-x-y (list x)
  (when-match (@x @x @y) list y))

(mtest
  (x-x-y '(1 1 2) 1) 2
  (x-x-y '(1 2 3) 1) nil
  (x-x-y '(1 1 2 r2) 1) nil)

(test (let ((a 3) (x 0))
        (match-case '(3 2 1)
          ((@x 2 @b) ^(1 ,b))
          ((@a 2 @b) ^(2 ,a))))
      (2 3))

(test
  (let ((a 3) (x 0))
    (labels ((local (:match)
               ((@x 2 @b) ^(1 ,b))
               ((@a 2 @b) ^(2 ,a))))
      (local 3 2 1)))
  (2 3))

(test
  (when-match @(sme (1 2) (3 4) (5 . 6) m e)
              '(1 2 3 4 5 . 6)
    (list m e))
   ((3 4 5 . 6) (5 . 6)))

(test
  (when-match @(sme (1 2) (3 4) (5 . 6) m d)
              '(1 2 abc 3 4 def 5 . 6)
    (list m d))
  ((3 4 def 5 . 6) (5 . 6)))

(test
  (when-match @(sme (1 2 @x . @y) (4 @z) 6)
              '(1 2 abc 3 4 def 5 . 6)
    (list x y z))
  (abc (3 4 def 5 . 6) def))

(mtest
  (when-match @(sme (1 2) (2 3) (4)) '(1 2 3 4) t) nil
  (when-match @(sme (1 2) (3 4) (4)) '(1 2 3 4) t) nil
  (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) nil
  (when-match @(sme (1 2 . @x) (3 . @y) (4)) '(1 2 3 4) t) t
  (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4) t) t
  (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4 . 5) t) nil)

(test (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2)
        (list x y z))
      (1 2 3))

(test (when-match @(and @(sme (1 @x) (3) (7) m n)
                        @(with @(coll @(oddp @y)) (ldiff m n)))
                  '(1 2 3 4 5 6 7)
        (list x y))
      (2 (3 5)))

(test (when-match @(sme () () 5) 5 t) t)

(mtest
  (when-match @(end 3 x) 3 x) 3
  (when-match @(end (2 @x) y) '(1 2 3) (list x y)) (3 (2 3))
  (when-match @(end (2 . @x) y) '(1 2 . 3) (list x y)) (3 (2 . 3)))

(test (when-match @(as z @(end (2 @x) y)) '(1 2 3) (list x y z))
      (3 (2 3) (1 2 3)))

(defmatch env (var :env e)
  ^@(with ,var ',e))

(test (when-match @(and @a @(env e) @b) 42
        (list a (env-vbindings e) (lexical-var-p e 'a) (lexical-var-p e 'b) b))
      (42 ((a . sys:special)) t nil 42))

(defmatch var= (sym :env e)
  (if (lexical-var-p e sym)
    (with-gensyms (obj)
      ^@(require (sys:var ,obj) (= ,sym ,obj)))
    ^(sys:var ,sym)))

(test (when-match (@(var= a) @(var= a)) '(1 1.0) a) 1)

(mtest
  (when-match `` "" t) t
  (when-match `abc` "abc" t) t
  (when-match `@a` "abc" a) "abc")

(mtest
  (when-match `@a@b` "abc" a) :error
  (when-match `@nil@b` "abc" a) :error
  (when-match `@nil@nil` "abc" a) :error
  (when-match `@a@nil` "abc" a) :error)

(mtest
  (when-match `@a-$` "a-$" a) "a"
  (when-match `#@a-$` "#a-$" a) "a"
  (when-match `#@a-$` "#a-$$" a) nil
  (when-match `#@a-$` "#a-" a) nil
  (when-match `#@a-@b` "#a-$" (list a b)) ("a" "$")
  (when-match `#@{a #/ab*c/}` "#abbbc" a) "abbbc"
  (when-match `#@{a #/ab*c/}d` "#abbbcd" a) "abbbc"
  (when-match `#@{a 3}@b` "#abb" a) "abb"
  (when-match `#@{a 3}@b` "#abbbc" (list a b)) ("abb" "bc")
  (when-match `#@{a 4}@b` "#abb" a) nil
  (when-match `#@{a 3}` "#abb" a) "abb"
  (when-match `#@{a 2}` "#abb" a) nil
  (when-match `#@{a 4}` "#abb" a) nil)

(let ((z 0))
  (mtest
    (when-match `@z#@a-$` "0#a-$" a) "a"
    (when-match `@z#@a-$` "0#a-$$" a) nil
    (when-match `@z#@a-$` "0#a-" a) nil
    (when-match `@z#@a-@b` "0#a-$" (list a b)) ("a" "$")
    (when-match `@z#@{a #/ab*c/}` "0#abbbc" a) "abbbc"
    (when-match `@z#@{a #/ab*c/}d` "0#abbbcd" a) "abbbc"
    (when-match `@z#@{a 3}@b` "0#abb" a) "abb"
    (when-match `@z#@{a 3}@b` "0#abbbc" (list a b)) ("abb" "bc")
    (when-match `@z#@{a 4}@b` "0#abb" a) nil
    (when-match `@z#@{a 3}` "0#abb" a) "abb"
    (when-match `@z#@{a 2}` "0#abb" a) nil
    (when-match `@z#@{a 4}` "0#abb" a) nil))

(test (when-match `#@{a 4 5}` "#abb" a) :error)

(let ((b "bcd"))
  (mtest
    (when-match `@a@b` "abcd" a) "a"
    (when-match `@a@{b [1..:]}` "acd" a) "a"
    (when-match `@a@{b [1..:]}` "abcd" a) "ab"
    (when-match `@a@{b [0..1]}` "abcd" a) nil
    (when-match `@a@{b [0..2]}d` "abcd" a) "a"))

(let ((x 123) (z 0))
  (mtest
    (when-match `^@{x 5}$` "^123  $" t) t
    (when-match `^@{x -5}$` "^  123$" t) t
    (when-match `@x@x` "123123" t) t
    (when-match `@x@{x [1..:]}` "12323" t) t
    (when-match `@z^@{x 5}$` "0^123  $" t) t
    (when-match `@z^@{x -5}$` "0^  123$" t) t
    (when-match `@z@x@x` "0123123" t) t
    (when-match `@z@x@{x [1..:]}` "012323" t) t))

(let ((a "$"))
  (test (when-match `@a-@b` "$-@" b) "@"))

(test
  (build
    (each-match (`(@a) @b-@c` '("x"
                                ""
                                "(311) 555-5353"
                                "(604) 923-2323"
                                "133"
                                "4-5-6-7")
                 @x 1)
     (add (list x a b c))))
  ((3 "311" "555" "5353") (4 "604" "923" "2323")))

(test
  (append-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
                   (@x :bar) '((1 :bar)  (2 :bar) (3 :bar) (4 :foo)))
    (list x y))
  (1 a 3 c))

(test
  (append-matches (@x '((1) (2) (3) 4)) x)
  (1 2 3 . 4))

(test
  (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
                 (@x :bar) '((1 :bar)  (2 :bar) (3 :bar) (4 :foo)))
    (list x y))
  ((1 a) (3 c)))

(test
  (build
    (each-match-product (`(@a) @b-@c` '("x"
                                        ""
                                        "(311) 555-5353"
                                        "(604) 923-2323"
                                        "133"
                                        "4-5-6-7")
                         @(oddp @x) '(1 2 3))
     (add (list x a b c))))
  ((1 "311" "555" "5353") (3 "311" "555" "5353")
   (1 "604" "923" "2323") (3 "604" "923" "2323")))

(test
  (append-match-products (@(oddp @x) (range 1 5)
                          @(evenp @y) (range 1 5))
    (list x y))
  (1 2 1 4 3 2 3 4 5 2 5 4))

(test
  (keep-match-products (@(oddp @x) (range 1 5)
                        @(evenp @y) (range 1 5))
    (list x y))
  ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4)))

(mtest
  (when-match ^(,a ,b) '(1 2) (list a b)) (1 2)
  (when-match ^(,(oddp @a) ,(evenp @b)) '(1 2) (list a b)) (1 2)
  (when-match ^#(,a ,b) #(1 2) (list a b)) (1 2)
  (when-match ^#S(,type year ,y) #S(time year 2021)
    (list (struct-type-name type) y)) (time 2021)
  (when-match ^#H(() (x ,y) (,(symbolp @y) ,datum))
              #H(() (x k) (k 42))
              datum) (42))

(mtest
  (when-match ^#J~a 42.0 a) 42.0
  (when-match ^#J[~a, ~b] #J[true, false] (list a b)) (t nil)
  (when-match ^#J{"x" : ~y, ~(symbolp @y) : ~datum}
              #J{"x" : true, true : 42}
              datum) (42.0)
  (when-match ^#J{"foo" : {"x" : ~val}} #J{"foo" : {"x" : "y"}} val) "y")

(test
  (let ((a '(1 2 3 4)))
    (build
      (while-match @(true @x) (pop a)
        (add (* 10 x)))))
  (10 20 30 40))

(test
  (let ((a '(1 (2 3) 4 (5 6))))
    (build
      (while-match-case (pop a)
        ((@x @y) (add :pair x y))
        (@(numberp @x) (add :num x)))))
  (:num 1 :pair 2 3 :num 4 :pair 5 6))

(test
  (let ((a '(1 (2 3) 4 (5 6))))
    (build
      (while-true-match-case (pop a)
        ((@x @y) (add :pair x y))
        (@(evenp @x) (add :even x))
        (@(oddp @x) (add :odd x))
        (@else (error "unhandled case")))))
  (:odd 1 :pair 2 3 :even 4 :pair 5 6))

(compile-only
  (eval-only
    (compile-file (base-name *load-path*) "temp.tlo")
    (remove-path "temp.tlo")))