(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 macro-helpers seq-destruc list-destruc dbind-ex dbind-lit
        dbind-len dbind-def map* flatten-map*)
  (only low-level-macros macro-rules once-only with-gensyms))

(compound-test (low-level-macros)
  (define-test (helpers?)
    (check
      (equal? (flatten '(a (b c (d))))
              '(a b c d))
      (equal? (memp odd? '(2 4 3 1))
              '(3 1))
      (not (assp odd? '((0 1) (0 2) (0 3))))
      (equal? (assp odd? '((0 1) (1 2) (2 3)))
              '(1 2))
      (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)
      (eq? (add-prefix 'x 'abc) 'xabc)
      ((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))
      (equal? (map* + '(1 (2 . 3) . 4) '(10 (20 . 30) . 40))
              '(11 (22 . 33) . 44))
      (equal? (flatten-map* + '(1 (2 . 3) . 4) '(10 (20 . 30) . 40))
              '(11 22 33 44))
      (equal?
        (replace* odd? (lambda (x) (* 10 x)) '(0 (1 (2 . 3))))
        '(0 (10 (2 . 30))))
      (equal? (vector-tail '#(0 1 2 3) 4) '#())
      (equal? (vector-tail '#(0 1 2 3) 0) '#(0 1 2 3))
      (atom? '#(1))
      ((list-of? atom?) '(#() #(1) #(0 1)))
      ))
  (helpers?) 

  (define-test (macros?)
    (check
      (define-er-macro (efreeze . body)
        (rename-prefix %)
        `(,%lambda () ,@body))
      (= ((efreeze 1 2 3)) 3)
      (define-macro (foo (qux))
        (keywords bar baz)
        `(case ',qux
           ((bar baz) ',qux)
           (else 'no)))
      (eq? (foo (bar)) 'bar)
      (eq? (foo (baz)) 'baz)
      (eq? (foo (qux)) 'no)
      (define-macro (freeze xpr)
        `(lambda () ,xpr))
      (= ((freeze 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))
      (= (let-macro (((freeze xpr) `(lambda () ,xpr)))
           ((freeze 3)))
         3)
      (= (letrec-macro (((second lst) `(car (rest ,lst)))
                        ((rest lst) `(cdr ,lst)))
          (second '(1 2 3)))
        2)

      "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))
        (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)))

      "LETREC"
      (define-macro (my-letrec pairs . body)
        (let ((vars (map car pairs))
              (vals (map cadr pairs))
              (aux (map (lambda (x) (gensym)) pairs)))
          `(let ,(map (lambda (var) `(,var #f)) vars)
             (let ,(map (lambda (a v) `(,a ,v)) aux vals)
               ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
               ,@body))))
      (equal?
        (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
                    (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
                   (list (o? 95) (e? 95)))
        '(#t #f))

      "ANAPHORIC MACROS"
      (define-macro (alambda args xpr . xprs)
        (inject self)
        `(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?)

  (define-test (destructuring?)
    (check
      "BIND-LIST"
      ; 1 is not a list
      (= (list-bind a 1 a) 1)
      (equal? (list-bind (a b) '(1 2) (where (odd? a)) (list a b))
              '(1 2))
      (equal?
        (list-bind (x y z w) '(1 2 3 4) (list x y z w))
        '(1 2 3 4))
      (equal?
        (list-bind (x . y) '(1 2 3 4) (list x y))
        '(1 (2 3 4)))
      (equal?
        (list-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? (list-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)))
      (condition-case
        (list-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) #t))
      (equal?
        (list-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-LIST-CASE"
      (not (list-bind-case '() (() #f)))
      (list-bind-case '("a") ((#f) #f) (("a") #t))
      (equal? (list-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? (list-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? (list-bind-case '(1 (2 3))
                ((x (y z)) (where (odd? y)) (list x y z))
                ((x y) (list x y)))
              '(1 (2 3)))
      (equal? (list-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? (list-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? (list-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? (list-bind-case '(1 (#f 3))
                ((x ("y" . z)) (list x z))
                ((x (#f z)) (list x z)))
              '(1 3))
      (equal? (list-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? (list-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? (list-bind-case '(1 (2 . 3))
                ((x (y . z)) (list x y z))
                ((x (y z)) (list x y z)))
              '(1 2 3))
      (equal? (list-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?
        (list-bind-case '(1 2)
          (() '())
          ((a) (list a))
          ((a b) (list a b))
          ((a b C) (list a b C)))
        '(1 2))
      (define (my-map fn lst)
        (list-bind-case lst
          (() '())
          ((x . xs) (cons (fn x)
                          (my-map fn xs)))))
      (equal?  (my-map add1 '(1 2 3)) '(2 3 4))
      ))
  (destructuring?)

  )