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

(require-library simple-tests list-bindings)
(import simple-tests list-bindings)
(import-for-syntax (only list-bindings macro-rules))

(compound-test ("LIST-BINDINGS")
  (simple-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 (a (b . c) (d (e f))) '(1 (2 3) (4 (5 6)))
              (list a b c d e f))
            '(1 2 (3) 4 5 6))
    (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-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) (my-map fn xs)))))))
        (my-map add1 '(0 1 2 3))) '(1 2 3 4))
    ((bindable? (a b)) '(1 2)) 
    (not ((bindable? (x)) '(name 1)))
    ((bindable? (_ x)) '(name 1))
    (not ((bindable? (_ x)) '(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)))
    )
  (simple-test ("DEFINE AND SET!")
    (bind-define (a (b c) (d (e f))) '(1 (2 3) (4 (5 6))))
    (= f 6)
    (bind-define (push top pop)
      (let ((state '()))
        (list (lambda (arg) (set! state (cons arg state)))
              (lambda () (car state))
              (lambda () (set! state (cdr state))))))
    (push 3)
    (push 5)
    (= (top) 5)
    (pop)
    (= (top) 3)
    (bind-set! (a (b c) (d (e f))) '(10 (20 30) (40 (50 60))))
    (= f 60)
    (bind-define (x (y . z)) '(1 (2 3 4 5)))
    (equal? z '(3 4 5))
    (bind-set! (x (y . z)) '(10 (20 . 30)))
    (= z 30)
    )
  (simple-test ("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? (let-macro (((ifreeze xpr) `(lambda () ,xpr))
                        ((efreeze xpr)
                         (renaming (% %lambda)
                           `(,%lambda () ,xpr))))
              (list ((efreeze 3)) ((ifreeze 5))))
            '(3 5))
    (define-syntax if-then-
      (macro-rules (? then? else?)
        ((_ test then-pair)
         (if (and (pair? then-pair) (then? (car then-pair)))
           `(if ,test
              (begin ,@(cdr then-pair)))
           `(error 'if-then- "syntax-error")))
        ((_ test then-pair else-pair)
         (if (and (pair? then-pair) (then? (car then-pair))
                  (pair? else-pair) (else? (car else-pair)))
           `(if ,test
              (begin ,@(cdr then-pair))
              (begin ,@(cdr else-pair)))
           `(error 'if-then- "syntax-error")))))
    (define (quux x)
      (if-then- (odd? x) (then "odd") (else "even")))
    (equal? (quux 3) "odd")
    (equal? (quux 4) "even")
    (define-syntax aif
      (macro-rules it ()
        ((_ test consequent . alternative)
         (if (null? alternative)
          `(let ((,it ,test))
             (if ,it ,consequent))
          `(let ((,it ,test))
             (if ,it ,consequent ,(car alternative)))))))
    (define (mist x) (aif (! x) it))
    (= (mist 5) 120)
    (define-syntax-rule (freeze x) (lambda () x))
    (= ((freeze 25)) 25))

  (simple-test ("ONCE-ONLY AND WITH-GENSYMS")
    (import-for-syntax (only list-bindings once-only with-gensyms))
;    (define-syntax square
;      (er-macro-transformer
;        (lambda (form rename compare?)
;          (let ((n (cadr form)) (%* (rename '*)))
;            (once-only (n)
;              `(,%* ,n ,n))))))
    (define-macro (square x)
      (once-only (x)
        `(* ,x ,x)))
    (let ((n 4))
      (= (square (begin (set! n (+ n 1)) n)) 25))

    (define-macro (for (var start end) . body)
      (once-only (start end)
        `(do ((,var ,start (add1 ,var)))
               ((= ,var ,end))
               ,@body)))
;    (define-syntax for ; ok
;      (er-macro-transformer
;        (lambda (form rename compare?)
;          (let ((lst (cadr form))
;                (body (cddr form)))
;            (let ((var (car lst))
;                  (start (cadr lst))
;                  (end (caddr lst))
;                  (%do (rename 'do))
;                  (%= (rename '=))
;                  (%add1 (rename 'add1)))
;              (once-only (start end)
;                `(,%do ((,var ,start (,%add1 ,var)))
;                   ((,%= ,var ,end))
;                   ,@body)))))))
    (define counter
      (let ((state 0))
        (lambda ()
          (set! state (+ state 1))
          state)))
    (let ((lst '()))
      (for (x 0 (counter)) (set! lst (cons x lst)))
      (equal? lst '(0)))
    (define-macro (times a b)
      (with-gensyms (x y)
        `(let ((,x ,a) (,y ,b))
           (* ,x ,y))))
    (= (times 3 5) 15)
    ))