moved the surrogate library to scheme/ (out of mzlib/)
svn: r9554
This commit is contained in:
Robby Findler
parent
efa0f5f396
commit
baa9ed726a
|
|
@ -1,50 +1,50 @@
|
|||
#lang scheme/unit
|
||||
(require mzlib/surrogate
|
||||
mzlib/class
|
||||
"sig.ss")
|
||||
|
||||
(import)
|
||||
(export framework:mode^)
|
||||
|
||||
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
|
||||
(surrogate
|
||||
(augment (void) on-change ())
|
||||
(override on-char (event))
|
||||
(override on-default-char (event))
|
||||
(override on-default-event (event))
|
||||
(augment (void) on-display-size ())
|
||||
(augment (void) on-edit-sequence ())
|
||||
(override on-event (event))
|
||||
(override on-focus (on?))
|
||||
(augment (void) on-load-file (filename format))
|
||||
(override on-local-char (event))
|
||||
(override on-local-event (event))
|
||||
(override on-new-box (type))
|
||||
(override on-new-image-snip (filename kind relative-path? inline?))
|
||||
(override on-paint (before? dc left top right bottom dx dy draw-caret))
|
||||
(augment (void) on-save-file (filename format))
|
||||
(augment (void) on-snip-modified (snip modified?))
|
||||
|
||||
(augment (void) on-change-style (start len))
|
||||
(augment (void) on-delete (start len))
|
||||
(augment (void) on-insert (start len))
|
||||
(override on-new-string-snip ())
|
||||
(override on-new-tab-snip ())
|
||||
(augment (void) on-set-size-constraint ())
|
||||
|
||||
(augment (void) after-change-style (start len))
|
||||
(augment (void) after-delete (start len))
|
||||
(augment (void) after-insert (start len))
|
||||
(augment (void) after-set-position ())
|
||||
(augment (void) after-set-size-constraint ())
|
||||
(augment (void) after-edit-sequence ())
|
||||
(augment (void) after-load-file (success?))
|
||||
(augment (void) after-save-file (success?))
|
||||
|
||||
(augment #t can-change-style? (start len))
|
||||
(augment #t can-delete? (start len))
|
||||
(augment #t can-insert? (start len))
|
||||
(augment #t can-set-size-constraint? ())
|
||||
(override can-do-edit-operation? (op) (op recursive?))
|
||||
(augment #t can-load-file? (filename format))
|
||||
(augment #t can-save-file? (filename format))))
|
||||
(require scheme/class
|
||||
scheme/surrogate
|
||||
"sig.ss")
|
||||
|
||||
(import)
|
||||
(export framework:mode^)
|
||||
|
||||
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
|
||||
(surrogate
|
||||
(augment (void) on-change ())
|
||||
(override on-char (event))
|
||||
(override on-default-char (event))
|
||||
(override on-default-event (event))
|
||||
(augment (void) on-display-size ())
|
||||
(augment (void) on-edit-sequence ())
|
||||
(override on-event (event))
|
||||
(override on-focus (on?))
|
||||
(augment (void) on-load-file (filename format))
|
||||
(override on-local-char (event))
|
||||
(override on-local-event (event))
|
||||
(override on-new-box (type))
|
||||
(override on-new-image-snip (filename kind relative-path? inline?))
|
||||
(override on-paint (before? dc left top right bottom dx dy draw-caret))
|
||||
(augment (void) on-save-file (filename format))
|
||||
(augment (void) on-snip-modified (snip modified?))
|
||||
|
||||
(augment (void) on-change-style (start len))
|
||||
(augment (void) on-delete (start len))
|
||||
(augment (void) on-insert (start len))
|
||||
(override on-new-string-snip ())
|
||||
(override on-new-tab-snip ())
|
||||
(augment (void) on-set-size-constraint ())
|
||||
|
||||
(augment (void) after-change-style (start len))
|
||||
(augment (void) after-delete (start len))
|
||||
(augment (void) after-insert (start len))
|
||||
(augment (void) after-set-position ())
|
||||
(augment (void) after-set-size-constraint ())
|
||||
(augment (void) after-edit-sequence ())
|
||||
(augment (void) after-load-file (success?))
|
||||
(augment (void) after-save-file (success?))
|
||||
|
||||
(augment #t can-change-style? (start len))
|
||||
(augment #t can-delete? (start len))
|
||||
(augment #t can-insert? (start len))
|
||||
(augment #t can-set-size-constraint? ())
|
||||
(override can-do-edit-operation? (op) (op recursive?))
|
||||
(augment #t can-load-file? (filename format))
|
||||
(augment #t can-save-file? (filename format))))
|
||||
|
|
|
|||
|
|
@ -237,10 +237,6 @@ Re-exports @schememodname[scheme/stxparam] and
|
|||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@include-section["surrogate.scrbl"]
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@mzlib[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.
|
||||
|
||||
}
|
||||
|
||||
@include-section["surrogate.scrbl"]
|
||||
|
|
@ -1,11 +1,14 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.ss"
|
||||
(for-label mzlib/surrogate
|
||||
mzlib/class))
|
||||
@(require
|
||||
scribble/basic
|
||||
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
|
||||
pattern consists of two objects, a @defterm{host} and a
|
||||
@defterm{surrogate} object. The host object delegates method calls to
|
||||
Loading…
Reference in New Issue
Block a user