moved the surrogate library to scheme/ (out of mzlib/)
svn: r9554
This commit is contained in:
Robby Findler
parent
efa0f5f396
commit
baa9ed726a
|
|
@ -1,12 +1,12 @@
|
||||||
#lang scheme/unit
|
#lang scheme/unit
|
||||||
(require mzlib/surrogate
|
(require scheme/class
|
||||||
mzlib/class
|
scheme/surrogate
|
||||||
"sig.ss")
|
"sig.ss")
|
||||||
|
|
||||||
(import)
|
(import)
|
||||||
(export framework:mode^)
|
(export framework:mode^)
|
||||||
|
|
||||||
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
|
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
|
||||||
(surrogate
|
(surrogate
|
||||||
(augment (void) on-change ())
|
(augment (void) on-change ())
|
||||||
(override on-char (event))
|
(override on-char (event))
|
||||||
|
|
|
||||||
|
|
@ -237,10 +237,6 @@ Re-exports @schememodname[scheme/stxparam] and
|
||||||
|
|
||||||
@; ----------------------------------------------------------------------
|
@; ----------------------------------------------------------------------
|
||||||
|
|
||||||
@include-section["surrogate.scrbl"]
|
|
||||||
|
|
||||||
@; ----------------------------------------------------------------------
|
|
||||||
|
|
||||||
@mzlib[tar]
|
@mzlib[tar]
|
||||||
|
|
||||||
Re-exports @schememodname[file/tar].
|
Re-exports @schememodname[file/tar].
|
||||||
|
|
|
||||||
|
|
@ -1,188 +0,0 @@
|
||||||
(module surrogate mzscheme
|
|
||||||
(require mzlib/class)
|
|
||||||
|
|
||||||
(provide surrogate)
|
|
||||||
|
|
||||||
(define-syntax (surrogate stx)
|
|
||||||
|
|
||||||
(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-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-with-inner-default name def-expr argspecs)
|
|
||||||
;; (not def-expr) => normal override
|
|
||||||
;; def-expr => beta override
|
|
||||||
(let ([super-call-name
|
|
||||||
(datum->syntax-object
|
|
||||||
name
|
|
||||||
(string->symbol
|
|
||||||
(string-append
|
|
||||||
(if def-expr
|
|
||||||
"inner-proc-"
|
|
||||||
"super-proc-")
|
|
||||||
(symbol->string
|
|
||||||
(syntax-object->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)]
|
|
||||||
[else (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-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 surrogate
|
|
||||||
(send 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)
|
|
||||||
(super-call id))])]))))
|
|
||||||
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ method-spec ...)
|
|
||||||
(with-syntax ([(ids ...) (map (extract-id stx) (syntax->list (syntax (method-spec ...))))]
|
|
||||||
[(overriding-methods ...)
|
|
||||||
(map make-overriding-method
|
|
||||||
(syntax->list
|
|
||||||
(syntax (method-spec ...))))]
|
|
||||||
[(empty-methods ...)
|
|
||||||
(map make-empty-method
|
|
||||||
(syntax->list
|
|
||||||
(syntax (method-spec ...))))])
|
|
||||||
(syntax/loc stx
|
|
||||||
(let ([surrogate<%>
|
|
||||||
(interface ()
|
|
||||||
on-disable-surrogate
|
|
||||||
on-enable-surrogate
|
|
||||||
ids ...)]
|
|
||||||
[host<%>
|
|
||||||
(interface ()
|
|
||||||
set-surrogate
|
|
||||||
get-surrogate
|
|
||||||
ids ...)])
|
|
||||||
(values
|
|
||||||
(lambda (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)
|
|
||||||
|
|
||||||
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))
|
|
||||||
surrogate<%>))))])))
|
|
||||||
190
collects/scheme/surrogate.ss
Normal file
190
collects/scheme/surrogate.ss
Normal file
|
|
@ -0,0 +1,190 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
|
(require scheme/class
|
||||||
|
(for-syntax scheme/base))
|
||||||
|
|
||||||
|
(provide surrogate)
|
||||||
|
|
||||||
|
(define-syntax (surrogate stx)
|
||||||
|
|
||||||
|
(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-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-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)]
|
||||||
|
[else (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-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 surrogate
|
||||||
|
(send 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)
|
||||||
|
(super-call id))])]))))
|
||||||
|
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ method-spec ...)
|
||||||
|
(with-syntax ([(ids ...) (map (extract-id stx) (syntax->list (syntax (method-spec ...))))]
|
||||||
|
[(overriding-methods ...)
|
||||||
|
(map make-overriding-method
|
||||||
|
(syntax->list
|
||||||
|
(syntax (method-spec ...))))]
|
||||||
|
[(empty-methods ...)
|
||||||
|
(map make-empty-method
|
||||||
|
(syntax->list
|
||||||
|
(syntax (method-spec ...))))])
|
||||||
|
(syntax/loc stx
|
||||||
|
(let ([surrogate<%>
|
||||||
|
(interface ()
|
||||||
|
on-disable-surrogate
|
||||||
|
on-enable-surrogate
|
||||||
|
ids ...)]
|
||||||
|
[host<%>
|
||||||
|
(interface ()
|
||||||
|
set-surrogate
|
||||||
|
get-surrogate
|
||||||
|
ids ...)])
|
||||||
|
(values
|
||||||
|
(lambda (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)
|
||||||
|
|
||||||
|
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))
|
||||||
|
surrogate<%>))))]))
|
||||||
|
|
@ -1708,3 +1708,5 @@ Raised for @scheme[class]-related failures, such as attempting to call
|
||||||
a method that is not supplied by an object.
|
a method that is not supplied by an object.
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@include-section["surrogate.scrbl"]
|
||||||
|
|
@ -1,11 +1,14 @@
|
||||||
#lang scribble/doc
|
#lang scribble/doc
|
||||||
@(require "common.ss"
|
@(require
|
||||||
(for-label mzlib/surrogate
|
scribble/basic
|
||||||
mzlib/class))
|
scribble/manual
|
||||||
|
(for-label scheme/surrogate
|
||||||
|
scheme/class))
|
||||||
|
|
||||||
@mzlib[#:mode title surrogate]
|
@title{Surrogates}
|
||||||
|
@(defmodule scheme/surrogate)
|
||||||
|
|
||||||
The @schememodname[mzlib/surrogate] library provides an abstraction
|
The @schememodname[scheme/surrogate] library provides an abstraction
|
||||||
for building an instance of the @deftech{proxy design pattern}. The
|
for building an instance of the @deftech{proxy design pattern}. The
|
||||||
pattern consists of two objects, a @defterm{host} and a
|
pattern consists of two objects, a @defterm{host} and a
|
||||||
@defterm{surrogate} object. The host object delegates method calls to
|
@defterm{surrogate} object. The host object delegates method calls to
|
||||||
Loading…
Reference in New Issue
Block a user