#lang racket

(provide left right left? right? squash
         >>= return reduce <*> e-map do)

(struct either (tag value))

(define (left val)
  (either 'left val))

(define (right val)
  (either 'right val))

(define (left? val)
  (and (either? val) (eq? (either-tag val) 'left)))

(define (right? val)
  (not (left? val)))

(define (>>= e f)
  (if (eq? (either-tag e) 'left)
    e
    (f (either-value e))))

(define (return x)
  (right x))

(define (reduce f-left f-right e)
  (if (eq? (either-tag e) 'left)
    (f-left (either-value e))
    (f-right (either-value e))))

(define (<*> f e)
  (cond
    ((eq? 'left (either-tag f))
     f)
    ((eq? 'left (either-tag e))
     e)
    (else
      (right ((either-value f) (either-value e))))))

(define (e-map f e)
  (if (eq? 'left (either-tag e))
    e
    (right (f (either-value e)))))

(define (squash e)
  (if (and (right? e) (either? (either-value e)))
    (either-value e)
    e))

; (do
;  (<- var1 exp1)
;  (exp2)
;  (let var2 exp3)
;  (return var2))
;
;  -->
; (>>= exp1 (lambda (var1) (exp2) (let ((var2 exp3)) (return var2))))

(define-syntax (do stx)
  (define (do->lambda exprs)
    (define expr (car exprs))
    (cond
      ((and (pair? expr) (eq? (car expr) '<-))
       `(>>= ,(caddr expr) (lambda (,(cadr expr)) ,(do->lambda (cdr exprs)))))
      ((and (pair? expr) (eq? (car expr) 'let))
       `(let ((,(cadr expr) ,(caddr expr))) ,(do->lambda (cdr exprs))))
      ((null? (cdr exprs))
       expr)
      (else
        `(begin ,expr ,(do->lambda (cdr exprs))))))
  (let* ((ast (syntax->datum stx))
         (transformed (do->lambda (cdr ast))))
    (datum->syntax stx transformed)))