;;;; File: tests/run.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de

(require-library bindings tuples simple-tests)

(import bindings
        (only tuples tuple tuple? tuple-empty? tuple-left tuple-butleft)
        (only chicken error)
        simple-tests)

(compound-test (bindings)
  (define-test (bind?)
    (check
      (= (bind a 1 a) 1)
      (equal? (bind (a b) '(1 2) (where (odd? a)) (list a b)) '(1 2))
      (equal?
        (bind (x y z w) '(1 2 3 4) (list x y z w))
        '(1 2 3 4))
      (equal?
        (bind (x . y) '#(1 2 3 4) (list x y))
        '(1 #(2 3 4)))
      (equal?
        (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
          (list x y z u v w))
        '(1 2 #\f #\o "o" 4))
      (equal? (bind (x (y (z . u) . v) . w)
                '(1 (2 (3 4) 5) 6)
                (where (odd? z))
                (list x y z u v w))
              '(1 2 3 (4) (5) (6)))
      (not (condition-case
             (bind (x (y (z . u) . v) . w)
               '(1 (2 (3 4) 5) 6)
               (where (even? z))
               (list x y z u v w))
             ((bind-exn) #f)))
      (equal?
        (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
          (list x y z u v w))
        '(1 2 #f #f 5 #(6)))
      (equal?
        (bind* loop (x (a . b) y) '(5 #(1) 0)
          (if (zero? x)
            (list x a b y)
            (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
        '(0 1 (1 1 1 1 1 . #()) 5))
      (equal?
        (bind* loop (x y) '#(5 0)
          (if (zero? x)
            (vector x y)
            (loop (vector (- x 1) (+ y 1)))))
        '#(0 5))
      ))
  (bind?)

  (define-test (predicate?)
    (check
      (not ((bindable? (x)) '(name 1)))
      (not ((bindable? (x y) (number? x)) '(name 1)))
      ((bindable? (_ x)) '(name 1))
      (not ((bindable? (_ x)) '(name 1 2)))
      (not ((bindable? (_ x y) (symbol? x)) '(name 1 2)))
      ((bindable? (a b) (odd? a)) '#(1 2))
      (not ((bindable? (x (y z)) (char-alphabetic? y)) '(1 "23")))
      ((bindable? (x (y . z))) '(1 "23"))
      ((bindable? (x y)) '(1 "23"))
      (not ((bindable? (a (b . C) . d)) '(1 2 3 4 5)))
      (not ((bindable? (a)) 1))
      ))
  (predicate?)

  (define-test (case?)
    (check
      (equal? (bind-case '#(2 2)
                ((a b) (where (even? a) (odd? b)) (print 'even-odd a b))
                ((a b) (where (odd? a) (even? b)) (print 'odd-even a b))
                ((a b) (list a b))) '(2 2))
      (equal? (bind-case '(1 "2 3")
                ((x (y z)) (list x y z))
                ((x (y . z)) (list x y z))
                ((x y) (list x y)))
              '(1 #\2 " 3"))
      (equal? (bind-case '(1 "23")
                ((x (y z)) (where (char-alphabetic? y)) (list x y z))
                ((x (y . z)) (list x y z))
                ((x y) (list x y)))
              '(1 #\2 "3"))
      (equal? (bind-case '(1 "23")
                ((x (y z)) (where (char-numeric? y)) (list x y z))
                ((x (y . z)) (list x y z))
                ((x y) (list x y)))
              '(1 #\2 #\3))
      (equal? (bind-case '(1 "23")
                ((x (y z)) (list x y z))
                ((x (y . z)) (list x y z))
                ((x y) (list x y)))
              '(1 #\2 #\3))
      (equal? (bind-case '(1 (2 3))
                ((x (y z)) (list x y z))
                ((x (y . z)) (list x y z))
                ((x y) (list x y)))
              '(1 2 3))
      (equal? (bind-case '(1 "2 3") ;
                ((x (y . z)) (list x y z))
                ((x (y z)) (list x y z))
                ((x y) (list x y)))
              '(1 #\2 " 3"))
      (equal? (bind-case '(1 #(2 3))
                ((x y) (where (list? y)) (list x y))
                ((x (y . z)) (list x y z))
                ((x (y z)) (list x y z)))
              '(1 2 #(3)))
      (equal? (bind-case '(1 (2 3))
                ((x (y . z)) (list x y z))
                ((x y) (list x y))
                ((x (y z)) (list x y z)))
              '(1 2 (3)))
      (equal? (bind-case '(1 (2 3))
                ((x y) (list x y))
                ((x (y . z)) (list x y z))
                ((x (y z)) (list x y z)))
              '(1 (2 3)))
      (equal? (bind-case '(1 (2 . 3))
                ((x (y . z)) (list x y z))
                ((x (y z)) (list x y z)))
              '(1 2 3))
      (equal? (bind-case '(1 (2 . 3))
                ((x y) (list x y))
                ((x (y . z)) (list x y z))
                ((x (y z)) (list x y z)))
              '(1 (2 . 3)))
      (equal?
        (bind-case '#(1 2)
          (() '())
          ((a) (list a))
          ((a b) (list a b))
          ((a b C) (list a b C)))
        '(1 2))
      (equal?
        (letrec
          ((my-map
             (lambda (fn lst)
               (bind-case lst
                 (() '())
                 ((x . xs) (cons (fn x)
                                 (my-map fn xs)))))))
          (my-map add1 '(1 2 3)))
        '(2 3 4))
      ))
  (case?)

  (define-test (lambdas?)
    (check
      (equal?
        ((bind-lambda (a (b . C) . d)
           (list a b C d))
         '(1 #(20 30 40) 2 3))
        '(1 20 #(30 40) (2 3)))
      (equal?
        ((bind-lambda* ((a (b . C) . d) (e . f))
           (list a b C d e f))
         '(1 #(20 30 40) 2 3) '#(4 5 6))
        '(1 20 #(30 40) (2 3) 4 #(5 6)))
      (equal?
        ((bind-case-lambda
           ((a (b . C) . d) (list a b C d))
           ((e . f) (where (zero? e)) e)
           ((e . f) (list e f)))
         '(1 2 3 4 5))
        '(1 (2 3 4 5)))
      (equal?
        ((bind-case-lambda
           ((e . f) (where (zero? e)) f)
           ((e . f) (list e f)))
         '#(0 2 3 4 5))
        '#(2 3 4 5))
      (equal?
        ((bind-case-lambda
           ((a (b . C) . d) (list a b C d))
           ((e . f) (list e f)))
         '(1 #(2 3 4) 5 6))
        '(1 2 #(3 4) (5 6)))
      (equal?
        ((bind-case-lambda*
           (((a b C . d) (e . f))
            (list a b C d e f)))
         '(1 2 3) '#(4 5 6))
        '(1 2 3 () 4 #(5 6)))
      (equal?
        ((bind-case-lambda*
           (((a (b . C) . d) (e . f))
            (list a b C d e f)))
         '(1 #(20 30 40) 2 3) '(4 5 6))
        '(1 20 #(30 40) (2 3) 4 (5 6)))
      ))
  (lambdas?)

  (define-test (lets?)
    (check
      (equal?
        (bind-let (((x y (z . w)) '(1 2 #(3 4 5))))
          (list x y z w))
        '(1 2 3 #(4 5)))
      (equal?
        (bind-let (
                   (((x y) z) '(#(1 2) 3))
                   (u (+ 2 2))
                   ((v w) '#(5 6))
                   )
          (list x y z u v w))
        '(1 2 3 4 5 6))
      (equal?
        (bind-let loop (((a b) '(5 0)))
          (if (zero? a)
            (list a b)
            (loop (list (list (- a 1) (+ b 1))))))
        '(0 5))
      (equal?
        (bind-let loop (
                        ((x . y) '(1 2 3))
                        ((z) '#(10))
                        )
          (if (zero? z)
            (list x y z)
            (loop (list (cons (+ x 1) (map add1 y)) (list (- z 1))))))
        '(11 (12 13) 0))
      (equal?
        (bind-let* (
                    (((x y) z) '(#(1 2) 3))
                    (u (+ 1 2 x))
                    ((v w) (list (+ z 2) 6))
                    )
          (list x y z u v w))
        '(1 2 3 4 5 6))
      (equal?
        (bindrec ((o?) e?)
          (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
                  (lambda (n) (if (zero? n) #t (o? (- n 1)))))
          (list (o? 95) (e? 95)))
        '(#t #f))
      (equal?
        (bind-letrec (
                      ((o? (e?))
                       (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
                             (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
                      )
          (list (o? 95) (e? 95)))
        '(#t #f))
      ))
  (lets?)

  (define-test (defines?)
    (check
      (equal?
        (let ((stack #f) (push! #f) (pop! #f))
          (bind-set! (stack (push! pop!))
            (list
              '()
              (vector
                (lambda (xpr) (set! stack (cons xpr stack)))
                (lambda () (set! stack (cdr stack))))))
          (push! 1)
          (push! 0)
          stack)
        '(0 1))
      (equal?
        (let ((x #f) (y #f) (z #f))
          (bind-set! (x (y . z)) '(1 #(2 3 3)))
          (list x y z))
        '(1 2 #(3 3)))
      (equal?
        (begin
          (bind-define (plus5 times5)
            (let ((a 5))
              (list
                (lambda (x) (+ x a))
                (lambda (x) (* x a)))))
          (list (plus5 6) (times5 6)))
        '(11 30))
      (equal?
        (begin
          (bind-define (push top pop)
            (let ((lst '()))
              (vector
                (lambda (xpr) (set! lst (cons xpr lst)))
                (lambda () (car lst))
                (lambda () (set! lst (cdr lst))))))
          (push 0)
          (push 1)
          (pop)
          (top))
        0)
      ))
  (defines?)

  (define-test (sequences?)
    (check
      (generic-null-car-cdr! tuple? tuple-empty? tuple-left tuple-butleft)
      (define-record point x y)
      (equal? (bind (x y z) (tuple 1 2 3) (list x y z)) '(1 2 3))
      (equal? (bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) '(0 1 2))
      (equal? (bind (x (y (z))) (vector 0 (tuple 1 "2")) (list x y z))
              '(0 1 #\2))
      ))
  (sequences?)
  )