chibi-scheme/lib/srfi/127/test.sld

(define-library (srfi 127 test)
  (import (scheme base) (srfi 127) (chibi test))
  (export run-tests)
  (begin
    ;; Make-generator for tests cloned from SRFI 121
    (define (make-generator . args)
      (lambda ()
        (if (null? args)
            (eof-object)
            (let ((next (car args)))
              (set! args (cdr args))
              next))))

    ;; Make-lseq creates an lseq, like list, but guarantees the use of
    ;; a generator.
    (define (make-lseq . args)
      (generator->lseq (apply make-generator args)))

    (define (factorial n)
      (cond
       ((< n 0) #f)
       ((= n 0) 1)
       (else (* n (factorial (- n 1))))))

    (define (run-tests)
      (test-group "srfi-127: lseqs"
        (test-group "lseqs/constructor"
          (let ((one23 (make-lseq 1 2 3)))
            (test 1 (car one23))
            (test-assert (procedure? (cdr one23)))
            (test '(1 2 3) (lseq-realize one23)))
          )

        (test-group "lseqs/predicates"
          (test-assert (lseq? '()))
          (test-assert (lseq? '(1 2 3)))
          (test-assert (lseq? (make-lseq 1 2 3)))
          (test-assert (lseq? (cons 'x (lambda () 'x))))

          (test-assert (lseq=? = '() '()))
          (test-assert (lseq=? = '(1 2 3) '(1 2 3)))
          (test-assert (lseq=? = (make-lseq 1 2 3)
                               (make-lseq 1 2 3)))
          (test-assert (lseq=? = (make-lseq 1 2 3) '(1 2 3)))
          )

        (test-group "lseqs/selectors"
          (test-error (lseq-car (make-generator)))
          (test 1 (lseq-car (make-lseq 1 2 3)))
          (test 1 (lseq-car '(1 2 3)))
          (test-error (lseq-car 2))

          (test-error (lseq-first (make-generator)))
          (test 1 (lseq-first (make-lseq 1 2 3)))
          (test 1 (lseq-first '(1 2 3)))
          (test-error (lseq-first 2))

          (test-error (lseq-cdr (make-generator)))
          (test 2 (lseq-cdr '(1 . 2)))
          (test 2 (lseq-car (lseq-cdr '(1 2 3))))
          (test 2 (lseq-car (lseq-cdr (make-lseq 1 2 3))))

          (test-error (lseq-rest (make-generator)))
          (test 2 (lseq-rest '(1 . 2)))
          (test 2 (lseq-car (lseq-rest '(1 2 3))))
          (test 2 (lseq-car (lseq-rest (make-lseq 1 2 3))))
          (test-error (lseq-rest 2))

          (test-error (lseq-ref '() 0))
          (test 1 (lseq-ref '(1) 0))
          (test 2 (lseq-ref '(1 2) 1))
          (test-error (lseq-ref (make-lseq) 0))
          (test 1 (lseq-ref (make-lseq 1) 0))
          (test 1 (lseq-ref (make-lseq 1 2) 0))
          (test 2 (lseq-ref (make-lseq 1 2) 1))

          (test-error (lseq-take '() 1))
          (test-error (lseq-take (make-lseq) 1))
          (test-assert (procedure? (cdr (lseq-take '(1 2 3 4 5) 3)))) ; test laziness
          (test '(1 2 3) (lseq-realize (lseq-take '(1 2 3 4 5) 3)))

          (test-error (lseq-drop '() 1))
          (test-error (lseq-drop (make-lseq 1) 2))
          (test '(3 4 5) (lseq-realize (lseq-drop '(1 2 3 4 5) 2)))
          (test '(3 4 5) (lseq-realize (lseq-drop (make-lseq 1 2 3 4 5) 2)))
          )

        (test-group "lseqs/whole"
          (test '() (lseq-realize '()))
          (test '(1 2 3) (lseq-realize '(1 2 3)))
          (test '() (lseq-realize (make-lseq)))
          (test '(1 2 3) (lseq-realize (make-lseq 1 2 3)))

          (let ((g (lseq->generator '(1 2 3))))
            (test 1 (g))
            (test 2 (g))
            (test 3 (g))
            (test-assert (eof-object? (g))))

          (let ((g (lseq->generator (make-lseq 1 2 3))))
            (test 1 (g))
            (test 2 (g))
            (test 3 (g))
            (test-assert (eof-object? (g))))

          (test 0 (lseq-length '()))
          (test 3 (lseq-length '(1 2 3)))
          (test 3 (lseq-length (make-lseq 1 2 3)))

          (test '(1 2 3 a b c) (lseq-realize (lseq-append '(1 2 3) '(a b c))))
          (let ((one23abc (lseq-append (make-lseq 1 2 3) (make-lseq 'a 'b 'c))))
            (test-assert (procedure? (cdr one23abc)))
            (test-assert (lseq-realize one23abc)))

          (let ((one2345 (make-lseq 1 2 3 4 5))
                (oddeven (make-lseq 'odd 'even 'odd 'even 'odd 'even 'odd 'even)))
            (test '((one 1 odd) (two 2 even) (three 3 odd))
                (lseq-realize (lseq-zip '(one two three) one2345 oddeven))))
          )

        (test-group "lseqs/mapping"
          (test '() (lseq-map - '()))
          (test '(-1 -2 -3) (lseq-realize (lseq-map - '(1 2 3))))
          (test '(-1 -2 -3) (lseq-realize (lseq-map - (make-lseq 1 2 3))))
          (test-assert (procedure? (cdr (lseq-map - '(1 2 3)))))

          (let* ((output '())
                 (out! (lambda (x) (set! output (cons x output)))))
            (lseq-for-each out! '())
            (test '() output)
            (lseq-for-each out! '(a b c))
            (test '(c b a) output)
            (lseq-for-each out! (make-lseq 1 2 3))
            (test '(3 2 1 c b a) output))

          (test '() (lseq-filter odd? '()))

          (let ((odds (lseq-filter odd? '(1 2 3 4 5))))
            (test-assert (procedure? (cdr odds)))
            (test '(1 3 5) (lseq-realize odds))
            (test '(1 3 5) (lseq-realize (lseq-filter odd? (make-lseq 1 2 3 4 5)))))

          (test '() (lseq-remove even? '()))
          (let ((odds (lseq-remove even? '(1 2 3 4 5))))
            (test-assert (procedure? (cdr odds)))
            (test '(1 3 5) (lseq-realize odds))
            (test '(1 3 5) (lseq-realize (lseq-remove even? (make-lseq 1 2 3 4 5))))))

        (test-group "lseqs/searching"
          (test 4 (lseq-find even? '(3 1 4 1 5 9 2 6)))
          (test 4 (lseq-find even? (make-lseq 3 1 4 1 5 9 2 6)))
          (test #f (lseq-find negative? (make-lseq 1 2 3 4 5)))

          (test '(-8 -5 0 0) (lseq-realize (lseq-find-tail even? '(3 1 37 -8 -5 0 0))))
          (test '(-8 -5 0 0) (lseq-realize (lseq-find-tail even?
                                                           (make-lseq 3 1 37 -8 -5 0 0))))
          (test #f (lseq-find-tail even? '()))
          (test #f (lseq-find-tail negative? (make-lseq 1 2 3 4 5)))

          (test '(2 18) (lseq-realize (lseq-take-while even? '(2 18 3 10 22 9))))
          (test '(2 18) (lseq-realize (lseq-take-while even?
                                                       (make-lseq 2 18 3 10 22 9))))
          (test '(2 18) (lseq-realize (lseq-take-while even?
                                                       (make-lseq 2 18 3 10 22 9))))

          (test '(3 10 22 9) (lseq-drop-while even? '(2 18 3 10 22 9)))
          (test '(3 10 22 9) (lseq-realize (lseq-drop-while even?
                                                            (make-lseq 2 18 3 10 22 9))))

          (test #t (lseq-any integer? '(a 3 b 2.7)))
          (test #t (lseq-any integer? (make-lseq 'a 3 'b 2.7)))
          (test #f (lseq-any integer? '(a 3.1 b 2.7)))
          (test #f (lseq-any integer? (make-lseq 'a 3.1 'b 2.7)))
          (test #t (lseq-any < '(3 1 4 1 5) '(2 7 1 8 2)))
          (test 6 (lseq-any factorial '(-1 -2 3 4)))
          (test 6 (lseq-any factorial (make-lseq -1 -2 3 4)))

          (test 24 (lseq-every factorial '(1 2 3 4)))
          (test 24 (lseq-every factorial (make-lseq 1 2 3 4)))

          (test 2 (lseq-index even? '(3 1 4 1 5 9)))
          (test 1 (lseq-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
          (test #f (lseq-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))

          (test '(a b c) (lseq-realize (lseq-memq 'a '(a b c))))
          (test '(a b c) (lseq-realize (lseq-memq 'a (make-lseq 'a 'b 'c))))
          (test #f (lseq-memq 'a (make-lseq 'b 'c 'd)))
          (test #f (lseq-memq (list 'a) '(b c d)))
          (test #f (lseq-memq (list 'a) (make-lseq 'b 'c 'd)))

          (test '(101 102) (lseq-realize (lseq-memv 101 (make-lseq 100 101 102))))

          (test '((a) c) (lseq-realize (lseq-member (list 'a) (make-lseq 'b '(a) 'c))))
          (test '(2 3) (lseq-realize (lseq-member 2.0 (make-lseq 1 2 3) =)))
          )))
    ))