#lang racket/base
(provide mailbox-select
mailbox->list
mailbox-clear
receive)
(require racket/list
racket/match
(for-syntax racket/base)
(for-syntax racket/list))
(define (mailbox-clear)
(when (thread-try-receive)
(mailbox-clear)))
(define (mailbox->list)
(let loop ([lst empty])
(let ([msg (thread-try-receive)])
(if msg
(loop (cons msg lst))
(begin
(thread-rewind-receive lst)
(reverse lst))))))
(define (mailbox-select match . events)
(let loop ([unmatched-messages empty])
(let ([ready-event (call-with-exception-handler
(λ (exn)
(thread-rewind-receive unmatched-messages))
(λ () (apply sync (thread-receive-evt) events)))])
(cond [(equal? ready-event (thread-receive-evt))
(let ([next (thread-receive)])
(cond [(call-with-exception-handler
(λ (exn)
(thread-rewind-receive (cons next unmatched-messages))
exn)
(λ ()
(match next))) =>
(λ (result)
(thread-rewind-receive unmatched-messages)
result)]
[else
(loop (cons next unmatched-messages))]))]
[else
(thread-rewind-receive unmatched-messages)
ready-event]))))
(define-syntax (receive stx)
(syntax-case stx ()
[(_)
#`(thread-receive)]
[(_ pat ...)
(let loop ([stx (syntax-e #`(pat ...))]
[events empty]
[match-clauses empty])
(if (empty? stx)
#`((mailbox-select (λ (msg)
(with-handlers ([exn:misc:match? (λ (exn) #f)])
(match msg #,@(reverse match-clauses))))
#,@(reverse events)))
(syntax-case (first stx) (event timeout when)
[((event evt) code ...)
(loop (rest stx)
(cons #`(wrap-evt evt
(λ (evt) (λ () code ...)))
events)
match-clauses)]
[((timeout time) code ...)
(loop (rest stx)
(cons #`(wrap-evt (alarm-evt (+ (current-inexact-milliseconds) (* time 1000)))
(λ (evt) (λ () code ...)))
events)
match-clauses)]
[((when condition ...) code ...)
(loop (rest stx)
(cons #`(wrap-evt (guard-evt (λ () (if ((λ () condition ...)) always-evt never-evt)))
(λ (evt) (λ () code ...)))
events)
match-clauses)]
[(match-clause match-code ...)
(loop (rest stx)
events
(cons #`(match-clause (λ () match-code ...))
match-clauses))])))]))