suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add property support to chaperone-generic, etc.

Browse Source
This commit is contained in:
Matthew Flatt 2015-02-19 09:43:13 -07:00
parent e913a13614
commit d69af6af30
4 changed files with 115 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
pkgs/racket-doc/scribblings/reference/generic.scrbl
View File

@ -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.
}

62
pkgs/racket-test/tests/generic/impersonate.rkt Normal file
View File

@ -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)))

3
pkgs/racket-test/tests/generic/tests.rkt
View File

@ -20,5 +20,6 @@
"top-level.rkt"
"pr13737.rkt"
"marked.rkt"
"methods.rkt")
"methods.rkt"
"impersonate.rkt")

32
racket/collects/racket/generic.rkt
View File

@ -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)