#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))