;;;; File: list-bindings-run.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de

(require-library list-bindings)

(import list-bindings)

;;; (run-tests xpr0 xpr1 ...)
;;; -------------------------
;;; evaluates each expression xpr0 xpr1 ... and reports it as failed, if
;;; it evaluates to #f, and as passed otherwise
(define-syntax run-tests
  (syntax-rules ()
    ((_  xpr ...)
     (begin
         (display "\nTesting ...\n")
         (display "-----------\n")
         (let ((n (simple-tests-run (list 'xpr ...))))
           (display "-----------\n")
           (if (zero?  n)
             (display "All tests passed\n\n")
             (begin
               (display n)
               (display " test(s) failed!!!\n\n"))))))))
(define (simple-tests-run lst)
  (let loop ((lst lst) (n 0))
    (if (null? lst)
      n
      (if (eval (car lst))
        (begin
          (display "passed ... ")
          (write (car lst))
          (newline)
          (loop (cdr lst) n))
        (begin
          (display "FAILED !!! ")
          (write (car lst))
          (newline)
          (loop (cdr lst) (+ n 1)))))))

(run-tests
  "TEST BINDING MACROS"
  (= (bind a 1 a) 1)
  (equal? (bind (a b) '(1 2)  (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 (z . u) . v) . w)
            '(1 (2 (3 4) 5) 6)
            
            (list x y z u v w))
          '(1 2 3 (4) (5) (6)))
  (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) (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) (list x y))
            ((x (y . z)) (list x y z))
            ((x (y z)) (list x y z)))
          '(1 (2 . 3)))
  (equal?
    (letrec (
      (my-map
        (lambda (fn lst)
          (bind-case lst
            (() '())
            ((x . xs) (cons (fn x) (map fn xs))))))
      )
      (my-map add1 '(1 2 3)))
    '(2 3 4))
  ((bindable? (a b)) '(1 2)) 
  ((bindable? (a b)) '(1 2))
  (not ((bindable? (x)) '(name 1)))
  ((bindable? (_ x)) '(name 1))
  (not ((bindable? (_ x)) '(name 1 2)))
  ((bindable? (_) (_ x y)  (_ x y)) '(name 1 2))
  (equal? (bind-let* (((a b) '(1 2)) ((x . y) '(3))) (list a b x y))
          '(1 2 3 ()))
  (equal? (bind-let* (((a b) '(1 2)) ((x . y) (list a))) (list a b x y))
          '(1 2 1 ()))
  (equal? (bind-let (((a b) '(1 2)) ((x . y) '(3 4 4))) (list a b x y))
          '(1 2 3 (4 4)))
  "TEST LOW-LEVEL MACROS"
  (define-macro (efreeze xpr)
    (renaming (% %lambda)
      `(,%lambda () ,xpr)))
  (= ((efreeze 3)) 3)
  (define-macro (ifreeze xpr)
    `(lambda () ,xpr))
  (= ((ifreeze 5)) 5)
  (define-macro (alambda args xpr . xprs)
    (injecting (self)
      `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
         ,self)))
  (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
  (= (! 5) 120)
  (define-macro (foo pair)
    (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))
  (eq? (foo (bar 'checked)) 'checked)
  (eq? (foo (baz 'checked)) 'unchecked)
  (define-macro (baz pair)
    (renaming (% %if)
      (comparing (? bar?)
        `(,%if ,(bar? (car pair)) ,@(cdr pair) 'unchecked))))
  (eq? (baz (bar 'checked)) 'checked)
  (eq? (baz (foo 'checked)) 'unchecked)
  (define-macro (swap! x y)
    `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
  (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
          '(y x))
  (= (letrec-macro (((ifreeze xpr) `(lambda () ,xpr))
                    ((efreeze xpr)
                     (renaming (% %lambda)
                       `(,%lambda () ,xpr))))
       ((efreeze ((ifreeze 3)))))
     3)
  (equal? (letrec-macro (((ifreeze xpr) `(lambda () ,xpr))
                         ((efreeze xpr)
                          (renaming (% %lambda)
                            `(,%lambda () ,xpr))))
            (list ((efreeze 3)) ((ifreeze 5))))
          '(3 5))
  )