From 3ab1ad8c93367deb46a6726c157fef3f4c8c82d4 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 14 Jan 2015 23:28:10 -0800 Subject: [PATCH] Implement chaperones, impersonators, and contracts for async-channels --- .../tests/racket/contract/async-channel.rkt | 26 +++ racket/collects/racket/async-channel.rkt | 185 +++++++++++++++--- 2 files changed, 186 insertions(+), 25 deletions(-) create mode 100644 pkgs/racket-test/tests/racket/contract/async-channel.rkt diff --git a/pkgs/racket-test/tests/racket/contract/async-channel.rkt b/pkgs/racket-test/tests/racket/contract/async-channel.rkt new file mode 100644 index 0000000000..118fb16fa7 --- /dev/null +++ b/pkgs/racket-test/tests/racket/contract/async-channel.rkt @@ -0,0 +1,26 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace (make-full-contract-namespace 'racket/async-channel)]) + (test/pos-blame + 'async-channel/c1 + '(contract (async-channel/c any/c) #f 'pos 'neg)) + + (test/pos-blame + 'async-channel/c2 + '(let ([ac (make-async-channel)]) + (async-channel-put ac #f) + (async-channel-get (contract (async-channel/c integer?) ac 'pos 'neg)))) + + (test/neg-blame + 'async-channel/c3 + '(let ([ac (make-async-channel)]) + (async-channel-put (contract (async-channel/c integer?) ac 'pos 'neg) #f))) + + (test/neg-blame + 'async-channel/c-with-cons/c-inside + '(let ([ac (contract (async-channel/c (cons/c (-> boolean? boolean?) '())) + (make-async-channel) 'pos 'neg)]) + (async-channel-put ac (list values)) + ((car (async-channel-get ac)) 3)))) diff --git a/racket/collects/racket/async-channel.rkt b/racket/collects/racket/async-channel.rkt index 1108834eb4..a7f531279d 100644 --- a/racket/collects/racket/async-channel.rkt +++ b/racket/collects/racket/async-channel.rkt @@ -1,29 +1,18 @@ #lang racket/base -(require racket/contract/base) +(require racket/contract/base + racket/contract/combinator + racket/generic) ;; This library implements buffered channels with ;; and optional buffer limit (so that puts block ;; if the buffer is full). -;; We make a fancy structure just so an async-channel -;; can be supplied directly to `sync'. -;; The alternative is to use `define-struct' and supply -;; a `async-channel-get-evt' procedure. -(define-values (struct:ac make-ac async-channel? ac-ref ac-set!) - (make-struct-type 'async-channel #f 5 0 #f - (list (cons prop:evt - ;; This is the guard that is called when - ;; we use an async-channel as an event - ;; (to get). - (lambda (ac) - (async-channel-get-guard ac)))) - (current-inspector) #f)) -(define ac-enqueue-ch (make-struct-field-accessor ac-ref 0)) -(define ac-dequeue-ch (make-struct-field-accessor ac-ref 1)) -(define ac-empty-ch (make-struct-field-accessor ac-ref 2)) -(define ac-full-ch (make-struct-field-accessor ac-ref 3)) -(define ac-thread (make-struct-field-accessor ac-ref 4)) +(define-generics async-channel-type + (async-channel-get async-channel-type) + (async-channel-try-get async-channel-type) + (async-channel-put async-channel-type v) + (async-channel-put-evt async-channel-type v)) ;; Make ---------------------------------------- @@ -99,15 +88,15 @@ (poll->ch (ac-dequeue-ch ac) (ac-empty-ch ac)) (ac-dequeue-ch ac))))) -(define (async-channel-get ac) +(define (-async-channel-get ac) (sync ac)) -(define (async-channel-try-get ac) +(define (-async-channel-try-get ac) (sync/timeout 0 ac)) ;; Put ---------------------------------------- -(define (async-channel-put-evt ac v) +(define (-async-channel-put-evt ac v) (letrec ([p (wrap-evt (guard-evt (lambda () @@ -123,7 +112,7 @@ (lambda (ignored) p))]) p)) -(define (async-channel-put ac v) +(define (-async-channel-put ac v) (thread-resume (ac-thread ac) (current-thread)) (sync (channel-put-evt (ac-enqueue-ch ac) v)) (void)) @@ -147,9 +136,145 @@ ;; a never-ready waitable: not-ready)) +;; Struct definition ------------------------------------- +;; needs to be down here because the generic methods need +;; to be defined + +(struct ac (enqueue-ch dequeue-ch empty-ch full-ch thread) + #:property prop:evt (lambda (ac) + (async-channel-get-guard ac)) + #:methods gen:async-channel-type + [(define async-channel-get -async-channel-get) + (define async-channel-try-get -async-channel-try-get) + (define async-channel-put -async-channel-put) + (define async-channel-put-evt -async-channel-put-evt)] + #:reflection-name 'async-channel + #:constructor-name make-ac) +(define async-channel? ac?) + +;; Impersonators and Chaperones --------------------------- + +(define (impersonate-async-channel ac get-proc put-proc . props) + (impersonate-generics + gen:async-channel-type + ; there's no impersonate-evt...? + (apply chaperone-evt + ac (λ (evt) (values evt (λ (v) (get-proc v)))) + props) + [async-channel-put + (λ (async-channel-put) + (chaperone-procedure async-channel-put + (λ (ac v) (values ac (put-proc v)))))] + [async-channel-put-evt + (λ (async-channel-put-evt) + (chaperone-procedure async-channel-put-evt + (λ (ac v) (values ac (put-proc v)))))])) + +(define (chaperone-async-channel ac get-proc put-proc . props) + (chaperone-generics + gen:async-channel-type + (apply chaperone-evt + ac (λ (evt) (values evt (λ (v) (get-proc v)))) + props) + [async-channel-put + (λ (async-channel-put) + (chaperone-procedure async-channel-put + (λ (ac v) (values ac (put-proc v)))))] + [async-channel-put-evt + (λ (async-channel-put-evt) + (chaperone-procedure async-channel-put-evt + (λ (ac v) (values ac (put-proc v)))))])) + +;; Contracts ----------------------------------------------- + +(define (async-channel/c-name ctc) + (define elem-name (contract-name (base-async-channel/c-content ctc))) + (apply build-compound-type-name + 'async-channel/c + elem-name + '())) + +(define (add-async-channel-context blame) + (blame-add-context blame "the content of")) + +(define (check-async-channel/c ctc val blame) + (unless (async-channel? val) + (raise-blame-error blame val '(expected "an async channel" given: "~e") val))) + +(define (check-async-channel/c-np ctc val blame) + (if (async-channel? val) + #f + (λ (neg-party) + (raise-blame-error blame #:missing-party neg-party + val '(expected "an async channel" given: "~e") val)))) + +(define ((async-channel/c-first-order ctc) val) + (define elem-ctc (base-async-channel/c-content ctc)) + (and (async-channel? val) + (contract-first-order-passes? elem-ctc val))) + +(define (async-channel/c-stronger? a b) + (contract-stronger? (base-async-channel/c-content a) (base-async-channel/c-content b))) + +(define ((ho-val-first-projection impersonate/chaperone-async-channel) ctc) + (define elem-ctc (base-async-channel/c-content ctc)) + (define vfp (get/build-val-first-projection elem-ctc)) + (λ (blame) + (define async-channel-blame (add-async-channel-context blame)) + (define pos-elem-proj (vfp async-channel-blame)) + (define neg-elem-proj (vfp (blame-swap async-channel-blame))) + (λ (val) + (or (check-async-channel/c-np ctc val blame) + (λ (neg-party) + (impersonate/chaperone-async-channel + val + (λ (v) ((pos-elem-proj v) neg-party)) + (λ (v) ((neg-elem-proj v) neg-party)) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))))))) + +(define ((ho-projection impersonate/chaperone-async-channel) ctc) + (let ([elem-ctc (base-async-channel/c-content ctc)]) + (λ (blame) + (let ([pos-elem-proj ((contract-projection elem-ctc) blame)] + [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))]) + (λ (val) + (check-async-channel/c ctc val blame) + (impersonate/chaperone-async-channel val pos-elem-proj neg-elem-proj + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))))) + +(struct base-async-channel/c (content)) + +(struct chaperone-async-channel/c base-async-channel/c () + #:property prop:custom-write custom-write-property-proc + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:name async-channel/c-name + #:first-order async-channel? + #:stronger async-channel/c-stronger? + #:val-first-projection (ho-val-first-projection chaperone-async-channel) + #:projection (ho-projection chaperone-async-channel))) + +(struct impersonator-async-channel/c base-async-channel/c () + #:property prop:custom-write custom-write-property-proc + #:property prop:contract + (build-contract-property + #:name async-channel/c-name + #:first-order async-channel? + #:stronger async-channel/c-stronger? + #:val-first-projection (ho-val-first-projection impersonate-async-channel) + #:projection (ho-projection impersonate-async-channel))) + +(define (async-channel/c elem) + (define ctc (coerce-contract 'async-channel/c elem)) + (if (chaperone-contract? ctc) + (chaperone-async-channel/c ctc) + (impersonator-async-channel/c ctc))) + ;; Provides ---------------------------------------- -(provide async-channel?) +(provide async-channel? async-channel/c) (provide/contract (make-async-channel (case-> (-> async-channel?) ((or/c false/c (lambda (x) @@ -160,4 +285,14 @@ (async-channel-get (async-channel? . -> . any/c)) (async-channel-try-get (async-channel? . -> . any/c)) (async-channel-put (async-channel? any/c . -> . any/c)) - (async-channel-put-evt (async-channel? any/c . -> . evt?))) + (async-channel-put-evt (async-channel? any/c . -> . evt?)) + (impersonate-async-channel ((async-channel? + (any/c . -> . any/c) + (any/c . -> . any/c)) + #:rest (listof any/c) + . ->* . (and/c chaperone? async-channel?))) + (chaperone-async-channel ((async-channel? + (any/c . -> . any/c) + (any/c . -> . any/c)) + #:rest (listof any/c) + . ->* . (and/c chaperone? async-channel?))))