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

misc small improvements to racket/surrogate

Browse Source 
(generate less code in macro, add some basic test cases,
 small improvement to syntax errors, and small docs clarification)
This commit is contained in:
Robby Findler 2016-12-16 13:25:11 -06:00
parent 02a267fdb2
commit 3e191fef04
3 changed files with 137 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/racket-doc/scribblings/reference/surrogate.scrbl
View File

@ -13,9 +13,9 @@ its surrogate object. Each host has a dynamically assigned surrogate,
so an object can completely change its behavior merely by changing the
surrogate.
@defform/subs[#:literals (override override-final)
@defform/subs[#:literals (augment override override-final)
(surrogate method-spec ...)
([method-spec (method-id arg-spec ...)
([method-spec (augment method-id arg-spec ...)
(override method-id arg-spec ...)
(override-final method-id (lambda () default-expr)
arg-spec ...)]
@ -40,7 +40,8 @@ new value of the field. The @racket[get-surrogate] method returns the
current value of the field.
The host mixin has a single overriding method for each
@racket[method-id] in the @racket[surrogate] form. Each of these
@racket[method-id] in the @racket[surrogate] form (even the ones
specified with @racket[augment]. Each of these
methods is defined with a @racket[case-lambda] with one arm for each
@racket[arg-spec]. Each arm has the variables as arguments in the
@racket[arg-spec]. The body of each method tests the

66
pkgs/racket-test/tests/racket/surrogate.rkt Normal file
View File

@ -0,0 +1,66 @@
#lang racket
(require rackunit racket/surrogate)
(let ()
(define-values (host-mixin host<%> surrogate% surrogate<%>)
(surrogate (override m (x))))
(define o
(new (host-mixin
(class object%
(define/public (m x) (+ x 1))
(super-new)))))
(check-equal? (send o m 2) 3)
(send o set-surrogate
(new (class surrogate%
(define/override (m that that-m x)
x)
(super-new))))
(check-equal? (send o m 2) 2)
(send o set-surrogate
(new (class surrogate%
(define/override (m that that-m x)
(that-m (* x x)))
(super-new))))
(check-equal? (send o m 4) 17)
(send o set-surrogate #f)
(check-equal? (send o m 2) 3))
(let ()
(define-values (host-mixin host<%> surrogate% surrogate<%>)
(surrogate (augment 0 m (x))))
(define o
(new (host-mixin
(class object%
(define/pubment (m x) (inner (+ x 1) m x))
(super-new)))))
(check-equal? (send o m 2) 0)
(send o set-surrogate
(new (class surrogate%
(define/override (m that that-m x)
x)
(super-new))))
(check-equal? (send o m 2) 2)
(send o set-surrogate
(new (class surrogate%
(define/override (m that that-m x)
(that-m (* x x)))
(super-new))))
(check-equal? (send o m 4) 0)
(send o set-surrogate #f)
(check-equal? (send o m 2) 0))

104
racket/collects/racket/surrogate.rkt
View File

@ -87,11 +87,31 @@
[(augment result-expr name argspec ...)
(identifier? #'name)
(syntax name)]
[else (raise-syntax-error
#f
"bad method specification"
stx
method-spec)]))
[(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)
@ -120,15 +140,15 @@
(syntax-case spec ()
;; Not a rest arg: normal mode for super-call
[(id ...) (syntax [(id ...)
(if surrogate
(send surrogate name this super-call 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 surrogate
(send surrogate name this (lambda args (super-call args)) . id)
(if the-surrogate
(send the-surrogate name this (lambda args (super-call args)) . id)
(super-call id))])]))))
(syntax-case stx ()
@ -142,7 +162,7 @@
(map make-empty-method
(syntax->list
(syntax (method-spec ...))))])
(syntax/loc stx
(quasisyntax/loc stx
(let ([surrogate<%>
(interface ()
on-disable-surrogate
@ -154,37 +174,47 @@
get-surrogate
ids ...)])
(values
(lambda (super%)
(λ (super%)
(class* super% (host<%>)
(field [surrogate #f])
(define/public (set-surrogate d)
(when surrogate
(send surrogate on-disable-surrogate this))
;; error checking
(when d
(unless (object? d)
(error 'set-surrogate "expected an object, got: ~e" d))
(let ([methods-to-impl '(on-enable-surrogate on-disable-surrogate ids ...)]
[i (object-interface d)])
(for-each (lambda (x)
(unless (method-in-interface? x i)
(error 'set-surrogate "expected object to implement an ~s method" x)))
methods-to-impl)))
(set! surrogate d)
(when surrogate
(send surrogate on-enable-surrogate this)))
(define/public (get-surrogate) surrogate)
(define the-surrogate #f)
(define/public-final (set-surrogate new-surrogate)
(do-set-surrogate (λ (s) (set! the-surrogate s))
the-surrogate
this
new-surrogate
'(ids ...)))
(define/public-final (get-surrogate) the-surrogate)
overriding-methods ...
(super-new)))
host<%>
(class* object% (surrogate<%>)
(define/public (on-enable-surrogate x) (void))
(define/public (on-disable-surrogate x) (void))
empty-methods ...
(super-new))
#,(syntax/loc stx
(class* object% (surrogate<%>)
(define/public (on-enable-surrogate x) (void))
(define/public (on-disable-surrogate x) (void))
empty-methods ...
(super-new)))
surrogate<%>))))]))
(define (do-set-surrogate set-the-surrogate the-surrogate this new-surrogate ids)
(when the-surrogate
(send the-surrogate on-disable-surrogate this))
;; error checking
(when new-surrogate
(unless (object? new-surrogate)
(raise-argument-error 'set-surrogate "object?" new-surrogate))
(let ([methods-to-impl (list* 'on-enable-surrogate 'on-disable-surrogate ids)]
[i (object-interface new-surrogate)])
(for ([x (in-list methods-to-impl)])
(unless (method-in-interface? x i)
(raise-argument-error 'set-surrogate
(format "object with method ~s" x)
new-surrogate)))))
(set-the-surrogate new-surrogate)
(when new-surrogate
(send new-surrogate on-enable-surrogate this)))