#lang racket/base

(require racket/async-channel
         racket/place
         port-channel)

(provide uni-channel?
         uni-channel-kind
         uni-channel-direction
         uni-channel-name
         uni-channel-impl

         make-uni-channel
         make-uni-async-channel
         make-uni-async-channel-pair
         make-uni-place-channel
         make-uni-place-channel-pair
         make-uni-port-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-closed?

         uni-channel-error-get
         uni-channel-error-try-get
         uni-channel-error-evt)

(struct uni-channel
  (kind impl direction name get-proc put-proc try-get-proc get-evt-proc put-evt-proc
        close-proc closed-box error-get-proc error-try-get-proc error-evt-proc)
  #:property prop:evt
  (lambda (ch)
    (cond
      [(and (can-get? ch) (uni-channel-get-proc ch))
       ((uni-channel-get-evt-proc ch) ch)]
      [else never-evt])))

(define (check-direction who v)
  (case v
    [(input output bidirectional) v]
    [else (raise-argument-error who "(or/c 'input 'output 'bidirectional)" v)]))

(define (check-kind who v)
  (case v
    [(async place port custom) v]
    [else (raise-argument-error who "(or/c 'async 'place 'port 'custom)" v)]))

(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"
                         "name" (uni-channel-name ch)
                         "direction" (uni-channel-direction ch)))

(define (raise-no-put who ch)
  (raise-arguments-error who "uni-channel does not support sending"
                         "name" (uni-channel-name ch)
                         "direction" (uni-channel-direction ch)))

(define (raise-closed who ch)
  (raise-arguments-error who "uni-channel is closed"
                         "name" (uni-channel-name ch)
                         "kind" (uni-channel-kind ch)))

