diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index 6ca58eee9f..6c37f7b4e7 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -685,6 +685,26 @@ an @tech{impersonator} contract. ] } +@defproc[(evt/c [contract chaperone-contract?] ...) chaperone-contract?]{ +Returns a contract that recognizes @tech{synchronizable event}s whose +@tech{synchronization result}s are checked by the given +@racket[contract]s. + +The resulting contract is always a @tech{chaperone} contract and its +arguments must all be chaperone contracts. + +@defexamples[#:eval (contract-eval) + (define/contract my-evt + (evt/c evt?) + always-evt) + (define/contract failing-evt + (evt/c number? number?) + (alarm-evt (+ (current-inexact-milliseconds) 50))) + (sync my-evt) + (sync failing-evt) +] +} + @defform[(flat-rec-contract id flat-contract-expr ...)]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/evt.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/evt.rkt new file mode 100644 index 0000000000..0d624301d9 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/evt.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require "test-util.rkt") +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/pos-blame + 'evt/c-first-order-1 + '(contract (evt/c) 5 'pos 'neg)) + + (test/spec-passed + 'evt/c-first-order-2 + '(contract (evt/c) always-evt 'pos 'neg)) + + (test/pos-blame + 'evt/c-higher-order-1 + '(let ([evt (contract (evt/c symbol?) + (handle-evt always-evt (λ (x) 0)) + 'pos 'neg)]) + (sync evt))) + + ;; return arity test + (test/pos-blame + 'evt/c-higher-order-2 + '(let ([evt (contract (evt/c symbol? number?) + (handle-evt always-evt (λ (x) 0)) + 'pos 'neg)]) + (sync evt))) + + (test/spec-passed + 'evt/c-higher-order-3 + '(let ([evt (contract (evt/c symbol? number?) + (handle-evt always-evt (λ (x) (values 'a 0))) + 'pos 'neg)]) + (sync evt))) + + (test/neg-blame + 'evt/c-higher-order-4 + '(let ([f (contract (-> (evt/c symbol?) number?) + (λ (e) 0) + 'pos 'neg)]) + (f 'not-an-evt))) + + (test/pos-blame + 'evt/c-higher-order-5 + '(let ([f (contract (-> (evt/c void?)) + (λ () 0) + 'pos 'neg)]) + (f))) + + (test/pos-blame + 'evt/c-higher-order-6 + '(let ([f (contract (-> (evt/c void?)) + (λ () always-evt) + 'pos 'neg)]) + (sync (f)))) + + (test/spec-passed + 'evt/c-higher-order-7 + '(let ([f (contract (-> (evt/c evt?)) + (λ () always-evt) + 'pos 'neg)]) + (sync (f))))) + diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index c5701b95c4..9731c4915b 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -40,6 +40,7 @@ continuation-mark-key/c channel/c + evt/c chaperone-contract? impersonator-contract? @@ -1452,6 +1453,71 @@ #:stronger continuation-mark-key/c-stronger? #:name continuation-mark-key/c-name)) +;; evt/c : Contract * -> Contract +;; Contract combinator for synchronizable events +(define (evt/c . maybe-ctcs) + (define ctcs (coerce-contracts 'evt/c maybe-ctcs)) + (for ([ctc ctcs]) + (unless (chaperone-contract? ctc) + (raise-argument-error 'evt/c "chaperone-contract?" ctc))) + (make-chaperone-evt/c ctcs)) + +;; evt/c-proj : Contract -> (Blame -> Any -> Any) +;; Constructs the projection for evt/c +(define (evt/c-proj evt-ctc) + (define ctcs (chaperone-evt/c-ctcs evt-ctc)) + (define projs (map contract-projection ctcs)) + (λ (blame) + (define ((checker val) . args) + (define expected-num (length ctcs)) + (unless (= (length args) expected-num) + (raise-blame-error + blame val + `(expected: "event that produces ~a values" + given: "event that produces ~a values") + expected-num + (length args))) + (apply + values + (for/list ([proj projs] [val args]) + ((proj blame) val)))) + (define (generator evt) + (values evt (checker evt))) + (λ (val) + (unless (contract-first-order-passes? evt-ctc val) + (raise-blame-error + blame val + '(expected: "~s" given: "~e") + (contract-name evt-ctc) + val)) + (chaperone-evt val generator)))) + +;; evt/c-first-order : Contract -> Any -> Boolean +;; First order check for evt/c +(define ((evt/c-first-order ctc) v) (evt? v)) + +;; evt/c-name : Contract -> Sexp +;; Construct the name of the contract +(define (evt/c-name ctc) + (apply build-compound-type-name + (cons 'evt/c (chaperone-evt/c-ctcs ctc)))) + +;; evt/c-stronger? : Contract Contract -> Boolean +(define (evt/c-stronger? this that) + (define this-ctcs (chaperone-evt/c-ctcs this)) + (define that-ctcs (chaperone-evt/c-ctcs that)) + (and (= (length this-ctcs) (that-ctcs)) + (for/and ([this this-ctcs] [that that-ctcs]) + (contract-stronger? this that)))) + +;; ctcs - Listof +(define-struct chaperone-evt/c (ctcs) + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:projection evt/c-proj + #:first-order evt/c-first-order + #:stronger evt/c-stronger? + #:name evt/c-name)) ;; channel/c (define/subexpression-pos-prop (channel/c ctc-arg)