add #:use-wrapper-proc to racket/surrogate
This commit is contained in:
Robby Findler
parent
3e191fef04
commit
deaf48ae30
|
|
@ -14,8 +14,9 @@ so an object can completely change its behavior merely by changing the
|
|||
surrogate.
|
||||
|
||||
@defform/subs[#:literals (augment override override-final)
|
||||
(surrogate method-spec ...)
|
||||
([method-spec (augment method-id arg-spec ...)
|
||||
(surrogate use-wrapper-proc method-spec ...)
|
||||
([use-wrapper-proc #:use-wrapper-proc (code:line)]
|
||||
[method-spec (augment method-id arg-spec ...)
|
||||
(override method-id arg-spec ...)
|
||||
(override-final method-id (lambda () default-expr)
|
||||
arg-spec ...)]
|
||||
|
|
@ -29,9 +30,11 @@ The @racket[surrogate] form produces four values: a host mixin (a
|
|||
procedure that accepts and returns a class), a host interface, a
|
||||
surrogate class, and a surrogate interface.
|
||||
|
||||
The host mixin adds one additional field, @racket[surrogate], to its
|
||||
argument. It also adds a getter method, @racket[get-surrogate], and a
|
||||
setter method, @racket[set-surrogate], for changing the field. The
|
||||
If @racket[#:use-wrapper-proc] does not appear,
|
||||
the host mixin adds one field @racket[surrogate].
|
||||
to its argument. It also adds getter and setter methods, @racket[get-surrogate],
|
||||
@racket[set-surrogate], @racket[get-surrogate-wrapper-proc], and
|
||||
@racket[set-surrogate-wrapper-proc] for changing the fields. The
|
||||
@racket[set-surrogate] method accepts instances of the class returned by
|
||||
the @racket[surrogate] form or @racket[#f], and it updates the field with its
|
||||
argument; then, @racket[set-surrogate] calls the @racket[on-disable-surrogate] on the
|
||||
|
|
@ -39,6 +42,24 @@ previous value of the field and @racket[on-enable-surrogate] for the
|
|||
new value of the field. The @racket[get-surrogate] method returns the
|
||||
current value of the field.
|
||||
|
||||
If @racket[#:use-wrapper-proc] does appear, the the host mixin adds
|
||||
both the @racket[_surrogate] field (with its getters and setters) and a
|
||||
a second field, @racket[_surrogate-wrapper-proc] and its getter and setter
|
||||
methods, @racket[_get-surrogate-wrapper-proc] and @racket[_set-surrogate-wrapper-proc].
|
||||
The @racket[_surrogate-wrapper-proc] field holds a procedure whose contract
|
||||
is @racket[(-> (-> any) (-> any) any)]. The function is invoked with two thunks.
|
||||
The first one is a fallback that invokes the original object's method,
|
||||
skipping the surrogate. The other one invokes the surrogate.
|
||||
@racketblock[(λ (fallback-thunk surrogate-thunk)
|
||||
(surrogate-thunk))]
|
||||
which means that it simply defers to the method being invoked on the surrogate.
|
||||
The @racket[_surrogate-wrapper-proc] capability is part of the surrogate
|
||||
so that the dynamic extent of the calls to the surrogate can be adjusted
|
||||
(by, for example, changing the values of parameters). The
|
||||
@racket[_surrogate-wrapper-proc] is also invoked when calling the
|
||||
@racket[_on-disable-surrogate] and @racket[_on-enable-surrogate] methods
|
||||
of the surrogate.
|
||||
|
||||
The host mixin has a single overriding method for each
|
||||
@racket[method-id] in the @racket[surrogate] form (even the ones
|
||||
specified with @racket[augment]. Each of these
|
||||
|
|
|
|||
|
|
@ -64,3 +64,66 @@
|
|||
(send o set-surrogate #f)
|
||||
|
||||
(check-equal? (send o m 2) 0))
|
||||
|
||||
|
||||
(let ()
|
||||
(define-values (host-mixin host<%> surrogate% surrogate<%>)
|
||||
(surrogate #:use-wrapper-proc
|
||||
(override m ())
|
||||
(override n x)))
|
||||
|
||||
(define p (make-parameter #f))
|
||||
|
||||
(define o
|
||||
(new (host-mixin
|
||||
(class object%
|
||||
(define/public (m) (p))
|
||||
(define/public (n . x) x)
|
||||
(super-new)))))
|
||||
|
||||
(check-equal? (send o m) #f)
|
||||
|
||||
(send o set-surrogate
|
||||
(new (class surrogate%
|
||||
(define/override (m that that-m)
|
||||
(list (p) (that-m)))
|
||||
(super-new))))
|
||||
|
||||
(check-equal? (send o m) (list #f #f))
|
||||
|
||||
(send o set-surrogate-wrapper-proc
|
||||
(λ (fallback thunk)
|
||||
(parameterize ([p #t])
|
||||
(thunk))))
|
||||
|
||||
(check-equal? (send o m) (list #t #t))
|
||||
|
||||
(send o set-surrogate-wrapper-proc (λ (fallback thunk) (thunk)))
|
||||
(send o set-surrogate
|
||||
(new (class surrogate%
|
||||
(define/override (m that that-m) 15)
|
||||
(super-new))))
|
||||
|
||||
(check-equal? (send o m) 15)
|
||||
|
||||
(send o set-surrogate-wrapper-proc (λ (fallback thunk) (fallback)))
|
||||
|
||||
(check-equal? (send o m) #f)
|
||||
|
||||
(send o set-surrogate-wrapper-proc (λ (fallback thunk) (thunk)))
|
||||
|
||||
(check-equal? (send o n 1 2 3) '(1 2 3))
|
||||
|
||||
(send o set-surrogate
|
||||
(new (class surrogate%
|
||||
(define/override (n that that-m . args) (cons 'surrogate args))
|
||||
(super-new))))
|
||||
|
||||
(check-equal? (send o n 1 2 3) '(surrogate 1 2 3))
|
||||
|
||||
(send o set-surrogate-wrapper-proc (λ (fallback thunk) (cons 'wrapper (fallback))))
|
||||
|
||||
(check-equal? (send o n 1 2 3) '(wrapper 1 2 3))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,158 +1,180 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
(for-syntax racket/base))
|
||||
(for-syntax racket/base syntax/parse))
|
||||
|
||||
(provide surrogate)
|
||||
|
||||
(define-syntax (surrogate stx)
|
||||
|
||||
(define-splicing-syntax-class maybe-surrogate-wrapper
|
||||
(pattern (~seq #:use-wrapper-proc)
|
||||
#:with wrapper? #t)
|
||||
(pattern (~seq)
|
||||
#:with wrapper? #f))
|
||||
|
||||
(define (make-empty-method method-spec)
|
||||
(syntax-case method-spec (override augment)
|
||||
[(override name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-empty-method-from-argspec #'name (syntax (argspec ...)))]
|
||||
[(augment def-expr name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-empty-method-from-argspec #'name (syntax (argspec ...)))]))
|
||||
(syntax-parse stx
|
||||
[(_ msw:maybe-surrogate-wrapper method-spec ...)
|
||||
|
||||
(define use-surrogate-wrapper-proc? (syntax-e #'msw.wrapper?))
|
||||
|
||||
(define (make-empty-method method-spec)
|
||||
(syntax-case method-spec (override augment)
|
||||
[(override name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-empty-method-from-argspec #'name (syntax (argspec ...)))]
|
||||
[(augment def-expr name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-empty-method-from-argspec #'name (syntax (argspec ...)))]))
|
||||
|
||||
(define (make-empty-method-from-argspec name argspecs)
|
||||
(with-syntax ([(cases ...) (map make-empty-lambda-case
|
||||
(syntax->list argspecs))]
|
||||
[name name])
|
||||
(syntax
|
||||
(begin
|
||||
(define/public name
|
||||
(case-lambda cases ...))))))
|
||||
(define (make-empty-method-from-argspec name argspecs)
|
||||
(with-syntax ([(cases ...) (map make-empty-lambda-case
|
||||
(syntax->list argspecs))]
|
||||
[name name])
|
||||
(syntax
|
||||
(begin
|
||||
(define/public name
|
||||
(case-lambda cases ...))))))
|
||||
|
||||
(define (make-empty-lambda-case spec)
|
||||
(syntax-case spec ()
|
||||
[(id ...) (syntax [(ths super-call id ...) (super-call id ...)])]
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(syntax [(ths super-call . name) (apply super-call name)])]))
|
||||
(define (make-empty-lambda-case spec)
|
||||
(syntax-case spec ()
|
||||
[(id ...) (syntax [(ths super-call id ...) (super-call id ...)])]
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(syntax [(ths super-call . name) (apply super-call name)])]))
|
||||
|
||||
(define (make-overriding-method method-spec)
|
||||
(syntax-case method-spec (override augment)
|
||||
[(override name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-overriding-method-with-inner-default
|
||||
#'name #f #'(argspec ...))]
|
||||
[(augment def-expr name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-overriding-method-with-inner-default
|
||||
#'name #'def-expr #'(argspec ...))]))
|
||||
(define (make-overriding-method method-spec)
|
||||
(syntax-case method-spec (override augment)
|
||||
[(override name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-overriding-method-with-inner-default
|
||||
#'name #f #'(argspec ...))]
|
||||
[(augment def-expr name argspec ...)
|
||||
(identifier? (syntax name))
|
||||
(make-overriding-method-with-inner-default
|
||||
#'name #'def-expr #'(argspec ...))]))
|
||||
|
||||
(define (make-overriding-method-with-inner-default name def-expr argspecs)
|
||||
;; (not def-expr) => normal override
|
||||
;; def-expr => beta override
|
||||
(let ([super-call-name
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append
|
||||
(if def-expr
|
||||
"inner-proc-"
|
||||
"super-proc-")
|
||||
(symbol->string
|
||||
(syntax->datum
|
||||
name)))))])
|
||||
(with-syntax ([(cases ...)
|
||||
(map (make-lambda-case name
|
||||
super-call-name)
|
||||
(syntax->list argspecs))]
|
||||
[(super-proc-cases ...)
|
||||
(map (make-super-proc-case name def-expr)
|
||||
(syntax->list argspecs))]
|
||||
[super-call-name super-call-name]
|
||||
[name name]
|
||||
[ren/inn (if def-expr
|
||||
#'inner
|
||||
#'rename)]
|
||||
[define/override/fnl (if def-expr
|
||||
#'define/augment
|
||||
#'define/override)])
|
||||
(syntax
|
||||
(begin
|
||||
(field [super-call-name
|
||||
(case-lambda super-proc-cases ...)])
|
||||
(define/override/fnl name
|
||||
(case-lambda cases ...)))))))
|
||||
(define (make-overriding-method-with-inner-default name def-expr argspecs)
|
||||
;; (not def-expr) => normal override
|
||||
;; def-expr => beta override
|
||||
(let ([super-call-name
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append
|
||||
(if def-expr
|
||||
"inner-proc-"
|
||||
"super-proc-")
|
||||
(symbol->string
|
||||
(syntax->datum
|
||||
name)))))])
|
||||
(with-syntax ([(cases ...)
|
||||
(map (make-lambda-case name
|
||||
super-call-name)
|
||||
(syntax->list argspecs))]
|
||||
[(super-proc-cases ...)
|
||||
(map (make-super-proc-case name def-expr)
|
||||
(syntax->list argspecs))]
|
||||
[super-call-name super-call-name]
|
||||
[name name]
|
||||
[ren/inn (if def-expr
|
||||
#'inner
|
||||
#'rename)]
|
||||
[define/override/fnl (if def-expr
|
||||
#'define/augment
|
||||
#'define/override)])
|
||||
(syntax
|
||||
(begin
|
||||
(field [super-call-name
|
||||
(case-lambda super-proc-cases ...)])
|
||||
(define/override/fnl name
|
||||
(case-lambda cases ...)))))))
|
||||
|
||||
(define ((extract-id stx) method-spec)
|
||||
(syntax-case method-spec (override augment)
|
||||
[(override name argspec ...)
|
||||
(identifier? #'name)
|
||||
(syntax name)]
|
||||
[(augment result-expr name argspec ...)
|
||||
(identifier? #'name)
|
||||
(syntax name)]
|
||||
[(override . whatever)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad override method specification"
|
||||
stx
|
||||
method-spec)]
|
||||
[(augment . whatever)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad augment method specification"
|
||||
stx
|
||||
method-spec)]
|
||||
[(id . whatever)
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad method specification, expected either override or augment"
|
||||
stx
|
||||
#'id)]
|
||||
[whatever
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad method specification"
|
||||
stx
|
||||
method-spec)]))
|
||||
(define ((extract-id stx) method-spec)
|
||||
(syntax-case method-spec (override augment)
|
||||
[(override name argspec ...)
|
||||
(identifier? #'name)
|
||||
(syntax name)]
|
||||
[(augment result-expr name argspec ...)
|
||||
(identifier? #'name)
|
||||
(syntax name)]
|
||||
[(override . whatever)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad override method specification"
|
||||
stx
|
||||
method-spec)]
|
||||
[(augment . whatever)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad augment method specification"
|
||||
stx
|
||||
method-spec)]
|
||||
[(id . whatever)
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad method specification, expected either override or augment"
|
||||
stx
|
||||
#'id)]
|
||||
[whatever
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad method specification"
|
||||
stx
|
||||
method-spec)]))
|
||||
|
||||
(define (make-super-proc-case name def-expr)
|
||||
(lambda (spec)
|
||||
(with-syntax ([name name])
|
||||
(syntax-case spec ()
|
||||
;; Not a rest arg: normal mode
|
||||
[(id ...) (quasisyntax [(id ...)
|
||||
(#,@(if def-expr
|
||||
(list #'inner def-expr)
|
||||
(list #'super))
|
||||
name
|
||||
id ...)])]
|
||||
;; A rest arg: take args as list
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(quasisyntax [(id) (#,@(if def-expr
|
||||
(list #'inner def-expr)
|
||||
(list #'super))
|
||||
name
|
||||
. id)])]))))
|
||||
(define (make-super-proc-case name def-expr)
|
||||
(lambda (spec)
|
||||
(with-syntax ([name name])
|
||||
(syntax-case spec ()
|
||||
;; Not a rest arg: normal mode
|
||||
[(id ...) (quasisyntax [(id ...)
|
||||
(#,@(if def-expr
|
||||
(list #'inner def-expr)
|
||||
(list #'super))
|
||||
name
|
||||
id ...)])]
|
||||
;; A rest arg: take args as list
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(quasisyntax [(id) (#,@(if def-expr
|
||||
(list #'inner def-expr)
|
||||
(list #'super))
|
||||
name
|
||||
. id)])]))))
|
||||
|
||||
(define (make-lambda-case name super-call)
|
||||
(with-syntax ([name name]
|
||||
[super-call super-call])
|
||||
(lambda (spec)
|
||||
(syntax-case spec ()
|
||||
;; Not a rest arg: normal mode for super-call
|
||||
[(id ...) (syntax [(id ...)
|
||||
(if the-surrogate
|
||||
(send the-surrogate name this super-call id ...)
|
||||
(super-call id ...))])]
|
||||
;; A rest arg: super-class takes args as a list
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(syntax [name
|
||||
(if the-surrogate
|
||||
(send the-surrogate name this (lambda args (super-call args)) . id)
|
||||
(super-call id))])]))))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ method-spec ...)
|
||||
(define (maybe-call-surrogate-wrapper-proc id fallback-stx body-stx)
|
||||
(if use-surrogate-wrapper-proc?
|
||||
#`(surrogate-wrapper-proc
|
||||
(λ () #,fallback-stx)
|
||||
(let ([id (λ () #,body-stx)]) id))
|
||||
body-stx))
|
||||
|
||||
(define (make-lambda-case name super-call)
|
||||
(with-syntax ([name name]
|
||||
[super-call super-call])
|
||||
(lambda (spec)
|
||||
(syntax-case spec ()
|
||||
;; Not a rest arg: normal mode for super-call
|
||||
[(id ...) #`[(id ...)
|
||||
(if the-surrogate
|
||||
#,(maybe-call-surrogate-wrapper-proc
|
||||
#'name
|
||||
#`(super-call id ...)
|
||||
#`(send the-surrogate name this super-call id ...))
|
||||
(super-call id ...))]]
|
||||
;; A rest arg: super-class takes args as a list
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
#`[name
|
||||
(if the-surrogate
|
||||
#,(maybe-call-surrogate-wrapper-proc
|
||||
#'name
|
||||
#`(super-call name)
|
||||
#`(send the-surrogate name this (lambda args (super-call args)) . name))
|
||||
(super-call name))]]))))
|
||||
|
||||
(with-syntax ([(ids ...) (map (extract-id stx) (syntax->list (syntax (method-spec ...))))]
|
||||
[(overriding-methods ...)
|
||||
(map make-overriding-method
|
||||
|
|
@ -172,16 +194,32 @@
|
|||
(interface ()
|
||||
set-surrogate
|
||||
get-surrogate
|
||||
#,@(if use-surrogate-wrapper-proc?
|
||||
(list #'set-surrogate-wrapper-proc
|
||||
#'get-surrogate-wrapper-proc)
|
||||
(list))
|
||||
ids ...)])
|
||||
(values
|
||||
(λ (super%)
|
||||
(class* super% (host<%>)
|
||||
(define the-surrogate #f)
|
||||
#,(if use-surrogate-wrapper-proc?
|
||||
#'(begin
|
||||
(define surrogate-wrapper-proc always-do-the-call-surrogate-wrapper-proc)
|
||||
(define/public-final (set-surrogate-wrapper-proc _p)
|
||||
(check-surrogate-wrapper-proc _p)
|
||||
(set! surrogate-wrapper-proc _p))
|
||||
(define/public-final (get-surrogate-wrapper-proc)
|
||||
surrogate-wrapper-proc))
|
||||
#'(begin))
|
||||
(define/public-final (set-surrogate new-surrogate)
|
||||
(do-set-surrogate (λ (s) (set! the-surrogate s))
|
||||
the-surrogate
|
||||
this
|
||||
new-surrogate
|
||||
#,(if use-surrogate-wrapper-proc?
|
||||
#'surrogate-wrapper-proc
|
||||
#'always-do-the-call-surrogate-wrapper-proc)
|
||||
'(ids ...)))
|
||||
(define/public-final (get-surrogate) the-surrogate)
|
||||
|
||||
|
|
@ -199,9 +237,25 @@
|
|||
(super-new)))
|
||||
surrogate<%>))))]))
|
||||
|
||||
(define (do-set-surrogate set-the-surrogate the-surrogate this new-surrogate ids)
|
||||
(define (always-do-the-call-surrogate-wrapper-proc fallback main) (main))
|
||||
|
||||
(define (check-surrogate-wrapper-proc p)
|
||||
(unless (procedure-arity-includes? p 2)
|
||||
(raise-argument-error 'set-surrogate-wrapper-proc
|
||||
"procedure of arity 2"
|
||||
p)))
|
||||
|
||||
(define (do-set-surrogate set-the-surrogate
|
||||
the-surrogate
|
||||
this
|
||||
new-surrogate
|
||||
surrogate-wrapper-proc
|
||||
ids)
|
||||
(when the-surrogate
|
||||
(send the-surrogate on-disable-surrogate this))
|
||||
(surrogate-wrapper-proc
|
||||
void
|
||||
(λ ()
|
||||
(send the-surrogate on-disable-surrogate this))))
|
||||
|
||||
;; error checking
|
||||
(when new-surrogate
|
||||
|
|
@ -217,4 +271,7 @@
|
|||
|
||||
(set-the-surrogate new-surrogate)
|
||||
(when new-surrogate
|
||||
(send new-surrogate on-enable-surrogate this)))
|
||||
(surrogate-wrapper-proc
|
||||
void
|
||||
(λ ()
|
||||
(send new-surrogate on-enable-surrogate this)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user