(define (closed-box) (box #f))

(define (mark-closed! ch)
  (set-box! (uni-channel-closed-box ch) #t))

(define (default-close ch)
  (mark-closed! ch)
  (void))

(define (no-error-get ch)
  (raise-arguments-error 'uni-channel-error-get "uni-channel has no error channel"
                         "name" (uni-channel-name ch)
                         "kind" (uni-channel-kind ch)))

(define (no-error-try-get ch) #f)
(define (no-error-evt ch) never-evt)

(define (make-oc #:kind kind
                 #:backend backend
                 #:direction direction
                 #:name name
                 #:get get-proc
                 #:put put-proc
                 #:try-get try-get-proc
                 #:get-evt get-evt-proc
                 #:put-evt put-evt-proc
                 #:close close-proc
                 #:error-get error-get-proc
                 #:error-try-get error-try-get-proc
                 #:error-evt error-evt-proc)
  (uni-channel kind backend direction name get-proc put-proc try-get-proc get-evt-proc put-evt-proc
                  close-proc (closed-box) error-get-proc error-try-get-proc error-evt-proc))

(define (make-uni-channel backend
                             #:kind [kind 'auto]
                             #:direction [direction 'auto]
                             #:name [name #f])
  (define detected-kind
    (case kind
      [(auto)
       (cond
         [(async-channel? backend) 'async]
         [(place-channel? backend) 'place]
         [(port-channel? backend) 'port]
         [else (raise-argument-error 'make-uni-channel
                                     "(or/c async-channel? place-channel? port-channel?)"
                                     backend)])]
      [else (check-kind 'make-uni-channel kind)]))
  (case detected-kind
    [(async)
     (unless (async-channel? backend)
       (raise-argument-error 'make-uni-channel "async-channel?" backend))
     (make-uni-async-channel backend #:direction direction #:name (or name 'async-channel))]
    [(place)
     (unless (place-channel? backend)
       (raise-argument-error 'make-uni-channel "place-channel?" backend))
     (make-uni-place-channel backend #:direction direction #:name (or name 'place-channel))]
    [(port)
     (unless (port-channel? backend)
       (raise-argument-error 'make-uni-channel "port-channel?" backend))
     (define pc-dir (port-channel-direction backend))
     (define dir (if (eq? direction 'auto) pc-dir (check-direction 'make-uni-channel direction)))
     (unless (eq? pc-dir dir)
       (raise-arguments-error 'make-uni-channel "direction does not match port-channel direction"
                              "requested direction" dir
                              "port-channel direction" pc-dir))
     (make-port-oc (and (eq? pc-dir 'input) backend)
                   (and (eq? pc-dir 'output) backend)
                   #:direction pc-dir
                   #:name (or name 'port-channel))]
    [else
     (raise-argument-error 'make-uni-channel "(or/c 'auto 'async 'place 'port)" kind)]))

(define (make-uni-async-channel [ch (make-async-channel)]
                                   #:direction [direction 'bidirectional]
                                   #:name [name 'async-channel])
  (define dir (if (eq? direction 'auto) 'bidirectional (check-direction 'make-uni-async-channel direction)))
  (define backend ch)
  (make-oc #:kind 'async
           #:backend backend
           #:direction dir
           #:name name
           #:get (lambda (_ch) (async-channel-get backend))
           #:put (lambda (_ch v) (async-channel-put backend v))
           #:try-get (lambda (_ch) (async-channel-try-get backend))
           #:get-evt (lambda (_ch) backend)
           #:put-evt (lambda (_ch v) (async-channel-put-evt backend v))
           #:close default-close
           #:error-get no-error-get
           #:error-try-get no-error-try-get
           #:error-evt no-error-evt))

(define (make-uni-async-channel-pair #:name-a [name-a 'async-channel-a]
                                        #:name-b [name-b 'async-channel-b])
  (define a-in (make-async-channel))
  (define b-in (make-async-channel))
  (define (endpoint name incoming outgoing)
    (make-oc #:kind 'async
             #:backend (vector 'async-channel-pair incoming outgoing)
             #:direction 'bidirectional
             #:name name
             #:get (lambda (_ch) (async-channel-get incoming))
             #:put (lambda (_ch v) (async-channel-put outgoing v))
             #:try-get (lambda (_ch) (async-channel-try-get incoming))
             #:get-evt (lambda (_ch) incoming)
             #:put-evt (lambda (_ch v) (async-channel-put-evt outgoing v))
             #:close default-close
             #:error-get no-error-get
             #:error-try-get no-error-try-get
             #:error-evt no-error-evt))
  (values (endpoint name-a a-in b-in) (endpoint name-b b-in a-in)))

(define (make-uni-place-channel ch
                                   #:direction [direction 'bidirectional]
                                   #:name [name 'place-channel])
  (define dir (if (eq? direction 'auto) 'bidirectional (check-direction 'make-uni-place-channel direction)))
  (define backend ch)
  (make-oc #:kind 'place
           #:backend backend
           #:direction dir
           #:name name
           #:get (lambda (_ch) (place-channel-get backend))
           #:put (lambda (_ch v) (place-channel-put backend v))
           #:try-get (lambda (_ch) (sync/timeout 0 backend))
           #:get-evt (lambda (_ch) backend)
           #:put-evt (lambda (_ch v) (handle-evt always-evt (lambda (_) (place-channel-put backend v))))
           #:close default-close
           #:error-get no-error-get
           #:error-try-get no-error-try-get
           #:error-evt no-error-evt))

(define (make-uni-place-channel-pair #:name-a [name-a 'place-channel-a]
                                        #:name-b [name-b 'place-channel-b])
  (define-values (a b) (place-channel))
  (values (make-uni-place-channel a #:name name-a)
          (make-uni-place-channel b #:name name-b)))

(define (make-port-oc in-pc out-pc #:direction direction #:name name)
  (define backend
    (cond
      [(and in-pc out-pc) (vector 'port-channel-pair in-pc out-pc)]
      [in-pc in-pc]
      [out-pc out-pc]
      [else (error 'make-port-oc "internal error: no port-channel backend")]))
  (define (get* _ch) (port-channel-get in-pc))
  (define (put* _ch v) (port-channel-put out-pc v))
  (define (try-get* _ch) (port-channel-try-get in-pc))
  (define (get-evt* _ch) (port-channel-evt in-pc))
  (define (put-evt* _ch v) (handle-evt always-evt (lambda (_) (port-channel-put out-pc v))))
  (define (close* ch)
    (mark-closed! ch)
    (cond
      [(and in-pc out-pc) (close-port-channel out-pc)]
      [in-pc (close-port-channel in-pc)]
      [out-pc (close-port-channel out-pc)])
    (void))
  (define (error-get* _ch)
    (cond
      [in-pc (port-channel-error-get in-pc)]
      [out-pc (port-channel-error-get out-pc)]))
  (define (error-try-get* _ch)
    (or (and in-pc (port-channel-error-try-get in-pc))
        (and out-pc (port-channel-error-try-get out-pc))))
  (define (error-evt* _ch)
    (cond
      [(and in-pc out-pc) (choice-evt (port-channel-error-evt in-pc) (port-channel-error-evt out-pc))]
      [in-pc (port-channel-error-evt in-pc)]
      [out-pc (port-channel-error-evt out-pc)]))
  (make-oc #:kind 'port
           #:backend backend
           #:direction direction
           #:name name
           #:get (and in-pc get*)
           #:put (and out-pc put*)
           #:try-get (and in-pc try-get*)
           #:get-evt (and in-pc get-evt*)
           #:put-evt (and out-pc put-evt*)
           #:close close*
           #:error-get error-get*
           #:error-try-get error-try-get*
           #:error-evt error-evt*))

(define (make-uni-port-channel #:input [in #f]
                                  #:output [out #f]
                                  #:source [source 'port-channel]
                                  #:close? [close? #t]
                                  #:name [name 'port-channel])
  (unless (or in out)
    (raise-arguments-error 'make-uni-port-channel
                           "expected at least one of #:input or #:output"))
  (when (and in (not (input-port? in)))
    (raise-argument-error 'make-uni-port-channel "input-port?" in))
  (when (and out (not (output-port? out)))
    (raise-argument-error 'make-uni-port-channel "output-port?" out))
  (define in-pc (and in (make-port-channel in #:direction 'input #:source source #:close? close?)))
  (define out-pc (and out (make-port-channel out #:direction 'output #:source source #:close? close?)))
  (define direction
    (cond
      [(and in-pc out-pc) 'bidirectional]
      [in-pc 'input]
      [else 'output]))
  (make-port-oc in-pc out-pc #:direction direction #:name name))

(define (uni-channel-closed? ch)
  (unbox (uni-channel-closed-box ch)))

(define (uni-channel-put ch v)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-put "uni-channel?" ch))
  (unless (can-put? ch) (raise-no-put 'uni-channel-put ch))
  (when (uni-channel-closed? ch) (raise-closed 'uni-channel-put ch))
  (define put-proc (uni-channel-put-proc ch))
  (unless put-proc (raise-no-put 'uni-channel-put ch))
  (put-proc ch v))

(define (uni-channel-get ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-get "uni-channel?" ch))
  (unless (can-get? ch) (raise-no-get 'uni-channel-get ch))
  (define get-proc (uni-channel-get-proc ch))
  (unless get-proc (raise-no-get 'uni-channel-get ch))
  (get-proc ch))

(define uni-channel-send uni-channel-put)
(define uni-channel-recv uni-channel-get)

(define (uni-channel-try-get ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-try-get "uni-channel?" ch))
  (unless (can-get? ch) (raise-no-get 'uni-channel-try-get ch))
  (define try-get-proc (uni-channel-try-get-proc ch))
  (unless try-get-proc (raise-no-get 'uni-channel-try-get ch))
  (try-get-proc ch))

(define (uni-channel-get-evt ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-get-evt "uni-channel?" ch))
  (unless (can-get? ch) (raise-no-get 'uni-channel-get-evt ch))
  (define get-evt-proc (uni-channel-get-evt-proc ch))
  (unless get-evt-proc (raise-no-get 'uni-channel-get-evt ch))
  (get-evt-proc ch))

(define (uni-channel-put-evt ch v)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-put-evt "uni-channel?" ch))
  (unless (can-put? ch) (raise-no-put 'uni-channel-put-evt ch))
  (when (uni-channel-closed? ch) (raise-closed 'uni-channel-put-evt ch))
  (define put-evt-proc (uni-channel-put-evt-proc ch))
  (unless put-evt-proc (raise-no-put 'uni-channel-put-evt ch))
  (put-evt-proc ch v))

(define (uni-channel-close ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-close "uni-channel?" ch))
  ((uni-channel-close-proc ch) ch))

(define (uni-channel-error-get ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-error-get "uni-channel?" ch))
  ((uni-channel-error-get-proc ch) ch))

(define (uni-channel-error-try-get ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-error-try-get "uni-channel?" ch))
  ((uni-channel-error-try-get-proc ch) ch))

(define (uni-channel-error-evt ch)
  (unless (uni-channel? ch) (raise-argument-error 'uni-channel-error-evt "uni-channel?" ch))
  ((uni-channel-error-evt-proc ch) ch))