do.rkt

#lang racket/base
(provide
 do
 with-bind-function)

(require
 racket/stxparam
 syntax/parse/define
 (for-syntax racket/base))

(module+ test
  (require racket/list rackunit))

;; -----------------------------------------------------------------------------

(begin-for-syntax
  (define-splicing-syntax-class larrow
    [pattern {~seq x:id {~datum <-} rhs:expr}
             #:attr bind (λ (>>= rest)
                           #`(#,>>= rhs (λ (x) #,rest)))]))

(define-simple-macro
  (do {~optional {~seq #:bind f:expr}
                 #:defaults ([f #`(current-bind-function #,this-syntax)])}
      a:larrow ...
      e:expr)
  #:with body (foldr (λ (bind acc) (bind #'>>= acc))
                     #'e
                     (attribute a.bind))
  (let ([>>= f])
    body))

(define-simple-macro
  (with-bind-function f:expr body ...)
  (let ([>>= f])
    (syntax-parameterize ([current-bind-function (λ (stx) #'>>=)])
      body ...)))

(define-syntax-parameter current-bind-function
  (syntax-parser
    [(_ orig)
     (raise-syntax-error #f "no bind function set" #'orig)]))

;; -----------------------------------------------------------------------------

(module+ test
  (define (opt-bind x f) (and x (f x)))
  (define (list-bind x f) (append-map f x))

  (check-equal? (do #:bind opt-bind 'ok)
                'ok)

  (check-equal? (do #:bind opt-bind
                    x <- 4
                    y <- 5
                    (+ x y))
                9)

  (check-equal? (do #:bind list-bind
                    x <- '(1 2)
                    y <- '(3 4)
                    `([,x ,y]))
                '([1 3] [1 4] [2 3] [2 4]))

  (with-bind-function opt-bind
    (define-values [i j] (values 0 0))
    (define-syntax-rule (inc! x e ...) (begin (set! x (add1 x)) e ...))

    (check-false (do x <- #f
                     y <- (inc! i 5)
                     (+ x y)))
    (check-equal? i 0)

    (check-false (do x <- (inc! j 3)
                     y <- #f
                     (+ x y)))
    (check-equal? j 1)))