;;; File: low-level-macros/run.scm
(require 'low-level-macros)
(import low-level-macros)
(import-for-syntax (only low-level-macros ir-macro-rules er-macro-rules))

(define-syntax er-do-forever
  (er-macro-rules (%call/cc %lambda %let %loop)
     ((_ . body)
      `(,%call/cc (,%lambda (exit)
                    (,%let ,%loop ()
                      ,@body
                      (,%loop)))))))

(macro-define (ir-do-forever . body)
  (with-injected (exit)
    `(call/cc (lambda (,exit)
                (let loop ()
                  ,@body
                  (loop))))))

(macro-define (er-or . args)
  (with-renamed (%if %er-or)
    (if (null? args)
      #f
      (let ((tmp (car args)))
        `(,%if ,tmp ,tmp (,%er-or ,@(cdr args)))))))

(macro-define (ir-or . args)
  (if (null? args)
    #f
    (let ((tmp (car args)))
      `(if ,tmp ,tmp (ir-or ,@(cdr args))))))

(macro-define (er-freeze xpr)
  (with-renamed (%lambda)
    `(,%lambda () ,xpr)))

(macro-define (ir-freeze xpr)
  `(lambda () ,xpr))

(define (f n) (+ n 10))

(define (er-bar)
  (macro-let (
    ((f n) (with-renamed ()  n))
    ((g n) (with-renamed (%f) `(,%f ,n)))
    )
    (list (f 1) (g 1))))

(define (ir-bar)
  (macro-let (
    ((f n) n)
    ((g n) `(f ,n))
    )
    (list (f 1) (g 1))))

(define (er-baz)
  (macro-letrec (
    ((f n) (with-renamed ()  n))
    ((g n) (with-renamed (%f) `(,%f ,n)))
    )
    (list (f 1) (g 1))))

(define (ir-baz)
  (macro-letrec (
    ((f n) n)
    ((g n) `(f ,n))
    )
    (list (f 1) (g 1))))

(define-syntax er-aif
  (er-macro-rules (%let %if)
    ((_ test then)
     `(,%let ((it ,test))
        (,%if it ,then)))
    ((_ test then else)
     `(,%let ((it ,test))
        (,%if it ,then ,else)))))

(define-syntax ir-aif
  (ir-macro-rules (it)
    ((_ test then)
     `(let ((,it ,test))
        (if ,it ,then)))
    ((_ test then else)
     `(let ((,it ,test))
        (if ,it ,then ,else)))))

(macro-define (er-awhen test xpr . xprs)
  (with-renamed (%let %if %begin)
    `(,%let ((it ,test))
       (,%if it (,%begin ,xpr ,@xprs)))))

(macro-define (ir-awhen test xpr . xprs)
  (with-injected (it)
    `(let ((,it ,test))
       (if ,it (begin ,xpr ,@xprs)))))

(macro-define (er-aand . args)
  (with-renamed (%let %if)
   (let loop ((args args))
     (cond 
       ((null? args) #t)
       ((null? (cdr args)) (car args))
       (else 
         `(,%let ((it ,(car args)))
            (,%if it
              ,(loop (cdr args)))))))))

(macro-define (ir-aand . args)
  (with-injected (it)
   (let loop ((args args))
     (cond 
       ((null? args) #t)
       ((null? (cdr args)) (car args))
       (else 
         `(let ((,it ,(car args)))
            (if ,it
              ,(loop (cdr args)))))))))

(define-syntax er-acond
  (er-macro-rules (%else %begin %let %if %error %er-acond)
    ((_ (test . xprs))
     (if (compare? test %else)
       `(,%begin ,@xprs)
       `(,%let ((it ,test))
          (,%if it
            (,%begin ,@xprs)
            (,%error 'er-acond "no test succeeds")))))
    ((_ (test . xprs) (test1 . xprs1) . clauses)
     `(,%let ((it ,test))
        (,%if it
          (,%begin ,@xprs)
          (,%er-acond (,test1 ,@xprs1) ,@clauses))))))

(define-syntax ir-acond
  (ir-macro-rules (it)
    ((_ (test . xprs))
     (if (compare? test 'else)
       `(begin ,@xprs)
       `(let ((,it ,test))
          (if ,it
            (begin ,@xprs)
            (error 'ir-acond "no test succeeds")))))
    ((_ (test . xprs) (test1 . xprs1) . clauses)
     `(let ((,it ,test))
        (if ,it
          (begin ,@xprs)
          (ir-acond (,test1 ,@xprs1) ,@clauses))))))

(macro-define (er-awhile ok? xpr . xprs)
  (with-renamed (%let %loop)
   `(,%let ,%loop ((it ,ok?))
      (when it
        ,xpr ,@xprs
        (,%loop ,ok?)))))

(macro-define (ir-awhile ok? xpr . xprs)
  (with-injected (it)
   `(let loop ((,it ,ok?))
      (when ,it
        ,xpr ,@xprs
        (loop ,ok?)))))

(macro-define (er-alambda args xpr . xprs)
  (with-renamed (%letrec %lambda)
   `(,%letrec ((self (,%lambda ,args ,xpr ,@xprs)))
      self)))

(macro-define (ir-alambda args xpr . xprs)
  (with-injected (self)
   `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
      ,self)))

(define (er-foo n)
  (let ((lst '()))
    (er-do-forever
      (if (zero? n)
        (exit lst))
        (begin
          (set! lst (cons 'a lst))
          (set! n (- n 1))))))

(define (ir-foo n)
  (let ((lst '()))
    (ir-do-forever
      (if (zero? n)
        (exit lst))
        (begin
          (set! lst (cons 'a lst))
          (set! n (- n 1))))))

(define (f n) (+ n 10))

;;; (run xpr0 xpr1 ...)
;;; -------------------
(define (run . xprs)
  (let loop ((xprs xprs))
    (if (null? xprs)
      (print "All tests passed!")
      (if (car xprs)
        (loop (cdr xprs))
        (error 'run "#### Some test failed! ####")))))

(run
  (equal?
    (macro-letrec (
      ((er-aif test then)
       (with-renamed (%let %if) `(,%let ((it ,test)) (,%if it ,then))))
      )
      (er-aif (memv 2 '(1 2 3)) it))
    '(2 3))
  (equal?
    (macro-let (
      ((er-aif test then)
       (with-renamed (%let %if) `(,%let ((it ,test)) (,%if it ,then))))
      )
      (er-aif (memv 2 '(1 2 3)) it))
    '(2 3))
  (equal?
    (macro-letrec (
      ((ir-aif test then) (with-injected (it) `(let ((,it ,test)) (if ,it ,then))))
      )
      (ir-aif (memv 2 '(1 2 3)) it))
    '(2 3))
  (equal?
    (macro-let (
      ((ir-aif test then) (with-injected (it) `(let ((,it ,test)) (if ,it ,then))))
      )
      (ir-aif (memv 2 '(1 2 3)) it))
    '(2 3))
  (equal?
    (map (er-alambda (n) (if (zero? n) 1 (* n (self (- n 1)))))
         '(1 2 3 4 5))
    '(1 2 6 24 120))
  (equal?
    (map (ir-alambda (n) (if (zero? n) 1 (* n (self (- n 1)))))
         '(1 2 3 4 5))
    '(1 2 6 24 120))
  (equal?
    (let ((lst '(0 1 2 3))) (er-aand lst (cdr it) (cdr it)))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3))) (ir-aand lst (cdr it) (cdr it)))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3)))
      (er-acond ((memv 5 lst) it) ((memv 2 lst) it) (else it)))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3)))
      (ir-acond ((memv 5 lst) it) ((memv 2 lst) it) (else it)))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3))) (er-aif (memv 2 lst) it #f))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3))) (ir-aif (memv 2 lst) it #f))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3))) (er-awhen (memv 2 lst) (reverse it)))
    '(3 2))
  (equal?
    (let ((lst '(0 1 2 3))) (ir-awhen (memv 2 lst) (reverse it)))
    '(3 2))
  (equal?
    (let ((lst '(0 1 2 3)) (acc '()))
      (er-awhile lst
        (if (null? lst)
          (set! lst #f)
          (begin 
            (set!  acc (cons (car lst) acc))
            (set! lst (cdr lst)))))
      acc)
    '(3 2 1 0))
  (equal?
    (let ((lst '(0 1 2 3)) (acc '()))
      (ir-awhile lst
        (if (null? lst)
          (set! lst #f)
          (begin 
            (set!  acc (cons (car lst) acc))
            (set! lst (cdr lst)))))
      acc)
    '(3 2 1 0))
  (equal? (with-aliases (identity %x %y) (list %x %y)) '(x y))
  (= (ir-or #f #f 2 #f) 2)
  (= (er-or #f #f 2 #f) 2)
  (= ((er-freeze 3)) 3)
  (= ((ir-freeze 3)) 3)
  (eq? (ir-or) #f)
  (eq? (er-or) #f)
  (equal? (er-foo 3) '(a a a))
  (equal? (ir-foo 3) '(a a a))
  (equal? (er-bar) '(1 11))
  (equal? (ir-bar) '(1 11))
  (equal? (er-baz) '(1 1))
  (equal? (ir-baz) '(1 1))
  (equal?
    (let ((f (lambda (n) (+ n 10))))
      (macro-let (
        ((f n) n)
        ((g n) `(f ,n))
        )
        (list (f 1) (g 1))))
    '(1 11))
  (equal?
    (let ((f (lambda (n) (+ n 10))))
      (macro-letrec (
        ((f n)  n)
        ((g n) `(f ,n))
        )
        (list (f 1) (g 1))))
    '(1 1))
  )