(import mew
        test
        (chicken port)
        (chicken condition))

(test-group "negate"
  (test #t ((negate not) #t))
  (test #f ((negate not) #f))
  (test #t ((negate even?) 5))
  (test #f ((negate even?) 6))
  (test #f ((negate (op)) 6))
  (test #t ((negate (op)) #f)))

(test-group "comp"
  (test 42 ((comp inc inc) 40))
  (test 43 ((comp inc *) 6 7))
  (test 42 ((comp) 42)))

(test-group "keys"
  (test '(1 2 3) (sort (keys (tbl 1 11 2 22 3 33)) <))
  (test-error (keys #(1 2 3))))

(test-group "vals"
  (test '(11 22 33) (sort (vals (tbl 1 11 2 22 3 33)) <))
  (test-error (vals #(1 2 3))))

(test-group "rand"
  (test #f (integer? (rand)))
  (test #t (integer? (rand 6)))
  (test #t (<= 2 (rand 2 6)))
  (test #t (< (rand 2 6) 6)))

(test-group "shuffle"
  (test #(1 2 3) (sort (shuffle #(3 2 1)) <))
  (test #f (=? (shuffle #(1 2 3 4 5 6 7 8 9 0))
               (shuffle #(1 2 3 4 5 6 7 8 9 0)))))

(test-group "shuffle!"
  (test #t (loc (v #(1 2 3)) (eq? v (shuffle! v))))
  (test #(1 2 3) (sort (shuffle! #(3 2 1)) <))
  (test #f (=? (shuffle! #(1 2 3 4 5 6 7 8 9 0))
               (shuffle! #(1 2 3 4 5 6 7 8 9 0)))))

(test-group "sample"
  (test #t ((one-of 1 2 3) (sample '(1 2 3))))
  (test #t ((one-of 1 2 3) (sample #(1 2 3))))
  (test #t ((one-of '(1 . 2) '(3 . 4)) (sample (tbl 1 2 3 4))))
  (test #t (string? (sample "foobar" 3)))
  (test 3 (len (sample "foobar" 3)))
  (test 2 (len (sample "fb" 3)))
  (test "" (sample "foobar" 0))
  (test "ooo" (sample "ooooo" 3))
  (test #(1 2 3) (sort (sample #(1 2 3) 3) <)))

(test-group "range"
  (test '(1 2 3) (into '() (range 1 4)))
  (test '() (into '() (range 4 1)))
  (test '(1 3 5) (into '() (range 1 6 2)))
  (test '(1 3 5) (into '() (range 1 7 2)))
  (test '(3 2 1) (into '() (range 3 0 -1)))
  (test '(2 3 4) (into '() (gtake (range 2) 3)))
  (test '(0 1 2) (into '() (gtake (range) 3)))
  (test '(1 3/2 2 5/2) (into '() (gtake (range 1 +inf.0 1/2) 4)))
  (test '(1 1 1 1) (into '() (gtake (range 1 +inf.0 0) 4))))

(test-group "cycle"
  (test '(1 2 3 1 2 3) (into '() (gtake (cycle 1 2 3) 6)))
  (test '(1 1 1 1 1 1) (into '() (gtake (cycle 1) 6)))
  (test-error (into '() (cycle))))

(test-group "div"
  (test 4 (div 8 2))
  (test 4 (div 9 2))
  (test 4 (div -9 -2))
  (test -5 (div -9 2))
  (test -5 (div 9 -2)))

(test-group "mod"
  (test 0 (mod 8 2))
  (test 1 (mod 9 2))
  (test 2 (mod 16 7))
  (test -5 (mod 16 -7))
  (test 5 (mod -16 7))
  (test -2 (mod -16 -7)))

(test-group "inc"
  (test 6 (inc 5))
  (test 0 (inc -1))
  (test 1.5 (inc 0.5))
  (test 3/2 (inc 1/2))
  (test-error (inc "foo")))

(test-group "dec"
  (test 4 (dec 5))
  (test -2 (dec -1))
  (test -0.5 (dec 0.5))
  (test -1/2 (dec 1/2))
  (test-error (dec "foo")))

(test-group "boolean"
  (test #f (boolean #f))
  (test #t (boolean #t))
  (test #t (boolean 1))
  (test #t (boolean "foo"))
  (test #t (boolean (void))))

(test-group "=?"
  (test #t (=?))
  (test #t (=? 1))
  (test #t (=? "foo" "foo"))
  (test #t (=? 1 1 1))
  (test #t (=? #(1 2 3) #(1 2 3)))
  (test #t (=? (tbl 1 2 3 4) (tbl 3 4 1 2)))
  (test #f (=? 4 5))
  (test #f (=? 4 5 6))
  (test #f (=? "foo" "bar"))
  (test #f (=? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
  (test #f (=? 4 5 4)))

(test-group "<>?"
  (test #t (<>? 4 5))
  (test #t (<>? 4 5 6))
  (test #t (<>? "foo" "bar"))
  (test #t (<>? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
  (test #f (<>? 4 5 4))
  (test #f (<>? "foo" "foo"))
  (test #f (<>? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 7))
  (test #t (<>? (tbl 1 2 3 4) (tbl 3 4 1 22)))
  (test #t (<>? (tbl 1 2 3 4) (tbl 3 4)))
  (test-error "error with no arguments" (<>?))
  (test-error "error with one argument" (<>? 42)))

(test-group "str"
  (test "456" (str 4 5 6))
  (test "foo#tbar" (str "foo" #t 'bar))
  (test "" (str)))

(test-group "prn"
  (test "1 2 3\n" (with-output-to-string (fun () (prn 1 2 3))))
  (test "\"a\" b #t\n" (with-output-to-string (fun () (prn "a" 'b #t))))
  (test "\n" (with-output-to-string (fun () (prn))))
  (test 3 (esc ret (with-output-to-string (fun () (ret (prn 1 2 3)))))))

(test-group "app"
  (test 15 (app + '(4 5 6)))
  (test 15 (app + 4 5 '(6)))
  (test 15 (app + 4 5 6 '()))
  (test 0 (app +)))

(test-group "seq"
  (test #t (void? (seq)))
  (test 1 (seq 1))
  (test 2 (seq 1 2))
  (test 3 (seq (def x 1)
               (set x (inc x))
               (set x (inc x))
               x)))

(test-group "def"
  (test "define variable"
        42 (let ()
             (def x (* 6 7))
             x))
  (test 42 (let ()
             (def x 23)
             (def x (* 6 7))
             x))
  (test "define lambda"
        81 (let ()
             (def (square x) (* x x))
             (square 9))))

(test-group "set"
  (test 42 (let ()
              (def x 6)
              (set x (* x 7))
              x))
  (test "return value"
        42 (let ()
             (def x 6)
             (set x (* x 7)))))

(test-group "esc"
  (test #t (void? (esc ret)))
  (test #t (void? (esc ret (ret))))
  (test 42 (esc ret
              (* 6 7)))
  (test 42 (esc ret
              (if #t
                (ret (* 6 7)))
              23))
  (test 23 (esc ret
              (if #f
                (ret (* 6 7)))
              23)))

(test-group "fin"
  (test 42 (fin 42))
  (test 42 (fin 42
                 23))
  (test '(42 43) (loc (r 0
                         s (fin (set r 43)
                                (set r 42)))
                     (list r s)))
  (test '(42 43) (loc (r 0
                         s (esc ret
                             (fin (ret (set r 43))
                                  (set r 42))))
                     (list r s)))
  (test 42 (loc (r 0)
             (and (test-error (fin (error "oh no") ;XXX
                                   (set r 42)))
                   r))))

(test-group "loc"
  (test #t (void? (loc ())))
  (test 42 (loc () 42))
  (test 42 (loc (a (* 6 7))
             a))
  (test 42 (loc (a 6
                 b (* a 7))
             b))
  (test 42 (loc ((a . b) '(42 2 3))
             a)))

(test-group "andloc"
  (test #t (void? (andloc ())))
  (test 42 (andloc () 42))
  (test 42 (andloc (a (* 6 7))
             a))
  (test 42 (andloc (a 6
                    b (* a 7))
             b))
  (test #t (andloc (a 6
                    c (even? a)
                    b (* a 7))
             c))
  (test #f (andloc (a 6
                    _ (odd? a)
                    b (* a 7))
             a)))

(test-group "fun*"
  (test 42 ((fun* ((a . b)) (* a b)) (cons 6 7))))

(test-group "op"
  (test 42 ((op) 42))
  (test '(42 43) (receive ((op) 42 43)))
  (test 42 ((op 42) 43))
  (test 42 ((op * 6 _) 7))
  (test 42 ((op * 2 _ 3) 7))
  (test 42 ((op - _ 3) 45))
  (test 42 ((op + _ _ _ (- _ _)) 14))
  (test 42 ((op 42)))
  (test 42 ((op 42) 1 2 3)))

(test-group "op*"
  (test 42 ((op* *) 6 7))
  (test 42 ((op* * 6) 7))
  (test 42 ((op* * 7) 2 3))
  (test 42 ((op* * 2 ... 3) 7)))

(test-group "rep"
  (test #t (void? (rep loop ())))
  (test 42 (rep loop (x 27 y 5)
              (if (> y 0)
                (loop (+ x y) (- y 1))
                x))))

(test-group "while"
  (test 42 (loc (x 27 y 5)
              (while (> y 0)
                (set x (+ x y))
                (set y (dec y)))
              x))
  (test 42 (loc (x 27 y 5)
              (while (> y 0)
                (def z (+ x y))
                (set x z)
                (set y (dec y)))
              x)))

(test-group "until"
  (test 42 (loc (x 27 y 5)
              (until (zero? y)
                (set x (+ x y))
                (set y (dec y)))
              x)))

(test-group "get"
  (test 42 (get '(41 42 43) 1))
  (test 42 (get #(41 42 43) 1))
  (test 42 (get (tbl 41 42) 41))
  (test #\o (get "foo" 1))

  (test-error (get '(41 42 43) 5))
  (test-error (get #(41 42 43) 5))
  (test-error (get (tbl 41 42) 5))
  (test-error (get "foo" 5))

  (test 42 (get '(1 2 3) 5 42))
  (test 42 (get #(1 2 3) 5 42))
  (test 42 (get (tbl 1 2) 5 42))
  (test #\o (get "foo" 5 #\o)))

(test-group "at"
  (test 42 (at '(41 42 43) 1))
  (test 42 (at #(41 42 43) 1))
  (test 42 (at (tbl 41 42) 41))
  (test #\o (at "foo" 1))

  (test-error (at '(41 42 43) 5))
  (test-error (at #(41 42 43) 5))
  (test-error (at (tbl 41 42) 5))
  (test-error (at "foo" 5))

  (test-group "setters"
    (test 42 (loc (x #(1 2 3))
                (set (at x 1) 42)
                (at x 1)))
    (test 42 (loc (x (tbl 1 2))
                (set (at x 1) 42)
                (at x 1)))
    (test #\o (loc (x "fox")
                  (set (at x 2) #\o)
                  (at x 2)))))

(test-group "tbl"
  (test-assert (hash-table? (tbl 1 2 3 4)))
  (test 0 (hash-table-size (tbl)))
  (test 42 (get (tbl 1 2 3 42) 3))
  (test-error (tbl 1 2 3)))

(test-group "set-at"
  (test #(0 42 0) (set-at #(0 0 0) 1 42))
  (test #t (=? (tbl 1 42) (set-at (tbl 1 11) 1 42)))
  (test "fox" (set-at "foo" 2 #\x))
  (test-error (set-at '(0 0 0) 1 42)))

(test-group "del-at"
  (test #t (=? (tbl 1 42) (del-at (tbl 0 41 1 42 2 43) 0 2)))
  (test-error (del-at "foo" 2)))

(test-group "empty?"
  (test-assert (empty? '()))
  (test-assert (empty? #()))
  (test-assert (empty? (tbl)))
  (test-assert (empty? ""))
  (test-assert (not (empty? #t)))
  (test-assert (not (empty? #f)))
  (test-assert (not (empty? '(1 2 3))))
  (test-assert (not (empty? #(1 2 3))))
  (test-assert (not (empty? "foo")))
  (test-assert (not (empty? (tbl 1 2 3 4)))))

(test-group "len"
  (test 0 (len '()))
  (test 0 (len #()))
  (test 0 (len (tbl)))
  (test 0 (len ""))
  (test 0 (len (generator)))
  (test 3 (len '(1 2 3)))
  (test 3 (len #(1 2 3)))
  (test 3 (len (tbl 1 11 2 22 3 33)))
  (test 3 (len "foo"))
  (test 3 (len (generator 5 6 7)))
  (test-error (len #t)))

; for

(test-group "eof"
  (test-assert (eof-object? (eof))))

; gconcatenate

(test-group "gpick"
  (test '(2 4 6) (into '() (gpick (fun (x) (if (even? x) x (eof)))
                                  (generator 1 2 3 4 5 6))))
  (test '(0 "" #f ()) (into '() (gpick (op) (generator 0 "" #f '())))))

; gwindow

(test-group "gsplit-on"
  (test '((1) (1) (3 7)) (into '() (gsplit-on even? (generator 1 2 1 2 3 7 0)))))

(test-group "gslice-when"
  (test '((1 2) (1 2 3) (0 7)) (into '() (gslice-when > (generator 1 2 1 2 3 0 7))))
  (test '() (into '() (gslice-when (op #t) (generator))))
  (test '((0)) (into '() (gslice-when (op #t) (generator 0))))
  (test '((0) (1)) (into '() (gslice-when (op #t) (generator 0 1)))))

; genumerate

; giterate

; gfix

(test-group "final"
  (test 3 (final (generator 1 2 3)))
  (test #t (void? (final (generator)))))

(test-group "odometer"
  (test '((0 0) (0 1) (0 2) (1 0) (1 1) (1 2)) (into '() (odometer 2 3)))
  (test '((0) (1) (2)) (into '() (odometer 3)))
  (test '() (into '() (odometer)))
  (test 1365 (len (odometer 3 5 7 13))))

(test-group "cross-product"
  (test '((a X) (a Y) (b X) (b Y) (c X) (c Y))
        (into '() (cross-product '(a b c) '(X Y))))
  (test '((a) (b) (c))
        (into '() (cross-product '(a b c))))
  (test '() (into '() (cross-product))))

(test-group "->"
  (test 6 (-> 3 -> inc -> + 2))
  (test 9 (-> #f -> or 7 -> + 2))
  (test 9 (-> 6 ->> or 7 -> + 2))
  (test 7 (-> 5 ok-> inc ok-> + 1))
  (test (err 7) (-> (err 7) ok-> inc ok-> + 1))
  (test 7 (-> (err 6) err-> + 1)))

; fun->

; fun->>

; set->

; ~?
(test-group "~?"
  (test '("o") (~? "foo" "o"))
  (test '("oo") (~? "foo" "o+"))
  (test #f (~? "bling" "o+"))
  (test #f (~? "foo" "^o"))
  (test-error (~? "bling" "+"))
  (test '("1,22" "1" "22") (~? "x1,22z" "([0-9]+),([0-9]+)")))

; gmatch

; gsplit

(test-group "slurp"
  (test #t (string? (slurp "/usr/bin/chicken-status")))
  (test-error (slurp "/dev/null/noexist")))

(test-group "lines"
  (test #t (string? ((lines "/usr/bin/chicken-status"))))
  (test-error (lines "/dev/null/noexist")))

(test-group "gen"
  (test '(1 2 3) (into '() (gen '(1 2 3))))
  (test '(1 2 3) (into '() (gen (gen '(1 2 3)))))
  (test '(1 2 3) (into '() (gen #(1 2 3))))
  (test '(#\1 #\2 #\3) (into '() (gen "123")))
  (test '((1 . 2)) (into '() (tbl 1 2)))
  (test-error (gen #t)))

(test-group "into"
  (test '(1 2 3) (into '() (generator 1 2 3)))
  (test '(4 1 2 3) (into '(4) (generator 1 2 3)))
  (test #(1 2 3) (into #() (generator 1 2 3)))
  (test #(4 1 2 3) (into #(4) (generator 1 2 3)))
  (test "fox" (into "f" (generator #\o #\x)))
  (test 10 (into (sum-accumulator) (generator 1 2 3 4))))

(test-group "accumulate"
  (test 10 (accumulate (add (sum-accumulator))
             (add 1)
             (add 2)
             (add 3)
             (add 4))))

; tally-accumulator

; group-by-accumulator

; uniq-accumulator

(test-group "one-of"
  (test #t ((one-of 1 2 3) 1))
  (test #f ((one-of 1 2 3) 4))
  (test #f ((one-of) 4)))

(test-group "per"
  (test 42 ((per inc inc) 40))
  (test #f ((per inc even?) 40))
  (test 43 ((per * inc) 6 7))
  (test 42 ((per) 42)))

(test-group "generator-xfold"
  (test -10 (generator-xfold - 0 (generator 1 2 3 4)))
  (test '((((() 1 5) 2 6) 3 7) 4 8) (generator-xfold list '() (generator 1 2 3 4) (generator 5 6 7 8))))

(test-group "inject"
  (test 10 ((inject +) (generator 1 2 3 4)))
  (test 0 ((inject +) (generator)))
  (test 20 ((inject + 10) (generator 1 2 3 4)))
  (test 10 ((inject + 10) (generator)))
  (test '((1 . 2) . 3) ((inject cons) (generator 1 2 3)))
  (test 20 (inject + 10 #(1 2 3 4))))

(test-group "sing?"
  (test #f (sing? '()))
  (test #t (sing? '(1)))
  (test #f (sing? '(1 2 3)))
  (test #f (sing? #(1))))

(test-group "unlist"
  (test 43 (act '(6 7) unlist * inc)))

(test-group "juxt"
  (test 42 (act 13/2 (juxt ceil floor) *))
  (test #t (act 13/2 (juxt) list empty?)))

(test-group "act"
  (test 42 (act 40 inc inc))
  (test #f (act 40 inc even?))
  (test 43 (act '(6 7) (op apply * _) inc))
  (test 42 (act 42)))

(test-group "=>"
  (test 42 (=> 40 inc inc))
  (test #f (=> 40 inc even?))
  (test 43 (=> '(6 7) (op apply * _) inc))
  (test 42 (=> 42)))

(test-group "=>*"
  (test 42 (=>* (values 6 7) * dec inc))
  (test '(6 7) (receive (=>* (values 6 7))))
  (test '(7 6) (receive (=>* (values 6 7) (proj 1 0)))))

(test-group "set=>"
  (test 42 (seq
             (def x 40)
             (set=> x inc inc)
             x))
  (test 42 (seq
             (def x #(13/2 2 3))
             (set=> (at x 0) (juxt ceil floor) *)
             (at x 0))))

(test-group "and=>"
  (test #t (and=> 42 even?))
  (test #f (and=> #f even?))
  (test 42 (and=> 40 inc inc))
  (test #f (and=> 40 odd? inc)))

(test-group "op=>"
  (test 42 (op=> 40 (+ _ 1) inc))
  (test 42 (op=> 40 (inc _) inc))
  (test 42 (op=> 40 ,(op inc _) inc))
  (test #f (op=> 40 inc even?))
  (test 43 (op=> '(6 7) (apply * _) inc))
  (test 42 (op=> 42)))

(test-group "fun=>"
  (test 42 ((fun=> (+ _ 1) inc) 40))
  (test #f ((fun=> inc even?) 40))
  (test 43 ((fun=> * inc) 6 7))
  (test 42 ((fun=>) 42)))

(test-group "void"
  (test #t (void? (void)))
  (test #t (void? (void 1 2 3))))

(test-group "void?"
  (test #f (void? 1))
  (test #f (void? #f))
  (test #t (void? (void)))
  (test #t (void? (if #f #f))))

(test-group "proj"
  (test 1 ((proj 0) 1 2 3))
  (test 2 ((proj 1) 1 2 3))
  (test 3 ((proj 2) 1 2 3))
  (test '(3 2) (receive ((proj 2 1) 1 2 3)))
  (test '() (receive ((proj) 1 2 3)))
  (test-error ((proj 4) 1 2 3)))

(test-group "fail"
  (test #t (condition-case (fail "foo")
             ((exn) #t)
             (() #f)))
  (test #t (condition-case (fail '(florp) "foo")
             ((florp) #t)
             (() #f)))
  (test #t (condition-case (fail '(florp flurp) "foo")
             ((florp flurp) #t)
             (() #f)))
  (test "foo 1 2" (condition-case (fail "foo ~a ~a" 1 2)
                    (e (exn) (get-condition-property e 'exn 'message)))))

(test-group "search"
  (test #f (search "foozing" "fooz00000fggg00foozixngbar"))
  (test 7 (search "foozing" "foodingfoozingbar"))
  (test 15 (search "foozing" "fooz00000fggg00foozingbar"))
  (test 16 (search "foozinggg" "foozinggfoozinggfoozingggfoozingg"))
  (test 0 (search "foobar" "foobar"))
  (test #f (search "foobar" "foobax"))
  (test #f (search "foobar" "000000"))
  (test #f (search "foobar" "fooba"))
  (test 4 (search "fofofox" "fofofofofox"))
  (test #f (search "fofofox" ""))
  (test 0 (search "" "fofofox"))
  (test 6 (search "x" "fofofox"))
  (test 4 (search "foo" "fooxfoo" 3))
  (test #f (search "foo" "fooxfoo" 5))
  (test 1 (search #(1 2 3) #(0 1 2 3 4)))
  (test 1 (search '(1 2 3) '(0 1 2 3 4))))

(test-group "scan"
  (test '(0 -4 -9 -15) (scan (flip -) 0 '(4 5 6)))
  (test '(42) (scan * 42 '()))
  (test '(0 6 14 24 36) (scan + 0 '(1 2 3 4) '(5 6 7 8)))
  (test '(0 -4 0 -4 0) (scan - 0 '(1 2 3 4) '(5 6 7 8))))

(test-group "xscan"
  (test '(0 6 14 24 36) (xscan + 0 '(1 2 3 4) '(5 6 7 8)))
  (test '(0 -6 -14 -24 -36) (xscan - 0 '(1 2 3 4) '(5 6 7 8))))

(test-group "scan-right"
  (test '(5 -1 6 0)    (scan-right - 0 '(4 5 6)))
  (test '(42) (scan-right * 42 '()))
  (test '(36 30 22 12 0) (scan-right + 0 '(1 2 3 4) '(5 6 7 8))))

(test-group "xscan-right"
  (test '(36 30 22 12 0) (xscan-right + 0 '(1 2 3 4) '(5 6 7 8))))

(test-group "xfold"
  (test -10 (xfold - 0 '(1 2 3 4)))
  (test '((((() 1 5) 2 6) 3 7) 4 8) (xfold list '() '(1 2 3 4) '(5 6 7 8))))

(test-group "xfold-right"
  (test '((((() 4 8) 3 7) 2 6) 1 5) (xfold-right list '() '(1 2 3 4) '(5 6 7 8)))
  (test -10 (xfold-right - 0 '(1 2 3 4))))

(test-group "xreduce"
  (test -8 (xreduce - 0 '(1 2 3 4)))
  (test #f (xreduce - #f '())))

(test-group "xreduce-right"
  (test -2 (xreduce-right - 0 '(1 2 3 4)))
  (test #f (xreduce-right - #f '())))

(test-group "imp"
  (test #t (imp #t #t))
  (test #f (imp #t #f))
  (test #t (imp #f #t))
  (test #t (imp #f #f))

  (test #t (imp #f (error "not reached")))
  (test #t (imp #t #t #f (error "not reached")))
  (test 42 (imp #t #t #t 42))
  (test 42 (imp 39 40 41 42))
  (test #t (imp 39 #f 41 42)))