(export list-test)

(import
  :gerbil/gambit/exceptions
  :std/error :std/misc/list :std/test)

(def (error-with-message? message)
  (lambda (e)
    (and (error-exception? e) (equal? (error-exception-message e) message))))

(def (copy-list lst) (foldr cons '() lst))

(def list-test
  (test-suite "test :std/misc/list"
    (test-case "test length=?"
      (check-equal? (length=? '(1 2 3) '(a b c)) #t)
      (check-equal? (length=? '(1 2 3) '(a b c d)) #f)
      (check-equal? (length=? '(1 2 3 4) '(a b c)) #f)
      (check-equal? (length=? '(1 2 3) '(a b c . d)) #t)
      (check-equal? (length=? '(1 2 3 . 4) '(a b c)) #t))
    (test-case "test length<?"
      (check-equal? (length<? '(1 2 3) '(a b c d)) #t)
      (check-equal? (length<? '(1 2 3 . 4) '(a b c d)) #t)
      (check-equal? (length<? '(1 2 3) '(a b c)) #f)
      (check-equal? (length<? '(1 2 3 4) '(a b c)) #f)
      (check-equal? (length<? '(1 2 3) '(a b c . d)) #f))
    (test-case "test length=n?"
      (check-equal? (length=n? '(1 2 3) 4) #f)
      (check-equal? (length=n? '(1 2 3) 3) #t)
      (check-equal? (length=n? '(1 2 3) 2) #f)
      (check-equal? (length=n? '(1 2 3) 3.14159) #f)
      (check-equal? (length=n? '(1 2 3) 3.0) #t)
      (check-equal? (length=n? '(1 2 3) 2.5) #f)
      (check-equal? (length=n? '(1 2 3 4) 3) #f)
      (check-equal? (length=n? '(1 2 3 . 4) 3) #t)
      (check-equal? (length=n? '(1 2 3 . 4) 4) #f)
      (check-equal? (length=n? '(1 2 3 . 4) 3.5) #f)
      (check-equal? (length=n? '(1 2 3) -4) #f)
      (check-equal? (length=n? '(1 2 3) 6.022e23) #f)
      (check-equal? (length=n? '(1 2 3) 2+3i) #f)
      (check-exception (length=n? '(1 2 3) 'foo) (error-with-message? "not a number")))
    (test-case "test length<=n?"
      (check-equal? (length<=n? '(1 2 3) 4) #t)
      (check-equal? (length<=n? '(1 2 3) 3) #t)
      (check-equal? (length<=n? '(1 2 3) 2) #f)
      (check-equal? (length<=n? '(1 2 3) 3.14159) #t)
      (check-equal? (length<=n? '(1 2 3) 3.0) #t)
      (check-equal? (length<=n? '(1 2 3) 2.5) #f)
      (check-equal? (length<=n? '(1 2 3 4) 3) #f)
      (check-equal? (length<=n? '(1 2 3 . 4) 4) #t)
      (check-equal? (length<=n? '(1 2 3 . 4) 3) #t)
      (check-equal? (length<=n? '(1 2 3 . 4) 2) #f)
      (check-equal? (length<=n? '(1 2 3) -4) #f)
      (check-equal? (length<=n? '(1 2 3) 6.022e23) #t)
      (check-exception (length<=n? '(1 2 3) 2+3i) (error-with-message? "not a real number"))
      (check-exception (length<=n? '(1 2 3) 'foo) (error-with-message? "not a real number")))
    (test-case "test length<n?"
      (check-equal? (length<n? '(1 2 3) 4) #t)
      (check-equal? (length<n? '(1 2 3) 3) #f)
      (check-equal? (length<n? '(1 2 3) 2) #f)
      (check-equal? (length<n? '(1 2 3) 3.14159) #t)
      (check-equal? (length<n? '(1 2 3) 3.0) #f)
      (check-equal? (length<n? '(1 2 3) 2.5) #f)
      (check-equal? (length<n? '(1 2 3 4) 3) #f)
      (check-equal? (length<n? '(1 2 3 . 4) 4) #t)
      (check-equal? (length<n? '(1 2 3 . 4) 3) #f)
      (check-equal? (length<n? '(1 2 3 . 4) 2) #f)
      (check-equal? (length<n? '(1 2 3) -4) #f)
      (check-equal? (length<n? '(1 2 3) 6.022e23) #t)
      (check-exception (length<n? '(1 2 3) 2+3i) (error-with-message? "not a real number"))
      (check-exception (length<n? '(1 2 3) 'foo) (error-with-message? "not a real number")))
    (test-case "test with-list-builder"
      (check-equal?
       (with-list-builder (put!)
         (put! 1) (put! 2) (put! 3))
       '(1 2 3))
      (check-equal?
       (with-list-builder (put! get-list-so-far)
         (put! 1)
         (put! 2)
         (put! (copy-list (get-list-so-far)))
         (put! 3))
       '(1 2 (1 2) 3)))
    (test-case "test snoc"
      (check-equal? (snoc 3 []) [3])
      (check-equal? (snoc 1 [3 2]) [3 2 1]))
    (test-case "test append1"
      (check-equal? (append1 [] 3) [3])
      (check-equal? (append1 [3 2] 1) [3 2 1]))
    (test-case "test flatten"
      (check-equal? (flatten '()) '())
      (check-equal? (flatten '(1)) '(1))
      (check-equal? (flatten '(1 2 3)) '(1 2 3))
      (check-equal? (flatten '(1 (2) (3))) '(1 2 3))
      (check-equal? (flatten '(1 ((2)) 3)) '(1 2 3))
      (check-equal? (flatten '((1 2) 3)) '(1 2 3))
      (check-equal? (flatten '(1 2 ())) '(1 2))
      (check-equal? (flatten '(1 2 (()))) '(1 2))
      (check-equal? (flatten '(1 (2) ((3) ()) (((4 5))))) '(1 2 3 4 5)))
    (test-case "test flatten1"
      (check-equal? (flatten1 '()) '())
      (check-equal? (flatten1 '(1)) '(1))
      (check-equal? (flatten1 '(1 2 3)) '(1 2 3))
      (check-equal? (flatten1 '(1 (2) (3))) '(1 2 3))
      (check-equal? (flatten1 '(1 (2) (3) ((4)))) '(1 2 3 (4)))
      (check-equal? (flatten1 '((1) ((2)) 3)) '(1 (2) 3))
      (check-equal? (flatten1 '(1 2 ())) '(1 2))
      (check-equal? (flatten1 '(1 2 (()))) '(1 2 ())))
    (test-case "test rassoc"
      (check-equal? (rassoc 2 '((a . 1) (b . 2) (c . 3))) '(b . 2))
      (check-equal? (rassoc "a" '((1 . "a") (2 . "b"))) #f)
      (check-equal? (rassoc "a" '((1 . "a") (2 . "b")) equal?) '(1 . "a"))
      (check-equal? (rassoc 2 '(1 2 3)) #f)
      (check-equal? (rassoc 2 '()) #f)
      (check-equal? (rassoc 3 '((a . 1) (b . 2))) #f)
      (check-equal? (rassoc 2 '((a . 1) 2 (b . 2))) #f)
      (check-equal? (rassoc 2 '((a . 1) '() (b . 2))) '(b . 2))
      (check-equal? (rassoc '() '((a . 1) (b . 2))) #f))
    (test-case "test when-list-or-empty"
      (check-equal? (when-list-or-empty 1 "a") [])
      (check-equal? (when-list-or-empty [1] "a") "a")
      (check-equal? (when-list-or-empty [] "a") []))
    (test-case "test slice"
      (check-equal? (slice [1 2 3 4] 2) [3 4])
      (check-equal? (slice [1 2 3 4] 2 1) [3])
      (check-equal? (slice [1 2 3 4] 0) [1 2 3 4])
      (check-equal? (slice [1 2 3 4] 1 0) [])
      (check-equal? (slice [1 2 3 4] 3) [4]))
    (test-case "test slice-right"
      (check-equal? (slice-right [1 2 3 4] 2) [1 2])
      (check-equal? (slice-right [1 2 3 4] 2 1) [2])
      (check-equal? (slice-right [1 2 3 4] 0) [1 2 3 4])
      (check-equal? (slice-right [1 2 3 4] 1 0) [])
      (check-equal? (slice-right [1 2 3 4] 3) [1]))
    (test-case "test slice!"
      (check-equal? (slice! [1 2 3 4] 2) [3 4])
      (check-equal? (slice! [1 2 3 4] 2 1) [3])
      (check-equal? (slice! [1 2 3 4] 0) [1 2 3 4])
      (check-equal? (slice! [1 2 3 4] 1 0) [])
      (check-equal? (slice! [1 2 3 4] 3) [4]))
    (test-case "test slice-right!"
      (check-equal? (slice-right! [1 2 3 4] 2) [1 2])
      (check-equal? (slice-right! [1 2 3 4] 2 1) [2])
      (check-equal? (slice-right! [1 2 3 4] 0) [1 2 3 4])
      (check-equal? (slice-right! [1 2 3 4] 1 0) [])
      (check-equal? (slice-right! [1 2 3 4] 3) [1]))
    (test-case "test butlast"
      (check-equal? (butlast [1 2 3]) [1 2])
      (check-equal? (butlast []) []))
    (test-case "test split"
      (check-equal? (split '(1 2 a 3 4) (cut equal? <> 'a)) [[1 2] [3 4]])
      (check-equal? (split '(1 2 a 3 4) 'a)            [[1 2] [3 4]])
      (check-equal? (split '(1 2 "hi") string?)        [[1 2]])
      (check-equal? (split '(_) '_)                    [[]])
      (check-equal? (split '() '_)                     [])
      (check-equal? (split [] number?)                 [])
      (check-equal? (split [] number? 1)               [])
      (check-equal? (split [1] number?)                [[]])
      (check-equal? (split [1] number? 1)              [[]])
      (check-equal? (split [1 2] number? 0)            [1 2])
      (check-equal? (split [1 2 0 3 4 0 5 6] zero?)    [[1 2] [3 4] [5 6]])
      (check-equal? (split [1 2 0 3 4 0 5 6] zero? 1)  [[1 2] [3 4 0 5 6]])
      (check-equal? (split [1 2 0 3 4 0 5 6] zero? 2)  [[1 2] [3 4] [5 6]])
      (check-equal? (split [1 2 0 3 4 0 5 6] zero? 10) [[1 2] [3 4] [5 6]]))
    (test-case "test group"
      (check-equal? (group [1 2 2 3 1]) [[1] [2 2] [3] [1]])
      (check-equal? (group []) [])
      (check-equal? (group [1]) [[1]])
      (check-equal? (group [1 []]) [[1] [[]]])
      (check-equal? (group ["aa" "aa" "b"]) [["aa" "aa"] ["b"]]))
    (test-case "test every-consecutive?"
      (check-equal? (every-consecutive? < [1 2 3 4 5]) #t)
      (check-equal? (every-consecutive? < [1 2 5 4 3]) #f)
      (check-equal? (every-consecutive? (lambda (x y) (not (= x y))) [1 2 3 4 5]) #t)
      (check-equal? (every-consecutive? error [1]) #t)
      (check-equal? (every-consecutive? error []) #t))
    (test-case "test pset!"
      (check-equal? (let (p ['a 1 'b 2]) (psetq! p 'a 3) p) ['a 3 'b 2])
      (check-equal? (let (p ['a 1 'b 2]) (psetq! p 'b 4) p) ['a 1 'b 4])
      (check-equal? (let (p ['a 1 'b 2]) (psetq! p 'c 3) p) ['c 3 'a 1 'b 2])
      (check-equal? (let (p ['a 1 'b 2]) (pgetq-set! 'a p 3) p) ['a 3 'b 2])
      (check-equal? (let (p ['a 1 'b 2]) (pgetq-set! 'b p 4) p) ['a 1 'b 4])
      (check-equal? (let (p ['a 1 'b 2]) (pgetq-set! 'c p 3) p) ['c 3 'a 1 'b 2]))
    (test-case "test prem!"
      (check-equal? (let (p ['a 1 'b 2]) (premq! 'a p) p) ['b 2])
      (check-equal? (let (p ['a 1 'b 2]) (premq! 'b p) p) ['a 1])
      (check-equal? (let (p ['a 1 'b 2]) (premq! 'c p) p) ['a 1 'b 2])
      (check-equal? (let (p []) (premq! 'a p) p) [])
      (check-exception (premq! 'a ['a 1]) (error-with-message? "Cannot remove last key from plist")))
    (test-case "test pset"
      (check-equal? (psetq ['a 1 'b 2] 'a 3) ['a 3 'b 2])
      (check-equal? (psetq ['a 1 'b 2] 'b 4) ['a 1 'b 4])
      (check-equal? (psetq ['a 1 'b 2] 'c 5) ['c 5 'a 1 'b 2]))
    (test-case "test prem"
      (check-equal? (premq 'a ['a 1 'b 2]) ['b 2])
      (check-equal? (premq 'b ['a 1 'b 2]) ['a 1])
      (check-equal? (premq 'c ['a 1 'b 2]) ['a 1 'b 2])
      (check-equal? (premq 'a []) [])
      (check-equal? (premq 'a ['a 1]) []))
    (test-case "test separate-keyword-arguments"
      (check-equal? (values->list (separate-keyword-arguments
                                   '(x a: 1 y b: 2 c: 3 z)))
                    '((x y z) (a: 1 b: 2 c: 3)))
      (check-equal? (values->list (separate-keyword-arguments
                                   '(x a: 1 y #!key b: 2 c: 3 z #!rest t d: 4) #t))
                    '((x y b: 2 z t d: 4) (a: 1 c: 3)))
      (check-equal? (values->list (separate-keyword-arguments
                                   '(x a: 1 y #!key b: 2 c: 3 z #!rest t d: 4) #f))
                    '((x y #!key b: 2 z #!rest t d: 4) (a: 1 c: 3))))
    ))
