diff --git a/collects/framework/private/mode.ss b/collects/framework/private/mode.ss index 6f70d7907c..9b51226a54 100644 --- a/collects/framework/private/mode.ss +++ b/collects/framework/private/mode.ss @@ -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)))) diff --git a/collects/mzlib/scribblings/mzlib.scrbl b/collects/mzlib/scribblings/mzlib.scrbl index f3dd027df9..8b1cfb2390 100644 --- a/collects/mzlib/scribblings/mzlib.scrbl +++ b/collects/mzlib/scribblings/mzlib.scrbl @@ -237,10 +237,6 @@ Re-exports @schememodname[scheme/stxparam] and @; ---------------------------------------------------------------------- -@include-section["surrogate.scrbl"] - -@; ---------------------------------------------------------------------- - @mzlib[tar] Re-exports @schememodname[file/tar]. diff --git a/collects/mzlib/surrogate.ss b/collects/mzlib/surrogate.ss deleted file mode 100644 index 23f8a907e0..0000000000 --- a/collects/mzlib/surrogate.ss +++ /dev/null @@ -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<%>))))]))) diff --git a/collects/scheme/surrogate.ss b/collects/scheme/surrogate.ss new file mode 100644 index 0000000000..86d45626ee --- /dev/null +++ b/collects/scheme/surrogate.ss @@ -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<%>))))])) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index ac5026a985..980885a685 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -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"] \ No newline at end of file diff --git a/collects/mzlib/scribblings/surrogate.scrbl b/collects/scribblings/reference/surrogate.scrbl similarity index 94% rename from collects/mzlib/scribblings/surrogate.scrbl rename to collects/scribblings/reference/surrogate.scrbl index a6fa1a7032..29a58b9c97 100644 --- a/collects/mzlib/scribblings/surrogate.scrbl +++ b/collects/scribblings/reference/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