1#lang racket/base
2(require "../common/check.rkt"
3         "../common/class.rkt"
4         "../host/thread.rkt"
5         "parameter.rkt"
6         "port.rkt"
7         "input-port.rkt"
8         "count.rkt"
9         "check.rkt")
10
11(provide (rename-out [progress-evt?* progress-evt?])
12         port-provides-progress-evts?
13         port-progress-evt
14         port-commit-peeked
15
16         check-progress-evt
17         unwrap-progress-evt)
18
19(struct progress-evt (port evt)
20  #:property prop:evt (lambda (pe)
21                        (wrap-evt (progress-evt-evt pe)
22                                  (lambda args pe))))
23
24(define progress-evt?*
25  (let ([progress-evt?
26         (case-lambda
27           [(v) (progress-evt? v)]
28           [(v port)
29            (and (progress-evt? v)
30                 (eq? port (progress-evt-port v)))])])
31    progress-evt?))
32
33;; ----------------------------------------
34
35(define/who (port-provides-progress-evts? in)
36  (check who input-port? in)
37  (let ([in (->core-input-port in)])
38    (and (method core-input-port in get-progress-evt) #t)))
39
40(define/who (port-progress-evt [orig-in (current-input-port)])
41  (check who input-port? orig-in)
42  (let ([in (->core-input-port orig-in)])
43    (define get-progress-evt (method core-input-port in get-progress-evt))
44    (if get-progress-evt
45        (progress-evt orig-in (get-progress-evt in))
46        (raise-arguments-error 'port-progress-evt
47                               "port does not provide progress evts"
48                               "port" orig-in))))
49
50(define/who (port-commit-peeked amt progress-evt evt [in (current-input-port)])
51  (check who exact-nonnegative-integer? amt)
52  (check who progress-evt? progress-evt)
53  (check who sync-atomic-poll-evt?
54         #:contract "(or/c channel-put-evt? channel? semaphore? semaphore-peek-evt? always-evt never-evt)"
55         evt)
56  (check who input-port? in)
57  (check-progress-evt who progress-evt in)
58  (let ([in (->core-input-port in)])
59    (atomically
60     ;; We specially skip a check on whether the port is closed,
61     ;; since that's handled as the progress evt becoming ready
62     (send core-input-port in commit
63           amt (progress-evt-evt progress-evt) evt
64           ;; in atomic mode (but maybe leaves atomic mode in between)
65           (lambda (bstr)
66             (port-count! in (bytes-length bstr) bstr 0))))))
67
68(define (check-progress-evt who progress-evt in)
69  (unless (progress-evt?* progress-evt in)
70    (raise-arguments-error who "evt is not a progress evt for the given port"
71                           "evt" progress-evt
72                           "port" in)))
73
74(define (unwrap-progress-evt progress-evt)
75  (and progress-evt
76       (progress-evt-evt progress-evt)))
77