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

(doclist '())

(ir-macro-define-with-contract (my-or . args)
  "another version of short-circuited or"
  (if (null? args)
    #f
    (let ((tmp (car args)))
      `(if ,tmp ,tmp (my-or ,@(cdr args))))))

(ir-macro-define-with-contract (freeze xpr)
  "freeze xpr in a thunk"
  `(lambda () ,xpr))

(ir-macro-define-with-contract (do-forever . body)
  "endless loop to be exited with exit"
  (with-injected (exit)
    `(call/cc (lambda (,exit)
                (let loop ()
                  ,@body
                  (loop))))))

(define-syntax-with-contract aif
  "anaphoric if, which can reference the test result with name it"
  (ir-macro-rules (it)
    ((_ test then)
     `(let ((,it ,test))
        (if ,it ,then)))
    ((_ test then else)
     `(let ((,it ,test))
        (if ,it ,then ,else)))))

(ir-macro-define-with-contract (awhen test xpr . xprs)
  "anaphoric when, which can reference the test result with it"
  (with-injected (it)
    `(let ((,it ,test))
       (if ,it (begin ,xpr ,@xprs)))))

(ir-macro-define-with-contract (aand . args)
  "anaphoric and, which can reference the previous arg with it"
  (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-with-contract acond
  "anaphoric cond, which can reference the test in each clause with it"
  (ir-macro-rules (it)
    ((_ (test . xprs))
     (if (compare? test 'else)
       `(begin ,@xprs)
       `(let ((,it ,test))
          (if ,it
            (begin ,@xprs)
            (error 'acond "no test succeeds")))))
    ((_ (test . xprs) (test1 . xprs1) . clauses)
     `(let ((,it ,test))
        (if ,it
          (begin ,@xprs)
          (acond (,test1 ,@xprs1) ,@clauses))))))

(ir-macro-define-with-contract (awhile ok? xpr . xprs)
  "anaphoric while, which can reference the result of each ok? with it"
  (with-injected (it)
   `(let loop ((,it ,ok?))
      (when ,it
        ,xpr ,@xprs
        (loop ,ok?)))))

(ir-macro-define-with-contract (alambda args xpr . xprs)
  "anaphoric lambda which can reference itself with self"
  (with-injected (self)
   `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
      ,self)))

(define docs (doclist->dispatcher (doclist)))

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

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

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



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

;;; (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
  (= ((freeze 3)) 3)
  (equal?
    (ir-macro-letrec (
      ((aif test then) (with-injected (it) `(let ((,it ,test)) (if ,it ,then))))
      )
      (aif (memv 2 '(1 2 3)) it))
    '(2 3))
  (equal?
    (ir-macro-let (
      ((aif test then) (with-injected (it) `(let ((,it ,test)) (if ,it ,then))))
      )
      (aif (memv 2 '(1 2 3)) it))
    '(2 3))
  (equal?
    (let ((f (lambda (n) (+ n 10))))
      (ir-macro-let (
        ((f n) n)
        ((g n) `(f ,n))
        )
        (list (f 1) (g 1))))
    '(1 11))
  (equal?
    (let ((f (lambda (n) (+ n 10))))
      (ir-macro-letrec (
        ((f n)  n)
        ((g n) `(f ,n))
        )
        (list (f 1) (g 1))))
    '(1 1))
  (equal?
    (map (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))) (aand lst (cdr it) (cdr it)))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3)))
      (acond ((memv 5 lst) it) ((memv 2 lst) it) (else it)))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3))) (aif (memv 2 lst) it #f))
    '(2 3))
  (equal?
    (let ((lst '(0 1 2 3))) (awhen (memv 2 lst) (reverse it)))
    '(3 2))
  (equal?
    (let ((lst '(0 1 2 3)) (acc '()))
      (awhile lst
        (if (null? lst)
          (set! lst #f)
          (begin 
            (set!  acc (cons (car lst) acc))
            (set! lst (cdr lst)))))
      acc)
    '(3 2 1 0))
  (= (my-or #f #f 2 #f) 2)
  (eq? (my-or) #f)
  (equal? (foo 3) '(a a a))
  (equal? (bar) '(1 11))
  (equal? (baz) '(1 1)))