179 lines
6.5 KiB
Racket
179 lines
6.5 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/async-channel
|
|
racket/place
|
|
port-channel)
|
|
|
|
(provide uni-channel?
|
|
uni-channel-kind
|
|
uni-channel-direction
|
|
|
|
make-uni-channel
|
|
|
|
uni-channel-put
|
|
uni-channel-get
|
|
uni-channel-send
|
|
uni-channel-recv
|
|
uni-channel-try-get
|
|
uni-channel-get-evt
|
|
uni-channel-put-evt
|
|
uni-channel-close
|
|
uni-channel-wait
|
|
uni-channel-closed?
|
|
|
|
uni-channel-error-get
|
|
uni-channel-error-try-get
|
|
uni-channel-error-evt)
|
|
|
|
(struct uni-channel
|
|
(kind impl direction get-proc put-proc try-get-proc get-evt-proc put-evt-proc
|
|
close-proc wait-proc closed-box error-get-proc error-try-get-proc error-evt-proc)
|
|
#:property prop:evt
|
|
(lambda (ch)
|
|
(if (can-get? ch) ((uni-channel-get-evt-proc ch) ch) never-evt)))
|
|
|
|
(define (can-get? ch) (not (eq? (uni-channel-direction ch) 'output)))
|
|
(define (can-put? ch) (not (eq? (uni-channel-direction ch) 'input)))
|
|
|
|
(define (raise-no-get who ch)
|
|
(raise-arguments-error who "uni-channel does not support receiving"
|
|
"kind" (uni-channel-kind ch)
|
|
"direction" (uni-channel-direction ch)))
|
|
|
|
(define (raise-no-put who ch)
|
|
(raise-arguments-error who "uni-channel does not support sending"
|
|
"kind" (uni-channel-kind ch)
|
|
"direction" (uni-channel-direction ch)))
|
|
|
|
(define (raise-closed who ch)
|
|
(raise-arguments-error who "uni-channel is closed"
|
|
"kind" (uni-channel-kind ch)
|
|
"direction" (uni-channel-direction ch)))
|
|
|
|
(define (mark-closed! ch) (set-box! (uni-channel-closed-box ch) #t))
|
|
|
|
(define (default-close ch)
|
|
(mark-closed! ch)
|
|
(void))
|
|
|
|
(define (default-wait ch)
|
|
(void))
|
|
|
|
(define (no-error-get ch)
|
|
(raise-arguments-error 'uni-channel-error-get "uni-channel has no error channel"
|
|
"kind" (uni-channel-kind ch)))
|
|
|
|
(define (no-error-try-get ch) #f)
|
|
(define (no-error-evt ch) never-evt)
|
|
|
|
(define (make-uc #:kind kind
|
|
#:impl impl
|
|
#:direction direction
|
|
#:get get-proc
|
|
#:put put-proc
|
|
#:try-get try-get-proc
|
|
#:get-evt get-evt-proc
|
|
#:put-evt put-evt-proc
|
|
#:close close-proc
|
|
#:wait wait-proc
|
|
#:error-get error-get-proc
|
|
#:error-try-get error-try-get-proc
|
|
#:error-evt error-evt-proc)
|
|
(uni-channel kind impl direction get-proc put-proc try-get-proc get-evt-proc put-evt-proc
|
|
close-proc wait-proc (box #f) error-get-proc error-try-get-proc error-evt-proc))
|
|
|
|
(define (make-uni-channel channel)
|
|
(cond
|
|
[(async-channel? channel) (make-async-uc channel)]
|
|
[(place-channel? channel) (make-place-uc channel)]
|
|
[(port-channel? channel) (make-port-uc channel)]
|
|
[else (raise-argument-error 'make-uni-channel
|
|
"(or/c async-channel? place-channel? port-channel?)"
|
|
channel)]))
|
|
|
|
(define (make-async-uc ch)
|
|
(make-uc #:kind 'async
|
|
#:impl ch
|
|
#:direction 'bidirectional
|
|
#:get (lambda (_ch) (async-channel-get ch))
|
|
#:put (lambda (_ch v) (async-channel-put ch v))
|
|
#:try-get (lambda (_ch) (async-channel-try-get ch))
|
|
#:get-evt (lambda (_ch) ch)
|
|
#:put-evt (lambda (_ch v) (async-channel-put-evt ch v))
|
|
#:close default-close
|
|
#:wait default-wait
|
|
#:error-get no-error-get
|
|
#:error-try-get no-error-try-get
|
|
#:error-evt no-error-evt))
|
|
|
|
(define (make-place-uc ch)
|
|
(make-uc #:kind 'place
|
|
#:impl ch
|
|
#:direction 'bidirectional
|
|
#:get (lambda (_ch) (place-channel-get ch))
|
|
#:put (lambda (_ch v) (place-channel-put ch v))
|
|
#:try-get (lambda (_ch) (sync/timeout 0 ch))
|
|
#:get-evt (lambda (_ch) ch)
|
|
#:put-evt (lambda (_ch v) (handle-evt always-evt (lambda (_) (place-channel-put ch v))))
|
|
#:close default-close
|
|
#:wait default-wait
|
|
#:error-get no-error-get
|
|
#:error-try-get no-error-try-get
|
|
#:error-evt no-error-evt))
|
|
|
|
(define (make-port-uc pc)
|
|
(define dir (port-channel-direction pc))
|
|
(make-uc #:kind 'port
|
|
#:impl pc
|
|
#:direction dir
|
|
#:get (lambda (_ch) (port-channel-get pc))
|
|
#:put (lambda (_ch v) (port-channel-put pc v))
|
|
#:try-get (lambda (_ch) (port-channel-try-get pc))
|
|
#:get-evt (lambda (_ch) (port-channel-evt pc))
|
|
#:put-evt (lambda (_ch v) (handle-evt always-evt (lambda (_) (port-channel-put pc v))))
|
|
#:close (lambda (ch) (mark-closed! ch) (close-port-channel pc))
|
|
#:wait (lambda (_ch) (port-channel-wait pc))
|
|
#:error-get (lambda (_ch) (port-channel-error-get pc))
|
|
#:error-try-get (lambda (_ch) (port-channel-error-try-get pc))
|
|
#:error-evt (lambda (_ch) (port-channel-error-evt pc))))
|
|
|
|
(define (uni-channel-put ch v)
|
|
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-put ch))
|
|
(unless (can-put? ch) (raise-no-put 'uni-channel-put ch))
|
|
((uni-channel-put-proc ch) ch v))
|
|
|
|
(define (uni-channel-get ch)
|
|
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-get ch))
|
|
(unless (can-get? ch) (raise-no-get 'uni-channel-get ch))
|
|
((uni-channel-get-proc ch) ch))
|
|
|
|
(define (uni-channel-send ch v) (uni-channel-put ch v))
|
|
(define (uni-channel-recv ch) (uni-channel-get ch))
|
|
|
|
(define (uni-channel-try-get ch)
|
|
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-try-get ch))
|
|
(unless (can-get? ch) (raise-no-get 'uni-channel-try-get ch))
|
|
((uni-channel-try-get-proc ch) ch))
|
|
|
|
(define (uni-channel-get-evt ch)
|
|
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-get-evt ch))
|
|
(if (can-get? ch) ((uni-channel-get-evt-proc ch) ch) never-evt))
|
|
|
|
(define (uni-channel-put-evt ch v)
|
|
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-put-evt ch))
|
|
(unless (can-put? ch) (raise-no-put 'uni-channel-put-evt ch))
|
|
((uni-channel-put-evt-proc ch) ch v))
|
|
|
|
(define (uni-channel-close ch)
|
|
(unless (uni-channel-closed? ch) ((uni-channel-close-proc ch) ch))
|
|
(void))
|
|
|
|
(define (uni-channel-wait ch)
|
|
((uni-channel-wait-proc ch) ch))
|
|
|
|
(define (uni-channel-closed? ch) (unbox (uni-channel-closed-box ch)))
|
|
|
|
(define (uni-channel-error-get ch) ((uni-channel-error-get-proc ch) ch))
|
|
(define (uni-channel-error-try-get ch) ((uni-channel-error-try-get-proc ch) ch))
|
|
(define (uni-channel-error-evt ch) ((uni-channel-error-evt-proc ch) ch))
|