Monad with do-notation in Racket

monad.rkt

#lang racket

(define-syntax define-macro
  (lambda (x)
    (syntax-case x ()
      ((_ (macro . args) body ...)
       #'(define-macro macro (lambda args body ...)))
      ((_ macro transformer)
       #'(define-syntax macro
           (lambda (y)
             (syntax-case y ()
               ((_ . args)
                (let ((v (syntax->datum #'args)))
                  (datum->syntax y (apply transformer v)))))))))))


(struct monad-i (pure bind))

(define-macro (let-monad monad-inst . exps)
  `(let ((bind (monad-i-bind ,monad-inst))
         (pure (monad-i-pure ,monad-inst)))
     (begin
       ,@exps)))


(define-macro (monad-do . exps)
  (define (impl exps)
    (if (eq? (cdr exps) '())
        (car exps)
        (let ((e (car exps))
              (es (cdr exps)))
          (if (and (pair? e)
                   (eq? (car e) 'assign))
              `(bind ,(caddr e) (lambda (,(cadr e))
                                  ,(impl es)))
              `(bind ,e (lambda (,(gensym)) ,(impl es)))))))
  (impl exps))

(struct just (val) #:transparent)
(define nothing 'nothing)

(define maybe-monad
  (monad-i
    ;; pure
    just
    ;; bind
    (lambda (m k)
      (match m
        ((quote nothing) nothing)
        ((struct just (x)) (k x))))))

(define-syntax curried-lambda
  (syntax-rules ()
    ((_ (e1) e2 ...)
      (lambda (e1) e2 ...))
    ((_ (e1 e2 ...) e3 ...)
      (lambda (e1) (curried-lambda (e2 ...) e3 ...)))))

(define-syntax define-curried
  (syntax-rules ()
    ((_ (f e1 ...) e2 ...)
      (define f
        (curried-lambda (e1 ...) e2 ...)))))

(define-curried (f monad-inst m)
  (let-monad monad-inst
    (monad-do
      (assign x m)
      (assign y (pure (+ x 1)))
      (pure (+ x y)))))

(define f-maybe (f maybe-monad))

(display (f-maybe (just 5)))
(newline)
(display (f-maybe nothing))
(newline)