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

fixed up the framework docs so there are no more warnings

Browse Source 
svn: r9810
This commit is contained in:
Robby Findler 2008-05-12 01:53:47 +00:00
parent 3d9ef571e7
commit 9d634308ee
10 changed files with 473 additions and 321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

244
collects/framework/decorated-editor-snip.ss
View File

@ -1,241 +1,9 @@
#lang scheme/base
(require scheme/gui/base
scheme/class)
(require "private/decorated-editor-snip.ss")
#;
(provide editor-snip:decorated%
editor-snip:decorated-snipclass
editor-snip:decorated-editor-snip-mixin
decorated-editor-snip<%>)
(provide decorated-editor-snip%
decorated-editor-snipclass%
decorated-editor-snip-mixin
decorated-editor-snip<%>)
(require "preferences.ss")
(define decorated-editor-snip<%>
(interface ((class->interface editor-snip%))
get-corner-bitmap get-color get-menu get-position reset-min-sizes))
(define decorated-editor-snip-mixin
(mixin ((class->interface editor-snip%)) (decorated-editor-snip<%>)
;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
;; returns the bitmap to be shown in the top right corner.
(define/public (get-corner-bitmap) #f)
;; get-color : -> (union string (is-a?/c color%))
(define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black"))
;; get-menu : -> (union #f (is-a?/c popup-menu%))
;; returns the popup menu that should appear
;; when clicking in the top part of the snip.
(define/public (get-menu) #f)
;; get-position : -> (union 'top-right 'left-top)
;; returns the location of the image and the clickable
;; region. 'top-right indicates top portion is clickable
;; and icon on right. 'left-top means left portion is
;; clickable and icon on top.
(define/public (get-position) 'top-right)
[define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)]
[define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)]
(inherit get-admin)
(define/override (on-event dc x y editorx editory evt)
(cond
[(eq? (send evt get-event-type) 'right-down)
(let ([sx (- (send evt get-x) x)]
[sy (- (send evt get-y) y)]
[bil (box 0)]
[bit (box 0)]
[bir (box 0)]
[bib (box 0)]
[bw (box 0)]
[bh (box 0)]
[bml (box 0)]
[bmt (box 0)]
[bmr (box 0)]
[bmb (box 0)]
[menu (get-menu)])
(get-extent dc x y bw bh #f #f #f #f)
(get-inset bil bit bir bib)
(get-margin bml bmt bmr bmb)
(let ([in-range
(case (get-position)
[(top-right)
(and (<= 0 sx (unbox bw))
(<= 0 sy (unbox bmt)))]
[(left-top)
(and (<= 0 sx (unbox bml))
(<= 0 sy (unbox bh)))]
[else #f])])
(cond
[(and menu in-range)
(let ([admin (get-admin)])
(when admin
(send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
[else (super on-event dc x y editorx editory evt)])))]
[else
(super on-event dc x y editorx editory evt)]))
(inherit get-extent get-inset)
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([bm (get-corner-bitmap)]
[bil (box 0)]
[bit (box 0)]
[bir (box 0)]
[bib (box 0)]
[bw (box 0)]
[bh (box 0)]
[bml (box 0)]
[bmt (box 0)]
[bmr (box 0)]
[bmb (box 0)])
(get-extent dc x y bw bh #f #f #f #f)
(get-inset bil bit bir bib)
(get-margin bml bmt bmr bmb)
(super draw dc x y left top right bottom dx dy draw-caret)
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[white-on-black? (preferences:get 'framework:white-on-black?)])
(send dc set-pen (send the-pen-list find-or-create-pen
(if white-on-black? "black" "white")
1
'transparent))
(send dc set-brush (send the-brush-list find-or-create-brush
(if white-on-black? "black" "white")
'solid))
(case (get-position)
[(top-right)
(send dc draw-rectangle
(+ x (unbox bml))
(+ y (unbox bit))
(max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
(- (unbox bmt) (unbox bit)))]
[(left-top)
(send dc draw-rectangle
(+ x (unbox bil))
(+ y (unbox bmt))
(- (unbox bml) (unbox bil))
(max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
(send dc set-pen (send the-pen-list find-or-create-pen
(if white-on-black? "white" "black")
1
'solid))
(send dc set-brush (send the-brush-list find-or-create-brush
(if white-on-black? "white" "black")
'solid))
(when bm
(let ([bm-w (send bm get-width)]
[bm-h (send bm get-height)])
(case (get-position)
[(top-right)
(send dc draw-bitmap
bm
(+ x (max 0
(- (unbox bw)
(unbox bmr)
bm-w)))
;; leave two pixels above and two below (see super-instantiate below)
(+ y (unbox bit) 2))]
[(left-top)
(send dc draw-bitmap
bm
;; leave two pixels left and two right (see super-instantiate below)
(+ x (unbox bil) 2)
(+ y (unbox bmt)))])))
(send dc set-pen (get-pen))
(send dc set-brush (get-brush))
(send dc draw-rectangle
(+ x (unbox bil))
(+ y (unbox bit))
(max 0 (- (unbox bw) (unbox bil) (unbox bir)))
(max 0 (- (unbox bh) (unbox bit) (unbox bib))))
(send dc set-pen old-pen)
(send dc set-brush old-brush))))
(inherit set-min-width set-min-height get-margin)
(define/public (reset-min-sizes)
(let ([bm (get-corner-bitmap)])
(when bm
(case (get-position)
[(top-right)
(set-min-width (+ 4 (send bm get-width)))]
[(left-top)
(set-min-height (+ 4 (send bm get-height)))]))))
(let ([top-margin
(case (get-position)
[(top-right)
(+ 4
(let ([bm (get-corner-bitmap)])
(if bm
(send bm get-height)
0)))]
[else 4])]
[left-margin
(case (get-position)
[(left-top)
(+ 4
(let ([bm (get-corner-bitmap)])
(if bm
(send bm get-width)
0)))]
[else 4])])
(super-new
(with-border? #f)
(top-margin top-margin)
(left-margin left-margin)))
(inherit use-style-background)
(use-style-background #t)
(reset-min-sizes)))
(define decorated-editor-snip%
(class (decorated-editor-snip-mixin editor-snip%)
(inherit get-editor get-style)
;; make-snip : -> this%
;; returns an instance of this class. used in the copy method
(define/public (make-snip) (make-object decorated-editor-snip%))
;; make-editor : -> editor<%>
;; returns the editor to be used in this snip.
(define/public (make-editor) (make-object text%))
(define/override write
(λ (stream-out)
(send (get-editor) write-to-file stream-out 0 'eof)))
(define/override (copy)
(let ([snip (make-snip)])
(send snip set-editor (send (get-editor) copy-self))
(send snip set-style (get-style))
snip))
(super-new
(editor (make-editor)))))
(define decorated-editor-snipclass%
(class snip-class%
;; make-snip : stream-in -> (is-a?/c snip%)
;; returns an unfilled version of the snip
(define/public (make-snip stream-in) (make-object decorated-editor-snip%))
(define/override (read stream-in)
(let ([snip (make-snip stream-in)])
(send (send snip get-editor) read-from-file stream-in #f)
snip))
(super-new)))
(provide
(rename-out [editor-snip:decorated% decorated-editor-snip%])
(rename-out [editor-snip:decorated-snipclass decorated-editor-snipclass%])
(rename-out [editor-snip:decorated-mixin decorated-editor-snip-mixin])
(rename-out [editor-snip:decorated<%> decorated-editor-snip<%>]))

26
collects/framework/main.ss
View File

@ -11,12 +11,14 @@
(require framework/preferences
framework/test
framework/gui-utils
framework/decorated-editor-snip)
framework/decorated-editor-snip
framework/private/decorated-editor-snip)
(provide (all-from-out framework/preferences
framework/test
framework/gui-utils
framework/decorated-editor-snip))
framework/decorated-editor-snip
framework/private/decorated-editor-snip))
(require/doc scheme/base scribble/manual framework/private/mapdesc)
@ -424,9 +426,7 @@
(parent (finder:dialog-parent-parameter))))
@{This procedure queries the user for a single filename, using a
platform-independent dialog box. Consider using
@scheme[finder:put-file] instead of this function.
See section @secref{selecting-a-filename} for more information.})
@scheme[finder:put-file] instead of this function.})
(proc-doc/names
finder:common-get-file
@ -445,9 +445,7 @@
(parent #f)))
@{This procedure queries the user for a single filename, using a
platform-independent dialog box. Consider using
@scheme[finder:get-file] instead of this function.
See section @secref{selecting-a-filename} for more information.})
@scheme[finder:get-file] instead of this function.})
(proc-doc/names
finder:std-put-file
@ -470,9 +468,7 @@
(parent (finder:dialog-parent-parameter))))
@{This procedure queries the user for a single filename, using a
platform-dependent dialog box. Consider using
@scheme[finder:put-file] instead of this function.
See section @secref{selecting-a-filename} for more information.})
@scheme[finder:put-file] instead of this function.})
(proc-doc/names
finder:std-get-file
@ -491,9 +487,7 @@
(parent #f)))
@{This procedure queries the user for a single filename, using a
platform-dependent dialog box. Consider using
@scheme[finder:get-file] instead of this function.
See section @secref{selecting-a-filename} for more information.})
@scheme[finder:get-file] instead of this function.})
(proc-doc/names
finder:put-file
@ -557,9 +551,7 @@
(filter-msg "That filename does not have the right form.")
(parent #f)))
@{This procedure queries the user for a list of filenames, using a
platform-independent dialog box.
See @secref{selecting-a-filename} for more information.})
platform-independent dialog box.})
(proc-doc/names
frame:setup-size-pref

240
collects/framework/private/decorated-editor-snip.ss Normal file
View File

@ -0,0 +1,240 @@
#lang scheme/base
(require scheme/gui/base
scheme/class)
(provide editor-snip:decorated%
editor-snip:decorated-snipclass
editor-snip:decorated-mixin
editor-snip:decorated<%>)
(require "../preferences.ss")
(define editor-snip:decorated<%>
(interface ((class->interface editor-snip%))
get-corner-bitmap
get-color
get-menu
get-position
reset-min-sizes))
(define editor-snip:decorated-mixin
(mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>)
;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
;; returns the bitmap to be shown in the top right corner.
(define/public (get-corner-bitmap) #f)
;; get-color : -> (union string (is-a?/c color%))
(define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black"))
;; get-menu : -> (union #f (is-a?/c popup-menu%))
;; returns the popup menu that should appear
;; when clicking in the top part of the snip.
(define/public (get-menu) #f)
;; get-position : -> (union 'top-right 'left-top)
;; returns the location of the image and the clickable
;; region. 'top-right indicates top portion is clickable
;; and icon on right. 'left-top means left portion is
;; clickable and icon on top.
(define/public (get-position) 'top-right)
[define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)]
[define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)]
(inherit get-admin)
(define/override (on-event dc x y editorx editory evt)
(cond
[(eq? (send evt get-event-type) 'right-down)
(let ([sx (- (send evt get-x) x)]
[sy (- (send evt get-y) y)]
[bil (box 0)]
[bit (box 0)]
[bir (box 0)]
[bib (box 0)]
[bw (box 0)]
[bh (box 0)]
[bml (box 0)]
[bmt (box 0)]
[bmr (box 0)]
[bmb (box 0)]
[menu (get-menu)])
(get-extent dc x y bw bh #f #f #f #f)
(get-inset bil bit bir bib)
(get-margin bml bmt bmr bmb)
(let ([in-range
(case (get-position)
[(top-right)
(and (<= 0 sx (unbox bw))
(<= 0 sy (unbox bmt)))]
[(left-top)
(and (<= 0 sx (unbox bml))
(<= 0 sy (unbox bh)))]
[else #f])])
(cond
[(and menu in-range)
(let ([admin (get-admin)])
(when admin
(send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
[else (super on-event dc x y editorx editory evt)])))]
[else
(super on-event dc x y editorx editory evt)]))
(inherit get-extent get-inset)
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([bm (get-corner-bitmap)]
[bil (box 0)]
[bit (box 0)]
[bir (box 0)]
[bib (box 0)]
[bw (box 0)]
[bh (box 0)]
[bml (box 0)]
[bmt (box 0)]
[bmr (box 0)]
[bmb (box 0)])
(get-extent dc x y bw bh #f #f #f #f)
(get-inset bil bit bir bib)
(get-margin bml bmt bmr bmb)
(super draw dc x y left top right bottom dx dy draw-caret)
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[white-on-black? (preferences:get 'framework:white-on-black?)])
(send dc set-pen (send the-pen-list find-or-create-pen
(if white-on-black? "black" "white")
1
'transparent))
(send dc set-brush (send the-brush-list find-or-create-brush
(if white-on-black? "black" "white")
'solid))
(case (get-position)
[(top-right)
(send dc draw-rectangle
(+ x (unbox bml))
(+ y (unbox bit))
(max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
(- (unbox bmt) (unbox bit)))]
[(left-top)
(send dc draw-rectangle
(+ x (unbox bil))
(+ y (unbox bmt))
(- (unbox bml) (unbox bil))
(max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
(send dc set-pen (send the-pen-list find-or-create-pen
(if white-on-black? "white" "black")
1
'solid))
(send dc set-brush (send the-brush-list find-or-create-brush
(if white-on-black? "white" "black")
'solid))
(when bm
(let ([bm-w (send bm get-width)]
[bm-h (send bm get-height)])
(case (get-position)
[(top-right)
(send dc draw-bitmap
bm
(+ x (max 0
(- (unbox bw)
(unbox bmr)
bm-w)))
;; leave two pixels above and two below (see super-instantiate below)
(+ y (unbox bit) 2))]
[(left-top)
(send dc draw-bitmap
bm
;; leave two pixels left and two right (see super-instantiate below)
(+ x (unbox bil) 2)
(+ y (unbox bmt)))])))
(send dc set-pen (get-pen))
(send dc set-brush (get-brush))
(send dc draw-rectangle
(+ x (unbox bil))
(+ y (unbox bit))
(max 0 (- (unbox bw) (unbox bil) (unbox bir)))
(max 0 (- (unbox bh) (unbox bit) (unbox bib))))
(send dc set-pen old-pen)
(send dc set-brush old-brush))))
(inherit set-min-width set-min-height get-margin)
(define/public (reset-min-sizes)
(let ([bm (get-corner-bitmap)])
(when bm
(case (get-position)
[(top-right)
(set-min-width (+ 4 (send bm get-width)))]
[(left-top)
(set-min-height (+ 4 (send bm get-height)))]))))
(let ([top-margin
(case (get-position)
[(top-right)
(+ 4
(let ([bm (get-corner-bitmap)])
(if bm
(send bm get-height)
0)))]
[else 4])]
[left-margin
(case (get-position)
[(left-top)
(+ 4
(let ([bm (get-corner-bitmap)])
(if bm
(send bm get-width)
0)))]
[else 4])])
(super-new
(with-border? #f)
(top-margin top-margin)
(left-margin left-margin)))
(inherit use-style-background)
(use-style-background #t)
(reset-min-sizes)))
(define editor-snip:decorated%
(class (editor-snip:decorated-mixin editor-snip%)
(inherit get-editor get-style)
;; make-snip : -> this%
;; returns an instance of this class. used in the copy method
(define/public (make-snip) (make-object editor-snip:decorated%))
;; make-editor : -> editor<%>
;; returns the editor to be used in this snip.
(define/public (make-editor) (make-object text%))
(define/override write
(λ (stream-out)
(send (get-editor) write-to-file stream-out 0 'eof)))
(define/override (copy)
(let ([snip (make-snip)])
(send snip set-editor (send (get-editor) copy-self))
(send snip set-style (get-style))
snip))
(super-new
(editor (make-editor)))))
(define editor-snip:decorated-snipclass
(class snip-class%
;; make-snip : stream-in -> (is-a?/c snip%)
;; returns an unfilled version of the snip
(define/public (make-snip stream-in) (make-object editor-snip:decorated%))
(define/override (read stream-in)
(let ([snip (make-snip stream-in)])
(send (send snip get-editor) read-from-file stream-in #f)
snip))
(super-new)))

26
collects/framework/private/mode.ss
View File

@ -1,14 +1,17 @@
#lang scheme/unit
(require scheme/class
#lang scheme/base
(require (for-syntax scheme/base)
scheme/unit
scheme/class
scheme/surrogate
"sig.ss")
(import)
(export framework:mode^)
(provide mode@ surrogate-methods)
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
(surrogate
(augment (void) on-change ())
(define-syntax (surrogate-methods stx)
(syntax-case stx ()
[(_ m)
#'(m (augment (void) on-change ())
(override on-char (event))
(override on-default-char (event))
(override on-default-event (event))
@ -47,4 +50,11 @@
(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))))
(augment #t can-save-file? (filename format)))]))
(define-unit mode@
(import)
(export framework:mode^)
(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)
(surrogate-methods surrogate)))

2
collects/scribblings/framework/comment-box.scrbl
View File

@ -4,7 +4,7 @@
@(require (for-label scheme/gui))
@title{Comment Box}
@defclass[comment-box:snip% decorated-editor-snip% (readable-snip<%>)]{
@defclass[comment-box:snip% editor-snip:decorated% (readable-snip<%>)]{
This snip implements the comment boxes that you see in
DrScheme.

10
collects/scribblings/framework/decorated-editor-snip.scrbl
View File

@ -1,10 +0,0 @@
#lang scribble/doc
@(require scribble/manual)
@(require (for-label framework))
@(require (for-label scheme/gui))
@title{Decorated Editor Snip}
@(defmodule framework/decorated-editor-snip)
@definterface[decorated-editor-snip<%> (editor-snip%)]{
}

89
collects/scribblings/framework/editor-snip.scrbl Normal file
View File

@ -0,0 +1,89 @@
#lang scribble/doc
@(require scribble/manual)
@(require (for-label framework))
@(require (for-label scheme/gui))
@title[#:tag "editor-snip"]{Editor Snip}
@definterface[editor-snip:decorated<%> (editor-snip%)]{
@defmethod[(get-corner-bitmap) (or/c false/c (is-a?/c bitmap%))]{
Returns a bitmap that is drawn in the upper-right corner of this snip.
}
@defmethod[(get-color) (or/c string? (is-a?/c color%))]{
Returns the color used to draw the background part of the snip.
}
@defmethod[(get-menu) (or/c false/c (is-a?/c popup-menu%))] {
Returns a popup menu that is used when clicking on the top part of the snip.
}
@defmethod[(get-position) (symbols 'top-right 'left-top)] {
Returns the location of the image and the clickable
region. The symbol @scheme['top-right] indicates top portion is clickable
and icon on right. The symbol @scheme['left-top] means left portion is
clickable and icon on top.
}
@defmethod[(reset-min-sizes) void?] {
Sets the minimum sizes based on the result of
@method[editor-snip:decorated<%> get-corner-bitmap].
}
}
@defmixin[editor-snip:decorated-mixin (editor-snip%) (editor-snip:decorated<%>)]{
@defmethod[(get-corner-bitmap) (or/c false/c (is-a?/c bitmap%))]{
Returns @scheme[#f].
}
@defmethod[(get-color) (or/c string? (is-a?/c color%))]{
Returns @schemeblock[
(if (preferences:get 'framework:white-on-black?)
"white"
"black")]
}
@defmethod[(get-menu) (or/c false/c (is-a?/c popup-menu%))] {
Returns @scheme[#f].
}
@defmethod[(get-position) (symbols 'top-right 'left-top)] {
Returns @scheme['top-right].
}
}
@defclass[editor-snip:decorated% (editor-snip:decorated-mixin editor-snip%) ()]{
@defconstructor/auto-super[()]{
Invokes the super constructor with the keyword @scheme[editor] as a call to
@method[editor-snip:decorated% make-editor].
}
@defmethod[(make-snip) (is-a?/c editor-snip:decorated%)]{
This method should return an instance of the class it is invoked in.
If you create a subclass of this class, be sure to override this method and
have it create instances of the subclass.
}
@defmethod[(make-editor) (is-a?/c editor<%>)]{
Creates an editor to be used in this snip.
}
@defmethod[(copy) (is-a?/c editor-snip:decorated%)]{
Uses the @method[editor-snip:decorated% make-editor] and
@method[editor-snip:decorated% make-snip] methods to create a
copy of this snip, as follows:
@schememod[
(let ([snip (make-snip)])
(send snip set-editor (send (get-editor) copy-self))
(send snip set-style (get-style))
snip)]
}
}
@defclass[editor-snip:decorated-snipclass% snip-class% ()]{
@defmethod[(make-snip [stream-in (is-a?/c editor-stream-in%)]) -editor-snip:decorated<%>]{
Returns an instance of @scheme[editor-snip:decorated%].
}
@defmethod[(read [stream-in (is-a?/c editor-stream-in%)]) editor-snip:decorated<%>]{
Calls @method[editor-snip:decorated-snipclass% make-snip] to get an object and
then invokes its @scheme[editor<%>]'s @method[editor<%> read-from-file] method
in order to read a snip from @scheme[stream-in], eg:
@schemeblock[
(let ([snip (make-snip stream-in)])
(send (send snip get-editor) read-from-file stream-in #f)
snip)
]
}
}

15
collects/scribblings/framework/framework.scrbl
View File

@ -6,12 +6,6 @@
@title{@bold{Framework}: PLT GUI Application Framework}
@(defmodule framework)
@bold{TODO}
@itemize{@item{decorated editor snip isn't exported by framework/framework}}
----------------------------------------------------------------------------------------------------
The framework provides a number of mixins, classes and
functions designed to help you build a complete application
program on top of the @scheme[scheme/gui] library.
@ -58,13 +52,13 @@ This library provides all of the definitions beginning with
@scheme[(require framework/gui-utils)]
This libraries provides all of the definitions beginning
with \scheme{gui-utils:} described in this manual.
with @scheme[gui-utils:] described in this manual.
}
@item{ @bold{Preferences}
@scheme[(require framework/preferences)]
This library provides a subset of the names of the
\scheme|framework.ss| library, namely those for
@tt{framework.ss} library, namely those for
manipulating preference settings and is designed to be
used from mzscheme.
@ -85,7 +79,9 @@ The precise set of exported names is:
@item{@bold{Decorated Editor Snip}
@scheme[(require framework/decorated-editor-snip)]
This library exports an editor snipclass
This library is here for backwards compatibility. The
functionality in it has moved into the framework proper, in
the @secref["editor-snip"] section.
}
}
@ -105,6 +101,7 @@ their feedback and help.
@include-section["color-prefs.scrbl"]
@include-section["color.scrbl"]
@include-section["comment-box.scrbl"]
@include-section["editor-snip.scrbl"]
@include-section["editor.scrbl"]
@include-section["exit.scrbl"]
@include-section["finder.scrbl"]

28
collects/scribblings/framework/mode-helpers.ss Normal file
View File

@ -0,0 +1,28 @@
#reader scribble/reader
#lang scheme/base
(provide spec->host-method spec->surrogate-method)
(require (for-template scribble/manual scheme/base))
(require scheme/class)
(require (for-label framework))
(define (spec->host-method spec)
(syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(override mtd (x ...) ...)
#'@defmethod*[(((mtd (x any/c) ...) any) ...)]{
Delegates to the result of @method[mode:host-text<%> get-surrogate] if it is not @scheme[#f].}]
[(augment default mtd (x ...) ...)
#'@defmethod*[(((mtd (x any/c) ...) any) ...)]{
Delegates to the result of @method[mode:host-text<%> get-surrogate] if it is not @scheme[#f].}]))
(define (spec->surrogate-method spec)
(syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(override method (x ...) ...)
#'@defmethod*[(((method (orig (is-a?/c text%)) (call-super (-> any)) (x any/c) ...) any) ...)]{
Returns the result of invoking @scheme[call-super].
}]
[(augment default method (x ...) ...)
#'@defmethod*[(((method (orig (is-a?/c text%)) (call-inner (-> any)) (x any/c) ...) any) ...)]{
Returns the result of invoking @scheme[call-super].
}]))

38
collects/scribblings/framework/mode.scrbl
View File

@ -2,7 +2,45 @@
@(require scribble/manual scribble/extract)
@(require (for-label framework))
@(require (for-label scheme/gui))
@(require (for-syntax "mode-helpers.ss"))
@title{Mode}
@(begin
(require framework/private/mode (for-syntax scheme/base))
(define-syntax (docs stx)
(syntax-case stx ()
[(_ spec ...)
#`(begin
@definterface[mode:surrogate-text<%> ()]{
@defmethod[(on-enable-surrogate) any]{
Called by @method[mode:host-text<%> set-surrogate] to
notify the surrogate that it has just become active.
}
@defmethod[(on-disable-surrogate) any]{
Called by @method[mode:host-text<%> set-surrogate] to
notify the surrogate that it has just been disabled.
}
}
@defclass[mode:surrogate-text% object% (mode:surrogate-text<%>)]{
@#,@(map spec->surrogate-method (syntax->list #'(spec ...)))
}
@definterface[mode:host-text<%> ()]{
@defmethod[(get-surrogate)
(or/c false/c (is-a?/c mode:surrogate-text<%>))]{
Returns the currently active surrogate.
}
@defmethod[(set-surrogate
[surrogate (or/c false/c (is-a?/c mode:surrogate-text<%>))])
void?]{
Sets the current surrogate to @scheme[surrogate].
}
}
@defmixin[mode:host-text-mixin () (mode:host-text<%>)]{
@#,@(map spec->host-method (syntax->list #'(spec ...)))
})]))
(surrogate-methods docs)
)
@(include-extracted (lib "main.ss" "framework") #rx"^mode:")