From d69af6af30ba72c6113e4611bb7feee9f8376bf7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Feb 2015 09:43:13 -0700 Subject: [PATCH] add property support to `chaperone-generic`, etc. --- .../scribblings/reference/generic.scrbl | 40 ++++++++---- .../racket-test/tests/generic/impersonate.rkt | 62 +++++++++++++++++++ pkgs/racket-test/tests/generic/tests.rkt | 3 +- racket/collects/racket/generic.rkt | 32 +++++++--- 4 files changed, 115 insertions(+), 22 deletions(-) create mode 100644 pkgs/racket-test/tests/generic/impersonate.rkt diff --git a/pkgs/racket-doc/scribblings/reference/generic.scrbl b/pkgs/racket-doc/scribblings/reference/generic.scrbl index 7aa45390b7..7f0136aa66 100644 --- a/pkgs/racket-doc/scribblings/reference/generic.scrbl +++ b/pkgs/racket-doc/scribblings/reference/generic.scrbl @@ -245,21 +245,34 @@ specified @racket[method-id]s with the corresponding @racket[method-ctc]s. } -@defform[(impersonate-generics gen-id val-expr [method-id method-proc] ...) - #:contracts ([method-proc (any/c . -> . any/c)])]{ +@defform[(impersonate-generics gen-id val-expr + [method-id method-proc-expr] ... + maybe-properties) + #:grammar ([maybe-properties code:blank + (code:line #:properties props-expr)]) + #:contracts ([method-proc-expr (any/c . -> . any/c)] + [props-expr (list/c impersonator-property? any/c ... ...)])]{ Creates an @tech{impersonator} of @racket[val-expr], which must be a structure that implements the @tech{generic interface} @racket[gen-id]. The impersonator -applies the specified @racket[method-proc]s to the structure's implementation +applies the results of the @racket[method-proc-expr]s to the structure's implementation of the corresponding @racket[method-id]s, and replaces the method implementation with the result. -} +A @racket[props-expr] can provide properties to attach to the +impersonator. The result of @racket[props-expr] bust be an list with +an even number of elements, where the first element of the list is an +impersonator property, the second element is its value, and so on. -@defform[(chaperone-generics gen-id val-expr [method-id method-proc] ...) - #:contracts ([method-proc (any/c . -> . any/c)])]{ +@history[#:changed "6.1.1.8" @elem{Added @racket[#:properties].}]} -Creates a @tech{chaperone} of @racket[val-expr], which must be a structure + +@defform[(chaperone-generics gen-id val-expr + [method-id method-proc-expr] ... + maybe-properties)]{ + +Like @racket[impersonate-generics], but +creates a @tech{chaperone} of @racket[val-expr], which must be a structure that implements the @tech{generic interface} @racket[gen-id]. The chaperone applies the specified @racket[method-proc]s to the structure's implementation of the corresponding @racket[method-id]s, and replaces the method @@ -267,13 +280,14 @@ implementation with the result, which must be a chaperone of the original. } -@defform[(redirect-generics mode gen-id val-expr [method-id method-proc] ...) - #:contracts ([method-proc (any/c . -> . any/c)])]{ +@defform[(redirect-generics mode gen-id val-expr + [method-id method-proc-expr] ... + maybe-properties)]{ -Creates an @tech{impersonator} of @racket[val-expr], like -@racket[impersonate-generics], if @racket[mode] evaluates to @racket[#f]. -Creates a @tech{chaperone} of @racket[val-expr], like -@racket[chaperone-generics], otherwise. +Like @racket[impersonate-generics], but +creates an @tech{impersonator} of @racket[val-expr] +if @racket[mode] evaluates to @racket[#f], or creates +a @tech{chaperone} of @racket[val-expr] otherwise. } diff --git a/pkgs/racket-test/tests/generic/impersonate.rkt b/pkgs/racket-test/tests/generic/impersonate.rkt new file mode 100644 index 0000000000..1c15424960 --- /dev/null +++ b/pkgs/racket-test/tests/generic/impersonate.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require racket/generic + rackunit) + +(define-generics fish + [eat fish n] + [swim fish]) + +(struct standard (size) + #:transparent + #:methods + gen:fish + [(define (eat self n) (standard (+ n (standard-size self)))) + (define (swim self) (standard (max 0 (- (standard-size self) 1))))]) + +(define-values (prop:color color? color-ref) (make-impersonator-property 'color)) + +(define phil (standard 1)) +(check-equal? (standard 6) (eat (standard 1) 5)) + +(define (chaperone-eat p) + (chaperone-procedure p + (lambda (self amt) + (values (lambda (r) + (chaperone-struct r struct:standard + prop:color 'blue)) + self + amt)))) + +(define not-phil + (impersonate-generics gen:fish + phil + [eat chaperone-eat])) +(check-true (impersonator-of? not-phil phil)) +(check-false (chaperone-of? not-phil phil)) +(check-false (color? not-phil)) +(check-true (color? (eat not-phil 2))) + +(define like-phil + (chaperone-generics gen:fish + phil + [eat chaperone-eat])) +(check-true (chaperone-of? like-phil phil)) +(check-false (color? like-phil)) +(check-true (color? (eat like-phil 2))) + +(define just-like-phil + (chaperone-generics gen:fish + phil + #:properties (list prop:color 'red))) +(check-true (color? just-like-phil)) +(check-false (color? (eat just-like-phil 2))) + +(define still-not-phil + (impersonate-generics gen:fish + phil + [eat chaperone-eat] + #:properties (list prop:color 'red))) +(check-true (color? still-not-phil)) +(check-true (color? (eat still-not-phil 2))) + + diff --git a/pkgs/racket-test/tests/generic/tests.rkt b/pkgs/racket-test/tests/generic/tests.rkt index 19a3330d4d..acf016e234 100644 --- a/pkgs/racket-test/tests/generic/tests.rkt +++ b/pkgs/racket-test/tests/generic/tests.rkt @@ -20,5 +20,6 @@ "top-level.rkt" "pr13737.rkt" "marked.rkt" - "methods.rkt") + "methods.rkt" + "impersonate.rkt") diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index a31020d7a2..91abd208d4 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -169,7 +169,7 @@ (define-syntax (redirect-generics/derived stx) (syntax-case stx () - [(_ orig mode gen-name val-expr [method-name proc-expr] ...) + [(_ orig mode gen-name val-expr [method-name proc-expr] ... props-expr) (parameterize ([current-syntax-context #'orig]) (define gen-id #'gen-name) (unless (identifier? gen-id) @@ -192,26 +192,42 @@ (case i [(method-index) (proc-expr x)] ... - [else x]))))])) + [else x])) + props-expr))])) (define-syntax (redirect-generics stx) (syntax-case stx () [(_ mode gen-name val-expr [id expr] ...) - #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ...)])) + #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... null)] + [(_ mode gen-name val-expr [id expr] ... #:properties props-expr) + #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... props-expr)])) (define-syntax (chaperone-generics stx) (syntax-case stx () [(_ gen-name val-expr [id expr] ...) - #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ...)])) + #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... null)] + [(_ gen-name val-expr [id expr] ... #:properties props-expr) + #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... props-expr)])) (define-syntax (impersonate-generics stx) (syntax-case stx () [(_ gen-name val-expr [id expr] ...) - #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ...)])) + #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... null)] + [(_ gen-name val-expr [id expr] ... #:properties props-expr) + #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... props-expr)])) -(define (redirect-generics-proc name chaperoning? pred ref x proc) +(define (redirect-generics-proc name chaperoning? pred ref x proc props) (unless (pred x) - (raise-argument-error name (format "a structure implementing ~a" name) x)) + (raise-argument-error name (format "~a?" name) x)) + (unless (and (list? props) + (let loop ([props props]) + (cond + [(null? props) #t] + [(null? (cdr props)) #f] + [(impersonator-property? (car props)) + (loop (cddr props))] + [else #f]))) + (raise-argument-error name "(list/c impersonator-property? any/c ... ...)" props)) (define-values (redirect-struct redirect-vector) (if chaperoning? (values chaperone-struct chaperone-vector) @@ -220,7 +236,7 @@ (proc i method)) (define (struct-proc x vec) (redirect-vector vec vec-proc vec-proc)) - (redirect-struct x ref struct-proc)) + (apply redirect-struct x ref struct-proc props)) (define-syntax-rule (define-generics-contract ctc-name gen-name) (define-syntax (ctc-name stx)