(require-library simple-tests low-level-macros tuples)
(import simple-tests low-level-macros macro-helpers
        tuples
        (only chicken condition-case))
(import-for-syntax
  (only low-level-macros macro-rules once-only with-gensyms))

(compound-test (low-level-macros)
  (define-test (symbols?)
    (check
      (equal? (flatten '(a (b c (d))))
              '(a b c d))
      (equal? (memp odd? '(2 4 3 1))
              '(3 1))
      (equal? (filter odd? '(2 4 3 6 1 0))
              '(3 1))
      (equal? (adjoin 'x '(a b c))
              '(x a b c))
      (equal? (adjoin 'x '(a b x c))
              '(a b x c))
      (equal? (remove-duplicates '(a b c b a d))
              '(a b c d))
      (eq? (strip-prefix 'x 'xabc) 'abc)
      (eq? (strip-suffix 'x 'abcx) 'abc)
      ((prefixed-with? 'x) 'xabc)
      (not ((prefixed-with? 'x) 'abc))
      (equal? (extract odd? '(1 2 (3 4 (5 6))))
              '(1 3 5))
      (equal? (extract (prefixed-with? 'x)
                       '(abc (xab yd (ya xb))))
              '(xab xb))
      ))
  (symbols?) 
  (define-test (destructuring?)
    (check
      "BIND"
      ; 1 is not a list
      (= (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 (3 4 5)) 6)
          (list x y z u v w))
        '(1 2 3 4 (5) 6))
      (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))
             ((exn bind) #f)))
      (equal?
        (bind (x (y (z . u)) v . w) (list 1 (list 2 (list #f #f)) 5 6)
          (list x y z u v w))
        '(1 2 #f (#f) 5 (6)))

      "BIND-CASE"
      (not (bind-case '() (() #f)))
      (bind-case '("a") ((#f) #f) (("a") #t))
      (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 (2 3))
                ((x (y z)) (where (odd? y)) (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 (#f 3))
                ((x y) (where (number? y)) (list x y))
                ((x ("y" . z)) (list x z))
                ((x (#f z)) (list x z)))
              '(1 3))
      (equal? (bind-case '(1 (#f 3))
                ((x y) (list x y))
                ((x ("y" . z)) (list x z))
                ((x (#f z)) (list x z)))
              '(1 (#f 3)))
      (equal? (bind-case '(1 (#f 3))
                ((x ("y" . z)) (list x z))
                ;((x y) (list x y))
                ((x (#f z)) (list x z)))
              '(1 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))
      ))
  (destructuring?)

  (define-test (macros?)
    (check
      (define-macro (foo (qux))
        (with-keywords (bar baz)
          `(case ',qux
             ((bar baz) ',qux)
             (else 'no))))
      (eq? (foo (bar)) 'bar)
      (eq? (foo (baz)) 'baz)
      (eq? (foo (qux)) 'no)
      (define-macro (efreeze xpr)
        (with-rename-prefix %
          `(,%lambda () ,xpr)))
      (= ((efreeze 3)) 3)
      (define-macro (ifreeze xpr)
        `(lambda () ,xpr))
      (= ((ifreeze 5)) 5)
      (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)
                         (with-rename-prefix %
                           `(,%lambda () ,xpr))))
           ((efreeze ((ifreeze 3)))))
         3)
      (equal? (let-macro (((ifreeze xpr) `(lambda () ,xpr))
                          ((efreeze xpr)
                           (with-rename-prefix %
                             `(,%lambda () ,xpr))))
                (list ((efreeze 3)) ((ifreeze 5))))
              '(3 5))

      "LITERALS"
      (define-syntax foo
        (macro-rules ()
          ((_ "foo" x) x)
          ((_ #f x) `(list 'false))
          ((_ #f x) 'false)
          ((_ a b) (where (string? a)) `(list ,a ,b))
          ((_ a b) (where (odd? a)) `(list ,a ,b))
          ((_ a b) a)))
        (= (foo "foo" 1) 1)
        (equal? (foo "bar" 2) '("bar" 2))
        (equal? (foo #f 'blabla) '(false))
        (equal? (foo 1 2) '(1 2))
        (= (foo 2 3) 2)

      "IN?"
      (define-macro (in? what equ? . choices)
        (let ((insym 'in))
          `(let ((,insym ,what))
             (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
                        choices)))))
      (in? 2 = 1 2 3)
      (not (in? 5 = 1 2 3))

      "VERBOSE IFS"
      (define-macro (verbose-if test (then . xprs) (else . yprs))
        (with-rename-prefix %
          (with-keywords (then else)
            `(,%if ,test
               (,%begin ,@xprs)
               (,%begin ,@yprs)))))
      (define (quux x)
        (verbose-if (odd? x) (then "odd") (else "even")))
      (equal? (quux 3) "odd")
      (equal? (quux 4) "even")
      (define-syntax vif
        (macro-rules (then else)
          ((_ test (then xpr . xprs))
           `(if ,test
              (begin ,xpr ,@xprs)))
          ((_ test (else xpr . xprs))
           `(if ,(not test)
              (begin ,xpr ,@xprs)))
          ((_ test (then xpr . xprs) (else ypr . yprs))
           `(if ,test
              (begin ,xpr ,@xprs)
              (begin ,ypr ,@yprs)))))
      (define (oux)
        (vif #t (then 'true)))
      (define (pux)
        (vif #t (else 'false)))
      (eq? (oux) 'true)
      (eq? (pux) 'false)
      
      "LOW-LEVEL COND"
      (define-syntax my-cond
        (macro-rules (else =>)
          ((_ (else xpr . xprs))
           `(begin ,xpr ,@xprs))
          ((_ (test => xpr))
           `(let ((tmp ,test))
              (if tmp (,xpr tmp))))
          ((_ (test => xpr) . clauses)
           `(let ((tmp ,test))
              (if tmp
                (,xpr tmp)
                (my-cond ,@clauses))))
          ((_ (test))
           test)
          ((_ (test) . clauses)
           `(let ((tmp ,test))
              (if tmp
                tmp
                (my-cond ,@clauses))))
          ((_ (test xpr . xprs))
           `(if ,test (begin ,xpr ,@xprs)))
          ((_ (test xpr . xprs) . clauses)
           `(if ,test
              (begin ,xpr ,@xprs)
              (my-cond ,@clauses)))
          ))
      (my-cond ((> 3 2)))
      (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
           'greater)
      (eq? (my-cond ((> 3 3) 'greater)
               ((< 3 3) 'less)
               (else 'equal))
           'equal)
      (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
               (else #f))
         2)
      (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
               (else #f)))

      "ANAPHORIC MACROS"
      (define-macro (alambda args xpr . xprs)
        (with-inject-prefix %
          `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
             ,%self)))
      (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
      (= (! 5) 120)
      (define-syntax aif
        (macro-rules it ()
          ((_ test consequent)
           `(let ((,it ,test))
              (if ,it ,consequent)))
          ((_ test consequent alternative)
           `(let ((,it ,test))
              (if ,it ,consequent ,alternative)))))
      (define (mist x) (aif (! x) it))
      (= (mist 5) 120)))
  (macros?)

  (define-test (generics?)
    (check
      (equal? (seq-tail '#(0 1 2) 3) '#())
      (string=? (seq-tail "foo" 1) "oo")
      (char=? (seq-ref "foo" 1) #\o)
      (equal? (seq-tail '(0 1 2) 1) '(1 2))
      (seq-length-ref-tail! tuple?
                            tuple-length
                            tuple-ref
                            tuple-from-upto)
      (= (seq-ref (tuple 0 1 2) 1) 1)
      (tuple-equal? (seq-tail (tuple 0 1 2) 1)
                    (tuple 1 2))))
  (generics?)      

  (define-test (etc?)
    (check
      (define-syntax-rule (freeze x) (lambda () x))
      (= ((freeze 25)) 25))
      (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 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))
  (etc?)
  )