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

sync to trunk

Browse Source 
svn: r14750

original commit: 0ddf7338cbc9c3d01c8a24820a04cac82deed6b7
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-08 20:11:09 +00:00
commit 3d02cc1202
137 changed files with 18041 additions and 1883 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/embedded-gui/doc.txt
View File

@ -93,8 +93,8 @@ Add the given alignment as a child after the existing child
> (send an-alignment-parent delete-child child) -> void
child : (is-a?/c alignment<%>)
Deletes a child from the the alignments
Deletes a child from the alignments
> (send an-alignment-parent is-shown?) -> boolean?
True if the alignment is being shown (accounting for its parent being shown)

2
collects/embedded-gui/private/aligned-pasteboard.ss
View File

@ -74,7 +74,7 @@
(set! alignment child))))
#;((is-a?/c alignment<%>) . -> . void?)
;; Deletes a child from the the alignments
;; Deletes a child from the alignments
(define/public (delete-child child)
(if alignment
(if (eq? child alignment)

10
collects/embedded-gui/private/cue-text.ss
View File

@ -19,7 +19,8 @@
(define cue-text-mixin
(mixin ((class->interface text%)) ()
(inherit insert change-style erase clear-undos)
(inherit insert change-style erase clear-undos
copy-self-to get-line-spacing)
(init [cue-text ""]
[color "gray"])
(init-field
@ -47,6 +48,13 @@
(when (member 'on-char behavior)
(clear-cue-text))
(super on-local-char akeyevent))
(define/override (copy-self)
(let ([m (new cue-text%
[behavior behavior]
[line-spacing (get-line-spacing)])])
(copy-self-to m)
m))
;; Insert the cue text into the text% on instantiation
(super-new)

2
collects/embedded-gui/private/interface.ss
View File

@ -66,7 +66,7 @@
add-child
#;((is-a?/c alignment<%>) . -> . void?)
;; Deletes a child from the the alignments
;; Deletes a child from the alignments
delete-child
#;(-> boolean?)

2
collects/embedded-gui/private/verthoriz-alignment.ss
View File

@ -137,7 +137,7 @@
(link (send tail prev) child tail))))
#;((is-a?/c alignment<%>) . -> . void?)
;; Deletes a child from the the alignments
;; Deletes a child from the alignments
(define/public (delete-child child)
(send child show/hide false)
(let ([p (send child prev)]

2
collects/embedded-gui/scribblings/alignment-parent.scrbl
View File

@ -13,7 +13,7 @@ Add the given alignment as a child after the existing child.}
@defmethod[(delete-child [child (is-a?/c alignment<%>)]) void?]{
Deletes a child from the the alignments.}
Deletes a child from the alignments.}
@defmethod[(is-shown?) boolean?]{

56
collects/framework/main.ss
View File

@ -1,5 +1,4 @@
#reader scribble/reader
#lang scheme/gui
#lang at-exp scheme/gui
(require mred/mred-unit
mred/mred-sig
@ -50,13 +49,10 @@
(prefix scheme: framework:scheme-class^)
(prefix main: framework:main-class^))
(define-compound-unit/infer framework+mred@
(import)
(define-values/invoke-unit/infer
(export framework^)
(link standard-mred@ framework@))
(define-values/invoke-unit/infer framework+mred@)
(provide/doc
(parameter-doc
text:autocomplete-append-after
@ -155,14 +151,14 @@
(name-list val-list)
@{Like @scheme[put-preferences], but has more sophisticated error
handling. In particular, it
@itemize{
@itemize[
@item{waits for three consecutive failures before informing the
user}
@item{gives the user the opportunity to ``steal'' the lockfile
after the third failure, and}
@item{when failures occur, it remembers what its arguments were
and if any preference save eventually succeeds, all of the
past failures are also written at that point.}}})
past failures are also written at that point.}]})
(proc-doc/names
preferences:add-panel
@ -202,6 +198,12 @@
@{Adds a preferences panel for configuring options related to
editing.})
(proc-doc/names
preferences:add-general-checkbox-panel
(-> void?)
()
@{Adds a catch-all preferences panel for options.})
(proc-doc/names
preferences:add-warnings-checkbox-panel
(-> void?)
@ -236,7 +238,15 @@
(((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
(proc)
@{Saves @scheme[proc] until the preferences panel is created, when it
is called with the Echeme preferences panel to add new children to
is called with the editor preferences panel to add new children to
the panel.})
(proc-doc/names
preferences:add-to-general-checkbox-panel
(((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
(proc)
@{Saves @scheme[proc] until the preferences panel is created, when it
is called with the general preferences panel to add new children to
the panel.})
(proc-doc/names
@ -355,7 +365,7 @@
(-> any)
()
@{@scheme[exit:exit] performs four actions:
@itemize{
@itemize[
@item{sets the result of the @scheme[exit:exiting?] function to
@scheme[#t].}
@item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if
@ -363,7 +373,7 @@
@item{invokes @scheme[exit:on-exit] and then}
@item{queues a callback that calls @scheme[exit]
(a mzscheme procedure) and (if @scheme[exit] returns) sets the result of
@scheme[exit:exiting?] back to @scheme[#t].}}})
@scheme[exit:exiting?] back to @scheme[#t].}]})
(proc-doc/names
exit:user-oks-exit
@ -723,22 +733,22 @@
Otherwise, it invokes the appropriate format handler to open the
file (see @scheme[handler:insert-format-handler]).
@itemize{
@itemize[
@item{If @scheme[filename] is a string, this function checks the
result of @scheme[group:get-the-frame-group] to see if the
@scheme[filename] is already open by a frame in the group.
@itemize{
@itemize[
@item{If so, it returns the frame.}
@item{If not, this function calls
@scheme[handler:find-format-handler] with
@scheme[filename].
@itemize{
@itemize[
@item{If a handler is found, it is applied to
@scheme[filename] and it's result is the
final result.}
@item{If not, @scheme[make-default] is used.}}}}}
@item{If not, @scheme[make-default] is used.}]}]}
@item{If @scheme[filename] is @scheme[#f], @scheme[make-default]
is used.}}})
is used.}]})
(parameter-doc
handler:current-create-new-window
@ -970,13 +980,13 @@
@{This returns a keymap for handling standard editing operations. It
binds these keys:
@itemize{
@itemize[
@item{@scheme["z"]: undo}
@item{@scheme["y"]: redo}
@item{@scheme["x"]: cut}
@item{@scheme["c"]: copy}
@item{@scheme["v"]: paste}
@item{@scheme["a"]: select all}}
@item{@scheme["a"]: select all}]
where each key is prefixed with the menu-shortcut key, based on the
platform. Under unix, the shortcut is @scheme["a:"]; under windows
the shortcut key is @scheme["c:"] and under MacOS, the shortcut key
@ -1059,7 +1069,7 @@
This function extends a @scheme[keymap%] with the following
functions:
@itemize{
@itemize[
@item{@mapdesc[ring-bell any] --- Rings the bell
(using @scheme[bell]) and removes the search panel from the frame,
if there.}
@ -1132,12 +1142,12 @@
@item{@mapdesc[end-macro key] --- Stops building a keyboard macro}
@item{@mapdesc[do-macro key] --- Executes the last keyboard macro}
@item{@mapdesc[toggle-overwrite key] --- Toggles overwriting
mode}}
mode}]
These functions are bound to the following keys
(C = control, S = shift, A = alt, M = ``meta'', D = command):
@itemize{
@itemize[
@item{C-g : ``ring-bell''}
@item{M-C-g : ``ring-bell''}
@item{C-c C-g : ``ring-bell''}
@ -1217,7 +1227,7 @@
@item{MIDDLEBUTTON : ``paste-click-region''}
@item{C-RIGHTBUTTON : ``copy-clipboard''}
@item{INSERT : ``toggle-overwrite''}
@item{M-o : ``toggle-overwrite''}}})
@item{M-o : ``toggle-overwrite''}]})
(proc-doc/names
keymap:setup-search
@ -1418,7 +1428,7 @@
This function is not symmetric in red, green, and blue, so it is
important to pass red, green, and blue components of the colors in
the the proper order. The first three arguments are red, green and
the proper order. The first three arguments are red, green and
blue for the first color, respectively, and the second three
arguments are red green and blue for the second color,
respectively.})

228
collects/framework/preferences.ss
View File

@ -38,12 +38,8 @@ the state transitions / contracts are:
(define exn:make-unknown-preference make-exn:unknown-preference)
(define exn:struct:unknown-preference struct:exn:unknown-preference)
(define old-preferences-symbol 'plt:framework-prefs)
(define old-preferences (make-hasheq))
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
(for-each
(λ (line) (hash-set! old-preferences (car line) (cadr line)))
old-prefs))
(define preferences:low-level-put-preferences (make-parameter put-preferences))
(define preferences:low-level-get-preference (make-parameter get-preference))
(define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
@ -51,12 +47,6 @@ the state transitions / contracts are:
;; the current values of the preferences
(define preferences (make-hasheq))
;; marshalled : hash-table[sym -o> any]
;; the values of the preferences, as read in from the disk
;; each symbol will only be mapped in one of the preferences
;; hash-table and this hash-table, but not both.
(define marshalled (make-hasheq))
;; marshall-unmarshall : sym -o> un/marshall
(define marshall-unmarshall (make-hasheq))
@ -67,11 +57,11 @@ the state transitions / contracts are:
(define defaults (make-hasheq))
;; these four functions determine the state of a preference
(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
(define (pref-default-set? pref) (hash-table-bound? defaults pref))
(define (pref-can-init? pref)
(define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
(define (pref-default-set? pref) (hash-has-key? defaults pref))
(define (pref-can-init? pref)
(and (not snapshot-grabbed?)
(not (hash-table-bound? preferences pref))))
(not (hash-has-key? preferences pref))))
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
(define-struct un/marshall (marshall unmarshall))
@ -86,35 +76,32 @@ the state transitions / contracts are:
;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
(define-struct pref-callback (cb))
;; used to detect missing hash entries
(define none (gensym 'none))
;; get : symbol -> any
;; return the current value of the preference `p'
;; exported
(define (preferences:get p)
(define v (hash-ref preferences p none))
(cond
;; if this is found, we can just return it immediately
[(not (eq? v none))
v]
;; first time reading this, check the file & unmarshall value, if
;; it's not there, use the default
[(pref-default-set? p)
;; unmarshall, if required
(when (hash-table-bound? marshalled p)
;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
(unless (hash-table-bound? preferences p)
(hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p))))
(hash-remove! marshalled p))
;; if there is no value in the preferences table, but there is one
;; in the old version preferences file, take that:
(unless (hash-table-bound? preferences p)
(when (hash-table-bound? old-preferences p)
(hash-set! preferences p (unmarshall-pref p (hash-ref old-preferences p)))))
;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore)
(when (hash-table-bound? old-preferences p)
(hash-remove! old-preferences p))
;; if it still isn't set, take the default value
(unless (hash-table-bound? preferences p)
(hash-set! preferences p (default-value (hash-ref defaults p))))
(hash-ref preferences p)]
(let* (;; try to read the preferece from the preferences file
[v ((preferences:low-level-get-preference)
(add-pref-prefix p) (λ () none))]
[v (if (eq? v none)
;; no value read, take the default value
(default-value (hash-ref defaults p))
;; found a saved value, unmarshall it
(unmarshall-pref p v))])
;; set the value for future reference and return it
(hash-set! preferences p v)
v)]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:get
@ -155,8 +142,6 @@ the state transitions / contracts are:
values))
(void))
(define preferences:low-level-put-preferences (make-parameter put-preferences))
(define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference
(string-append (format "~a: " sym) (apply format fmt args))
@ -229,11 +214,6 @@ the state transitions / contracts are:
[(not (pref-can-init? p))
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
(define (hash-table-bound? ht s)
(let/ec k
(hash-ref ht s (λ () (k #f)))
#t))
(define (preferences:restore-defaults)
(hash-for-each
defaults
@ -248,12 +228,7 @@ the state transitions / contracts are:
(unless default-okay?
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
p checker default-okay? default-value))
(hash-set! defaults p (make-default default-value checker))
(let/ec k
(let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))])
;; if there is no preference saved, we just don't do anything.
;; `get' notices this case.
(hash-set! marshalled p m))))]
(hash-set! defaults p (make-default default-value checker)))]
[(not (pref-can-init? p))
(error 'preferences:set-default
"tried to call set-default for preference ~e but it cannot be configured any more"
@ -355,83 +330,77 @@ the state transitions / contracts are:
((p f)
((weak? #f)))
@{This function adds a callback which is called with a symbol naming a
preference and it's value, when the preference changes.
@scheme[preferences:add-callback] returns a thunk, which when
invoked, removes the callback from this preference.
If @scheme[weak?] is true, the preferences system will only hold on to
the callback weakly.
The callbacks will be called in the order in which they were added.
If you are adding a callback for a preference that requires
marshalling and unmarshalling, you must set the marshalling and
unmarshalling functions by calling
@scheme[preferences:set-un/marshall] before adding a callback.
This function raises
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
@scheme[exn:unknown-preference]
if the preference has not been set.})
preference and its value, when the preference changes.
@scheme[preferences:add-callback] returns a thunk, which when
invoked, removes the callback from this preference.
If @scheme[weak?] is true, the preferences system will only hold on to
the callback weakly.
The callbacks will be called in the order in which they were added.
If you are adding a callback for a preference that requires
marshalling and unmarshalling, you must set the marshalling and
unmarshalling functions by calling
@scheme[preferences:set-un/marshall] before adding a callback.
This function raises
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
@scheme[exn:unknown-preference]
if the preference has not been set.})
(proc-doc/names
preferences:set-default
(symbol? any/c (any/c . -> . any) . -> . void?)
(symbol value test)
@{This function must be called every time your application starts up, before any call to
@scheme[preferences:get] or
@scheme[preferences:set]
(for any given preference).
If you use
@scheme[preferences:set-un/marshall],
you must call this function before calling it.
This sets the default value of the preference @scheme[symbol] to
@scheme[value]. If the user has chosen a different setting,
the user's setting
will take precedence over the default value.
The last argument, @scheme[test] is used as a safeguard. That function is
called to determine if a preference read in from a file is a valid
preference. If @scheme[test] returns @scheme[#t], then the preference is
treated as valid. If @scheme[test] returns @scheme[#f] then the default is
used.})
@{This function must be called every time your application starts up, before
any call to @scheme[preferences:get] or @scheme[preferences:set]
(for any given preference).
If you use @scheme[preferences:set-un/marshall],
you must call this function before calling it.
This sets the default value of the preference @scheme[symbol] to
@scheme[value]. If the user has chosen a different setting,
the user's setting will take precedence over the default value.
The last argument, @scheme[test] is used as a safeguard. That function is
called to determine if a preference read in from a file is a valid
preference. If @scheme[test] returns @scheme[#t], then the preference is
treated as valid. If @scheme[test] returns @scheme[#f] then the default is
used.})
(proc-doc/names
preferences:set-un/marshall
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
(symbol marshall unmarshall)
@{@scheme[preference:set-un/marshall] is used to specify marshalling and
unmarshalling functions for the preference
@scheme[symbol]. @scheme[marshall] will be called when the users saves their
preferences to turn the preference value for @scheme[symbol] into a
printable value. @scheme[unmarshall] will be called when the user's
preferences are read from the file to transform the printable value
into it's internal representation. If @scheme[preference:set-un/marshall]
is never called for a particular preference, the values of that
preference are assumed to be printable.
If the unmarshalling function returns a value that does not meet the
guard passed to
@scheme[preferences:set-default]
for this preference, the default value is used.
The @scheme[marshall] function might be called with any value returned
from @scheme[read] and it must not raise an error
(although it can return arbitrary results if it gets bad input). This might
happen when the preferences file becomes corrupted, or is edited
by hand.
@scheme[preference:set-un/marshall] must be called before calling
@scheme[preferences:get],
@scheme[preferences:set].})
unmarshalling functions for the preference
@scheme[symbol]. @scheme[marshall] will be called when the users saves their
preferences to turn the preference value for @scheme[symbol] into a
printable value. @scheme[unmarshall] will be called when the user's
preferences are read from the file to transform the printable value
into its internal representation. If @scheme[preference:set-un/marshall]
is never called for a particular preference, the values of that
preference are assumed to be printable.
If the unmarshalling function returns a value that does not meet the
guard passed to @scheme[preferences:set-default]
for this preference, the default value is used.
The @scheme[marshall] function might be called with any value returned
from @scheme[read] and it must not raise an error
(although it can return arbitrary results if it gets bad input). This might
happen when the preferences file becomes corrupted, or is edited
by hand.
@scheme[preference:set-un/marshall] must be called before calling
@scheme[preferences:get],@scheme[preferences:set].})
(proc-doc/names
preferences:restore-defaults
(-> void?)
()
@{@scheme[(preferences:restore-defaults)]
restores the users's configuration to the
default preferences.})
@{@scheme[(preferences:restore-defaults)] restores the users' configuration
to the default preferences.})
(proc-doc/names
exn:make-unknown-preference
@ -447,28 +416,33 @@ the state transitions / contracts are:
(parameter-doc
preferences:low-level-put-preferences
(parameter/c (-> (listof symbol?) (listof any/c) any))
put-preference
@{This parameter's value
is called when to save preference the preferences. Its interface should
be just like mzlib's @scheme[put-preference].})
(parameter/c ((listof symbol?) (listof any/c) . -> . any))
put-preferences
@{This parameter's value is called to save preference the preferences file.
Its interface should be just like mzlib's @scheme[put-preferences].})
(parameter-doc
preferences:low-level-get-preference
(parameter/c (->* [symbol?] [(-> any)] any))
get-preference
@{This parameter's value is called to get a preference from the preferences
file. Its interface should be just like mzlib's @scheme[get-preference].})
(proc-doc/names
preferences:snapshot?
(-> any/c boolean?)
(arg)
@{Determines if its argument is a preferences snapshot.
See also
@scheme[preferences:get-prefs-snapshot] and
@scheme[preferences:restore-prefs-snapshot].})
See also @scheme[preferences:get-prefs-snapshot] and
@scheme[preferences:restore-prefs-snapshot].})
(proc-doc/names
preferences:restore-prefs-snapshot
(-> preferences:snapshot? void?)
(snapshot)
@{Restores the preferences saved in @scheme[snapshot].
See also @scheme[preferences:get-prefs-snapshot].})
See also @scheme[preferences:get-prefs-snapshot].})
(proc-doc/names
preferences:get-prefs-snapshot
@ -477,7 +451,7 @@ the state transitions / contracts are:
@{Caches all of the current values of the preferences and returns them.
For any preference that has marshalling and unmarshalling set
(see @scheme[preferences:set-un/marshall]), the preference value is
copied by passing it thru the marshalling and unmarshalling process.
copied by passing it through the marshalling and unmarshalling process.
Other values are not copied, but references to them are instead saved.
See also @scheme[preferences:restore-prefs-snapshot].}))

7
collects/framework/private/bday.ss
View File

@ -1,7 +1,6 @@
#lang mzscheme
(require framework/private/encode-decode)
(decode
#lang scheme/base
(require "decode.ss")
(decode
\5d8f4
\10ec22010
\45aff297b02

18
collects/framework/private/color.ss
View File

@ -260,7 +260,11 @@ added get-regions
(define/private (re-tokenize ls in in-start-pos enable-suspend)
(let-values ([(lexeme type data new-token-start new-token-end)
(get-token in)])
(begin
(enable-suspend #f)
(begin0
(get-token in)
(enable-suspend #t)))])
(unless (eq? 'eof type)
(enable-suspend #f)
#; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
@ -365,10 +369,14 @@ added get-regions
(for-each
(lambda (ls)
(re-tokenize ls
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f))
(begin
(enable-suspend #f)
(begin0
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f))
(enable-suspend #t)))
(lexer-state-current-pos ls)
enable-suspend))
lexer-states)))))

43
collects/framework/private/decode.ss Normal file
View File

@ -0,0 +1,43 @@
#lang scheme/base
(require (for-syntax mzlib/inflate
scheme/base))
(provide decode)
(define-syntax (decode stx)
(syntax-case stx ()
[(_ arg ...)
(andmap identifier? (syntax->list (syntax (arg ...))))
(let ()
(define (decode-sexp str)
(let* ([loc
(let loop ([chars (string->list str)])
(cond
[(null? chars) '()]
[(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
[else (let ([fst (to-digit (car chars))]
[snd (to-digit (cadr chars))])
(cons
(+ (* fst 16) snd)
(loop (cddr chars))))]))])
(let-values ([(p-in p-out) (make-pipe)])
(inflate (open-input-bytes (apply bytes loc)) p-out)
(read p-in))))
(define (to-digit char)
(cond
[(char<=? #\0 char #\9)
(- (char->integer char)
(char->integer #\0))]
[(char<=? #\a char #\f)
(+ 10 (- (char->integer char)
(char->integer #\a)))]))
(define decoded
(decode-sexp
(apply
string-append
(map (λ (x) (symbol->string (syntax-e x)))
(syntax->list (syntax (arg ...)))))))
(datum->syntax stx decoded stx))]))

18
collects/framework/private/decorated-editor-snip.ss
View File

@ -22,6 +22,9 @@
(define editor-snip:decorated-mixin
(mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>)
(init [with-border? #t])
(define draw-border? with-border?)
;; 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)
@ -152,13 +155,14 @@
(+ 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))))
(when draw-border?
(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))))

1
collects/framework/private/editor.ss
View File

@ -321,6 +321,7 @@
(define/override (on-new-image-snip filename kind relative-path? inline?)
(super on-new-image-snip
filename
(if (eq? kind 'unknown) 'unknown/mask kind)
relative-path?
inline?))

67
collects/framework/private/encode.ss Normal file
View File

@ -0,0 +1,67 @@
#lang scheme/base
(require mzlib/deflate
mzlib/match
mzlib/pretty)
(require (for-syntax mzlib/inflate
mzlib/string))
(provide encode-sexp
encode-module)
(define (encode-module in-filename out-filename)
(call-with-input-file in-filename
(λ (port)
(let ([mod (read port)])
(unless (eof-object? (read port))
(error 'encode-module "found an extra expression"))
(match mod
[`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename
(λ (oport)
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(fprintf oport "(module ~a mzscheme\n" m)
(fprintf oport " (require framework/private/decode)\n")
(fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)]
[else (error 'encode-module "cannot parse module")])))))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (encode-sexp sexp)
(define (str->sym string)
(string->symbol
(apply
string-append
(map
(λ (x)
(to-hex x))
(bytes->list string)))))
(define (to-hex n)
(let ([digit->hex
(λ (d)
(cond
[(<= d 9) d]
[else (integer->char (+ d -10 (char->integer #\a)))]))])
(cond
[(< n 16) (format "0~a" (digit->hex n))]
[else (format "~a~a"
(digit->hex (quotient n 16))
(digit->hex (modulo n 16)))])))
(let ([in (open-input-string (format "~s" sexp))]
[out (open-output-bytes)])
(deflate in out)
(str->sym (get-output-bytes out))))

21
collects/framework/private/frame.ss
View File

@ -2096,17 +2096,14 @@
(send (send find-edit get-canvas) focus))))
(define/public (unhide-search-and-toggle-focus)
(cond
[hidden?
(unhide-search #t)]
[(or (not text-to-search)
(send (send text-to-search get-canvas) has-focus?))
(send find-edit set-position 0 (send find-edit last-position))
(send find-canvas focus)]
[else
(let ([canvas (send text-to-search get-canvas)])
(when canvas
(send canvas focus)))]))
(if hidden?
(unhide-search #t)
(let ([canvas (and text-to-search (send text-to-search get-canvas))])
(cond
[(or (not text-to-search) (and canvas (send canvas has-focus?)))
(send find-edit set-position 0 (send find-edit last-position))
(send find-canvas focus)]
[canvas (send canvas focus)]))))
(define/public (search searching-direction)
(unhide-search #f)
@ -2178,7 +2175,7 @@
(when found-pos
(unless (hash-ref ht found-txt #f)
(hash-set! ht found-txt #t)
(send txt begin-edit-sequence))
(send found-txt begin-edit-sequence))
(let ([start (- found-pos (send find-edit last-position))])
(send found-txt delete start found-pos)
(copy-over replace-edit 0 (send replace-edit last-position) found-txt start)

1
collects/framework/private/main.ss
View File

@ -58,6 +58,7 @@
("cond" 0)
("field" 0)
("provide/contract" 0)
("match" 1)
("new" 1)
("case" 1)
("syntax-rules" 1)

61
collects/framework/private/preferences.ss
View File

@ -227,8 +227,9 @@ the state transitions / contracts are:
(super show on?))
(super-new))]
[frame
(make-object frame-stashed-prefs%
(string-constant preferences))]
(new frame-stashed-prefs%
[label (string-constant preferences)]
[height 200])]
[build-ppanel-tree
(λ (ppanel tab-panel single-panel)
(send tab-panel append (ppanel-name ppanel))
@ -310,6 +311,11 @@ the state transitions / contracts are:
(let ([old editor-panel-procs])
(λ (parent) (old parent) (f parent)))))
(define (add-to-general-checkbox-panel f)
(set! general-panel-procs
(let ([old general-panel-procs])
(λ (parent) (old parent) (f parent)))))
(define (add-to-warnings-checkbox-panel f)
(set! warnings-panel-procs
(let ([old warnings-panel-procs])
@ -317,6 +323,7 @@ the state transitions / contracts are:
(define scheme-panel-procs void)
(define editor-panel-procs void)
(define general-panel-procs void)
(define warnings-panel-procs void)
(define (add-checkbox-panel label proc)
@ -394,21 +401,8 @@ the state transitions / contracts are:
(list (string-constant editor-prefs-panel-label)
(string-constant general-prefs-panel-label))
(λ (editor-panel)
(make-recent-items-slider editor-panel)
(make-check editor-panel
'framework:autosaving-on?
(string-constant auto-save-files)
values values)
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
(make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace)
not not)
(make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
(make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
(make-check editor-panel
'framework:display-line-numbers
(string-constant display-line-numbers)
values values)
(make-check editor-panel
'framework:auto-set-wrap?
(string-constant wrap-words-in-editor-buffers)
@ -432,13 +426,7 @@ the state transitions / contracts are:
'framework:coloring-active
(string-constant online-coloring-active)
values values)
(unless (eq? (system-type) 'unix)
(make-check editor-panel
'framework:print-output-mode
(string-constant automatically-to-ps)
(λ (b)
(if b 'postscript 'standard))
(λ (n) (eq? 'postscript n))))
(make-check editor-panel
'framework:anchored-search
(string-constant find-anchor-based)
@ -454,6 +442,35 @@ the state transitions / contracts are:
(editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel)))
(define (add-general-checkbox-panel)
(letrec ([add-general-checkbox-panel
(λ ()
(set! add-general-checkbox-panel void)
(add-checkbox-panel
(list (string-constant general-prefs-panel-label))
(λ (editor-panel)
(make-recent-items-slider editor-panel)
(make-check editor-panel
'framework:autosaving-on?
(string-constant auto-save-files)
values values)
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
(make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
(make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
(make-check editor-panel
'framework:display-line-numbers
(string-constant display-line-numbers)
values values)
(unless (eq? (system-type) 'unix)
(make-check editor-panel
'framework:print-output-mode
(string-constant automatically-to-ps)
(λ (b)
(if b 'postscript 'standard))
(λ (n) (eq? 'postscript n))))
(general-panel-procs editor-panel))))])
(add-general-checkbox-panel)))
(define (add-warnings-checkbox-panel)
(letrec ([add-warnings-checkbox-panel
(λ ()

3
collects/framework/private/scheme.ss
View File

@ -1183,7 +1183,8 @@
(define/override (put-file text sup directory default-name)
(parameterize ([finder:default-extension "ss"]
[finder:default-filters '(("SCM" "*.scm") ("Any" "*.*"))])
[finder:default-filters '(["Scheme Sources" "*.ss;*.scm"]
["Any" "*.*"])])
;; don't call the surrogate's super, since it sets the default extension
(sup directory default-name)))

2
collects/framework/private/sig.ss
View File

@ -74,10 +74,12 @@
add-font-panel
add-editor-checkbox-panel
add-general-checkbox-panel
add-warnings-checkbox-panel
add-scheme-checkbox-panel
add-to-editor-checkbox-panel
add-to-general-checkbox-panel
add-to-warnings-checkbox-panel
add-to-scheme-checkbox-panel

14
collects/framework/private/text.ss
View File

@ -21,11 +21,7 @@ WARNING: printf is rebound in the body of the unit to always
(prefix-in srfi1: srfi/1))
(require setup/xref
scribble/xref
scribble/struct
scribble/manual-struct
scribble/decode
scribble/basic
(prefix-in s/m: scribble/manual))
scribble/manual-struct)
(import mred^
[prefix icon: framework:icon^]
@ -386,7 +382,7 @@ WARNING: printf is rebound in the body of the unit to always
(and (string? color)
(send the-color-database find-color color)))
(error 'highlight-range
"expected a color or a string in the the-color-database for the third argument, got ~e" color))
"expected a color or a string in the-color-database for the third argument, got ~e" color))
(unless (memq style '(rectangle hollow-ellipse ellipse dot))
(error 'highlight-range
"expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style))
@ -1174,7 +1170,11 @@ WARNING: printf is rebound in the body of the unit to always
(set! clear-yellow void)
(when (and searching-str (= (string-length searching-str) (- end start)))
(when (do-search searching-str start end)
(set! clear-yellow (highlight-range start end "khaki" #f 'low 'ellipse))))
(set! clear-yellow (highlight-range start end
(if (preferences:get 'framework:white-on-black?)
(make-object color% 50 50 5)
"khaki")
#f 'low 'ellipse))))
(end-edit-sequence)]))]
[else
(clear-yellow)

554
collects/framework/splash.ss
View File

@ -1,253 +1,325 @@
#lang scheme/base
(module splash mzscheme
(require mzlib/class
mzlib/file
mred)
(provide get-splash-bitmap
set-splash-bitmap
get-splash-canvas
get-splash-eventspace
start-splash
shutdown-splash
close-splash
add-splash-icon
set-splash-char-observer
set-splash-paint-callback
get-splash-paint-callback
set-splash-event-callback)
(define splash-filename #f)
(define splash-bitmap #f)
(define splash-eventspace (make-eventspace))
(define (get-splash-bitmap) splash-bitmap)
(define (set-splash-bitmap bm)
(set! splash-bitmap bm)
(send splash-canvas on-paint))
(define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace)
(require scheme/class
scheme/file
scheme/gui/base)
(define (set-splash-paint-callback pc) (set! splash-paint-callback pc))
(define (get-splash-paint-callback) splash-paint-callback)
(define (set-splash-event-callback ec) (set! splash-event-callback ec))
(provide get-splash-bitmap
set-splash-bitmap
get-splash-canvas
get-splash-eventspace
get-splash-paint-callback
set-splash-paint-callback
start-splash
shutdown-splash
close-splash
add-splash-icon
set-splash-progress-bar?
set-splash-char-observer
set-splash-event-callback
get-splash-event-callback
get-splash-width
get-splash-height)
(define splash-bitmap #f)
(define splash-cache-bitmap #f)
(define splash-cache-dc (make-object bitmap-dc%))
(define splash-eventspace (make-eventspace))
(define (get-splash-bitmap) splash-bitmap)
(define (set-splash-bitmap bm)
(set! splash-bitmap bm)
(send splash-canvas on-paint))
(define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace)
(define (get-splash-paint-callback) splash-paint-callback)
(define (set-splash-paint-callback sp)
(set! splash-paint-callback sp)
(refresh-splash))
(define (get-splash-width) (send splash-canvas get-width))
(define (get-splash-height) (send splash-canvas get-height))
(define (set-splash-event-callback cb) (set! splash-event-callback cb))
(define (get-splash-event-callback cb) splash-event-callback)
(define (refresh-splash)
(define (splash-paint-callback dc)
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear))
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)
(icon-y icon)
'solid
(make-object color% "black")
(send (icon-bm icon) get-loaded-mask)))
icons))
(define (splash-event-callback evt) (void))
(define char-observer void)
(define (set-splash-char-observer proc)
(set! char-observer proc))
(define-struct icon (bm x y))
(define icons null)
(define (add-splash-icon bm x y)
(set! icons (cons (make-icon bm x y) icons))
(define (recompute-bitmap/refresh)
(send splash-cache-dc set-bitmap splash-cache-bitmap)
(call-splash-paint-callback splash-cache-dc)
(send splash-cache-dc set-bitmap #f)
(send splash-canvas on-paint))
(define (start-splash _splash-filename _splash-title width-default)
(set! splash-title _splash-title)
(set! splash-filename _splash-filename)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width)
(send splash-frame set-label splash-title)
(let/ec k
(define (no-splash)
(set! splash-bitmap #f)
(set! splash-canvas #f)
(set! splash-eventspace #f)
(k (void)))
(unless splash-filename
(no-splash))
(unless (file-exists? splash-filename)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-filename)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-filename))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-filename)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height))
(send splash-frame center 'both)
(send splash-frame show #t)
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep)))
(cond
[(not (is-a? splash-cache-bitmap bitmap%)) (void)]
[(eq? (current-thread) (eventspace-handler-thread splash-eventspace))
(recompute-bitmap/refresh)]
[else
(parameterize ([current-eventspace splash-eventspace])
(queue-callback
recompute-bitmap/refresh))]))
(define (call-splash-paint-callback dc)
(cond
[(equal? 1 (procedure-arity splash-paint-callback))
(splash-paint-callback dc)]
[else
(splash-paint-callback dc
(send gauge get-value)
(send gauge get-range)
(get-splash-width)
(get-splash-height))])
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)
(icon-y icon)
'solid
(make-object color% "black")
(send (icon-bm icon) get-loaded-mask)))
icons))
(define (set-splash-progress-bar? b?)
(send gauge-panel change-children
(λ (l) (if b? (list gauge) '()))))
(define (splash-paint-callback dc)
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear)))
(define (splash-event-callback evt) (void))
(define char-observer void)
(define (set-splash-char-observer proc)
(set! char-observer proc))
(define-struct icon (bm x y))
(define icons null)
(define (add-splash-icon bm x y)
(set! icons (cons (make-icon bm x y) icons))
(refresh-splash))
(define (start-splash splash-draw-spec _splash-title width-default)
(set! splash-title _splash-title)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width)
(send splash-frame set-label splash-title)
(let/ec k
(define (no-splash)
(set! splash-bitmap #f)
(set! splash-canvas #f)
(set! splash-eventspace #f)
(k (void)))
(define splash-title "no title")
(define splash-current-width 0)
(define (get-splash-width-preference-name)
(string->symbol (format "plt:~a-splash-max-width" splash-title)))
(define splash-max-width 1)
(define (close-splash)
(unless (= splash-max-width splash-current-width)
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(set! quit-on-close? #f)
(when splash-frame
(send splash-frame show #f)))
(define (shutdown-splash)
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(collection-path "icons")
#t)
(= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)])
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width))
(old-load f expected)))
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(if (or (getenv "PLTDRCM")
(getenv "PLTDRDEBUG"))
(parameterize ([current-namespace (make-namespace)])
(values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))
(values #f #f))])
(cond
[(or (path? splash-draw-spec)
(string? splash-draw-spec))
(unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height))
(set! splash-cache-bitmap (make-object bitmap%
(send splash-bitmap get-width)
(send splash-bitmap get-height)))]
[(and (vector? splash-draw-spec)
(procedure? (vector-ref splash-draw-spec 0))
(number? (vector-ref splash-draw-spec 1))
(number? (vector-ref splash-draw-spec 2)))
(set! splash-paint-callback (vector-ref splash-draw-spec 0))
(send splash-canvas min-width (vector-ref splash-draw-spec 1))
(send splash-canvas min-height (vector-ref splash-draw-spec 2))
(set! splash-cache-bitmap (make-object bitmap%
(vector-ref splash-draw-spec 1)
(vector-ref splash-draw-spec 2)))]
[(not splash-draw-spec)
(no-splash)]
[else
(fprintf (current-error-port)
"WARNING: unknown splash spec: ~s" splash-draw-spec)
(no-splash)])
(current-load
(let ([old-load (current-load)])
(λ (f expected)
(splash-load-handler old-load f expected))))
(when (and make-compilation-manager-load/use-compiled-handler
(refresh-splash)
(send splash-frame center 'both)
(send splash-frame show #t)
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep)))
(define splash-title "no title")
(define splash-current-width 0)
(define (get-splash-width-preference-name)
(string->symbol (format "plt:~a-splash-max-width" splash-title)))
(define splash-max-width 1)
(define (close-splash)
(unless (= splash-max-width splash-current-width)
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(set! quit-on-close? #f)
(when splash-frame
(send splash-frame show #f)))
(define (shutdown-splash)
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(collection-path "icons")
#t)
(= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)])
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width)
(unless (member gauge (send gauge-panel get-children))
;; when the gauge is not visible, we'll redraw the canvas
(refresh-splash)))
(old-load f expected)))
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when (or (equal? (getenv "PLTDRCM") "trace")
(equal? (getenv "PLTDRDEBUG") "trace"))
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
(manager-trace-handler
(λ (x) (display "2: ") (display x) (newline))))))
(if (or (getenv "PLTDRCM")
(getenv "PLTDRDEBUG"))
(parameterize ([current-namespace (make-base-namespace)])
(values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))
(values #f #f))])
(define funny-gauge%
(class canvas%
(inherit get-dc min-width min-height stretchable-width stretchable-height)
(field
[funny-value 0]
[funny-bitmap
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1])
(current-load
(let ([old-load (current-load)])
(λ (f expected)
(splash-load-handler old-load f expected))))
(when (and make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when (or (equal? (getenv "PLTDRCM") "trace")
(equal? (getenv "PLTDRDEBUG") "trace"))
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
(manager-trace-handler
(λ (x) (display "2: ") (display x) (newline))))))
[define/public set-range (λ (r) (set! max-value r))]
[define/public set-value
(λ (new-value)
(let* ([before-x
(floor (* (send funny-bitmap get-width) (/ funny-value max-value)))]
[after-x
(ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))]
[width (- after-x before-x)])
(send (get-dc) draw-line
(+ before-x 2) 0
(+ width 2) 0)
(send (get-dc) draw-line
(+ before-x 2) (+ (send funny-bitmap get-height) 4)
(+ width 2) (+ (send funny-bitmap get-height) 4))
(send (get-dc) draw-bitmap-section funny-bitmap
(+ 2 before-x) 2
before-x 0
width (send funny-bitmap get-height)))
(set! funny-value new-value))]
(define funny-gauge%
(class canvas%
(inherit get-dc min-width min-height stretchable-width stretchable-height)
(field
[funny-value 0]
[funny-bitmap
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1])
(define/public (get-range) max-value)
(define/public (get-value) funny-value)
[define/public set-range (λ (r) (set! max-value r))]
[define/public set-value
(λ (new-value)
(let* ([before-x
(floor (* (send funny-bitmap get-width) (/ funny-value max-value)))]
[after-x
(ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))]
[width (- after-x before-x)])
(send (get-dc) draw-line
(+ before-x 2) 0
(+ width 2) 0)
(send (get-dc) draw-line
(+ before-x 2) (+ (send funny-bitmap get-height) 4)
(+ width 2) (+ (send funny-bitmap get-height) 4))
(send (get-dc) draw-bitmap-section funny-bitmap
(+ 2 before-x) 2
before-x 0
width (send funny-bitmap get-height)))
(set! funny-value new-value))]
[define/override (on-paint)
(let ([dc (get-dc)])
(send dc clear)
(send dc draw-rectangle 0 0
(+ (send funny-bitmap get-width) 4)
(+ (send funny-bitmap get-height) 4))
(send dc draw-bitmap-section funny-bitmap
2 2 0 0
(* (send funny-bitmap get-width) (/ funny-value max-value))
(send funny-bitmap get-height)))]
(super-instantiate ())
(min-width (+ (send funny-bitmap get-width) 4))
(min-height (+ (send funny-bitmap get-height) 4))
(stretchable-width #f)
(stretchable-height #f)))
[define/override (on-paint)
(let ([dc (get-dc)])
(send dc clear)
(send dc draw-rectangle 0 0
(+ (send funny-bitmap get-width) 4)
(+ (send funny-bitmap get-height) 4))
(send dc draw-bitmap-section funny-bitmap
2 2 0 0
(* (send funny-bitmap get-width) (/ funny-value max-value))
(send funny-bitmap get-height)))]
(define (splash-get-preference name default)
(get-preference
name
(λ ()
default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
(super-instantiate ())
(min-width (+ (send funny-bitmap get-width) 4))
(min-height (+ (send funny-bitmap get-height) 4))
(stretchable-width #f)
(stretchable-height #f)))
(define (splash-get-preference name default)
(get-preference
name
(λ ()
default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
(define (splitup-path f)
(let*-values ([(absf) (if (relative-path? f)
(build-path (current-directory) f)
f)]
[(base name _1) (split-path absf)])
(if base
(let-values ([(base2 name2 _2) (split-path base)])
(if base2
(let-values ([(base3 name3 _2) (split-path base2)])
(build-path name3 name2 name))
(build-path name2 name)))
name)))
(define quit-on-close? #t)
(define splash-frame%
(class frame%
(define/augment (on-close)
(when quit-on-close?
(exit)))
(super-new)))
(define splash-canvas%
(class canvas%
(inherit get-dc)
(define/override (on-char evt) (char-observer evt))
(define/override (on-paint) (splash-paint-callback (get-dc)))
(define/override (on-event evt) (splash-event-callback evt))
(super-new)))
(define splash-frame
(parameterize ([current-eventspace splash-eventspace])
(instantiate splash-frame% ()
(label splash-title)
(style '(no-resize-border)))))
(send splash-frame set-alignment 'center 'center)
(define panel (make-object vertical-pane% splash-frame))
(define splash-canvas (make-object splash-canvas% panel))
(define h-panel (make-object horizontal-pane% panel))
(define gauge
(if funny?
(make-object funny-gauge% h-panel)
(make-object gauge% #f splash-max-width h-panel '(horizontal))))
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send h-panel set-alignment 'center 'top)
(send splash-canvas focus)
(send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f))
(define (splitup-path f)
(let*-values ([(absf) (if (relative-path? f)
(build-path (current-directory) f)
f)]
[(base name _1) (split-path absf)])
(if base
(let-values ([(base2 name2 _2) (split-path base)])
(if base2
(let-values ([(base3 name3 _2) (split-path base2)])
(build-path name3 name2 name))
(build-path name2 name)))
name)))
(define quit-on-close? #t)
(define splash-frame%
(class frame%
(define/augment (on-close)
(when quit-on-close?
(exit)))
(super-new)))
(define splash-canvas%
(class canvas%
(inherit get-client-size get-dc)
(define/override (on-char evt) (char-observer evt))
(define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0))
(define/override (on-event evt) (splash-event-callback evt))
(super-new)))
(define splash-frame
(parameterize ([current-eventspace splash-eventspace])
(instantiate splash-frame% ()
(label splash-title)
(style '(no-resize-border)))))
(send splash-frame set-alignment 'center 'center)
(define panel (make-object vertical-pane% splash-frame))
(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)]))
(define gauge-panel (make-object horizontal-pane% panel))
(define gauge
(if funny?
(make-object funny-gauge% gauge-panel)
(make-object gauge% #f splash-max-width gauge-panel '(horizontal))))
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send gauge-panel set-alignment 'center 'top)
(send splash-canvas focus)
(send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f)

2
collects/framework/test.ss
View File

@ -352,7 +352,7 @@
[(zero? n) (error 'test:set-radio-box!
"did not find ~e as a label for ~e; labels: ~a"
state in-cb
(build-labels in-cb))]
(build-labels rb))]
[else (let ([i (- total n)])
(if (or (string=? state (send rb get-item-label i))
(string=? state (send rb get-item-plain-label i)))

2
collects/mred/edit.ss
View File

@ -158,7 +158,7 @@
(send c set-editor e)
(when file
(if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" file)
(if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" (string-downcase file))
(send e insert (make-object image-snip% file))
(send e load-file file)))

22
collects/mred/mred.ss
View File

@ -6,6 +6,17 @@
scheme/class
mzlib/etc
(prefix wx: "private/kernel.ss")
(prefix wx: "private/wxme/style.ss")
(prefix wx: "private/wxme/editor.ss")
(prefix wx: "private/wxme/text.ss")
(prefix wx: "private/wxme/pasteboard.ss")
(prefix wx: "private/wxme/snip.ss")
(prefix wx: "private/wxme/keymap.ss")
(prefix wx: "private/wxme/editor-admin.ss")
(prefix wx: "private/wxme/editor-snip.ss")
(prefix wx: "private/wxme/stream.ss")
(prefix wx: "private/wxme/wordbreak.ss")
(prefix wx: "private/wxme/snip-admin.ss")
"private/wxtop.ss"
"private/app.ss"
"private/misc.ss"
@ -63,6 +74,11 @@
(namespace-require 'scheme/class))
ns))
(define (make-eventspace)
(parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
[wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
(wx:make-eventspace)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax propagate
@ -128,7 +144,6 @@
is-color-display?
key-event%
keymap%
make-eventspace
editor-admin%
editor-set-x-selection-mode
editor-snip-editor-admin<%>
@ -182,8 +197,8 @@
(define the-font-list (wx:get-the-font-list))
(define the-pen-list (wx:get-the-pen-list))
(define the-brush-list (wx:get-the-brush-list))
(define the-style-list (wx:get-the-style-list))
(define the-editor-wordbreak-map (wx:get-the-editor-wordbreak-map))
(define the-style-list wx:the-style-list)
(define the-editor-wordbreak-map wx:the-editor-wordbreak-map)
(provide button%
canvas%
@ -296,6 +311,7 @@
current-eventspace-has-standard-menus?
current-eventspace-has-menu-root?
eventspace-handler-thread
make-eventspace
make-gui-namespace
make-gui-empty-namespace
file-creator-and-type

17
collects/mred/private/editor.ss
View File

@ -5,6 +5,15 @@
mzlib/list
mzlib/file
(prefix wx: "kernel.ss")
(prefix wx: "wxme/style.ss")
(prefix wx: "wxme/keymap.ss")
(prefix wx: "wxme/editor.ss")
(prefix wx: "wxme/text.ss")
(prefix wx: "wxme/pasteboard.ss")
(prefix wx: "wxme/editor-snip.ss")
(rename "wxme/cycle.ss" wx:set-extended-editor-snip%! set-extended-editor-snip%!)
(rename "wxme/cycle.ss" wx:set-extended-text%! set-extended-text%!)
(rename "wxme/cycle.ss" wx:set-extended-pasteboard%! set-extended-pasteboard%!)
"seqcontract.ss"
"lock.ss"
"check.ss"
@ -324,7 +333,7 @@
(when (and can-wrap? auto-set-wrap?)
(let-values ([(current-width) (as-exit (lambda () (get-max-width)))]
[(new-width new-height) (max-view-size)])
(when (and (not (= current-width new-width))
(when (and (not (equal? current-width new-width))
(< 0 new-width))
(as-exit (lambda () (set-max-width new-width)))))))
(as-exit (lambda () (inner (void) on-display-size)))))])
@ -481,9 +490,9 @@
min-height
max-height))))
(wx:set-editor-snip-maker (lambda args (apply make-object editor-snip% args)))
(wx:set-text-editor-maker (lambda () (make-object text%)))
(wx:set-pasteboard-editor-maker (lambda () (make-object pasteboard%)))
(wx:set-extended-editor-snip%! editor-snip%)
(wx:set-extended-text%! text%)
(wx:set-extended-pasteboard%! pasteboard%)
;; ----------------------- Keymap ----------------------------------------

6
collects/mred/private/filedialog.ss
View File

@ -3,6 +3,8 @@
mzlib/etc
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/style.ss")
(prefix wx: "wxme/cycle.ss")
"lock.ss"
"wx.ss"
"cycle.ss"
@ -105,4 +107,6 @@
((mk-file-selector 'get-directory #f #f #t)
message parent directory #f #f style null)))
(set-get-file! get-file))
(set-get-file! get-file)
(wx:set-editor-get-file! get-file)
(wx:set-editor-put-file! put-file))

1
collects/mred/private/helper.ss
View File

@ -1,6 +1,7 @@
(module helper mzscheme
(require mzlib/class
(prefix wx: "kernel.ss")
(prefix wx: "wxme/style.ss")
"lock.ss")
(provide (protect (struct child-info (x-min y-min x-margin y-margin x-stretch y-stretch))

852
collects/mred/private/kernel.ss
View File

@ -160,147 +160,6 @@
on-size
on-set-focus
on-kill-focus)
(define-private-class editor% editor<%> object% () #f
dc-location-to-editor-location
editor-location-to-dc-location
set-inactive-caret-threshold
get-inactive-caret-threshold
get-focus-snip
end-write-header-footer-to-file
begin-write-header-footer-to-file
print
insert-image
insert-box
get-filename
is-modified?
is-locked?
lock
set-cursor
get-paste-text-only
set-paste-text-only
get-load-overwrites-styles
set-load-overwrites-styles
set-style-list
get-style-list
get-keymap
set-keymap
can-do-edit-operation?
do-edit-operation
get-max-undo-history
set-max-undo-history
add-undo
clear-undos
redo
undo
select-all
clear
get-view-size
get-dc
local-to-global
global-to-local
locked-for-flow?
locked-for-write?
locked-for-read?
set-admin
get-admin
print-to-dc
find-scroll-line
num-scroll-lines
scroll-line-location
get-snip-location
locations-computed?
in-edit-sequence?
refresh-delayed?
end-edit-sequence
begin-edit-sequence
style-has-changed
set-min-height
set-max-height
get-min-height
get-max-height
set-min-width
set-max-width
get-min-width
get-max-width
insert-file
load-file
insert-port
save-port
default-style-name
get-flattened-text
put-file
get-file
after-edit-sequence
on-edit-sequence
after-load-file
on-load-file
can-load-file?
after-save-file
on-save-file
can-save-file?
on-new-box
on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache
on-paint
write-footers-to-file
write-headers-to-file
read-footer-from-file
read-header-from-file
write-to-file
read-from-file
set-filename
release-snip
on-snip-modified
set-modified
scroll-editor-to
set-snip-data
get-snip-data
needs-update
resized
set-caret-owner
scroll-to
on-display-size-when-ready
on-display-size
on-change
on-focus
on-default-char
on-default-event
on-local-char
on-local-event
find-first-snip
get-space
get-descent
get-extent
blink-caret
own-caret
refresh
adjust-cursor
on-char
on-event
copy-self-to
copy-self
kill
paste-x-selection
paste
copy
cut
insert
change-style)
(define-function get-the-editor-data-class-list)
(define-function get-the-snip-class-list)
(define-function editor-set-x-selection-mode)
(define-function add-pasteboard-keymap-functions)
(define-function add-text-keymap-functions)
(define-function add-editor-keymap-functions)
(define-function write-editor-global-footer)
(define-function write-editor-global-header)
(define-function read-editor-global-footer)
(define-function read-editor-global-header)
(define-function read-editor-version)
(define-function write-editor-version)
(define-function set-editor-print-margin)
(define-function get-editor-print-margin)
(define-class bitmap% object% () #f
get-argb-pixels
get-gl-config
@ -375,6 +234,7 @@
on-event
on-paint)
(define-private-class dc% dc<%> object% () #f
cache-font-metrics-key
get-alpha
set-alpha
glyph-exists?
@ -711,255 +571,6 @@
on-size
on-set-focus
on-kill-focus)
(define-class editor-canvas% canvas% () #f
on-char
on-event
on-paint
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus
popup-for-editor
call-as-primary-owner
get-canvas-background
set-canvas-background
set-y-margin
set-x-margin
get-y-margin
get-x-margin
clear-margins
scroll-to
set-lazy-refresh
get-lazy-refresh
scroll-with-bottom-base
allow-scroll-to-last
force-display-focus
is-focus-on?
on-scroll-on-change
get-editor
set-editor
get-wheel-step
set-wheel-step)
(define-class editor-admin% object% () #f
modified
refresh-delayed?
popup-menu
update-cursor
needs-update
resized
grab-caret
scroll-to
get-max-view
get-view
get-dc)
(define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% () #f
get-snip)
(define-class snip-admin% object% () #f
modified
popup-menu
update-cursor
release-snip
needs-update
recounted
resized
set-caret-owner
scroll-to
get-view
get-view-size
get-dc
get-editor)
(define-class snip-class% object% () #f
reading-version
write-header
read-header
read
get-classname
set-classname
get-version
set-version)
(define-private-class snip-class-list% snip-class-list<%> object% () #f
nth
number
add
find-position
find)
(define-class keymap% object% () #f
remove-chained-keymap
chain-to-keymap
set-break-sequence-callback
call-function
remove-grab-mouse-function
set-grab-mouse-function
remove-grab-key-function
set-grab-key-function
add-function
map-function
break-sequence
handle-mouse-event
handle-key-event
set-double-click-interval
get-double-click-interval)
(define-class editor-wordbreak-map% object% () #f
get-map
set-map)
(define-function get-the-editor-wordbreak-map)
(define-class text% editor% () #f
call-clickback
remove-clickback
set-clickback
set-wordbreak-func
set-autowrap-bitmap
on-reflow
on-new-tab-snip
on-new-string-snip
caret-hidden?
hide-caret
get-wordbreak-map
set-wordbreak-map
find-wordbreak
set-region-data
get-region-data
get-revision-number
after-merge-snips
after-split-snip
after-set-size-constraint
on-set-size-constraint
can-set-size-constraint?
after-set-position
after-change-style
on-change-style
can-change-style?
after-delete
on-delete
can-delete?
after-insert
on-insert
can-insert?
set-tabs
get-tabs
set-overwrite-mode
get-overwrite-mode
set-file-format
get-file-format
write-to-file
read-from-file
get-character
get-text
find-next-non-string-snip
get-snip-position
get-snip-position-and-location
find-snip
find-string-all
find-string
set-styles-sticky
get-styles-sticky
set-line-spacing
get-line-spacing
set-paragraph-alignment
set-paragraph-margins
last-paragraph
paragraph-end-line
paragraph-start-line
line-paragraph
paragraph-end-position
paragraph-start-position
position-paragraph
last-line
last-position
line-length
line-end-position
line-start-position
line-location
position-locations
position-location
position-line
set-between-threshold
get-between-threshold
find-position-in-line
find-line
find-position
split-snip
change-style
do-paste-x-selection
do-paste
do-copy
kill
paste-next
paste-x-selection
paste
copy
cut
erase
delete
insert
get-top-line-base
flash-off
flash-on
get-anchor
set-anchor
get-visible-line-range
get-visible-position-range
scroll-to-position
move-position
set-position-bias-scroll
set-position
get-end-position
get-start-position
get-position
default-style-name
get-flattened-text
put-file
get-file
after-edit-sequence
on-edit-sequence
after-load-file
on-load-file
can-load-file?
after-save-file
on-save-file
can-save-file?
on-new-box
on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache
on-paint
write-footers-to-file
write-headers-to-file
read-footer-from-file
read-header-from-file
set-filename
release-snip
on-snip-modified
set-modified
scroll-editor-to
set-snip-data
get-snip-data
needs-update
resized
set-caret-owner
scroll-to
on-display-size-when-ready
on-display-size
on-change
on-focus
on-default-char
on-default-event
on-local-char
on-local-event
find-first-snip
get-space
get-descent
get-extent
blink-caret
own-caret
refresh
adjust-cursor
on-char
on-event
copy-self-to
copy-self)
(define-class menu% object% () #f
select
get-font
@ -984,46 +595,13 @@
(define-class menu-item% object% () #f
id)
(define-function id-to-menu-item)
(define-class editor-stream-in-base% object% () #f
read
bad?
skip
seek
tell)
(define-class editor-stream-out-base% object% () #f
write
bad?
seek
tell)
(define-class editor-stream-in-bytes-base% editor-stream-in-base% () #f)
(define-class editor-stream-out-bytes-base% editor-stream-out-base% () #f
get-bytes)
(define-class editor-stream-in% object% () #f
ok?
jump-to
tell
skip
remove-boundary
set-boundary
get-inexact
get-exact
get-fixed
get-unterminated-bytes
get-bytes
get)
(define-class editor-stream-out% object% () #f
ok?
pretty-finish
jump-to
tell
put-fixed
put)
(define-class timer% object% () ()
stop
start
notify
interval)
(define-private-class clipboard% clipboard<%> object% () #f
same-clipboard-client?
get-clipboard-bitmap
set-clipboard-bitmap
get-clipboard-data
@ -1033,6 +611,7 @@
(define-function get-the-x-selection)
(define-function get-the-clipboard)
(define-class clipboard-client% object% () ()
same-eventspace?
get-types
add-type
get-data
@ -1063,123 +642,6 @@
get-command)
(define-function show-print-setup)
(define-function can-show-print-setup?)
(define-class pasteboard% editor% () #f
set-scroll-step
get-scroll-step
set-selection-visible
get-selection-visible
set-dragable
get-dragable
after-interactive-resize
on-interactive-resize
can-interactive-resize?
after-interactive-move
on-interactive-move
can-interactive-move?
interactive-adjust-resize
interactive-adjust-move
interactive-adjust-mouse
on-double-click
after-select
on-select
can-select?
after-reorder
on-reorder
can-reorder?
after-resize
on-resize
can-resize?
after-move-to
on-move-to
can-move-to?
after-delete
on-delete
can-delete?
after-insert
on-insert
can-insert?
find-next-selected-snip
is-selected?
find-snip
get-center
remove-selected
no-selected
add-selected
set-selected
change-style
set-after
set-before
lower
raise
resize
move
move-to
remove
erase
do-paste-x-selection
do-paste
do-copy
delete
insert
default-style-name
get-flattened-text
put-file
get-file
after-edit-sequence
on-edit-sequence
after-load-file
on-load-file
can-load-file?
after-save-file
on-save-file
can-save-file?
on-new-box
on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache
on-paint
write-footers-to-file
write-headers-to-file
read-footer-from-file
read-header-from-file
write-to-file
read-from-file
set-filename
release-snip
on-snip-modified
set-modified
scroll-editor-to
set-snip-data
get-snip-data
needs-update
resized
set-caret-owner
scroll-to
on-display-size-when-ready
on-display-size
on-change
on-focus
on-default-char
on-default-event
on-local-char
on-local-event
find-first-snip
get-space
get-descent
get-extent
blink-caret
own-caret
refresh
adjust-cursor
on-char
on-event
copy-self-to
copy-self
kill
paste-x-selection
paste
copy
cut)
(define-class panel% window% () #f
get-label-position
set-label-position
@ -1227,302 +689,6 @@
on-size
on-set-focus
on-kill-focus)
(define-class snip% object% () #f
previous
next
set-unmodified
get-scroll-step-offset
find-scroll-step
get-num-scroll-steps
set-admin
resize
write
match?
can-do-edit-operation?
do-edit-operation
blink-caret
own-caret
adjust-cursor
on-char
on-event
size-cache-invalid
copy
get-text!
get-text
merge-with
split
draw
partial-offset
get-extent
release-from-owner
is-owned?
set-style
set-flags
set-count
get-admin
get-count
get-flags
get-style
get-snipclass
set-snipclass)
(define-class string-snip% snip% () #f
read
insert
set-unmodified
get-scroll-step-offset
find-scroll-step
get-num-scroll-steps
set-admin
resize
write
match?
can-do-edit-operation?
do-edit-operation
blink-caret
own-caret
adjust-cursor
on-char
on-event
size-cache-invalid
copy
get-text!
get-text
merge-with
split
draw
partial-offset
get-extent)
(define-class tab-snip% string-snip% () #f
set-unmodified
get-scroll-step-offset
find-scroll-step
get-num-scroll-steps
set-admin
resize
write
match?
can-do-edit-operation?
do-edit-operation
blink-caret
own-caret
adjust-cursor
on-char
on-event
size-cache-invalid
copy
get-text!
get-text
merge-with
split
draw
partial-offset
get-extent)
(define-class image-snip% snip% (equal<%>) #f
equal-secondary-hash-code-of
equal-hash-code-of
other-equal-to?
equal-to?
set-offset
get-bitmap-mask
get-bitmap
set-bitmap
get-filetype
get-filename
load-file
set-unmodified
get-scroll-step-offset
find-scroll-step
get-num-scroll-steps
set-admin
resize
write
match?
can-do-edit-operation?
do-edit-operation
blink-caret
own-caret
adjust-cursor
on-char
on-event
size-cache-invalid
copy
get-text!
get-text
merge-with
split
draw
partial-offset
get-extent)
(define-class editor-snip% snip% () #f
get-inset
set-inset
get-margin
set-margin
style-background-used?
use-style-background
border-visible?
show-border
set-align-top-line
get-align-top-line
set-tight-text-fit
get-tight-text-fit
get-min-height
get-min-width
set-min-height
set-min-width
get-max-height
get-max-width
set-max-height
set-max-width
set-unmodified
get-scroll-step-offset
find-scroll-step
get-num-scroll-steps
set-admin
resize
write
match?
can-do-edit-operation?
do-edit-operation
blink-caret
own-caret
adjust-cursor
on-char
on-event
size-cache-invalid
copy
get-text!
get-text
merge-with
split
draw
partial-offset
get-extent
set-editor
get-editor)
(define-class editor-data-class% object% () #f
read
get-classname
set-classname)
(define-private-class editor-data-class-list% editor-data-class-list<%> object% () #f
nth
number
add
find-position
find)
(define-class editor-data% object% () #f
set-next
write
get-dataclass
set-dataclass
get-next)
(define-private-class mult-color% mult-color<%> object% () #f
set
get
get-r
set-r
get-g
set-g
get-b
set-b)
(define-private-class add-color% add-color<%> object% () #f
set
get
get-r
set-r
get-g
set-g
get-b
set-b)
(define-class style-delta% object% () #f
copy
collapse
equal?
set-delta-foreground
set-delta-background
set-delta-face
set-delta
get-family
set-family
get-face
set-face
get-size-mult
set-size-mult
get-size-add
set-size-add
get-weight-on
set-weight-on
get-weight-off
set-weight-off
get-smoothing-on
set-smoothing-on
get-smoothing-off
set-smoothing-off
get-style-on
set-style-on
get-style-off
set-style-off
get-underlined-on
set-underlined-on
get-underlined-off
set-underlined-off
get-size-in-pixels-on
set-size-in-pixels-on
get-size-in-pixels-off
set-size-in-pixels-off
get-transparent-text-backing-on
set-transparent-text-backing-on
get-transparent-text-backing-off
set-transparent-text-backing-off
get-foreground-mult
get-background-mult
get-foreground-add
get-background-add
get-alignment-on
set-alignment-on
get-alignment-off
set-alignment-off)
(define-private-class style% style<%> object% () #f
switch-to
set-shift-style
get-shift-style
is-join?
set-delta
get-delta
set-base-style
get-base-style
get-text-width
get-text-space
get-text-descent
get-text-height
get-transparent-text-backing
get-alignment
get-background
get-foreground
get-font
get-size-in-pixels
get-underlined
get-smoothing
get-style
get-weight
get-size
get-face
get-family
get-name)
(define-class style-list% object% () #f
forget-notification
notify-on-change
style-to-index
index-to-style
convert
replace-named-style
new-named-style
find-named-style
find-or-create-join-style
find-or-create-style
number
basic-style)
(define-function get-the-style-list)
(define-class tab-group% item% () #f
button-focus
set
@ -1551,7 +717,6 @@
(define-functions
special-control-key
special-option-key
map-command-as-meta-key
application-file-handler
application-quit-handler
application-about-handler
@ -1576,20 +741,19 @@
shortcut-visible-in-label?
eventspace-shutdown?
in-atomic-region
set-editor-snip-maker
set-text-editor-maker
set-pasteboard-editor-maker
set-menu-tester
location->window
set-dialogs
set-executer
send-event
file-creator-and-type
set-snip-class-getter
set-editor-data-class-getter
set-ps-procs
main-eventspace?
eventspace-handler-thread)
eventspace-handler-thread
begin-refresh-sequence
end-refresh-sequence
run-printout
get-double-click-time)
)
;; end

1
collects/mred/private/moredialogs.ss
View File

@ -3,6 +3,7 @@
mzlib/etc
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/style.ss")
"lock.ss"
"const.ss"
"check.ss"

8
collects/mred/private/mrmenu.ss
View File

@ -3,6 +3,7 @@
mzlib/class100
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/keymap.ss")
"lock.ss"
"const.ss"
"helper.ss"
@ -285,11 +286,12 @@
":"
"")])
(case (system-type)
[(unix windows) (format "~a~a~a~a~a?:~a"
[(unix windows) (format "~a~a~a~a?:~a"
exact
(if (memq 'shift prefix) "s:" "")
(if (memq 'meta prefix) "m:" "~m:")
(if (memq 'alt prefix) "m:" "~m:")
(if (or (memq 'meta prefix)
(memq 'alt prefix))
"m:" "~m:")
(if (memq 'ctl prefix) "c:" "")
base)]
[(macosx) (format "~a~a~a~a~a?:~a"

5
collects/mred/private/mrpopup.ss
View File

@ -3,6 +3,7 @@
mzlib/class100
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/cycle.ss")
"lock.ss"
"const.ss"
"helper.ss"
@ -63,4 +64,6 @@
(wx:queue-callback go wx:middle-queue-key)
(go))))
(no-val->#f font)))
(super-init wx)))))))
(super-init wx))))))
(wx:set-popup-menu%! popup-menu%))

1
collects/mred/private/path-dialog.ss
View File

@ -1,6 +1,7 @@
(module path-dialog mzscheme
(require mzlib/class mzlib/list mzlib/string mzlib/file
(prefix wx: "kernel.ss")
(prefix wx: "wxme/style.ss")
"helper.ss" "mrtop.ss" "mritem.ss" "mrpanel.ss" "mrtextfield.ss"
"messagebox.ss" "mrmenu.ss" (only scheme/base compose))
(provide path-dialog%)

1
collects/mred/private/repl.ss
View File

@ -2,6 +2,7 @@
(require mzlib/class
mzlib/class100
(prefix wx: "kernel.ss")
(prefix wx: "wxme/style.ss")
"editor.ss"
"app.ss"
"mrtop.ss"

2
collects/mred/private/seqcontract.ss
View File

@ -245,7 +245,7 @@ Matthew
(not (locked-for-read?)))
(set-position [(x) (x y) (x y z) (x y z p) (x y z p q)] unlocked)
(set-autowrap-bitmap [(bitmap)] unlocked)
(print-to-dc [(dc)] unlocked)
(print-to-dc [(dc) (dc page)] unlocked)
(move-position [(code?) (code? extend) (code? extend kind)] unlocked)
(split-snip [(pos)] unlocked)
(set-line-spacing [(space)] unlocked)

6
collects/mred/private/snipfile.ss
View File

@ -4,6 +4,8 @@
mzlib/port
syntax/moddep
(prefix wx: "kernel.ss")
(prefix wx: "wxme/snip.ss")
(prefix wx: "wxme/cycle.ss")
"check.ss"
"editor.ss")
@ -50,10 +52,10 @@
(error 'load-class "not a ~a% instance" id))))
#f)))])
;; install the getters:
(wx:set-snip-class-getter
(wx:set-get-snip-class!
(lambda (name)
(load-one name 'snip-class wx:snip-class%)))
(wx:set-editor-data-class-getter
(wx:set-get-editor-data-class!
(lambda (name)
(load-one name 'editor-data-class wx:editor-data-class%))))

266
collects/mred/private/syntax.ss Normal file
View File

@ -0,0 +1,266 @@
#lang scheme/base
(require scheme/class
scheme/stxparam
(for-syntax scheme/base))
(provide defclass defclass*
def/public def/override define/top case-args
maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts
make-literal symbol-in make-procedure
method-name init-name
let-boxes
properties field-properties init-properties
->long)
(define-syntax-parameter class-name #f)
(define-syntax-rule (defclass name super . body)
(defclass* name super () . body))
(define-syntax-rule (defclass* name super intfs . body)
(define name
(syntax-parameterize ([class-name 'name])
(class* super intfs . body))))
(define-syntax (def/public stx)
#`(def/thing define/public #,stx))
(define-syntax (def/override stx)
#`(def/thing define/override #,stx))
(define-syntax (define/top stx)
#`(def/thing define #,stx))
(define (method-name class method)
(string->symbol (format "~a in ~a" method class)))
(define (init-name class)
(string->symbol (format "initialization for ~a" class)))
(define-syntax just-id
(syntax-rules ()
[(_ [id default]) id]
[(_ id) id]))
(define-struct named-pred (pred make-name)
#:property prop:procedure (struct-field-index pred))
(define (apply-pred pred val)
(cond
[(procedure? pred) (pred val)]
[(class? pred) (val . is-a? . pred)]
[(interface? pred) (val . is-a? . pred)]
[else (error 'check-arg "unknown predicate type: ~e" pred)]))
(define (make-or-false pred)
(make-named-pred (lambda (v)
(or (not v) (apply-pred pred v)))
(lambda ()
(string-append (predicate-name pred)
" or #f"))))
(define (make-box pred)
(make-named-pred (lambda (v)
(and (box? v) (apply-pred pred (unbox v))))
(lambda ()
(string-append "boxed " (predicate-name pred)))))
(define (make-list pred)
(make-named-pred (lambda (v)
(and (list? v) (andmap (lambda (v) (apply-pred pred v)) v)))
(lambda ()
(string-append "list of " (predicate-name pred)))))
(define (make-alts a b)
(make-named-pred (lambda (v)
(or (apply-pred a v) (apply-pred b v)))
(lambda ()
(string-append (predicate-name a)
" or "
(predicate-name b)))))
(define (make-literal lit)
(make-named-pred (lambda (v) (equal? v lit))
(lambda () (if (symbol? lit)
(format "'~s" lit)
(format "~s" lit)))))
(define (make-symbol syms)
(make-named-pred (lambda (v) (memq v syms))
(lambda ()
(let loop ([syms syms])
(cond
[(null? (cdr syms))
(format "'~s" (car syms))]
[(null? (cddr syms))
(format "'~s, or '~s" (car syms) (cadr syms))]
[else
(format "'~s, ~a" (car syms) (loop (cdr syms)))])))))
(define-syntax-rule (symbol-in sym ...)
(make-symbol '(sym ...)))
(define (make-procedure arity)
(make-named-pred (lambda (p)
(and (procedure? p)
(procedure-arity-includes? p arity)))
(lambda ()
(format "procedure (arity ~a)" arity))))
(define (check-arg val pred pos)
(if (apply-pred pred val)
#f
(cons (predicate-name pred)
pos)))
(define (predicate-name pred)
(cond
[(named-pred? pred) ((named-pred-make-name pred))]
[(procedure? pred) (let ([s (symbol->string (object-name pred))])
(substring s 0 (sub1 (string-length s))))]
[(or (class? pred) (interface? pred))
(format "~a instance" (object-name pred))]
[else "???"]))
(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v)))
(lambda () "box or #f")))
(define (any? v) #t)
(define (bool? v) #t)
(define (nonnegative-real? v) (and (real? v) (v . >= . 0)))
(define (method-of cls nam)
(if cls
(string->symbol (format "~a method of ~a" nam cls))
nam))
(define-syntax (def/thing stx)
(syntax-case stx ()
[(_ define/orig (_ (id [arg-type arg] ...)))
(raise-syntax-error #f "missing body" stx)]
[(_ define/orig (_ (id [arg-type arg] ...) . body))
(with-syntax ([(_ _ orig-stx) stx]
[(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))])
i)]
[cname (syntax-parameter-value #'class-name)])
(syntax/loc #'orig-stx
(define/orig (id arg ...)
(let ([bad (or (check-arg (just-id arg) arg-type pos)
...)])
(when bad
(raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...)))
(let ()
. body))))]))
(define-for-syntax lifted (make-hash))
(define-syntax (lift-predicate stx)
(syntax-case stx ()
[(_ id) (identifier? #'id) #'id]
[(_ expr)
(let ([d (syntax->datum #'expr)])
(or (hash-ref lifted d #f)
(let ([id (syntax-local-lift-expression #'expr)])
(hash-set! lifted d id)
id)))]))
(define-syntax (case-args stx)
(syntax-case stx ()
[(_ expr [([arg-type arg] ...) rhs ...] ... who)
(with-syntax ([((min-args-len . max-args-len) ...)
(map (lambda (args)
(let ([args (syntax->list args)])
(cons (let loop ([args args])
(if (or (null? args)
(not (identifier? (car args))))
0
(add1 (loop (cdr args)))))
(length args))))
(syntax->list #'((arg ...) ...)))])
#'(let* ([args expr]
[len (length args)])
(find-match
(lambda (next)
(if (and (len . >= . min-args-len)
(len . <= . max-args-len))
(apply
(lambda (arg ...)
(if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...)
(lambda () rhs ...)
next))
args)
next))
...
(lambda (next)
(bad-args who args)))))]))
(define (bad-args who args)
(error who "bad argument combination:~a"
(apply string-append (map (lambda (x) (format " ~e" x))
args))))
(define-syntax find-match
(syntax-rules ()
[(_ proc)
((proc #f))]
[(_ proc1 proc ...)
((proc1 (lambda () (find-match proc ...))))]))
(define-syntax-rule (let-boxes ([id init] ...)
call
body ...)
(let ([id (box init)] ...)
call
(let ([id (unbox id)] ...)
body ...)))
(define-syntax (do-properties stx)
(syntax-case stx ()
[(_ define-base check-immutable [[type id] expr] ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(getter ...)
(map (lambda (id)
(datum->syntax id
(string->symbol
(format "get-~a" (syntax-e id)))
id))
ids)]
[(setter ...)
(map (lambda (id)
(datum->syntax id
(string->symbol
(format "set-~a" (syntax-e id)))
id))
ids)])
#'(begin
(define-base id expr) ...
(define/public (getter) id) ...
(def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))]))
(define-syntax coerce
(syntax-rules (bool?)
[(_ bool? v) (and v #t)]
[(_ _ v) v]))
(define-syntax properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define check-immutable . props)]
[(_ . props)
(do-properties define void . props)]))
(define-syntax field-properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define-field check-immutable . props)]
[(_ . props)
(do-properties define-field void . props)]))
(define-syntax-rule (define-field id val) (field [id val]))
(define-syntax init-properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define-init check-immutable . props)]
[(_ . props)
(do-properties define-init void . props)]))
(define-syntax-rule (define-init id val) (begin
(init [(internal id) val])
(define id internal)))
(define (->long i)
(cond
[(eqv? -inf.0 i) (- (expt 2 64))]
[(eqv? +inf.0 i) (expt 2 64)]
[(eqv? +nan.0 i) 0]
[else (inexact->exact (floor i))]))

13
collects/mred/private/wxcanvas.ss
View File

@ -2,6 +2,8 @@
(require mzlib/class
mzlib/class100
(prefix wx: "kernel.ss")
(prefix wx: "wxme/text.ss")
(prefix wx: "wxme/editor-canvas.ss")
"lock.ss"
"helper.ss"
"wx.ss"
@ -216,6 +218,11 @@
(when mred
(as-exit (lambda () (send init-buffer add-canvas mred)))))))))
(define wx-editor-canvas% (make-canvas-glue%
(make-editor-canvas% (make-control% wx:editor-canvas%
0 0 #t #t)))))
(define wx-editor-canvas%
(class (make-canvas-glue%
(make-editor-canvas% (make-control% wx:editor-canvas%
0 0 #t #t)))
(inherit editor-canvas-on-scroll)
(define/override (on-scroll e)
(editor-canvas-on-scroll))
(super-new))))

5
collects/mred/private/wxme/const.ss Normal file
View File

@ -0,0 +1,5 @@
#lang scheme/base
(provide (all-defined-out))
(define CURSOR-WIDTH 2)

29
collects/mred/private/wxme/cycle.ss Normal file
View File

@ -0,0 +1,29 @@
#lang scheme/base
(define-syntax-rule (decl id set-id)
(begin
(provide id set-id)
(define id #f)
(define (set-id v) (set! id v))))
(decl text% set-text%!)
(decl pasteboard% set-pasteboard%!)
(decl snip-admin% set-snip-admin%!)
(decl editor-stream-in% set-editor-stream-in%!)
(decl editor-stream-out% set-editor-stream-out%!)
(decl editor-snip% set-editor-snip%!)
(decl editor-snip-editor-admin% set-editor-snip-editor-admin%!)
(decl extended-editor-snip% set-extended-editor-snip%!)
(decl extended-text% set-extended-text%!)
(decl extended-pasteboard% set-extended-pasteboard%!)
(decl get-snip-class set-get-snip-class!)
(decl get-editor-data-class set-get-editor-data-class!)
(decl editor-get-file set-editor-get-file!)
(decl editor-put-file set-editor-put-file!)
(decl popup-menu% set-popup-menu%!)

57
collects/mred/private/wxme/editor-admin.ss Normal file
View File

@ -0,0 +1,57 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"snip.ss"
"private.ss"
(only-in "cycle.ss" popup-menu%))
(provide editor-admin%)
(defclass editor-admin% object%
(super-new)
(define standard 0) ; used to recognize standard display
(define/public (get-s-standard) standard)
(define/public (set-s-standard v) (set! standard v))
(def/public (get-dc [maybe-box? [x #f]] [maybe-box? [y #f]])
(when x (set-box! x 0.0))
(when y (set-box! y 0.0))
#f)
(define/private (do-get-view x y w h)
(when x (set-box! x 0.0))
(when y (set-box! y 0.0))
(when w (set-box! w 0.0))
(when h (set-box! h 0.0)))
(def/public (get-view [maybe-box? x] [maybe-box? y]
[maybe-box? w] [maybe-box? h]
[any? [full? #f]])
(do-get-view x y w h))
(def/public (get-max-view [maybe-box? x] [maybe-box? y]
[maybe-box? w] [maybe-box? h]
[any? [full? #f]])
(get-view x y w h full?))
(def/public (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]]
[(symbol-in start none end) [bias 'none]])
(void))
(def/public (grab-caret [(symbol-in immediate display global) [dist 'global]])
(void))
(def/public (resized [any? redraw-now]) (void))
(def/public (needs-update [real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h])
(void))
(def/public (update-cursor) (void))
(def/public (refresh-delayed?) #f)
(def/public (popup-menu [popup-menu% m] [real? x] [real? y]) #f)
(def/public (modified [any? mod?]) (void)))

1141
collects/mred/private/wxme/editor-canvas.ss Normal file
View File

File diff suppressed because it is too large Load Diff

716
collects/mred/private/wxme/editor-snip.ss Normal file
View File

@ -0,0 +1,716 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"private.ss"
"const.ss"
"snip.ss"
"snip-flags.ss"
"editor.ss"
"editor-admin.ss"
"snip-admin.ss"
"text.ss"
"pasteboard.ss"
"wx.ss"
(except-in "cycle.ss"
text%
pasteboard%
editor-snip%
editor-snip-editor-admin%
snip-admin%))
(provide editor-snip%
editor-snip-editor-admin<%>)
;; FIXME: use "type"s
(define-syntax-rule (private-inits [[type id] val] ...)
(begin
(define-init id val)
...))
(define-syntax-rule (define-init id v)
(begin
(init [(init-tmp id) v])
(define id init-tmp)))
;; see also "private.ss"
(define-local-member-name
with-dc
do-get-left-margin do-get-right-margin do-get-bottom-margin do-get-top-margin
do-get-extent)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass editor-snip% snip%
(private-inits
[[(make-or-false editor<%>) editor] #f]
[[bool? with-border?] #t]
[[exact-nonnegative-integer? left-margin] 5]
[[exact-nonnegative-integer? top-margin] 5]
[[exact-nonnegative-integer? right-margin] 5]
[[exact-nonnegative-integer? bottom-margin] 5]
[[exact-nonnegative-integer? left-inset] 1]
[[exact-nonnegative-integer? top-inset] 1]
[[exact-nonnegative-integer? right-inset] 1]
[[exact-nonnegative-integer? bottom-inset] 1]
[[(make-alts (symbol-in none) nonnegative-real?) min-width] 'none]
[[(make-alts (symbol-in none) nonnegative-real?) max-width] 'none]
[[(make-alts (symbol-in none) nonnegative-real?) min-height] 'none]
[[(make-alts (symbol-in none) nonnegative-real?) max-height] 'none])
(unless (symbol? min-width) (set! min-width (exact->inexact min-width)))
(unless (symbol? max-width) (set! max-width (exact->inexact max-width)))
(unless (symbol? min-height) (set! min-height (exact->inexact min-height)))
(unless (symbol? max-height) (set! max-height (exact->inexact max-height)))
(define align-top-line? #f)
(define tight-fit? #f)
(define use-style-bg? #f)
(super-new)
(inherit set-snipclass
do-copy-to)
(inherit-field s-admin
s-flags
s-style)
(set-snipclass the-editor-snip-class)
(when (and editor (send editor get-admin))
(set! editor #f))
(unless editor
(set! editor (new extended-text%)))
(define my-admin (new editor-snip-editor-admin% [owner this]))
(set! s-flags (add-flag s-flags HANDLES-EVENTS))
(when (no-permanent-filename? editor)
(set! s-flags (add-flag s-flags USES-BUFFER-PATH)))
(send editor own-caret #f)
;; ----------------------------------------
(define/private (no-permanent-filename? editor)
(let ([temp (box #f)])
(let ([fn (send editor get-filename temp)])
(or (not fn) (unbox temp)))))
(def/override (set-admin [(make-or-false snip-admin%) a])
(when (not (eq? a s-admin))
(super set-admin a)
(when editor
(if a
(begin
(when (send editor get-admin)
;; traitor! - get rid of it
(set! editor #f))
(send editor set-admin my-admin))
(send editor set-admin #f))))
(when (and s-admin
(has-flag? s-flags USES-BUFFER-PATH))
;; propogate a filename change:
(if (and editor
(no-permanent-filename? editor))
(let ([b (send s-admin get-editor)])
(when b
(let ([fn (send b get-filename)])
(when fn
(send editor set-filename fn #t)))))
(set! s-flags (remove-flag s-flags USES-BUFFER-PATH)))) ;; turn off the flag; not needed
(void))
(def/public (set-editor [editor<%> b])
(unless (eq? editor b)
(when (and editor s-admin)
(send editor set-admin #f))
(set! editor b)
(when b
(cond
[(send b get-admin)
(set! editor #f)]
[s-admin
(send editor set-admin my-admin)]))
(when s-admin
(send s-admin resized this #t))))
(def/public (get-editor)
editor)
(def/override (adjust-cursor [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [mouse-event% event])
(if (not editor)
#f
(send my-admin
with-dc
dc x y
(lambda ()
(send editor adjust-cursor event)))))
(def/override (on-event [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [mouse-event% event])
(when editor
(send my-admin
with-dc
dc x y
(lambda ()
(send editor on-event event)))))
(def/override (on-char [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [key-event% event])
(when editor
(send my-admin
with-dc
dc x y
(lambda ()
(send editor on-char event)))))
(def/override (own-caret [bool? own?])
(when editor
(send editor own-caret own?)))
(def/override (blink-caret [dc<%> dc] [real? x] [real? y])
(when editor
(send my-admin
with-dc
dc x y
(lambda ()
(send editor blink-caret)))))
(def/override (do-edit-operation [symbol? op] [any? [recur? #t]] [exact-integer? [timestamp 0]])
(when editor
(send editor do-edit-operation op recur? timestamp)))
(def/override (can-do-edit-operation? [symbol? op] [any? [recur? #t]])
(and editor
(send editor can-do-edit-operation? op recur?)))
(def/override (match? [snip% s])
#f)
(def/override (size-cache-invalid)
(when editor
(send editor size-cache-invalid)))
(def/override (get-text [exact-nonnegative-integer? offset] [exact-integer? num]
[any? [flattened? #f]])
(cond
[(or (offset . >= . 1)
(zero? num))
""]
[(not flattened?)
"."]
[editor
(send editor get-flattened-text)]
[else ""]))
(define/public (do-get-extent dc x y w h -descent -space lspace rspace)
(send my-admin
with-dc
dc x y
(lambda ()
(let ([h2 (or h (box 0.0))])
(if editor
(send editor get-extent w h2)
(begin
(when w (set-box! w 0.0))
(set-box! h2 0.0)))
(let ([orig-h (if align-top-line?
(unbox h2)
0.0)])
(when w
(when (editor . is-a? . text%)
(set-box!
w
(- (unbox w)
(if tight-fit?
CURSOR-WIDTH
1)))) ;; it still looks better to subtract 1
(when ((unbox w) . < . (if (symbol? min-width) -inf.0 min-width))
(set-box! w min-width))
(when ((unbox w) . > . (if (symbol? max-width) +inf.0 max-width))
(set-box! w max-width))
(set-box! w (+ (unbox w) (+ right-margin left-margin))))
(when h
(when (editor . is-a? . text%)
(when tight-fit?
(set-box! h
(max 0.0
(- (unbox h)
(send editor get-line-spacing))))))
(when ((unbox h) . < . (if (symbol? min-height) -inf.0 min-height))
(set-box! h min-height))
(when ((unbox h) . > . (if (symbol? max-height) +inf.0 max-height))
(set-box! h max-height))
(set-box! h (+ (unbox h) (+ top-margin bottom-margin))))
(let* ([descent (+ (if editor
(send editor get-descent)
0.0)
bottom-margin)]
[descent
(if (editor . is-a? . text%)
(let ([descent (if align-top-line?
(- orig-h
(+ (send editor get-top-line-base)
bottom-margin))
descent)])
(if tight-fit?
(max (- descent (send editor get-line-spacing)) 0.0)
descent))
descent)]
[space (+ (if editor
(send editor get-space)
0.0)
top-margin)])
(let-values ([(space descent)
(if (and (not (symbol? max-height))
((+ descent space) . >= . (+ max-height top-margin bottom-margin)))
;; just give up on spaces in this case:
(values top-margin bottom-margin)
(values space descent))])
(when -descent (set-box! -descent descent))
(when -space (set-box! -space space))))
(when lspace (set-box! lspace left-margin))
(when rspace (set-box! rspace right-margin)))))))
(def/override (get-extent [dc<%> dc] [real? x] [real? y]
[maybe-box? [w #f]] [maybe-box? [h #f]]
[maybe-box? [-descent #f]] [maybe-box? [-space #f]]
[maybe-box? [lspace #f]] [maybe-box? [rspace #f]])
(do-get-extent dc x y w h -descent -space lspace rspace))
(def/override (draw [dc<%> dc] [real? x] [real? y]
[real? left] [real? top] [real? right] [real? bottom]
[real? dx] [real? dy] [symbol? caret])
(send my-admin
with-dc
dc x y
(lambda ()
(let-boxes ([w 0.0]
[h 0.0])
(when editor
(send editor get-extent w h)
(when (editor . is-a? . text%)
(set-box! w (max 0.0
(- (unbox w)
(if tight-fit?
CURSOR-WIDTH
1)))) ;; it still looks better to subtract 1
(when tight-fit?
(set-box! h (max 0.0
(- (unbox h)
(send editor get-line-spacing)))))))
(let* ([w (min (max w (if (symbol? min-width) -inf.0 min-width))
(if (symbol? max-width) +inf.0 max-width))]
[h (min (max h (if (symbol? min-height) -inf.0 min-height))
(if (symbol? max-height) +inf.0 max-height))]
[orig-x x]
[orig-y y]
[x (+ x left-margin)]
[y (+ y top-margin)]
[r (+ x w)]
[b (+ y h)]
[l (max x left)]
[t (max y top)]
[r (min r right)]
[b (min b bottom)])
(let ([bg-color
(cond
[(not use-style-bg?)
(make-object color% 255 255 255)]
[(send s-style get-transparent-text-backing)
#f]
[else
(let ([bg-color (send s-style get-background)])
(let ([l (+ orig-x left-inset)]
[t (+ orig-y top-inset)]
[r (+ l w left-margin right-margin
(- (+ left-inset right-inset))
-1)]
[b (+ t h top-margin bottom-margin
(- (+ top-inset bottom-inset))
-1)])
(let ([trans-pen (send the-pen-list
find-or-create-pen
bg-color 0 'transparent)]
[fill (send the-brush-list
find-or-create-brush
bg-color 'solid)]
[savep (send dc get-pen)]
[saveb (send dc get-brush)])
(send dc set-pen trans-pen)
(send dc set-brush fill)
(send dc draw-rectangle l t (- r l) (- b t))
(send dc set-brush saveb)
(send dc set-pen savep)))
bg-color)])])
(when editor
(send editor refresh
(- l x) (- t y) (max 0.0 (- r l)) (max 0.0 (- b t))
caret bg-color))
(when with-border?
(let* ([l (+ orig-x left-inset)]
[t (+ orig-y top-inset)]
[r (+ l w left-margin right-margin
(- (+ left-inset right-inset))
-1)]
[b (+ t h top-margin bottom-margin
(- (+ top-inset bottom-inset))
-1)])
(let ([ml (max (min l right) left)]
[mr (max (min r right) left)]
[mt (max (min t bottom) top)]
[mb (max (min b bottom) top)])
(when (and (l . >= . left)
(l . < . right)
(mt . < . mb))
(send dc draw-line l mt l mb))
(when (and (r . >= . left)
(r . < . right)
(mt . < . mb))
(send dc draw-line r mt r mb))
(when (and (t . >= . top)
(t . < . bottom)
(ml . < . mr))
(send dc draw-line ml t mr t))
(when (and (b . >= . top)
(b . < . bottom)
(ml . < . mr))
(send dc draw-line ml b mr b)))))))))))
(def/override (copy)
(let* ([mb (and editor
(send editor copy-self))]
[ms (make-object extended-editor-snip%
mb
with-border?
left-margin top-margin
right-margin bottom-margin
left-inset top-inset
right-inset bottom-inset
min-width max-width
min-height max-height)])
(do-copy-to ms)
(send ms do-set-graphics tight-fit? align-top-line? use-style-bg?)
(when (not editor)
(send ms set-editor #f))
ms))
(define/public (do-set-graphics tf? atl? usb?)
(set! tight-fit? tf?)
(set! align-top-line? atl?)
(set! use-style-bg? usb?))
(def/override (write [editor-stream-out% f])
(send f put (if editor
(if (editor . is-a? . pasteboard%) 2 1)
0))
(send f put (if with-border? 1 0))
(send f put left-margin)
(send f put top-margin)
(send f put right-margin)
(send f put bottom-margin)
(send f put left-inset)
(send f put top-inset)
(send f put right-inset)
(send f put bottom-inset)
(send f put (if (symbol? min-width) -1.0 min-width))
(send f put (if (symbol? max-width) -1.0 max-width))
(send f put (if (symbol? min-height) -1.0 min-height))
(send f put (if (symbol? max-height) -1.0 max-height))
(send f put (if tight-fit? 1 0))
(send f put (if align-top-line? 1 0))
(send f put (if use-style-bg? 1 0))
(when editor
(send editor write-to-file f)))
(define/private (resize-me)
(when s-admin (send s-admin resized this #t)))
(def/public (set-max-width [(make-alts (symbol-in none) nonnegative-real?) w])
(set! max-width w)
(resize-me))
(def/public (set-min-width [(make-alts (symbol-in none) nonnegative-real?) w])
(set! min-width w)
(resize-me))
(def/public (set-max-height [(make-alts (symbol-in none) nonnegative-real?) h])
(set! max-height h)
(resize-me))
(def/public (set-min-height [(make-alts (symbol-in none) nonnegative-real?) h])
(set! min-height h)
(resize-me))
(def/public (get-max-width) max-width)
(def/public (get-min-width) min-width)
(def/public (get-max-height) max-height)
(def/public (get-min-height) min-height)
(def/public (get-tight-text-fit)
tight-fit?)
(def/public (set-tight-text-fit [bool? t])
(set! tight-fit? t)
(resize-me))
(def/public (get-align-top-line)
align-top-line?)
(def/public (set-align-top-line [bool? t])
(set! align-top-line? t)
(resize-me))
(def/public (style-background-used?)
use-style-bg?)
(def/public (use-style-background [bool? u])
(unless (eq? use-style-bg? u)
(set! use-style-bg? u)
(request-refresh)))
(def/override (resize [real? w] [real? h])
(let ([w (max 0.0 (- w (+ left-margin right-margin)))]
[h (max 0.0 (- h (+ top-margin bottom-margin)))])
(set! min-width w)
(set! max-width w)
(set! min-height h)
(set! max-height h)
(when editor
(send editor set-max-width w)
(send editor set-min-width w))
(resize-me)
#t))
(define/private (request-refresh)
(when s-admin
(let ([dc (send s-admin get-dc)])
(when dc
(let-boxes ([w 0.0]
[h 0.0])
(get-extent dc 0 0 w h)
(send s-admin needs-update
this left-inset top-inset
(+ w (- right-margin right-inset))
(+ h (- bottom-margin bottom-inset))))))))
(def/public (show-border [bool? show])
(unless (eq? with-border? show)
(set! with-border? show)
(request-refresh)))
(def/public (border-visible?)
with-border?)
(def/public (set-margin [exact-nonnegative-integer? lm]
[exact-nonnegative-integer? tm]
[exact-nonnegative-integer? rm]
[exact-nonnegative-integer? bm])
(set! left-margin lm)
(set! top-margin tm)
(set! right-margin rm)
(set! bottom-margin bm)
(resize-me))
(def/public (get-margin [box? lm] [box? tm] [box? rm] [box? bm])
(set-box! lm left-margin)
(set-box! tm top-margin)
(set-box! rm right-margin)
(set-box! bm bottom-margin))
(def/public (set-inset [exact-nonnegative-integer? lm]
[exact-nonnegative-integer? tm]
[exact-nonnegative-integer? rm]
[exact-nonnegative-integer? bm])
(set! left-margin lm)
(set! top-margin tm)
(set! right-margin rm)
(set! bottom-margin bm)
(request-refresh))
(def/public (get-inset [box? lm] [box? tm] [box? rm] [box? bm])
(set-box! lm left-inset)
(set-box! tm top-inset)
(set-box! rm right-inset)
(set-box! bm bottom-inset))
(def/override (get-num-scroll-steps)
(if editor
(send editor num-scroll-lines)
1))
(def/override (find-scroll-step [real? y])
(if editor
(send editor find-scroll-line (- y top-margin))
0))
(def/override (get-scroll-step-offset [exact-integer? n])
(if editor
(+ (send editor scroll-line-location n) top-margin)
0))
(def/override (set-unmodified)
(when editor
(send editor set-modified #f)))
(def/public (do-get-left-margin) left-margin)
(def/public (do-get-right-margin) right-margin)
(def/public (do-get-bottom-margin) bottom-margin)
(def/public (do-get-top-margin) top-margin))
(set-editor-snip%! editor-snip%)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct state (dc x y))
(defclass editor-snip-editor-admin% editor-admin%
(init owner)
(define snip owner)
(define state #f)
(super-new)
(define/public (get-snip) snip)
(define/public (with-dc dc x y thunk)
(let* ([other (make-state dc
(+ x (send snip do-get-left-margin))
(+ y (send snip do-get-top-margin)))]
[swap (lambda ()
(let ([s state])
(set! state other)
(set! other s)))])
(dynamic-wind swap thunk swap)))
(def/override (get-dc [maybe-box? [x #f]] [maybe-box? [y #f]])
(let-values ([(xv yv)
(if state
(values (- (state-x state))
(- (state-y state)))
(values 0 0))])
(when x (set-box! x xv))
(when y (set-box! y yv))
(if state
(state-dc state)
(let ([sadmin (send snip get-admin)])
(if sadmin
(send sadmin get-dc)
#f)))))
(def/override (get-view [maybe-box? x] [maybe-box? y]
[maybe-box? w] [maybe-box? h]
[any? [full? #f]])
(let ([sadmin (send snip get-admin)])
(cond
[(not sadmin)
(when x (set-box! x 0.0))
(when y (set-box! y 0.0))
(when w (set-box! w 0.0))
(when h (set-box! h 0.0))]
[full?
(send sadmin get-view x y w h #f)]
[else
(let-boxes ([sx 0.0]
[sy 0.0]
[sw 0.0]
[sh 0.0])
(send sadmin get-view sx sy sw sh snip)
(when x
(set-box! x (max 0.0 (- sx (send snip do-get-left-margin)))))
(when y
(set-box! y (max 0.0 (- sy (send snip do-get-top-margin)))))
(when (or w h)
(if (or (positive? sw) (positive? sh))
;; w and h might be too big due to margins - but
;; they might be small enough already because
;; part of the snip itself is not viewed
(let-boxes ([rw 0.0]
[rh 0.0])
;; we want the internal, non-overridden method:
(send snip do-get-extent (and state (state-dc state)) 0 0 rw rh #f #f #f #f)
;; remember: sx and sy are in snip coordinates
(when w
(let* ([left-margin (max 0.0 (- (send snip do-get-left-margin) sx))]
[sw (- sw left-margin)]
[rw (- rw (send snip do-get-left-margin))]
[right-margin (max 0.0 (- (send snip do-get-right-margin) (- rw sw)))]
[sw (max 0.0 (- sw right-margin))])
(set-box! w sw)))
(when h
(let* ([top-margin (max 0.0 (- (send snip do-get-top-margin) sy))]
[sh (- sh top-margin)]
[rh (- rh (send snip do-get-top-margin))]
[bottom-margin (max 0.0 (- (send snip do-get-bottom-margin) (- rh sh)))]
[sh (max 0.0 (- sh bottom-margin))])
(set-box! h sh))))
(begin
(when w (set-box! w 0.0))
(when h (set-box! h 0.0))))))])))
(def/override (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]]
[(symbol-in start none end) [bias 'none]])
(let ([sadmin (send snip get-admin)])
(and sadmin
(send sadmin scroll-to snip (+ localx (send snip do-get-left-margin))
(+ localy (send snip do-get-top-margin))
w h refresh? bias))))
(def/override (grab-caret [(symbol-in immediate display global) dist])
(let ([sadmin (send snip get-admin)])
(when sadmin
(send sadmin set-caret-owner snip dist))))
(def/override (resized [any? redraw-now])
(let ([sadmin (send snip get-admin)])
(when sadmin
(send sadmin resized snip redraw-now))))
(def/override (needs-update [real? localx] [real? localy]
[nonnegative-real? w] [nonnegative-real? h])
(let ([sadmin (send snip get-admin)])
(when sadmin
(send sadmin needs-update snip
(+ localx (send snip do-get-left-margin))
(+ localy (send snip do-get-top-margin))
w h))))
(def/override (update-cursor)
(let ([sadmin (send snip get-admin)])
(when sadmin
(send sadmin update-cursor))))
(def/override (popup-menu [popup-menu% m] [real? x] [real? y])
(let ([sadmin (send snip get-admin)])
(and sadmin
(send sadmin popup-menu m snip
(+ x (send snip do-get-left-margin))
(+ y (send snip do-get-top-margin))))))
(def/override (refresh-delayed?)
(let ([sadmin (send snip get-admin)])
(or (not sadmin)
(and (sadmin . is-a? . standard-snip-admin%)
(send (send sadmin get-editor) refresh-delayed?)))))
(def/override (modified [any? mod?])
(let ([sadmin (send snip get-admin)])
(when sadmin
(send sadmin modified snip mod?)))))
(set-editor-snip-editor-admin%! editor-snip-editor-admin%)
(define editor-snip-editor-admin<%> (class->interface editor-snip-editor-admin%))

1815
collects/mred/private/wxme/editor.ss Normal file
View File

File diff suppressed because it is too large Load Diff

739
collects/mred/private/wxme/keymap.ss Normal file
View File

@ -0,0 +1,739 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"wx.ss")
(provide keymap%
map-command-as-meta-key)
(define map-command-as-meta? #f)
(define/top (map-command-as-meta-key [bool? v])
(set! map-command-as-meta? v))
(define (as-meta-key k)
(case (system-type)
[(macosx) (if map-command-as-meta?
k
#f)]
[else k]))
(define (as-cmd-key k)
(case (system-type)
[(macosx) k]
[else #f]))
(define keylist
#hash(("leftbutton" . mouse-left)
("rightbutton" . mouse-right)
("middlebutton" . mouse-middle)
("leftbuttondouble" . mouse-left-double)
("rightbuttondouble" . mouse-right-double)
("middlebuttondouble" . mouse-middle-double)
("leftbuttontriple" . mouse-left-triple)
("rightbuttontriple" . mouse-right-triple)
("middlebuttontriple" . mouse-middle-triple)
("leftbuttonseq" . mouse-left)
("rightbuttonseq" . mouse-right)
("middlebuttonseq" . mouse-middle)
("wheelup" . wheel-up)
("wheeldown" . wheel-down)
("esc" . escape)
("delete" . delete)
("del" . #\rubout)
("insert" . insert)
("ins" . insert)
("add" . add)
("subtract" . subtract)
("multiply" . multiply)
("divide" . divide)
("backspace" . back)
("back" . back)
("return" . #\return)
("enter" . #\return)
("tab" . #\tab)
("space" . #\space)
("right" . right)
("left" . left)
("up" . up)
("down" . down)
("home" . home)
("end" . end)
("pageup" . prior)
("pagedown" . next)
("semicolon" . #\;)
("colon" . #\:)
("numpad0" . numpad0)
("numpad1" . numpad1)
("numpad2" . numpad2)
("numpad3" . numpad3)
("numpad4" . numpad4)
("numpad5" . numpad5)
("numpad6" . numpad6)
("numpad7" . numpad7)
("numpad8" . numpad8)
("numpad9" . numpad9)
("numpadenter" . #\u3)
("f1" . f1)
("f2" . f2)
("f3" . f3)
("f4" . f4)
("f5" . f5)
("f6" . f6)
("f7" . f7)
("f8" . f8)
("f9" . f9)
("f10" . f10)
("f11" . f11)
("f12" . f12)
("f13" . f13)
("f14" . f14)
("f15" . f15)
("f16" . f16)
("f17" . f17)
("f18" . f18)
("f19" . f19)
("f20" . f20)
("f21" . f21)
("f22" . f22)
("f23" . f23)
("f24" . f24)))
(define rev-keylist
(make-immutable-hash
(hash-map keylist (lambda (k v) (cons v k)))))
(define-struct kmfunc (name f))
(define-struct key (code
shift-on?
shift-off?
ctrl-on?
ctrl-off?
alt-on?
alt-off?
meta-on?
meta-off?
cmd-on?
cmd-off?
caps-on?
caps-off?
score
check-other?
fullset?
[fname #:mutable]
isprefix?
seqprefix))
(define-local-member-name
chain-handle-key-event
get-best-score
chain-handle-mouse-event
get-best-mouse-score
cycle-check)
(defclass keymap% object%
(super-new)
(define functions (make-hash))
(define keys (make-hash))
(define prefix #f)
(define prefixed? #f)
(define active-mouse-function #f)
(define grab-key-function #f)
(define grab-mouse-function #f)
(define on-break #f)
(define chain-to null)
(define last-time 0)
(define last-x 0)
(define last-y 0)
(define click-count 0)
(define last-code #f)
(define last-button #f)
(define double-interval (get-double-click-threshold))
(def/public (reset)
(set! prefix #f)
(set! prefixed? #f)
(for-each (lambda (c)
(send c reset))
chain-to))
(def/public (break-sequence)
(set! prefix #f)
(when on-break
(let ([f on-break])
(set! on-break #f)
(f)))
(for-each (lambda (c)
(send c break-sequence))
chain-to))
(def/public (set-break-sequence-callback [(make-procedure 0) f])
(let ([old on-break])
(set! on-break f)
(when old (old))))
(define/private (find-key code other-code alt-code other-alt-code caps-code
shift? ctrl? alt? meta? cmd? caps?
prefix)
(for*/fold ([best-key #f]
[best-score -1])
([findk (in-list (list code other-code alt-code other-alt-code caps-code))]
[key (in-list (hash-ref keys findk null))])
(if (and (or (eqv? (key-code key) code)
(and (key-check-other? key)
(or (eqv? (key-code key) other-code)
(eqv? (key-code key) alt-code)
(eqv? (key-code key) other-alt-code)
(eqv? (key-code key) caps-code))))
(or (and (key-shift-on? key) shift?)
(and (key-shift-off? key) (not shift?))
(and (not (key-shift-on? key)) (not (key-shift-off? key))))
(or (and (key-ctrl-on? key) ctrl?)
(and (key-ctrl-off? key) (not ctrl?))
(and (not (key-ctrl-on? key)) (not (key-ctrl-off? key))))
(or (and (key-alt-on? key) alt?)
(and (key-alt-off? key) (not alt?))
(and (not (key-alt-on? key)) (not (key-alt-off? key))))
(or (and (key-meta-on? key) meta?)
(and (key-meta-off? key) (not meta?))
(and (not (key-meta-on? key)) (not (key-meta-off? key))))
(or (and (key-cmd-on? key) cmd?)
(and (key-cmd-off? key) (not cmd?))
(and (not (key-cmd-on? key)) (not (key-cmd-off? key))))
(or (and (key-caps-on? key) caps?)
(and (key-caps-off? key) (not caps?))
(and (not (key-caps-on? key)) (not (key-caps-off? key))))
(eq? (key-seqprefix key) prefix))
(let ([score (+ (key-score key)
(if (eqv? (key-code key) code)
0
(if (eqv? (key-code key) other-alt-code)
-4
-2)))])
(if (score . > . best-score)
(values key score)
(values best-key best-score)))
(values best-key best-score))))
(define/private (do-map-function code shift ctrl alt meta cmd caps check-other?
fname prev isprefix? fullset?)
;; look for existing key mapping:
(let ([key
(ormap (lambda (key)
(and (eqv? (key-code key) code)
(eq? (key-shift-on? key) (shift . > . 0))
(eq? (key-shift-off? key) (shift . < . 0))
(eq? (key-ctrl-on? key) (ctrl . > . 0))
(eq? (key-ctrl-off? key) (ctrl . < . 0))
(eq? (key-alt-on? key) (alt . > . 0))
(eq? (key-alt-off? key) (alt . < . 0))
(eq? (key-meta-on? key) (meta . > . 0))
(eq? (key-meta-off? key) (meta . < . 0))
(eq? (key-cmd-on? key) (cmd . > . 0))
(eq? (key-cmd-off? key) (cmd . < . 0))
(eq? (key-caps-on? key) (caps . > . 0))
(eq? (key-caps-off? key) (caps . < . 0))
(eq? (key-check-other? key) check-other?)
(eq? (key-seqprefix key) prev)
key))
(hash-ref keys code null))])
(if key
;; Found existing
(if (not (eq? isprefix? (key-isprefix? key)))
;; prefix vs no-prefix mismatch:
(let ([s
(string-append
(if (meta . > . 0) "m:" "")
(if (meta . < . 0) "~m:" "")
(if (cmd . > . 0) "d:" "")
(if (cmd . < . 0) "~d:" "")
(if (alt . > . 0) "a:" "")
(if (alt . < . 0) "~a:" "")
(if (ctrl . > . 0) "c:" "")
(if (ctrl . < . 0) "~c:" "")
(if (shift . > . 0) "s:" "")
(if (shift . < . 0) "~s:" "")
(or (hash-ref rev-keylist code)
(format "~c" code)))])
(error (method-name 'keymap% 'map-function)
"~s is already mapped as a ~aprefix key"
s (if isprefix? "non-" "")))
(begin
(set-key-fname! key (string->immutable-string fname))
key))
;; Create new
(let ([newkey (make-key
code
(shift . > . 0) (shift . < . 0)
(ctrl . > . 0) (ctrl . < . 0)
(alt . > . 0) (alt . < . 0)
(meta . > . 0) (meta . < . 0)
(cmd . > . 0) (cmd . < . 0)
(caps . > . 0) (caps . < . 0)
(+ (if (shift . > . 0) 1 0)
(if (shift . < . 0) 5 0)
(if (ctrl . > . 0) 1 0)
(if (ctrl . < . 0) 5 0)
(if (alt . > . 0) 1 0)
(if (alt . < . 0) 5 0)
(if (meta . > . 0) 1 0)
(if (meta . < . 0) 5 0)
(if (cmd . > . 0) 1 0)
(if (cmd . < . 0) 5 0)
(if (caps . > . 0) 1 0)
(if (caps . < . 0) 5 0)
(if check-other? 6 30))
check-other?
fullset?
(string->immutable-string fname)
isprefix?
prev)])
(hash-set! keys code (cons newkey (hash-ref keys code null)))
newkey))))
(define/private (get-code str)
(let ([code (hash-ref keylist (string-downcase str) #f)])
(if code
(values code (member str '("leftbuttonseq"
"middlebuttonseq"
"rightbuttonseq")))
(if (= 1 (string-length str))
(values (string-ref str 0)
#f)
(values #f #f)))))
(def/public (map-function [string? keys]
[string? fname])
(if (string=? keys "")
(error (method-name 'keymap% 'map-function)
"bad key string: ~e"
keys)
(let loop ([seq (regexp-split #rx";" keys)]
[prev-key #f])
(let ([str (car seq)])
(define (bad-string msg)
(error (method-name 'keymap% 'map-function)
"bad keymap string: ~e~a: ~a"
str
(if (equal? str keys)
""
(format " within ~e" keys))
msg))
(let-values ([(str default-off?)
(if (regexp-match? #rx"^:" str)
(values (substring str 1) #t)
(values str #f))])
(let sloop ([str str]
[downs null]
[ups null]
[others? #f])
(cond
[(regexp-match? #rx"^[?]:" str)
(sloop (substring str 2) downs ups #t)]
[(regexp-match? #rx"^~[SsCcAaMmDdLl]:" str)
(let ([c (char-downcase (string-ref str 1))])
(if (memv c downs)
(bad-string (format "inconsistent ~a: modifier state" c))
(sloop (substring str 3) downs (cons c ups) others?)))]
[(regexp-match? #rx"^[SsCcAaMmDdLl]:" str)
(let ([c (char-downcase (string-ref str 0))])
(if (memv c ups)
(bad-string (format "inconsistent ~a: modifier state" c))
(sloop (substring str 2) (cons c downs) ups others?)))]
[else
(let-values ([(code fullset?) (get-code str)])
(if (not code)
(bad-string "unrecognized key name")
(let-values ([(downs code)
(if (and (char? code)
((char->integer code) . > . 0)
((char->integer code) . < . 127)
(char-alphabetic? code))
(cond
[(memq #\s downs)
(if (or (and (eq? (system-type) 'macosx)
(not (memq #\m downs))
(not (memq #\d downs)))
(and (eq? (system-type) 'windows)
(or (not (memq #\c downs))
(memq #\m downs))))
(values downs (char-upcase code))
(values downs code))]
[(char-upper-case? code)
(values (cons #\s downs) code)]
[else
(values downs code)])
(values downs code))])
(let ([newkey
(let ([modval (lambda (c)
(cond
[(memq c downs) 1]
[(memq c ups) -1]
[else (if default-off? -1 0)]))])
(do-map-function code
(modval #\s)
(modval #\c)
(modval #\a)
(modval #\m)
(modval #\d)
(modval #\l)
others?
fname
prev-key
(not (null? (cdr seq)))
fullset?))])
(if (null? (cdr seq))
(void)
(loop (cdr seq) newkey))))))])))))))
(define/private (handle-event code other-code alt-code other-alt-code caps-code
shift? ctrl? alt? meta? cmd? caps?
score)
(let-values ([(key found-score)
(find-key code other-code alt-code other-alt-code caps-code
shift? ctrl? alt? meta? cmd? caps? prefix)])
(set! prefix #f)
(if (and key (found-score . >= . score))
(if (key-isprefix? key)
(begin
(set! prefix key)
(values #t #f #f))
(values #t
(key-fname key)
(key-fullset? key)))
(values #f #f #f))))
(define/public (get-best-score code other-code alt-code other-alt-code caps-code
shift? ctrl? alt? meta? cmd? caps?)
(let-values ([(key score)
(find-key code other-code alt-code other-alt-code caps-code
shift? ctrl? alt? meta? cmd? caps? prefix)])
(for/fold ([s (if key score -1)])
([c (in-list chain-to)])
(max s
(send c get-best-score code other-code alt-code other-alt-code caps-code
shift? ctrl? alt? meta? cmd? caps?)))))
(def/public (set-grab-key-function [(make-procedure 4) grab])
(set! grab-key-function grab))
(def/public (remove-grab-key-function)
(set! grab-key-function #f))
(def/public (handle-key-event [any? obj] [key-event% event])
(let ([code (send event get-key-code)])
(or (eq? code 'shift)
(eq? code 'control)
(eq? code 'release)
(let ([score (get-best-score
code
(send event get-other-shift-key-code)
(send event get-other-altgr-key-code)
(send event get-other-shift-altgr-key-code)
(send event get-other-caps-key-code)
(send event get-shift-down)
(send event get-control-down)
(send event get-alt-down)
(as-meta-key (send event get-meta-down))
(as-cmd-key (send event get-meta-down))
(send event get-caps-down))])
(let ([was-prefixed? prefixed?])
(let* ([r (chain-handle-key-event obj event #f prefixed? score)]
[r (if (and (zero? r)
was-prefixed?)
(begin
(reset)
;; try again without prefix:
(chain-handle-key-event obj event #f #f score))
r)])
(when (r . >= . 0)
(reset))
(not (zero? r))))))))
(define/private (other-handle-key-event obj event grab try-prefixed? score)
(for/fold ([r 0])
([c (in-list chain-to)]
#:when (r . <= . 0))
(let ([r2 (send c chain-handle-key-event obj event grab try-prefixed? score)])
(if (r2 . > . 0)
(begin
(reset)
r2)
(if (r2 . < . 0)
r2
r)))))
(define/public (chain-handle-key-event obj event grab only-prefixed? score)
;; results: 0 = no match, 1 = match, -1 = matched prefix
(set! last-time (send event get-time-stamp))
(set! last-button #f)
(let ([grab (or grab-key-function
grab)])
(if (and only-prefixed? (not prefixed?))
0
(let ([sub-result (other-handle-key-event obj event grab only-prefixed? score)])
(if (sub-result . > . 0)
sub-result
(let-values ([(h? fname fullset?)
(handle-event (send event get-key-code)
(send event get-other-shift-key-code)
(send event get-other-altgr-key-code)
(send event get-other-shift-altgr-key-code)
(send event get-other-caps-key-code)
(send event get-shift-down)
(send event get-control-down)
(send event get-alt-down)
(as-meta-key (send event get-meta-down))
(as-cmd-key (send event get-meta-down))
(send event get-caps-down)
score)])
(if h?
(if fname
(begin
(reset)
(if (and grab
(grab fname this obj event))
1
(if (call-function fname obj event)
1
0)))
(if prefix
(begin
(set! prefixed? #t)
-1)
;; shouldn't get here
0))
(let ([result
(if (sub-result . < . 0)
(begin
(set! prefixed? #t)
-1)
0)])
(if (and (zero? result)
grab-key-function
(grab-key-function #f this obj event))
1
result)))))))))
(def/public (set-grab-mouse-function [(make-procedure 4) grab])
(set! grab-mouse-function grab))
(def/public (remove-grab-mouse-function)
(set! grab-mouse-function #f))
(define/private (adjust-button-code code click-count)
(case click-count
[(0) code]
[(1) (case code
[(mouse-right) 'mouse-right-double]
[(mouse-left) 'mouse-left-double]
[(mouse-middle) 'mouse-middle-double])]
[else (case code
[(mouse-right) 'mouse-right-triple]
[(mouse-left) 'mouse-left-triple]
[(mouse-middle) 'mouse-middle-triple])]))
(def/public (handle-mouse-event [any? obj][mouse-event% event])
(let ([score (get-best-mouse-score event)])
(not (zero? (chain-handle-mouse-event obj event #f 0 score)))))
(define/public (get-best-mouse-score event)
(cond
[(not (send event button-down?))
(if active-mouse-function
100
(or (ormap (lambda (c)
(and (not (zero? (send c get-best-mouse-score event)))
100))
chain-to)
-1))]
[else
(let ([code (cond
[(send event get-right-down) 'mouse-right]
[(send event get-left-down) 'mouse-left]
[(send event get-middle-down) 'mouse-middle]
[else #f])])
(if (not code)
-1
(let ([code
(if (and (eq? code last-button)
(= (send event get-x) last-x)
(= (send event get-y) last-y)
((abs (- (send event get-time-stamp) last-time)) . < . double-interval))
(adjust-button-code code click-count)
code)])
(get-best-score code #f #f #f #f
(send event get-shift-down)
(send event get-control-down)
(send event get-alt-down)
(as-meta-key (send event get-meta-down))
(as-cmd-key (send event get-meta-down))
(send event get-caps-down)))))]))
(define/private (other-handle-mouse-event obj event grab try-state score)
(for/fold ([result 0])
([c (in-list chain-to)]
#:when (result . <= . 0))
(let ([r (send c chain-handle-mouse-event obj event grab try-state score)])
(cond
[(r . > . 0)
(reset)
r]
[(zero? r) result]
[else r]))))
(define/public (chain-handle-mouse-event obj event grab try-state score)
(let ([grab (or grab-mouse-function grab)])
(define (step1)
(cond
[(and (not prefix)
(try-state . >= . 0))
(let ([r (other-handle-mouse-event obj event grab 1 score)])
(cond
[(r . > . 0) r]
[(try-state . > . 0) r]
[else (step2 -1)]))]
[(and prefix (try-state . < . 0))
(other-handle-mouse-event obj event grab -1 score)]
[else (step2 try-state)]))
(define (step2 try-state)
(cond
[(not (send event button-down?))
(when (and (not (send event dragging?))
(not (send event button-up?)))
;; we must have missed the button-up
(set! active-mouse-function #f))
(if (not active-mouse-function)
(other-handle-mouse-event obj event grab -1 score)
(let ([v (if (and grab
(grab active-mouse-function this obj event))
1
(if (call-function active-mouse-function obj event)
1
0))])
(when (send event button-up?)
(set! active-mouse-function #f))
v))]
[else
(let ([code (cond
[(send event get-right-down) 'mouse-right]
[(send event get-left-down) 'mouse-left]
[(send event get-middle-down) 'mouse-middle]
[else #f])])
(if (not code)
0 ;; FIXME: should we call grab here?
(let ([orig-code code]
[code
(if (and (eq? code last-button)
(= (send event get-x) last-x)
(= (send event get-y) last-y))
(if ((abs (- (send event get-time-stamp) last-time)) . < . double-interval)
(begin0
(adjust-button-code code click-count)
(set! click-count (add1 click-count)))
(begin
(set! click-count 1)
code))
(begin
(set! last-button code)
(set! click-count 1)
code))])
(set! last-time (send event get-time-stamp))
(set! last-x (send event get-x))
(set! last-y (send event get-y))
(let loop ([code code])
(let-values ([(h? fname fullset?) (handle-event code
#f #f #f #f
(send event get-shift-down)
(send event get-control-down)
(send event get-alt-down)
(as-meta-key (send event get-meta-down))
(as-cmd-key (send event get-meta-down))
(send event get-caps-down)
score)])
(cond
[(and h? fname)
(reset)
(when fullset?
(set! active-mouse-function fname))
(cond
[(and grab (grab fname this obj event)) 1]
[(call-function fname obj event) 1]
[else 0])]
[h?
(let ([r (other-handle-mouse-event obj event grab try-state score)])
(if (r . > . 0)
r
-1))]
[else
(set! last-code code)
(if (not (eqv? last-code orig-code))
(loop orig-code)
(let ([result (other-handle-mouse-event obj event grab try-state score)])
(if (and (zero? result)
grab-mouse-function
(grab-mouse-function #f this obj event))
1
result)))]))))))]))
(step1)))
(def/public (add-function [string? name] [(make-procedure 2) f])
(hash-set! functions
(string->immutable-string name)
f))
(def/public (call-function [string? name] [any? obj] [event% event] [any? [try-chained? #f]])
(let ([f (hash-ref functions name #f)])
(cond
[f
(f obj event)
#t]
[try-chained?
(ormap (lambda (c)
(send c call-function name obj event #t))
chain-to)]
[else
(error 'keymap "no function ~e" name)])))
(def/public (get-double-click-interval)
double-interval)
(def/public (set-double-click-interval [exact-positive-integer? d])
(set! double-interval d))
(define/public (cycle-check km)
(ormap (lambda (c)
(or (eq? km c)
(send c cycle-check km)))
chain-to))
(def/public (chain-to-keymap [keymap% km] [any? prefix?])
(unless (or (eq? km this)
(cycle-check km)
(send km cycle-check this))
(set! chain-to (if prefix?
(cons km chain-to)
(append chain-to (list km))))))
(def/public (remove-chained-keymap [keymap% km])
(set! chain-to (remq km chain-to))))

1192
collects/mred/private/wxme/mline.ss Normal file
View File

File diff suppressed because it is too large Load Diff

2124
collects/mred/private/wxme/pasteboard.ss Normal file
View File

File diff suppressed because it is too large Load Diff

142
collects/mred/private/wxme/private.ss Normal file
View File

@ -0,0 +1,142 @@
#lang scheme/base
(require scheme/class)
(provide (all-defined-out))
;; snip% and editor%
(define-local-member-name
s-admin)
;; snip%
(define-local-member-name
s-prev set-s-prev
s-next set-s-next
s-count
s-style set-s-style
s-line set-s-line
s-snipclass set-s-snipclass
s-flags set-s-flags
s-dtext get-s-dtext
s-buffer get-s-buffer
str-w set-str-w
s-set-flags
do-copy-to)
;; string-snip%
(define-local-member-name
insert-with-offset)
;; snip-class%
(define-local-member-name
get-s-required?
s-read)
;; editor-data%
(define-local-member-name
get-s-dataclass
get-s-next)
;; standard-snip-class-list%, editor-data-class-list%
(define-local-member-name
reset-header-flags
find-by-map-position)
;; editor%
(define-local-member-name
s-offscreen
s-custom-cursor
s-custom-cursor-overrides?
s-keymap
s-style-list
get-s-style-list
s-user-locked?
s-modified?
s-noundomode
s-caret-snip
s-inactive-caret-threshold
s-filename
s-need-on-display-size?
really-can-edit?
copy-out-x-selection
own-x-selection
do-own-x-selection
perform-undo-list
copy-ring-next
begin-copy-buffer
end-copy-buffer
free-old-copies
install-copy-buffer
add-undo-rec
read-snips-from-file
admin-scroll-to
do-buffer-paste
insert-paste-snip
insert-paste-string
paste-region-data
setting-admin
init-new-admin
do-read-insert
do-set-caret-owner
do-own-caret
s-start-intercept
s-end-intercept
wait-sequence-lock
begin-sequence-lock
end-sequence-lock
check-flow
get-printing
is-printing?
do-begin-print
do-end-print
do-has-print-page?)
;; text%
(define-local-member-name
get-s-line-spacing
get-s-last-snip
get-s-total-width
get-s-total-height
refresh-box
add-back-clickback
do-insert-snips)
;; editor-admin%
(define-local-member-name
get-s-standard
set-s-standard)
;; editor-canvas-editor-admin%
(define-local-member-name
do-get-canvas
do-scroll-to)
;; editor-stream%
(define-local-member-name
get-sl
get-dl
set-sl
set-dl
add-sl
add-dl
set-s-sll
get-s-sll
get-s-scl
get-s-bdl
get-s-style-count
set-s-style-count
do-reading-version
do-map-position
do-get-header-flag
do-set-header-flag)
;; editor-stream-in%
(define-local-member-name
set-s-read-format
get-s-read-format
set-s-read-version
get-wxme-version)
;; editor-snip%
(define-local-member-name
do-set-graphics)

147
collects/mred/private/wxme/snip-admin.ss Normal file
View File

@ -0,0 +1,147 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"snip.ss"
(only-in "cycle.ss"
set-snip-admin%!
popup-menu%)
"wx.ss")
(provide snip-admin%
standard-snip-admin%)
(defclass snip-admin% object%
(super-new)
(def/public (get-editor) #f)
(def/public (get-dc) #f)
(def/public (get-view-size [maybe-box? w] [maybe-box? h])
#f)
(def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h]
[(make-or-false snip%) [snip #f]])
#f)
(def/public (scroll-to [snip% s]
[real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h]
[any? refresh?]
[(symbol-in start end none) [bias 'none]])
#f)
(def/public (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist])
(void))
(def/public (resized [snip% s] [any? redraw?]) (void))
(def/public (recounted [snip% s] [any? redraw?]) (void))
(def/public (needs-update [snip% s] [real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h])
(void))
(def/public (release-snip [snip% s]) #f)
(def/public (update-cursor) (void))
(def/public (popup-menu [popup-menu% p][snip% snip][real? x][real? y])
#f)
(def/public (modified [snip% s] [any? modified?])
(void)))
(set-snip-admin%! snip-admin%)
(defclass standard-snip-admin% snip-admin%
(init-field editor)
(super-new)
(def/override (get-editor) editor)
(def/override (get-dc) (send editor get-dc))
(def/override (get-view-size [maybe-box? w] [maybe-box? h])
(get-view #f #f w h #f))
(def/override (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h]
[(make-or-false snip%) snip])
(let ([admin (send editor get-admin)]
[zeros (lambda ()
(when x (set-box! x 0.0))
(when y (set-box! y 0.0))
(when w (set-box! w 0.0))
(when h (set-box! h 0.0)))])
(if snip
(if admin
(let-boxes ([mx 0.0] [my 0.0]
[mw 0.0] [mh 0.0])
(send admin get-view mx my mw mh #f)
(let ([mb (+ my mh)]
[mr (+ mx mw)])
(let-boxes ([ok? #f]
[sl 0.0]
[st 0.0])
(set-box! ok? (send editor get-snip-location snip sl st #f))
(if ok?
(let-boxes ([sr 0.0][sb 0.0])
(send editor get-snip-location snip sr sb #t)
(let ([l (max mx sl)]
[t (max my st)]
[r (min mr sr)]
[b (min mb sb)])
(when x (set-box! x (- l sl)))
(when y (set-box! y (- t st)))
(when w (set-box! w (max 0 (- r l))))
(when h (set-box! h (max 0 (- b t))))))
(zeros)))))
(zeros))
(if admin
(send admin get-view x y w h #t)
(zeros)))))
(def/override (scroll-to [snip% s]
[real? localx] [real? localy]
[nonnegative-real? w] [nonnegative-real? h]
[any? [refresh? #t]]
[(symbol-in start end none) [bias 'none]])
(and (eq? (send s get-admin) this)
(send editor scroll-to s localx localy w h refresh? bias)))
(def/override (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist])
(when (eq? (send s get-admin) this)
(send editor set-caret-owner s dist)))
(def/override (resized [snip% s] [any? redraw?])
(when (eq? (send s get-admin) this)
(send editor resized s redraw?)))
(def/override (recounted [snip% s] [any? redraw?])
(when (eq? (send s get-admin) this)
(send editor recounted s redraw?)))
(def/override (needs-update [snip% s] [real? localx] [real? localy]
[nonnegative-real? w] [nonnegative-real? h])
(when (eq? (send s get-admin) this)
(send editor needs-update s localx localy w h)))
(def/override (release-snip [snip% s])
(and (eq? (send s get-admin) this)
(send editor release-snip s)))
(def/override (update-cursor)
(let ([admin (send editor get-admin)])
(when admin
(send admin update-cursor))))
(def/override (popup-menu [popup-menu% m][snip% snip][real? x][real? y])
(let ([admin (send editor get-admin)])
(and admin
(let-boxes ([sl 0.0]
[st 0.0]
[ok? #f])
(set-box! ok? (send editor get-snip-location snip sl st #f))
(and ok?
(send admin popup-menu m (+ x sl) (+ y st)))))))
(def/override (modified [snip% s] [any? modified?])
(when (eq? (send s get-admin) this)
(send editor on-snip-modified s modified?))))

786
collects/mred/private/wxme/stream.ss Normal file
View File

@ -0,0 +1,786 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"private.ss"
"snip.ss"
(only-in "cycle.ss"
set-editor-stream-in%!
set-editor-stream-out%!))
(provide editor-stream-in%
editor-stream-out%
editor-stream-in-base%
editor-stream-in-bytes-base%
editor-stream-in-file-base%
editor-stream-out-base%
editor-stream-out-bytes-base%
editor-stream-out-file-base%)
;; ----------------------------------------
(defclass editor-stream% object%
(super-new)
(define scl (get-the-snip-class-list))
(define bdl (get-the-editor-data-class-list))
(define/public (get-s-scl) scl)
(define/public (get-s-bdl) bdl)
(define sl null)
(define dl null)
(define/public (get-sl) sl)
(define/public (get-dl) dl)
(define/public (set-sl n) (set! sl n))
(define/public (set-dl n) (set! dl n))
(define/public (add-sl v) (set! sl (cons v sl)))
(define/public (add-dl v) (set! dl (cons v dl)))
(define sll null)
(define style-count 0)
(define/public (get-s-sll) sll)
(define/public (set-s-sll v) (set! sll v))
(define/public (get-s-style-count) style-count)
(define/public (set-s-style-count v) (set! style-count v))
(define/public (do-reading-version sclass)
(or (ormap (lambda (scl)
(and (eq? (snip-class-link-c scl) sclass)
(snip-class-link-reading-version scl)))
sl)
;; Class didn't show up in the header?
;; Assume we're reading the current version.
(send sclass get-version)))
(define/public (do-map-position sclass-or-dclass)
(if (sclass-or-dclass . is-a? . snip-class%)
(or (ormap (lambda (scl)
(and (eq? (snip-class-link-c scl) sclass-or-dclass)
(snip-class-link-map-position scl)))
sl)
-1)
(or (ormap (lambda (dcl)
(and (eq? (editor-data-class-link-c dcl) sclass-or-dclass)
(editor-data-class-link-map-position dcl)))
dl)
-1)))
(define/public (do-get-header-flag sclass)
(or (ormap (lambda (scl)
(and (eq? (snip-class-link-c scl) sclass)
(snip-class-link-header-flag scl)))
sl)
0))
(define/public (do-set-header-flag sclass)
(ormap (lambda (scl)
(and (eq? (snip-class-link-c scl) sclass)
(begin
(set-snip-class-link-header-flag! scl #t)
#t)))
sl)
(void)))
;; ----------------------------------------
(defclass editor-stream-in-base% object%
(super-new)
(def/public (tell) 0)
(def/public (seek [exact-nonnegative-integer? i]) (void))
(def/public (skip [exact-nonnegative-integer? i]) (void))
(def/public (bad?) #t)
(def/public (read [vector? v])
(let ([s (make-bytes (vector-length v))])
(let ([n (read-bytes s)])
(for ([i (in-range n)])
(vector-set! v i (integer->char (bytes-ref s i))))
n)))
(def/public (read-bytes [bytes? v]
[exact-nonnegative-integer? [start 0]]
[exact-nonnegative-integer? [end (bytes-length v)]])
0)
(def/public (read-byte)
(let ([s (make-bytes 1)])
(and (= 1 (read-bytes s 0 1))
(bytes-ref s 0)))))
(defclass editor-stream-out-base% object%
(super-new)
(def/public (tell) 0)
(def/public (seek [exact-nonnegative-integer? i]) (void))
(def/public (skip [exact-nonnegative-integer? i]) (void))
(def/public (bad?) #t)
(def/public (write [(make-list char?) v])
(write-bytes (string->bytes/latin-1 (list->string v) (char->integer #\?))))
(def/public (write-bytes [bytes? v]
[exact-nonnegative-integer? [start 0]]
[exact-nonnegative-integer? [end (bytes-length v)]])
(void)))
;; ----------------------------------------
(define mz:read-byte read-byte)
(defclass editor-stream-in-port-base% editor-stream-in-base%
(init-field port)
(super-new)
(def/override (tell)
(file-position port))
(def/override (seek [exact-nonnegative-integer? i])
(file-position port i))
(def/override (skip [exact-nonnegative-integer? i])
(file-position port (+ i (file-position port))))
(def/override (bad?) #f)
(def/override (read-bytes [bytes? v]
[exact-nonnegative-integer? [start 0]]
[exact-nonnegative-integer? [end (bytes-length v)]])
(let ([r (read-bytes! v port start end)])
(if (eof-object? r)
0
r)))
(def/override (read-byte)
(let ([v (mz:read-byte port)])
(if (eof-object? v) #f v))))
(defclass editor-stream-in-file-base% editor-stream-in-port-base%
(super-new))
(defclass editor-stream-in-bytes-base% editor-stream-in-port-base%
(init s)
(super-new [port (open-input-bytes s)]))
;; ----------------------------------------
(define write-bytes-proc write-bytes)
(defclass editor-stream-out-port-base% editor-stream-out-base%
(init-field port)
(super-new)
(def/override (tell)
(file-position port))
(def/override (seek [exact-nonnegative-integer? i])
(file-position port i))
(def/override (skip [exact-nonnegative-integer? i])
(file-position port (+ i (file-position port))))
(def/override (bad?) #f)
(def/override (write-bytes [bytes? v]
[exact-nonnegative-integer? [start 0]]
[exact-nonnegative-integer? [end (bytes-length v)]])
(write-bytes-proc v port start end)))
(defclass editor-stream-out-file-base% editor-stream-out-port-base%
(super-new))
(defclass editor-stream-out-bytes-base% editor-stream-out-port-base%
(define s (open-output-bytes))
(super-new [port s])
(def/public (get-bytes)
(get-output-bytes s)))
;; ----------------------------------------
(define in-read-byte (generic editor-stream-in-base% read-byte))
(defclass editor-stream-in% editor-stream%
(init-rest args)
(define f
(case-args
args
[([editor-stream-in-base% base]) base]
(init-name 'editor-stream-in%)))
(define boundaries null)
(define is-bad? #f)
(define items 0)
(define pos-map (make-hash))
(define read-version 8)
(define s-read-version #"08")
(super-new)
(define/public (set-s-read-version bstr)
(set! s-read-version bstr)
(set! read-version (or (string->number (bytes->string/utf-8 bstr)) 0)))
(define/public (get-wxme-version) read-version)
(define s-read-format #"WXME")
(define/public (set-s-read-format bstr)
(set! s-read-format bstr))
(define/public (get-s-read-format)
s-read-format)
(define/private (do-skip-whitespace)
(define (bad!) (set! is-bad? #t) 0)
(if is-bad?
0
(let loop ([prev-byte 0])
(let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!)
(case (integer->char b)
[(#\#)
(let ([pos (send f tell)]
[b (send-generic f in-read-byte)])
(if (and b
(= b (char->integer #\|)))
;; skip to end of comment
(let cloop ([saw-bar? #f]
[saw-hash? #f]
[nesting 0])
(let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!)
(cond
[(and saw-bar? (= b (char->integer #\#)))
(if (zero? nesting)
(loop (char->integer #\space))
(cloop #f #f (sub1 nesting)))]
[(and saw-hash? (= b (char->integer #\|)))
(cloop #t #f (add1 nesting))]
[else (cloop (= b (char->integer #\|))
(= b (char->integer #\#))
nesting)]))))
(begin
(send f seek pos)
(char->integer #\#))))]
[(#\;)
;; skip to end of comment
(let cloop ()
(let ([b (send-generic f in-read-byte)])
(if (not b)
(bad!)
(if (or (= b (char->integer #\newline))
(= b (char->integer #\return)))
(loop (char->integer #\space))
(cloop)))))]
[else
(if (char-whitespace? (integer->char b))
(loop b)
b)]))))))
(define/private (skip-whitespace [buf #f])
(let ([c (do-skip-whitespace)])
(when buf
(bytes-set! buf 0 c))
c))
(define/private (is-delim? b)
(cond
[(char-whitespace? (integer->char b)) #t]
[(= b (char->integer #\#))
(let ([pos (send f tell)]
[b (send-generic f in-read-byte)])
(let ([d? (= b (char->integer #\|))])
(send f seek (if d? (sub1 pos) pos))
d?))]
[(= b (char->integer #\;))
(send f seek (sub1 (send f tell)))
#t]
[else #f]))
(define/private (get-number get-exact?)
(let ([c0 (skip-whitespace)])
(if (check-boundary)
(if get-exact? 0 0.0)
(let* ([l
;; As fast path, accum integer result
(let loop ([counter 50][c c0][v 0])
(if (zero? counter)
null
(if (or (not c)
(is-delim? c))
(or v null)
(let ([rest (loop (sub1 counter)
(send-generic f in-read-byte)
(and v
(c . >= . (char->integer #\0))
(c . <= . (char->integer #\9))
(+ (* v 10) (- c (char->integer #\0)))))])
(if (exact-integer? rest)
rest
(cons (integer->char c) rest))))))])
(inc-item-count)
(let ([n (if (exact-integer? l)
l
(string->number (list->string l)))])
(cond
[(and get-exact? (exact-integer? n)) n]
[(real? n) (exact->inexact n)]
[else
(set! is-bad? #t)
(if get-exact? 0 0.0)]))))))
(define/private (get-a-string limit recur?)
(let* ([orig-len (if recur?
(if (limit . < . 16)
limit
16)
(let ([v (get-exact)])
(if (check-boundary)
0
v)))]
[buf (make-bytes 32)]
[fail (lambda ()
(set! is-bad? #t)
#"")])
(if recur?
(bytes-set! buf 0 (char->integer #\#))
(begin
(skip-whitespace buf)
(when is-bad?
(bytes-set! buf 0 0))))
(cond
[(= (bytes-ref buf 0) (char->integer #\#))
(if (and (= (send f read-bytes buf 1 2) 1)
(= (bytes-ref buf 1) (char->integer #\")))
(let-values ([(si s) (make-pipe)]
[(tmp) (make-bytes (+ orig-len 2))])
(display "#\"" s)
(let loop ([get-amt (add1 orig-len)]) ;; add 1 for closing quote
(let ([got-amt (send f read-bytes tmp 0 get-amt)])
(if (not (= got-amt get-amt))
(fail)
(begin
(write-bytes tmp s 0 got-amt)
(let ([done?
(let loop ([i 0])
(cond
[(= i got-amt) #f]
[(= (bytes-ref tmp i) (char->integer #\")) #t]
[(= (bytes-ref tmp i) (char->integer #\\))
(if (= (add1 i) got-amt)
;; need to read escaped character
(if (not (= (send f read-bytes tmp got-amt (add1 got-amt)) 1))
(fail)
(begin
(write-bytes tmp s got-amt (add1 got-amt))
#f))
(loop (+ i 2)))]
[else (loop (+ i 1))]))])
(if done?
(begin
(close-output-port s)
(unless recur? (inc-item-count))
(let ([s (with-handlers ([exn:fail:read? (lambda (x) #f)])
(read si))])
(if (or (not s)
(not (eof-object? (read-byte si))))
(fail)
(if (if recur?
((bytes-length s) . <= . limit)
(= (bytes-length s) orig-len))
s
(fail)))))
(loop 1))))))))
(fail))]
[(and (not recur?) (= (bytes-ref buf 0) (char->integer #\()))
;; read a sequence of strings
(let loop ([accum null]
[left-to-get orig-len])
(skip-whitespace buf)
(if (or is-bad?
(negative? left-to-get))
(fail)
(cond
[(= (bytes-ref buf 0) (char->integer #\)))
;; got all byte strings
(if (zero? left-to-get)
(begin
(inc-item-count)
(apply bytes-append (reverse accum)))
(fail))]
[(= (bytes-ref buf 0) (char->integer #\#))
(let ([v (get-a-string left-to-get #t)])
(if is-bad?
(fail)
(loop (cons v accum)
(- left-to-get (bytes-length v)))))]
[else (fail)])))]
[else (fail)])))
(define/private (inc-item-count)
(set! items (add1 items))
(tell))
(define/private (skip-one recur?)
(let ([buf (make-bytes 1)]
[fail (lambda () (set! is-bad? #t) (void))]
[success (lambda () (unless recur? (inc-item-count)))])
(if recur?
(bytes-set! buf 0 (char->integer #\#))
(skip-whitespace buf))
(unless is-bad?
(cond
[(= (bytes-ref buf 0) (char->integer #\#))
;; byte string
(if (and (= 1 (send f read-bytes buf))
(= (bytes-ref buf 0) (char->integer #\")))
(let loop ()
(if (= 1 (send f read-bytes buf))
(cond
[(= (bytes-ref buf 0) (char->integer #\\))
(if (= 1 (send f read-bytes buf))
(loop)
(fail))]
[(= (bytes-ref buf 0) (char->integer #\"))
(success)]
[else (loop)])
(fail)))
(fail))]
[(= (bytes-ref buf 0) (char->integer #\)))
;; list of byte strings
(let loop ()
(if is-bad?
(fail)
(if (not (= (send f read-bytes buf) 1))
(fail)
(if (is-delim? (bytes-ref buf 0))
(cond
[(= (bytes-ref buf 0) (char->integer #\)))
(success)]
[(= (bytes-ref buf 0) (char->integer #\#))
(skip-one #t)
(loop)]
[else (fail)])
(loop)))))]
[else
;; number -- skip anything delimited
(let loop ()
(if (not (= (send f read-bytes buf) 1))
(fail)
(if (is-delim? (bytes-ref buf 0))
(success)
(loop))))]))))
(def/public (get-fixed-exact)
(if (check-boundary)
0
(if (read-version . < . 8)
(let ([buf (make-bytes 4)])
(send f read-bytes buf)
(integer-bytes->integer
buf
#t
(if (= read-version 1)
(system-big-endian?)
#t)))
(get-exact))))
(def/public (get-fixed [box? vb])
(set-box! vb (get-fixed-exact)))
#|
integer format specified by first byte:
bit 8: 0 - read 7-bit (positive) number
bit 8: 1 - ...
bit 7: 0 - read abother byte for 15-bit (positive) number
bit 7: 1 - negative and long numbers...
bit 1: 1 - read another 8-bit (signed) number
bit 1: 0 - ...
bit 2: 1 - read another 16-bit (signed) number
bit 2: 0 - read another 32-bit (signed) number
|#
(def/public (get-exact)
(if (check-boundary)
0
(if (read-version . < . 8)
(let ([buf (make-bytes 4)]
[fail (lambda () (set! is-bad? #t) 0)])
(if (not (= 1 (send f read-bytes buf 0 1)))
(fail)
(let ([b (bytes-ref buf 0)])
(if (positive? (bitwise-and b #x80))
(if (positive? (bitwise-and b #x40))
(cond
[(positive? (bitwise-and b #x01))
(if (= 1 (send f read-bytes buf 0 1))
(let ([b (bytes-ref buf 0)])
(if (b . > . 127)
(- b 256)
b))
(fail))]
[(positive? (bitwise-and b #x02))
(if (= 2 (send f read-bytes buf 0 2))
(integer-bytes->integer b #t #t)
(fail))]
[else
(if (= 4 (send f read-bytes buf 0 2))
(integer-bytes->integer buf #t #t)
(fail))])
(if (= 1 (send f read-bytes buf 0 1))
(+ (arithmetic-shift (bitwise-and b #x3F) 8)
(bytes-ref buf 0))
(fail)))
b))))
(get-number #t))))
(def/public (get-inexact)
(if (check-boundary)
0
(if (read-version . < . 8)
(let ([buf (make-bytes 8)])
(send f read-bytes buf)
(floating-point-bytes->real
buf
(if (= read-version 1)
(system-big-endian?)
#t)))
(get-number #f))))
(define/private (do-get-bytes)
(if (check-boundary)
#""
(if (read-version . < . 8)
(let* ([len (get-exact)]
[s (make-bytes len)])
(send f read-bytes s)
s)
(get-a-string #f #f))))
(def/public (get-bytes [maybe-box? [len #f]])
(let ([s (do-get-bytes)])
(when len
(set-box! len (max 1 (bytes-length s))))
(subbytes s 0 (max 0 (sub1 (bytes-length s))))))
(def/public (get-unterminated-bytes [maybe-box? [len #f]])
(let ([s (do-get-bytes)])
(when len
(set-box! len (bytes-length s)))
s))
(def/public (get-unterminated-bytes! [(make-box exact-nonnegative-integer?) len]
[(lambda (s) (and (bytes? s) (not (immutable? s)))) s])
(let ([s2 (do-get-bytes)])
(if ((bytes-length s2) . <= . (unbox len))
(begin
(bytes-copy! s 0 s2)
(set-box! len (bytes-length s2)))
(set! is-bad? #t))))
(def/public (get [(make-box real?) b])
(unless (check-boundary)
(if (exact-integer? (unbox b))
(set-box! b (get-exact))
(set-box! b (get-inexact)))))
(def/public (set-boundary [exact-nonnegative-integer? n])
(set! boundaries (cons (+ (tell) n) boundaries)))
(def/public (remove-boundary)
(set! boundaries (cdr boundaries)))
(define/private (check-boundary)
(if is-bad?
#t
(cond
[(and (pair? boundaries)
(items . >= . (car boundaries)))
(set! is-bad? #t)
(error 'editor-stream-in%
"overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))]
[(send f bad?)
(set! is-bad? #t)
(error 'editor-stream-in% "stream error")]
[else #f])))
(def/public (skip [exact-nonnegative-integer? n])
(if (read-version . < . 8)
(send f skip n)
(jump-to (+ n items))))
(def/public (tell)
(if (read-version . < . 8)
(send f tell)
(let ([pos (send f tell)])
(when (not (equal? (hash-ref pos-map items pos) pos))
(error "again"))
(hash-set! pos-map items pos)
items)))
(def/public (jump-to [exact-nonnegative-integer? pos])
(if (read-version . < . 8)
(send f seek pos)
(let ([p (hash-ref pos-map pos #f)])
(if (not p)
(begin
(let loop ()
(when (and (items . < . pos) (not is-bad?))
(skip-one #f)
(loop)))
(unless (= items pos)
(set! is-bad? #t)))
(begin
(send f seek p)
(set! items pos))))))
(def/public (ok?) (not is-bad?)))
(set-editor-stream-in%! editor-stream-in%)
;; ----------------------------------------
(defclass editor-stream-out% editor-stream%
(init-rest args)
(define f
(case-args
args
[([editor-stream-out-base% base]) base]
(init-name 'editor-stream-out%)))
(define is-bad? #f)
(define col 72)
(define items 0)
(define pos-map (make-hash))
(super-new)
(define/private (check-ok)
(unless is-bad?
(when (send f bad?)
(error 'editor-stream-out% "stream error"))))
(def/public (put-fixed [exact-integer? v])
(check-ok)
(let-values ([(new-col spc)
(if ((+ col 12) . > . 72)
(values 11 #"\n")
(values (+ col 12) #" "))])
(let ([s (number->string v)])
(send f
write-bytes
(bytes-append spc
(make-bytes (- 11 (string-length s)) (char->integer #\space))
(string->bytes/latin-1 s))))
(set! col new-col)
(set! items (add1 items)))
this)
(define/public (put . args)
(case-args
args
[([exact-nonnegative-integer? n][bytes? s])
(do-put-bytes (subbytes s 0 n))]
[([bytes? s])
(do-put-bytes (bytes-append s #"\0"))]
[([exact-integer? n])
(do-put-number n)]
[([real? n])
(do-put-number (exact->inexact n))]
(method-name 'editor-stream-out% 'put)))
(def/public (put-unterminated [bytes? s])
(do-put-bytes s))
(define/private (do-put-bytes orig-s)
(define (single-string)
(if ((bytes-length orig-s) . < . 72)
(let ([s (open-output-bytes)])
(write orig-s s)
(let* ([v (get-output-bytes s)]
[len (bytes-length v)])
(if (len . >= . 72)
(multiple-strings)
(begin
(if ((+ col len 1) . > . 72)
(send f write-bytes #"\n")
(send f write-bytes #" "))
(send f write-bytes v)
(set! col 72))))) ;; forcing a newline after every string makes the file more readable
(multiple-strings)))
(define (multiple-strings)
(send f write-bytes #"\n(")
(let loop ([offset 0][remain (bytes-length orig-s)])
(unless (zero? remain)
(let lloop ([amt (min 50 remain)][retry? #t])
(let ([s (open-output-bytes)])
(write (subbytes orig-s offset (+ offset amt)) s)
(let* ([v (get-output-bytes s)]
[len (bytes-length v)])
(if (len . <= . 71)
(if (and (len . < . 71)
retry?
(amt . < . remain))
(lloop (add1 amt) #t)
(begin
(send f write-bytes #"\n ")
(send f write-bytes v)
(loop (+ offset amt) (- remain amt))))
(lloop (sub1 amt) #f)))))))
(send f write-bytes #"\n)")
(set! col 1))
(check-ok)
(do-put-number (bytes-length orig-s))
(single-string)
(set! items (add1 items))
this)
(define/private (do-put-number v)
(check-ok)
(let* ([s (string->bytes/latin-1 (format " ~a" v))]
[len (bytes-length s)])
(if ((+ col len) . > . 72)
(begin
(set! col (sub1 len))
(bytes-set! s 0 (char->integer #\newline)))
(set! col (+ col len)))
(send f write-bytes s)
(set! items (add1 items))
this))
(def/public (tell)
(let ([pos (send f tell)])
(hash-set! pos-map items (cons pos col))
items))
(def/public (jump-to [exact-nonnegative-integer? icount])
(unless is-bad?
(let ([p (hash-ref pos-map icount #f)])
(when p
(send f seek (car p))
(set! col (cdr p))
(set! items icount)))))
(def/public (ok?) (not is-bad?))
(def/public (pretty-finish)
(unless is-bad?
(when (positive? col)
(send f write-bytes #"\n")
(set! col 0))))
(def/public (pretty-start)
(define (show s)
(send f write-bytes (if (string? s) (string->bytes/latin-1 s) s)))
(when (positive? col)
(show #"\n"))
(show #"#|\n This file is in plt scheme editor format.\n")
(show (format " Open this file in dr-scheme version ~a or later to read it.\n" (version)))
(show #"\n")
(show #" Most likely, it was created by saving a program in DrScheme,\n")
(show #" and it probably contains a program with non-text elements\n")
(show #" (such as images or comment boxes).\n")
(show #"\n")
(show #" http://www.plt-scheme.org\n|#\n")
(set! col 0)))
(set-editor-stream-out%! editor-stream-out%)

5493
collects/mred/private/wxme/text.ss Normal file
View File

File diff suppressed because it is too large Load Diff

308
collects/mred/private/wxme/undo.ss Normal file
View File

@ -0,0 +1,308 @@
#lang scheme/base
(require scheme/class
"private.ss"
"snip.ss"
"snip-flags.ss")
(provide change-record%
proc-record%
unmodify-record%
insert-record%
insert-snip-record%
delete-record%
delete-snip-record%
style-change-record%
style-change-snip-record%
move-snip-record%
resize-snip-record%
composite-record%)
(define (disown snip)
(when (has-flag? (snip->flags snip) OWNED)
(send snip set-s-flags (remove-flag (snip->flags snip) OWNED))))
(define change-record%
(class object%
(super-new)
(define/public (cancel) (void))
(define/public (undo editor) #f)
(define/public (drop-set-unmodified) (void))
(define/public (is-composite?) #f)
(define/public (get-id) #f)
(define/public (get-parity) 0)
(define/public (inverse) #f)))
(define proc-record%
(class change-record%
(init-field proc)
(super-new)
(define/override (undo editor)
(proc))))
(define unmodify-record%
(class change-record%
(init-field cont?)
(define ok? #t)
(super-new)
(define/override (undo editor)
(when ok?
(send editor set-modified #f))
cont?)
(define/override (drop-set-unmodified)
(set! ok? #f))))
(define insert-record%
(class change-record%
(init-field start)
(init length)
(init-field cont?
startsel
endsel)
(define end (+ start length))
(super-new)
(define/override (undo editor)
(send editor delete start end)
(send editor set-position startsel endsel)
cont?)))
(define insert-snip-record%
(class change-record%
(init-field snip
cont?)
(super-new)
(define/override (undo editor)
(send editor delete snip)
(unless cont?
(send editor set-selected snip))
cont?)))
(define-struct delete-snip-item (snip before x y))
(define delete-snip-record%
(class change-record%
(init-field cont?)
(define deletions null)
(define undid? #f)
(super-new)
(define/public (insert-snip snip before x y)
(set! deletions (cons (make-delete-snip-item snip before x y)
deletions)))
(define/override (cancel)
(unless undid?
(for-each (lambda (i)
(let ([snip (delete-snip-item-snip i)])
(disown snip)
(send snip set-admin #f)))
deletions)))
(define/override (undo editor)
(unless cont?
(send editor no-selected))
(for-each
(lambda (del)
(let ([snip (delete-snip-item-snip del)])
;; have to turn off the owned flag; we know that it's really ours
(disown snip)
(send editor insert snip
(delete-snip-item-before del)
(delete-snip-item-x del)
(delete-snip-item-y del))
(unless cont?
(send editor add-selected snip))))
deletions)
(set! undid? #t)
cont?)))
(define delete-record%
(class change-record%
(init-field start
end
cont?
startsel
endsel)
(define deletions null)
(define clickbacks null)
(define undid? #f)
(super-new)
(define/public (insert-snip snip)
(set! deletions (cons snip deletions)))
(define/public (add-clickback click)
(set! clickbacks (cons click clickbacks)))
(define/override (cancel)
(unless undid?
(for-each (lambda (snip)
(disown snip)
(send snip set-admin #f))
deletions)))
(define/override (undo editor)
;; have to turn off the owned flag; we know that it's really ours
(for-each disown deletions)
(send editor do-insert-snips deletions start)
(for-each (lambda (cb)
(send editor set-clickback cb))
clickbacks)
(send editor set-position startsel endsel)
(set! undid? #t)
cont?)))
(define style-change-record%
(class change-record%
(init-field start
end
cont?
startsel
endsel
restore-selection?)
(define changes null)
(super-new)
(define/public (add-style-change start end style)
(set! changes (cons (vector start end style)
changes)))
(define/override (undo editor)
(for-each (lambda (c)
(send editor change-style
(vector-ref c 2)
(vector-ref c 0)
(vector-ref c 1)))
(reverse changes))
(when restore-selection?
(send editor set-position startsel endsel))
cont?)))
(define style-change-snip-record%
(class change-record%
(init-field cont?)
(define changes null)
(super-new)
(define/public (add-style-change snip style)
(set! changes (cons (cons snip style) changes)))
(define/override (undo editor)
(unless cont?
(send editor no-selected))
(for-each (lambda (s)
(send editor change-style (cdr s) (cdr s))
(unless cont?
(send editor add-selected (car s))))
(reverse changes))
cont?)))
(define move-snip-record%
(class change-record%
(init-field snip
x
y
delta?
cont?)
(super-new)
(define/override (undo editor)
(if delta?
(send editor move snip x y)
(send editor move-to snip x y))
cont?)))
(define resize-snip-record%
(class change-record%
(init-field snip
x
y
cont?)
(super-new)
(define/override (undo editor)
(send editor resize snip x y)
cont?)))
(define composite-record%
(class change-record%
(init count)
(init-field id
parity?)
(unless id
(set! id (if parity?
(cons this #f)
(cons #f this))))
(define seq (make-vector count))
(super-new)
(define/override (cancel)
(for ([c (in-vector seq)])
(send c cancel)))
(define/override (undo editor)
(for ([c (in-vector seq)])
(send c undo))
#f)
(define/override (drop-set-unmodified)
(for ([c (in-vector seq)])
(send c drop-set-unmodified)))
(define/public (add-undo pos c)
(vector-set! seq (- (vector-length seq) pos 1) c))
(define/override (is-composite?) #t)
(define/override (get-id) id)
(define/override (get-parity) parity?)
(define/override (inverse)
(make-object inverse-record% id (not parity?)))))
(define inverse-record%
(class change-record%
(init-field id
parity?)
(define/private (get)
(if parity?
(car id)
(cdr id)))
(define/override (cancel)
;; Avoid double-frees by not doing anything
(void))
(define/override (undo editor)
(send (get) undo editor))
(define/override (drop-set-unmodified)
(let ([c (get)])
(when c
(send c drop-set-unmodified))))
(define/override (get-id) id)
(define/override (get-parity) parity?)
(define/override (inverse)
(send (get) inverse))))

153
collects/mred/private/wxme/wordbreak.ss Normal file
View File

@ -0,0 +1,153 @@
#lang scheme/base
(require scheme/class
"../syntax.ss"
"cycle.ss")
(provide editor-wordbreak-map%
the-editor-wordbreak-map
standard-wordbreak)
(defclass editor-wordbreak-map% object%
(define char-map (make-hash))
(super-new)
(hash-set! char-map #\- '(line))
(def/public (set-map [char? ch] [(make-list (symbol-in caret line selection user1 user2)) mask])
(hash-set! char-map ch mask))
(def/public (get-map [char? ch])
(or (hash-ref char-map ch #f)
(cond
[(or (char-alphabetic? ch)
(char-numeric? ch))
'(caret line selection)]
[(not (char-whitespace? ch))
'(line)]
[else null]))))
(define the-editor-wordbreak-map (new editor-wordbreak-map%))
(define MAX-DIST-TRY 30)
(define wb-get-map (generic editor-wordbreak-map% get-map))
(define (string-ref* str n)
(if (n . >= . (string-length str))
#\nul
(string-ref str n)))
(define/top (standard-wordbreak [text% win]
[(make-or-false (make-box exact-nonnegative-integer?)) startp]
[(make-or-false (make-box exact-nonnegative-integer?)) endp]
[(symbol-in caret line selection user1 user2)reason])
(with-method ([get-map ((send win get-wordbreak-map) get-map)])
(define (nonbreak? ch) (memq reason (get-map ch)))
(when startp
(let* ([start (unbox startp)]
[pstart start]
[lstart (send win find-newline 'backward start 0)]
[lstart (if lstart
(if (eq? 'caret reason)
(or (and (positive? lstart)
(send win find-newline 'backward (sub1 lstart) 0))
0)
lstart)
0)]
[lend (min (+ start 1) (send win last-position))]
[tstart (if ((- start lstart) . > . MAX-DIST-TRY)
(- start MAX-DIST-TRY)
lstart)]
[text (send win get-text tstart lend)]
[start (- start tstart)]
[pstart (- pstart tstart)])
(let ploop ([phase1-complete? #f]
[phase2-complete? #f]
[start start]
[pstart pstart]
[text text]
[tstart tstart])
(let*-values ([(start phase1-complete?)
(if phase1-complete?
(values start #t)
(let ([start (if (and (positive? start)
(nonbreak? (string-ref* text start)))
(sub1 start)
start)])
(values start
(not (nonbreak? (string-ref* text start))))))]
[(start phase2-complete?)
(if (not (eq? 'selection reason))
(if (not phase2-complete?)
(let loop ([start start])
(if (and (positive? start)
(not (nonbreak? (string-ref* text start))))
(loop (sub1 start))
(if (nonbreak? (string-ref* text start))
(values start #t)
(values start #f))))
(values start #t))
(values start phase2-complete?))])
(let loop ([start start])
(if (and (positive? start)
(nonbreak? (string-ref* text start)))
(loop (sub1 start))
(let ([start (if (and (start . < . pstart)
(not (nonbreak? (string-ref* text start))))
(add1 start)
start)])
(if (and (zero? start)
(not (= lstart tstart)))
(ploop phase1-complete?
phase2-complete?
(+ start (- tstart lstart))
(+ pstart (- tstart lstart))
(send win get-text lstart lend)
lstart)
(set-box! startp (+ start tstart))))))))))
(when endp
(let* ([end (unbox endp)]
[lstart end]
[lend (send win find-newline 'forward end)]
[lend (if lend
(if (eq? 'caret reason)
(or (send win find-newline 'forward (+ lend 1))
(send win last-position))
lend)
(send win last-position))]
[tend (if ((- lend end) . > . MAX-DIST-TRY)
(+ end MAX-DIST-TRY)
lend)]
[text (send win get-text lstart tend)]
[end (- end lstart)]
[lend (- lend lstart)]
[tend (- tend lstart)])
(let ploop ([phase1-complete? #f]
[text text]
[tend tend]
[end end])
(let-values ([(end phase1-complete?)
(if phase1-complete?
(values end #t)
(let loop ([end end])
(if (and (end . < . tend)
(not (nonbreak? (string-ref* text end))))
(loop (add1 end))
(if (end . < . tend)
(values end #t)
(values end #f)))))])
(let loop ([end end])
(if (and (end . < . tend)
(nonbreak? (string-ref* text end)))
(loop (add1 end))
(if (and (= tend end) (not (= lend tend)))
(ploop phase1-complete?
(send win get-text lstart (+ lstart lend))
lend
end)
(set-box! endp (+ end lstart)))))))))))

63
collects/mred/private/wxme/wx.ss Normal file
View File

@ -0,0 +1,63 @@
#lang scheme/base
(require "../kernel.ss")
(define the-clipboard (get-the-clipboard))
(define the-x-selection-clipboard (get-the-x-selection))
(define the-brush-list (get-the-brush-list))
(define the-pen-list (get-the-pen-list))
(define the-font-list (get-the-font-list))
(define the-color-database (get-the-color-database))
(define the-font-name-directory (get-the-font-name-directory))
(define (family-symbol? s)
(memq s '(default decorative roman script
swiss modern symbol system)))
(define (style-symbol? s)
(memq s '(normal italic slant)))
(define (weight-symbol? s)
(memq s '(normal bold light)))
(define (smoothing-symbol? s)
(memq s '(default smoothed unsmoothed partly-smoothed)))
(define (size? v) (and (exact-positive-integer? v)
(byte? v)))
(provide event%
mouse-event%
key-event%
timer%
canvas%
bitmap-dc%
color%
the-color-database
pen%
the-pen-list
brush%
the-brush-list
font%
the-font-list
the-font-name-directory
cursor%
bitmap%
dc<%>
post-script-dc%
printer-dc%
current-eventspace
clipboard-client%
clipboard<%>
the-clipboard
the-x-selection-clipboard
get-double-click-threshold
begin-refresh-sequence
end-refresh-sequence
begin-busy-cursor
end-busy-cursor
hide-cursor
run-printout
current-ps-setup
family-symbol?
style-symbol?
weight-symbol?
smoothing-symbol?)
(define (get-double-click-threshold)
(get-double-click-time))

1
collects/mred/private/wxmenu.ss
View File

@ -3,6 +3,7 @@
mzlib/class100
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/keymap.ss")
"lock.ss"
"const.ss"
"helper.ss"

2
collects/mred/private/wxtextfield.ss
View File

@ -2,6 +2,8 @@
(require mzlib/class
mzlib/class100
(prefix wx: "kernel.ss")
(prefix wx: "wxme/text.ss")
(prefix wx: "wxme/editor-canvas.ss")
"lock.ss"
"const.ss"
"check.ss"

2
collects/mred/private/wxtop.ss
View File

@ -4,6 +4,8 @@
mzlib/etc
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/editor-canvas.ss")
(prefix wx: "wxme/editor-snip.ss")
"lock.ss"
"helper.ss"
"const.ss"

66
collects/mrlib/graph.ss
View File

@ -21,7 +21,9 @@
add-parent
remove-parent
has-self-loop?
set-parent-link-label
find-shortest-path))
(define-local-member-name get-parent-links)
@ -83,7 +85,18 @@
number?
(or/c false/c string?)
. -> .
void?)))
void?))
(remove-links
((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>)
. -> .
void?))
(set-link-label
((is-a?/c graph-snip<%>)
(is-a?/c graph-snip<%>)
(or/c false/c string?)
. -> .
void?)))
(define self-offset 10)
@ -140,7 +153,14 @@
label)
(send parent add-child child)
(send child add-parent parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label))
(define (remove-links parent child)
(send parent remove-child child)
(send child remove-parent parent))
(define (set-link-label parent child label)
(send child set-parent-link-label parent label))
(define graph-snip-mixin
(mixin ((class->interface snip%)) (graph-snip<%>)
(field (children null))
@ -185,6 +205,15 @@
parent
parent-links
(lambda (parent parent-link) (eq? (link-snip parent-link) parent))))))
(define/public (set-parent-link-label parent label)
(let ([parent-link
(cond [(memf (lambda (parent-link)
(eq? (link-snip parent-link) parent))
parent-links)
=> car]
[else #f])])
(when parent-link
(set-link-label! parent-link label))))
(define/public (has-self-loop?)
(memq this (get-children)))
@ -223,6 +252,7 @@
set-arrowhead-params
get-arrowhead-params
set-draw-arrow-heads?
set-flip-labels?
draw-edges))
(define-struct rect (left top right bottom))
@ -235,23 +265,21 @@
[edge-labels? #t])
(define draw-arrow-heads? #t)
(define flip-labels? #t)
(inherit refresh get-admin)
(define/public (set-draw-arrow-heads? x)
(set! draw-arrow-heads? x)
(define (refresh*)
(let ([admin (get-admin)])
(when admin
(let ([xb (box 0)]
[yb (box 0)]
[wb (box 0)]
[hb (box 0)])
(let ([xb (box 0)] [yb (box 0)] [wb (box 0)] [hb (box 0)])
(send admin get-view xb yb wb hb)
(send admin needs-update
(unbox xb)
(unbox yb)
(unbox wb)
(unbox hb))))))
(unbox xb) (unbox yb) (unbox wb) (unbox hb))))))
(define/public (set-draw-arrow-heads? x)
(set! draw-arrow-heads? x)
(refresh*))
(define/public (set-flip-labels? x)
(set! flip-labels? x)
(refresh*))
(define arrowhead-angle-width (* 1/4 pi))
(define arrowhead-short-side 8)
@ -614,9 +642,13 @@
[arrow-end-y (send point3 get-y)]
[arrowhead-end (make-rectangular arrow-end-x arrow-end-y)]
[vec (- arrowhead-end from-pt)]
[angle (- (angle vec))]
[flip? (and flip-labels?
(not (< (/ pi -2) angle (/ pi 2))))]
[angle (if flip? (+ angle pi) angle)]
[middle (+ from-pt
(- (* 1/2 vec)
(make-polar (/ text-len 2) (angle vec))))])
(make-polar (/ text-len 2) (- angle))))])
(when (> (sqrt (+ (sqr (- arrow-end-x from-x))
(sqr (- arrow-end-y from-y))))
text-len)
@ -625,7 +657,7 @@
(+ dy (imag-part middle))
#f
0
(- (angle vec)))))))]))))))))
angle)))))]))))))))
(define (set-pen/brush from-link dark-lines?)
(send dc set-brush

2
collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
View File

@ -80,7 +80,7 @@
(define/public (realign-to-alloted)
(when (and alloted-width alloted-height)
(when (not (and (positive? alloted-width) (positive? alloted-height)))
(error 'here "I am"))
(error "allotted width or height is not positive"))
(dynamic-let ([ignore-resizing? true])
(let* ([first-snip (find-first-snip)]
[aligned-rects

16
collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl
View File

@ -45,6 +45,20 @@ different nodes.
}
@defmethod[(set-flip-labels? [flip-labels? any/c])
void?]{
Sets a boolean controlling whether or not arrow labels are flipped so
the are always right-side-up. Note that if there are two nodes with
edges going from the first to the second, and from the second to the
first, and the two have labels, then this should be turned off or the
labels will appear in the same space.
This setting does not affect self-links---only links between two
different nodes.
}
@defmethod[(draw-edges [dc (is-a?/c dc<%>)]
[left real?]
[top real?]
@ -84,7 +98,7 @@ destination snip's bounding box where a straight line
between the centers of the snip would intersect.
The @scheme[arrow-point-ok?] function returns @scheme[#t]
when the point specified by its arguments is inside the the
when the point specified by its arguments is inside the
smallest rectangle that covers both the source and
destination snips, but is outside of both of the rectangles
that surround the source and destination snips themselves.

16
collects/mrlib/scribblings/graph/graph-snip-intf.scrbl
View File

@ -51,6 +51,8 @@ this snip.
Removes a child snip from this snip. Be sure to remove
this snip as a parent from the argument, too.
Instead of calling this method, consider using the
@scheme[remove-links] function.
}
@ -59,5 +61,17 @@ this snip.
Removes a parent snip from this snip. Be sure to remove this
snip as a child from the argument, too.
Instead of calling this method, consider using the
@scheme[remove-links] function.
}
}}
@defmethod[(set-parent-link-label [parent (is-a?/c graph-snip<%>)]
[label (or/c false/c string/)])
void?]{
Changes the label on the edge going to the @scheme[parent] to be
@scheme[label]. Ignored if no such egde exists.
}
}

15
collects/mrlib/scribblings/graph/graph.scrbl
View File

@ -74,3 +74,18 @@ used.}
Like @scheme[add-links], but with extra @scheme[dark-text] and
@scheme[light-text] arguments to set the colors of the label.}
@defproc[(remove-links [parent (is-a?/c graph-snip<%>)]
[child (is-a?/c graph-snip<%>)])
void?]{
Disconnects a parent snip from a child snip within a pasteboard.}
@defproc[(set-link-label [parent (is-a?/c graph-snip<%>)]
[child (is-a?/c graph-snip<%>)]
[label (or/c string? false/c)])
void?]{
Changes the label on the edge going from @scheme[child] to
@scheme[parent] to be @scheme[label]. If there is no existing edge
between the two nodes, then nothing happens.}

4
collects/mrlib/scribblings/hierlist/hierlist.scrbl
View File

@ -12,7 +12,7 @@ arrow that the user can click to hide or show the sub-list's items.
The list control supports the following default keystrokes:
@itemize{
@itemize[
@item{Down: move to the next entry at the current level (skipping lower levels).}
@ -24,7 +24,7 @@ The list control supports the following default keystrokes:
@item{Return: open/close the current selected level (only valid for lists).}
}
]
@local-table-of-contents[]

4
collects/mrlib/scribblings/interactive-value-port.scrbl
View File

@ -14,13 +14,13 @@ Sets @scheme[port]'s display handler (via
@scheme[port-display-handler]) so that when it encounters these
values:
@itemize{
@itemize[
@item{exact, real, non-integral numbers}
@item{syntax objects}
}
]
it uses @scheme[write-special] to send snips to the port,
instead of those values. Otherwise, it behaves like the

2
collects/mrlib/scribblings/name-message.scrbl
View File

@ -67,7 +67,7 @@ saying that there is no file name until the file is saved.}
@defmethod[(get-background-color) (or/c false/c (is-a/c color%) string?)]{
The result of this method is used for the background color
when redrawing the the name message. If it is @scheme[#f], the
when redrawing the name message. If it is @scheme[#f], the
OS's default panel background is used.
}

4
collects/mrlib/scribblings/path-dialog.scrbl
View File

@ -72,7 +72,7 @@ user to create a new directory.
The @scheme[filters] argument is one of:
@itemize{
@itemize[
@item{@scheme[(list (list _filter-name _filter-glob) ...)] --- a
list of pattern names (e.g., @scheme["Scheme Files"]) and glob
@ -89,7 +89,7 @@ The @scheme[filters] argument is one of:
@scheme["*.*"] under Windows and @scheme["*"] on other
platforms.}
}
]
The @scheme[show-file?] predicate is used to filter file paths that
are shown in the dialog. The predicate is applied to the file name as

8
collects/mrlib/switchable-button.ss
View File

@ -76,8 +76,16 @@
(define/override (enable e?)
(unless (equal? disabled? (not e?))
(set! disabled? (not e?))
(set! down? #f)
(set! in? #f)
(refresh)))
(define/override (is-enabled?) (not disabled?))
(define/override (on-superwindow-show show?)
(unless show?
(set! in? #f)
(set! down? #f))
(super on-superwindow-show show?))
(define/override (on-event evt)
(cond

22
collects/redex/private/dot.ss
View File

@ -1,7 +1,7 @@
#lang scheme/gui
(provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)]
[find-dot (-> (or/c string? false/c))])
[find-dot (-> (or/c path? false/c))])
(require scheme/system)
@ -11,6 +11,9 @@
(define neato-hier-label "neato – hier")
(define neato-ipsep-label "neato – ipsep")
;; these paths are explicitly checked (when find-executable-path
;; fails) because starting drscheme from the finder (or the doc)
;; under mac os x generally does not get the path right.
(define dot-paths
'("/usr/bin"
"/bin"
@ -18,10 +21,17 @@
"/opt/local/bin/"))
(define (find-dot [neato? #f])
(ormap (λ (x) (and (file-exists? (build-path x "dot"))
(file-exists? (build-path x "neato"))
(path->string (build-path x (if neato? "neato" "dot")))))
dot-paths))
(cond
[(and (find-executable-path "dot")
(find-executable-path "neato"))
(if neato?
(find-executable-path "neato")
(find-executable-path "dot"))]
[else
(ormap (λ (x) (and (file-exists? (build-path x "dot"))
(file-exists? (build-path x "neato"))
(build-path x (if neato? "neato" "dot"))))
dot-paths)]))
(define (dot-positioning pb option overlap?)
(let ([info (snip-info pb)])
@ -92,7 +102,7 @@
(λ ()
(parameterize ([current-input-port in1]
[current-output-port out2])
(system (format "~a -Tplain" (find-dot (regexp-match #rx"neato" option)))))
(system (format "~a -Tplain" (path->string (find-dot (regexp-match #rx"neato" option))))))
(close-output-port out2)
(close-input-port in1)))
(parse-plain in2)))

82
collects/scribblings/framework/color.scrbl
View File

@ -8,25 +8,31 @@
This interface describes how coloring is stopped and started for text
that knows how to color itself. It also describes how to query the
lexical and s-expression structure of the text.
@defmethod*[(((start-colorer (token-sym-style (-> symbol? string?)) (get-token (-> input-port? (values any? symbol? (union false? symbol?) natural-number? natural-number?))) (pairs (listof (list/p symbol? symbol?)))) void))]{
@defmethod*[(((start-colorer (token-sym->style (-> symbol? string?))
(get-token (-> input-port? (values any/c
symbol?
(or/c false? symbol?)
exact-nonnegative-integer?
exact-nonnegative-integer?)))
(pairs (listof (list/p symbol? symbol?)))) void))]{
Starts tokenizing the buffer for coloring and parenthesis matching.
token-sym-style will be passed the first return symbol from get-token
The @scheme[token-sym->style] argument will be passed the first return symbol from @scheme[get-token]
and should return the style-name that the token should be colored.
get-token takes an input port and returns the next token as 5 values:
@itemize{
The @scheme[get-token] argument takes an input port and returns the next token as 5 values:
@itemize[
@item{
An unused value. This value is intended to represent the textual
component of the token and may be used as such in the future.}
@item{
A symbol describing the type of the token. This symbol is transformed
into a style-name via the token-sym->style argument. The symbols
'white-space and 'comment have special meaning and should always be
into a style-name via the @scheme[token-sym->style] argument. The symbols
@scheme['white-space] and @scheme['comment] have special meaning and should always be
returned for white space and comment tokens respectively. The symbol
@scheme['no-color] can be used to indicate that although the token is not white
space, it should not be colored. The symbol 'eof must be used to
space, it should not be colored. The symbol @scheme['eof] must be used to
indicate when all the tokens have been consumed.}
@item{
A symbol indicating how the token should be treated by the paren
@ -34,17 +40,17 @@
@item{
The starting position of the token.}
@item{
The ending position of the token.}}
The ending position of the token.}]
get-token will usually be implemented with a lexer using the
The @scheme[get-token] function will usually be implemented with a lexer using the
@scheme[parser-tools/lex] library.
get-token must obey the following invariants:
@itemize{
@itemize[
@item{
Every position in the buffer must be accounted for in exactly one
token.}
@item{
The token returned by get-token must rely only on the contents of the
The token returned by @scheme[get-token] must rely only on the contents of the
input port argument. This means that the tokenization of some part of
the input cannot depend on earlier parts of the input.}
@item{
@ -57,25 +63,25 @@
the buffer look like:
@verbatim{" 1 2 3"}
would result in a single string token modifying previous tokens. To
handle these situations, get-token must treat the first line as a
single token.}}
handle these situations, @scheme[get-token] must treat the first line as a
single token.}]
@scheme[pairs] is a list of different kinds of matching parens. The second
The @scheme[pairs] argument is a list of different kinds of matching parens. The second
value returned by get-token is compared to this list to see how the
paren matcher should treat the token. An example: Suppose pairs is
@scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there
are three kinds of parens. Any token which has 'begin as its second
return value will act as an open for matching tokens with 'end.
are three kinds of parens. Any token which has @scheme['begin] as its second
return value will act as an open for matching tokens with @scheme['end].
Similarly any token with @scheme['|]|] will act as a closing match for
tokens with @scheme['|[|]. When trying to correct a mismatched
closing parenthesis, each closing symbol in pairs will be converted to
a string and tried as a closing parenthesis.
}
@defmethod*[(((stop-colorer (clear-colors boolean |#t|)) void))]{
@defmethod*[(((stop-colorer (clear-colors boolean #t)) void))]{
Stops coloring and paren matching the buffer.
If clear-colors is true all the text in the buffer will have it's
If @scheme[clear-colors] is true all the text in the buffer will have its
style set to Standard.
}
@defmethod*[(((force-stop-colorer (stop? boolean?)) void))]{
@ -83,7 +89,7 @@
Intended for debugging purposes only.
stop? determines whether the system is being forced to stop or allowed
@scheme[stop?] determines whether the system is being forced to stop or allowed
to wake back up.
}
@defmethod*[(((is-stopped?) boolean?))]{
@ -96,27 +102,25 @@
and
@method[color:text<%> thaw-colorer].
}
@defmethod*[(((freeze-colorer) void))]{
Keep the text tokenized and paren matched, but stop altering the colors.
freeze-colorer will not return until the coloring/tokenization of the
@scheme[freeze-colorer] will not return until the coloring/tokenization of the
entire text is brought up-to-date. It must not be called on a locked
text.
}
@defmethod*[(((thaw-colorer (recolor boolean |#t|) (retokenize boolean |#f|)) void))]{
@defmethod*[(((thaw-colorer (recolor boolean #t) (retokenize boolean #f)) void))]{
Start coloring a frozen buffer again.
If recolor? is @scheme[#t], the text is re-colored. If it is
@scheme[#f] the text is not recolored. When recolor? is @scheme[#t],
retokenize? controls how the text is recolored. @scheme[#f] causes
If @scheme[recolor?] is @scheme[#t], the text is re-colored. If it is
@scheme[#f] the text is not recolored. When @scheme[recolor?] is @scheme[#t],
@scheme[retokenize?] controls how the text is recolored. @scheme[#f] causes
the text to be entirely re-colored before thaw-colorer returns using
the existing tokenization. @scheme[#t] causes the entire text to be
retokenized and recolored from scratch. This will happen in the
background after the call to thaw-colorer returns.
background after the call to @scheme[thaw-colorer] returns.
}
@defmethod*[(((reset-region (start natural-number?) (end (union (quote end) natural-number?))) void))]{
@ -134,19 +138,16 @@
@defmethod*[(((skip-whitespace (position natural-number?) (direction (symbols (quote forward) (quote backward))) (comments? boolean?)) natural-number?))]{
Returns the next non-whitespace character.
Starts from position and skips whitespace in the direction indicated
by direction. If comments? is true, comments are skipped as well as
by direction. If @scheme[comments?] is true, comments are skipped as well as
whitespace. skip-whitespace determines whitespaces and comments by
comparing the token type to 'white-space and 'comment.
comparing the token type to @scheme['white-space] and @scheme['comment].
Must only be called while the tokenizer is started.
}
@defmethod*[(((backward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{
Skip all consecutive whitespaces and comments (using skip-whitespace)
Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace])
immediately preceding the position. If the token at this position is
a close, return the position of the matching open, or @scheme[#f] if
there is none. If the token was an open, return @scheme[#f]. For any
@ -163,9 +164,7 @@
}
@defmethod*[(((forward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{
Skip all consecutive whitespaces and comments (using skip-whitespace)
Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace])
immediately following position. If the token at this position is an
open, return the position of the matching close, or @scheme[#f] if
there is none. For any other token, return the end of that token.
@ -174,12 +173,11 @@
}
@defmethod*[(((insert-close-paren (position natural-number?) (char char?) (flash? boolean?) (fixup? boolean?)) void))]{
Position is the place to put the parenthesis and char is the
parenthesis to be added. If fixup? is true, the right kind of closing
parenthesis to be added. If @scheme[fixup?] is true, the right kind of closing
parenthesis will be chosen from the pairs list kept last passed to
start-colorer, otherwise char will be inserted, even if it is not the
right kind. If flash? is true the matching open parenthesis will be
@scheme[start-colorer], otherwise char will be inserted, even if it is not the
right kind. If @scheme[flash?] is true the matching open parenthesis will be
flashed.
}
@defmethod*[(((classify-position (position natural-number?)) symbol?))]{
@ -218,7 +216,9 @@
@defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{
This mixin adds coloring functionality to the mode.
@defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |scheme(λ (x) "Standard"))|) (matches (listof (list/c symbol? symbol?)) null))]{
@defconstructor[((get-token lexer default-lexer)
(token-sym->style (symbol? . -> . string?) (λ (x) "Standard"))
(matches (listof (list/c symbol? symbol?)) null))]{
The arguments are passed to
@method[color:text<%> start-colorer].

4
collects/scribblings/framework/frame.scrbl
View File

@ -223,7 +223,7 @@ framework)) @(require (for-label scheme/gui)) @(require
If that returns @scheme[#t],
it checks for one of the these three conditions:
@itemize{
@itemize[
@item{
@scheme[exit:exiting?]
returns @scheme[#t]}
@ -233,7 +233,7 @@ framework)) @(require (for-label scheme/gui)) @(require
@scheme[group:get-the-frame-group], or}
@item{the procedure
@scheme[exit:user-oks-exit]
returns @scheme[#t].}}
returns @scheme[#t].}]
If any of those conditions hold, the
method returns @scheme[#t].
}

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

@ -12,10 +12,10 @@ 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.
@itemize{
@itemize[
@item{@bold{Entire Framework}
@itemize{
@itemize[
@item{@scheme[(require #, @schememodname[framework])]
@ -41,7 +41,7 @@ program on top of the @scheme[scheme/gui] library.
@scheme[framework^]. It imports the @scheme[mred^] signature.
}
}}
]}
@item{
@bold{Test Suite Engine}
@ -85,7 +85,7 @@ This library is here for backwards compatibility. The
functionality in it has moved into the framework proper, in
the @secref["editor-snip"] section.
}
}
]
@bold{Thanks}

4
collects/scribblings/framework/scheme.scrbl
View File

@ -57,7 +57,7 @@
The result of this method is used to determine if the return key
automatically tabs over to the correct position.
Override it to change it's behavior.
Override it to change its behavior.
}
@ -199,7 +199,7 @@
}
@defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer)) void))]{
If the paren after @scheme[pos] is matched, this method
highlights it and it's matching counterpart in dark green.
highlights it and its matching counterpart in dark green.
}
@defmethod*[(((get-tab-size) exact-integer))]{

6
collects/scribblings/framework/text.scrbl
View File

@ -387,7 +387,7 @@
@method[text:searching<%> set-replace-start]) and the
closest search hit following @tt{replace-start} does not
collapse with an adjacent bubble,the result will include
that bubble. If the the closest search hit after
that bubble. If the closest search hit after
@tt{replace-start} is collpased with another bubble, then
the search hit is not reflected in the result.
@ -444,7 +444,7 @@
changes. Ensures the snip is as wide as the viewing area.
This method should only be called by
@method[canvas:wide-snip<%> add-tall-snip].
@xmethod[canvas:wide-snip<%> add-wide-snip].
}
@defmethod*[(((add-tall-snip (snip (is-a?/c snip%))) void))]{
@ -452,7 +452,7 @@
viewing area of the editor changes.
This method should only be called by
@method[canvas:wide-snip<%> add-tall-snip].
@xmethod[canvas:wide-snip<%> add-tall-snip].
}
}

4
collects/scribblings/gui/area-container-intf.scrbl
View File

@ -7,7 +7,7 @@ An @scheme[area-container<%>] is a container @scheme[area<%>].
All @scheme[area-container<%>] classes accept the following named
instantiation arguments:
@itemize{
@itemize[
@item{@indexed-scheme[border] --- default is @scheme[0]; passed to
@method[area-container<%> border]}
@ -17,7 +17,7 @@ All @scheme[area-container<%>] classes accept the following named
@scheme['(center top)] for @scheme[vertical-panel%]; the list
elements are passed to
@method[area-container<%> set-alignment]}
}
]

4
collects/scribblings/gui/area-intf.scrbl
View File

@ -10,7 +10,7 @@ An @scheme[area<%>] object is either a window or a windowless
All @scheme[area<%>] classes accept the following named instantiation
arguments:
@itemize{
@itemize[
@item{@indexed-scheme[min-width] --- default is the initial graphical minimum width; passed to
@method[area<%> min-width]}
@ -20,7 +20,7 @@ All @scheme[area<%>] classes accept the following named instantiation
@method[area<%> stretchable-width]}
@item{@indexed-scheme[stretchable-height] --- default is class-specific; passed to
@method[area<%> stretchable-height]}
}
]

75
collects/scribblings/gui/blurbs.ss
View File

@ -4,16 +4,18 @@
scribble/manual
scribble/scheme
scribble/decode
(for-label scheme/gui/base))
(for-label scheme/gui/base)
(for-syntax scheme/base))
(provide (except-out (all-defined-out) p))
(provide (except-out (all-defined-out) p define-inline))
(define-syntax-rule (define-inline (name) body)
(define-syntax (name stx)
(datum->syntax stx 'body stx)))
(define (p . l)
(decode-paragraph l))
(define (itemstyleinfo)
@elem{The @scheme[style] argument is reserved for future use.})
(define (labelsimplestripped where what)
@elem{If @litchar{&} occurs in @|where|, it is specially parsed;
under Windows and X, the character
@ -83,13 +85,6 @@
(define (insertscrolldetails what)
@elem{@|what| editor's display is scrolled to show the new selection @techlink{position}.})
(define (insertdetails what)
@elem{If @scheme[end] is
not @scheme['same], then the region from @scheme[start] to @scheme[end] is
replaced with the text. @insertmovedetails[@scheme[end]]. If @scheme[scroll-ok?] is not @scheme[#f]
@insertscrolldetails[@elem{and @scheme[start] is the same as the
current caret @techlink{position}, then the}]})
(define (insertmovedetails what)
@elem{If the insertion @techlink{position} is before
or equal to the selection's start/end @techlink{position}, then the selection's
@ -143,21 +138,14 @@ information@|details|, even if the editor currently has delayed refreshing (see
(define seesniporderdiscuss
@elem{See @secref["tb:miaoverview"] for information about snip order in pasteboards.})
(define (clipboardtypes)
@elem{The @scheme[format] string is typically four capital letters. (Under
Mac OS X, only four characters for @scheme[format] are ever used.) For
example, @scheme["TEXT"] is the name of the UTF-8-encoded string format. New
format names can be used to communicate application- and
platform-specific data formats.})
(define PrintNote
(make-splice
(list
@p{Be sure to use the following methods to start/end drawing:}
@itemize{@item{@method[dc<%> start-doc]}
@itemize[@item{@method[dc<%> start-doc]}
@item{@method[dc<%> start-page]}
@item{@method[dc<%> end-page]}
@item{@method[dc<%> end-doc]}}
@item{@method[dc<%> end-doc]}]
@p{Attempts to use a drawing method outside of an active page raises an exception.})))
(define reference-doc '(lib "scribblings/reference/reference.scrbl"))
@ -170,37 +158,40 @@ information@|details|, even if the editor currently has delayed refreshing (see
(define LineNumbering @elem{Lines are numbered starting with @scheme[0].})
(define ParagraphNumbering @elem{Paragraphs are numbered starting with @scheme[0].})
(define (italicptyStyleNote)
@elem{The @scheme[style] argument is provided for future extensions. Currently, @scheme[style] must be the empty list.})
(define (italicptyStyleNote style)
@elem{The @|style| argument is provided for future extensions. Currently, @|style| must be the empty list.})
(define (HVLabelNote what)
@elem{If @scheme[style] includes @scheme['vertical-label], then the @|what| is
created with a label above the control; if @scheme[style] does not include
(define (HVLabelNote style what)
@elem{If @|style| includes @scheme['vertical-label], then the @|what| is
created with a label above the control; if @|style| does not include
@scheme['vertical-label] (and optionally includes @scheme['horizontal-label]), then the
label is created to the left of the @|what|.})
(define (DeletedStyleNote what)
@elem{If @scheme[style] includes @scheme['deleted], then the @|what| is created as hidden,
(define (DeletedStyleNote style parent what)
@elem{If @|style| includes @scheme['deleted], then the @|what| is created as hidden,
and it does not affect its parent's geometry; the @|what| can be made active later by calling
@scheme[parent]'s @method[area-container<%> add-child] method.})
@|parent|'s @method[area-container<%> add-child] method.})
(define (InStyleListNote)
@elem{The editor's style list must contain @scheme[style], otherwise
(define (InStyleListNote style)
@elem{The editor's style list must contain @style, otherwise
the style is not changed. See also @xmethod[style-list% convert].})
(define (FontKWs) @elem{The @scheme[font] argument determines the font for the control.})
(define (FontLabelKWs) @elem{The @scheme[font] argument determines the font for the control content,
and @scheme[label-font] determines the font for the control label.})
(define (FontKWs font) @elem{The @|font| argument determines the font for the control.})
(define (FontLabelKWs font label-font) @elem{The @|font| argument determines the font for the control content,
and @|label-font| determines the font for the control label.})
(define (WindowKWs) @elem{For information about the @scheme[enabled] argument, see @scheme[window<%>].})
(define (SubareaKWs) @elem{For information about the @scheme[horiz-margin] and @scheme[vert-margin]
arguments, see @scheme[subarea<%>].})
(define (AreaContKWs) @elem{For information about the @scheme[border], @scheme[spacing], and @scheme[alignment]
arguments, see @scheme[area-container<%>].})
(define (WindowKWs enabled) @elem{For information about the @|enabled| argument, see @scheme[window<%>].})
(define-inline (SubareaKWs)
@elem{For information about the @scheme[horiz-margin] and @scheme[vert-margin]
arguments, see @scheme[subarea<%>].})
(define-inline (AreaContKWs)
@elem{For information about the @scheme[border], @scheme[spacing], and @scheme[alignment]
arguments, see @scheme[area-container<%>].})
(define (AreaKWs) @elem{For information about the
@scheme[min-width], @scheme[min-height], @scheme[stretchable-width], and
@scheme[stretchable-height] arguments, see @scheme[area<%>].})
(define-inline (AreaKWs)
@elem{For information about the
@scheme[min-width], @scheme[min-height], @scheme[stretchable-width], and
@scheme[stretchable-height] arguments, see @scheme[area<%>].})
(define MismatchExn @elem{an @scheme[exn:fail:contract] exception is raised})

4
collects/scribblings/gui/button-class.scrbl
View File

@ -50,9 +50,9 @@ The @scheme[callback] procedure is called (with the event type
If @scheme[style] includes @scheme['border], the button is drawn with
a special border that indicates to the user that it is the default
action button (see @method[top-level-window<%>
on-traverse-char]). @DeletedStyleNote{button}
on-traverse-char]). @DeletedStyleNote[@scheme[style] @scheme[parent]]{button}
@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[]}
@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]}
@defmethod[#:mode override

34
collects/scribblings/gui/canvas-class.scrbl
View File

@ -26,7 +26,7 @@ A @scheme[canvas%] object is a general-purpose window for drawing
The @scheme[style] argument indicates one or more of the following styles:
@itemize{
@itemize[
@item{@scheme['border] --- gives the canvas a thin border}
@ -63,7 +63,7 @@ The @scheme[style] argument indicates one or more of the following styles:
later by calling @scheme[parent]'s @method[area-container<%> add-child]
method}
}
]
The @scheme['hscroll] and @scheme['vscroll] styles create a
canvas with an initially inactive scrollbar. The scrollbars are
@ -86,7 +86,7 @@ The @scheme[gl-config] argument determines properties of an OpenGL
@xmethod[dc<%> get-gl-context].
@WindowKWs[] @SubareaKWs[] @AreaKWs[]
@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
}
@ -111,7 +111,7 @@ When tab-focus is enabled for a canvas, Tab, arrow, and Enter keyboard
@defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)])
(integer-in 1 10000)]{
(integer-in 1 1000000000)]{
Get the current page step size of a manual scrollbar. The result is
@scheme[0] if the scrollbar is not active or it is automatic.
@ -126,7 +126,7 @@ See also
@defmethod[(get-scroll-pos [which (one-of/c 'horizontal 'vertical)])
(integer-in 0 10000)]{
(integer-in 0 1000000000)]{
Gets the current value of a manual scrollbar. The result is always
@scheme[0] if the scrollbar is not active or it is automatic.
@ -141,7 +141,7 @@ See also
@defmethod[(get-scroll-range [which (one-of/c 'horizontal 'vertical)])
(integer-in 0 10000)]{
(integer-in 0 1000000000)]{
Gets the current maximum value of a manual scrollbar. The result is
always @scheme[0] if the scrollbar is not active or it is automatic.
@ -183,8 +183,8 @@ Gets the size in device units of the scrollable canvas area (as
}
@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 10000) false/c)]
[vert-pixels (or/c (integer-in 1 10000) false/c)]
@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 1000000000) false/c)]
[vert-pixels (or/c (integer-in 1 1000000000) false/c)]
[h-value (real-in 0.0 1.0)]
[v-value (real-in 0.0 1.0)])
void?]{
@ -222,12 +222,12 @@ See also
}
@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 10000) false/c)]
[v-length (or/c (integer-in 0 10000) false/c)]
[h-page (integer-in 1 10000)]
[v-page (integer-in 1 10000)]
[h-value (integer-in 0 10000)]
[v-value (integer-in 0 10000)])
@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 1000000000) false/c)]
[v-length (or/c (integer-in 0 1000000000) false/c)]
[h-page (integer-in 1 1000000000)]
[v-page (integer-in 1 1000000000)]
[h-value (integer-in 0 1000000000)]
[v-value (integer-in 0 1000000000)])
void?]{
Enables and initializes manual scrollbars for the canvas. A
@ -319,7 +319,7 @@ See also
@defmethod[(set-scroll-page [which (one-of/c 'horizontal 'vertical)]
[value (integer-in 1 10000)])
[value (integer-in 1 1000000000)])
void?]{
Set the current page step size of a manual scrollbar. (This method has
@ -336,7 +336,7 @@ See also
@defmethod[(set-scroll-pos [which (one-of/c 'horizontal 'vertical)]
[value (integer-in 0 10000)])
[value (integer-in 0 1000000000)])
void?]{
Sets the current value of a manual scrollbar. (This method has no
@ -356,7 +356,7 @@ See also
@defmethod[(set-scroll-range [which (one-of/c 'horizontal 'vertical)]
[value (integer-in 0 10000)])
[value (integer-in 0 1000000000)])
void?]{
Sets the current maximum value of a manual scrollbar. (This method has

4
collects/scribblings/gui/canvas-intf.scrbl
View File

@ -10,7 +10,7 @@ To draw onto a canvas, get its device context (see
@method[canvas<%> get-dc]).
The @scheme[canvas<%>] interface is implemented by two classes:
@itemize{
@itemize[
@item{@scheme[canvas%] --- a canvas for arbitrary drawing and
event handling}
@ -18,7 +18,7 @@ The @scheme[canvas<%>] interface is implemented by two classes:
@item{@scheme[editor-canvas%] --- a canvas for displaying
@scheme[editor<%>] objects}
}
]
@defmethod[(get-canvas-background)

4
collects/scribblings/gui/check-box-class.scrbl
View File

@ -35,12 +35,12 @@ Creates a check box with a string or bitmap label. @bitmaplabeluse[label]
The @scheme[callback] procedure is called (with the event type
@indexed-scheme['check-box]) whenever the user clicks the check box.
@DeletedStyleNote{check box}
@DeletedStyleNote[@scheme[style] @scheme[parent]]{check box}
If @scheme[value] is true, it is passed to
@method[check-box% set-value] so that the box is initially checked.
@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[]
@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]

4
collects/scribblings/gui/choice-class.scrbl
View File

@ -49,7 +49,7 @@ The @scheme[callback] procedure is called (with the event type
@indexed-scheme['choice]) when the user selects a choice item (or
re-selects the currently selected item).
@HVLabelNote{choice item} @DeletedStyleNote{choice item}
@HVLabelNote[@scheme[style]]{choice item} @DeletedStyleNote[@scheme[style] @scheme[parent]]{choice item}
By default, the first choice (if any) is initially selected. If
@scheme[selection] is positive, it is passed to
@ -57,7 +57,7 @@ By default, the first choice (if any) is initially selected. If
must be less than the length of @scheme[choices], it can be @scheme[0]
when @scheme[choices] is empty.
@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[]
@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
}}

6
collects/scribblings/gui/clipboard-client-class.scrbl
View File

@ -24,7 +24,11 @@ Creates a clipboard client that supports no data formats.
Adds a new data format name to the list supported by the clipboard
client.
@clipboardtypes[]
The @scheme[format] string is typically four capital letters. (Under
Mac OS X, only four characters for @scheme[format] are ever used.)
For example, @scheme["TEXT"] is the name of the UTF-8-encoded string
format. New format names can be used to communicate application- and
platform-specific data formats.
}

8
collects/scribblings/gui/clipboard-intf.scrbl
View File

@ -80,6 +80,14 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If
}
@defmethod[(same-clipboard-client? [owner (is-a?/c clipboard-client%)])
boolean?]{
Returns @scheme[#t] if @scheme[owner] currently owns the clipboard,
@scheme[#f] otherwise.}
@defmethod[(set-clipboard-bitmap [new-bitmap (is-a?/c bitmap%)]
[time (and/c exact? integer?)])
void?]{

4
collects/scribblings/gui/combo-field-class.scrbl
View File

@ -55,9 +55,9 @@ If @scheme[init-value] is not @scheme[""], the minimum width of the text item
is made wide enough to show @scheme[init-value]. Otherwise, a built-in
default width is selected.
@HVLabelNote{combo} @DeletedStyleNote{combo}.
@HVLabelNote[@scheme[style]]{combo} @DeletedStyleNote[@scheme[style] @scheme[parent]]{combo}.
@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[]
@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
}

4
collects/scribblings/gui/control-event-class.scrbl
View File

@ -14,7 +14,7 @@ A @scheme[control-event%] object contains information about a
[time-stamp (and/c exact? integer?) 0])]{
The @scheme[event-type] argument is one of the following:
@itemize{
@itemize[
@item{@scheme['button] --- for @scheme[button%] clicks}
@item{@scheme['check-box] --- for @scheme[check-box%] toggles}
@item{@scheme['choice] --- for @scheme[choice%] item selections}
@ -28,7 +28,7 @@ The @scheme[event-type] argument is one of the following:
@item{@scheme['menu-popdown] --- for @scheme[popup-menu%] callbacks (item selected)}
@item{@scheme['menu-popdown-none] --- for @scheme[popup-menu%] callbacks (no item selected)}
@item{@scheme['tab-panel] --- for @scheme[tab-panel%] tab changes}
}
]
This value is extracted out of a @scheme[control-event%] object with
the

4
collects/scribblings/gui/control-intf.scrbl
View File

@ -5,7 +5,7 @@
The @scheme[control<%>] interface is implemented by the built-in
control window classes:
@itemize{
@itemize[
@item{@scheme[message%]}
@item{@scheme[button%]}
@item{@scheme[check-box%]}
@ -15,7 +15,7 @@ The @scheme[control<%>] interface is implemented by the built-in
@item{@scheme[radio-box%]}
@item{@scheme[choice%]}
@item{@scheme[list-box%]}
}
]

4
collects/scribblings/gui/cursor-class.scrbl
View File

@ -30,7 +30,7 @@ relative to its top-left corner.
The second case creates a cursor using a stock cursor, specified
as one of the following:
@itemize{
@itemize[
@item{@scheme['arrow] --- the default cursor}
@ -60,7 +60,7 @@ as one of the following:
@item{@scheme['size-nw/se] --- arrows up-left and down-right}
}
]
If the cursor is created successfully, @method[cursor% ok?]
returns @scheme[#t], otherwise the cursor object cannot be

6
collects/scribblings/gui/dialog-class.scrbl
View File

@ -56,7 +56,7 @@ If the @scheme[x] or @scheme[y] argument is not @scheme[#f], it
The @scheme[style] flags adjust the appearance of the dialog on some
platforms:
@itemize{
@itemize[
@item{@scheme['no-caption] --- omits the title bar for the dialog
(Windows)}
@ -68,14 +68,14 @@ The @scheme[style] flags adjust the appearance of the dialog on some
@item{@scheme['no-sheet] --- uses a movable window for the dialog,
even if a parent window is provided (Mac OS X)}
}
]
Even if the dialog is not shown, a few notification events may be
queued for the dialog on creation. Consequently, the new dialog's
resources (e.g., memory) cannot be reclaimed until some events are
handled, or the dialog's eventspace is shut down.
@WindowKWs[] @AreaContKWs[] @AreaKWs[]
@WindowKWs[@scheme[enabled]] @AreaContKWs[] @AreaKWs[]
}
@defmethod[#:mode override

24
collects/scribblings/gui/dialog-funcs.scrbl
View File

@ -190,7 +190,7 @@ Displays a message to the user in a (modal) dialog, using
breaking lines.
The style must include exactly one of the following:
@itemize{
@itemize[
@item{@scheme['ok] --- the dialog only has an @onscreen{OK} button
and always returns @scheme['ok].}
@ -208,7 +208,7 @@ The style must include exactly one of the following:
labels, so that the user does not have to read the message text
carefully to make a selection.}
}
]
In addition, @scheme[style] can contain @scheme['caution] to make the
dialog use a caution icon instead of the application (or generic
@ -262,7 +262,7 @@ If the user clicks the button labelled @scheme[button1-label], a @scheme[1]
If @scheme[style] does not include @scheme['number-order], the order of
the buttons is platform-specific, and labels should be assigned to
the buttons based on their role:
@itemize{
@itemize[
@item{Button 1 is the normal action, and it is usually the default
button. For example, if the dialog has an @onscreen{OK} button, it is
@ -279,7 +279,7 @@ If @scheme[style] does not include @scheme['number-order], the order of
Mac OS X, it is left-aligned in the dialog). Use this button only
for three-button dialogs.}
}
]
Despite the above guidelines, any combination of visible buttons is
allowed in the dialog.
@ -323,13 +323,13 @@ See also @scheme[message+check-box/custom].
Like @scheme[message-box], except that
@itemize{
@itemize[
@item{the dialog contains a check box whose label is @scheme[check-label];}
@item{the result is two values: the @scheme[message-box] result, and a
boolean indicating whether the box was checked; and}
@item{@scheme[style] can contain @scheme['checked] to indicate that the check box
should be initially checked.}
}}
]}
@defproc[(message+check-box/custom [title label-string?]
[message string]
@ -346,13 +346,13 @@ Like @scheme[message-box], except that
(one-of/c 1 2 3 close-result)]{
Like @scheme[message-box/custom], except that
@itemize{
@itemize[
@item{the dialog contains a check box whose label is @scheme[check-label];}
@item{the result is two values: the @scheme[message-box] result, and a
boolean indicating whether the box was checked; and}
@item{@scheme[style] can contain @scheme['checked] to indicate that the check box
should be initially checked.}
}
]
@ -422,7 +422,7 @@ Lets the user select a color though the platform-specific
dialog if possible. If @scheme[init-color] is provided, the dialog is
initialized to the given color.
@italicptyStyleNote[]
@italicptyStyleNote[@scheme[style]]
The result is @scheme[#f] if the user cancels the dialog, the selected
color otherwise.
@ -443,7 +443,7 @@ Lets the user select a font though the platform-specific
dialog if possible. If @scheme[init-font] is provided, the dialog is
initialized to the given font.
@italicptyStyleNote[]
@italicptyStyleNote[@scheme[style]]
The result is @scheme[#f] if the user cancels the dialog, the selected
font otherwise.
@ -465,7 +465,7 @@ Lets the user select a PostScript configuration though a (modal)
the given configuration, otherwise the current configuration from
@scheme[current-ps-setup] is used.
@italicptyStyleNote[]
@italicptyStyleNote[@scheme[style]]
The result is @scheme[#f] if the user cancels the dialog, , a
@scheme[ps-setup%] object that encapsulates the selected PostScript
@ -494,7 +494,7 @@ The @scheme[parent] argument is used as the parent window for a dialog if
configuration from
@scheme[current-ps-setup] is used.
@italicptyStyleNote[]
@italicptyStyleNote[@scheme[style]]
The result is @scheme[#f] if the user cancels the dialog, a
@scheme[ps-setup%] object that encapsulates the selected

4
collects/scribblings/gui/editor-admin-class.scrbl
View File

@ -264,11 +264,11 @@ If @scheme[refresh?] is not @scheme[#f], then the editor is requesting
to be updated immediately.
The @scheme[bias] argument is one of:
@itemize{
@itemize[
@item{@scheme['start] --- if the range doesn't fit in the visible area, show the top-left region}
@item{@scheme['none] --- no special scrolling instructions}
@item{@scheme['end] --- if the range doesn't fit in the visible area, show the bottom-right region}
}
]
The return value is @scheme[#t] if the @techlink{display} is scrolled,
@scheme[#f] if not (either because the requested region is already

10
collects/scribblings/gui/editor-canvas-class.scrbl
View File

@ -34,7 +34,7 @@ If a canvas is initialized with @scheme[#f] for @scheme[editor],
The @scheme[style] list can contain the following flags:
@itemize{
@itemize[
@item{@scheme['no-border] --- omits a border around the canvas}
@ -73,7 +73,7 @@ The @scheme[style] list can contain the following flags:
@item{@scheme['transparent] --- the canvas is ``erased'' before an
update using it's parent window's background}
}
]
While vertical scrolling of text editors is based on lines,
horizontal scrolling and pasteboard vertical scrolling is based on a
@ -93,7 +93,7 @@ If @scheme[horizontal-inset] is not @scheme[5], it is passed on to the
@scheme[vertical-inset] is not @scheme[5], it is passed on to the
@method[editor-canvas% vertical-inset] method.
@WindowKWs[] @SubareaKWs[] @AreaKWs[]
@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
}
@ -276,7 +276,7 @@ If @scheme[refresh?] is not @scheme[#f], then the editor is updated
immediately after a successful scroll.
The @scheme[bias] argument is one of:
@itemize{
@itemize[
@item{@scheme['start] --- if the range doesn't fit in the visible
area, show the top-left region}
@ -286,7 +286,7 @@ The @scheme[bias] argument is one of:
@item{@scheme['end] --- if the range doesn't fit in the visible area,
show the bottom-right region}
}
]
The return value is @scheme[#t] if the @techlink{display} is scrolled, @scheme[#f]
if not (either because the requested region is already visible,

8
collects/scribblings/gui/editor-funcs.scrbl
View File

@ -11,7 +11,7 @@
Given a @scheme[keymap%] object, the keymap is loaded with mappable
functions that apply to all @scheme[editor<%>] objects:
@itemize{
@itemize[
@item{@scheme["copy-clipboard"]}
@item{@scheme["copy-append-clipboard"]}
@item{@scheme["cut-clipboard"]}
@ -23,7 +23,7 @@ Given a @scheme[keymap%] object, the keymap is loaded with mappable
@item{@scheme["undo"]}
@item{@scheme["redo"]}
@item{@scheme["select-all"]}
}
]
}
@ -44,7 +44,7 @@ See also
Given a @scheme[keymap%] object, the table is loaded with functions
that apply to all @scheme[text%] objects:
@itemize{
@itemize[
@item{@scheme["forward-character"]}
@item{@scheme["backward-character"]}
@item{@scheme["previous-line"]}
@ -85,7 +85,7 @@ Given a @scheme[keymap%] object, the table is loaded with functions
@item{@scheme["delete-line"]}
@item{@scheme["undo"]}
@item{@scheme["redo"]}
}
]
See also
@scheme[add-editor-keymap-functions].

146
collects/scribblings/gui/editor-intf.scrbl
View File

@ -59,7 +59,7 @@ The system adds undoers to an editor (in response to other method
}
@defmethod[(adjust-cursor [event (is-a?/c mouse-event%)])
(or/c (is-a?/c cursor%) false/c)]{
(or/c (is-a?/c cursor%) #f)]{
@methspec{
@ -332,9 +332,9 @@ Returns @scheme[#t].
}}
@defmethod*[([(change-style [delta (or/c (is-a?/c style-delta%) false/c)])
@defmethod*[([(change-style [delta (or/c (is-a?/c style-delta%) #f)])
void?]
[(change-style [style (or/c (is-a?/c style<%>) false/c)])
[(change-style [style (or/c (is-a?/c style<%>) #f)])
void?])]{
Changes the style for @techlink{items} in the editor, either by
@ -456,6 +456,12 @@ Returns the name of a style to be used for newly inserted text,
}
@defmethod[(do-copy) void?]{
See @xmethod[text% do-copy] or @xmethod[pasteboard% do-copy].}
@defmethod[(do-edit-operation [op (one-of/c 'undo 'redo 'clear 'cut 'copy 'paste
'kill 'select-all 'insert-text-box
'insert-pasteboard-box 'insert-image)]
@ -466,7 +472,7 @@ Returns the name of a style to be used for newly inserted text,
Performs a generic edit command. The @scheme[op] argument must be a
valid edit command, one of:
@itemize{
@itemize[
@item{@scheme['undo] --- undoes the last operation}
@item{@scheme['redo] --- undoes the last undo}
@item{@scheme['clear] --- deletes the current selection}
@ -481,7 +487,7 @@ valid edit command, one of:
@method[editor<%> on-new-box] .}
@item{@scheme['insert-image] --- gets a filename from the user and inserts the image as an @techlink{item} in this editor; see also
@method[editor<%> on-new-image-snip] .}
}
]
If @scheme[recursive?] is not @scheme[#f], then the command is passed on to
any active snips of this editor (i.e., snips which own the caret).
@ -492,6 +498,17 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If
}
@defmethod[(do-paste) void?]{
See @xmethod[text% do-paste] or @xmethod[pasteboard% do-paste].}
@defmethod[(do-paste-x-selection) void?]{
See @xmethod[text% do-paste-x-selection] or @xmethod[pasteboard% do-paste-x-selection].}
@defmethod[(editor-location-to-dc-location [x real?]
[y real?])
(values real? real?)]{
@ -530,7 +547,7 @@ more information.
@defmethod[(find-first-snip)
(or/c (is-a?/c snip%) false/c)]{
(or/c (is-a?/c snip%) #f)]{
Returns the first snip in the editor, or @scheme[#f] if the editor is
empty. To get all of the snips in the editor, use the @xmethod[snip%
@ -553,7 +570,7 @@ For @scheme[text%] objects: @|FCA| @|OVD|
}
@defmethod[(get-active-canvas)
(or/c (is-a?/c editor-canvas%) false/c)]{
(or/c (is-a?/c editor-canvas%) #f)]{
If the editor is displayed in a canvas, this method returns the canvas
that most recently had the keyboard focus (while the editor was
@ -562,7 +579,7 @@ If the editor is displayed in a canvas, this method returns the canvas
}
@defmethod[(get-admin)
(or/c (is-a?/c editor-admin%) false/c)]{
(or/c (is-a?/c editor-admin%) #f)]{
Returns the @scheme[editor-admin%] object currently managing this
editor or @scheme[#f] if the editor is not displayed.
@ -570,7 +587,7 @@ Returns the @scheme[editor-admin%] object currently managing this
}
@defmethod[(get-canvas)
(or/c (is-a?/c editor-canvas%) false/c)]{
(or/c (is-a?/c editor-canvas%) #f)]{
If @method[editor<%> get-active-canvas] returns a canvas, that canvas
is also returned by this method. Otherwise, if @method[editor<%>
@ -591,7 +608,7 @@ Returns a list of canvases displaying the editor. An editor may be
}
@defmethod[(get-dc)
(or/c (is-a?/c dc<%>) false/c)]{
(or/c (is-a?/c dc<%>) #f)]{
Typically used (indirectly) by snip objects belonging to the
editor. Returns a destination drawing context which is suitable for
@ -610,8 +627,8 @@ Returns the font descent for the editor. This method is primarily used
}
@defmethod[(get-extent [w (or/c (box/c (and/c real? (not/c negative?))) false/c)]
[h (or/c (box/c (and/c real? (not/c negative?))) false/c)])
@defmethod[(get-extent [w (or/c (box/c (and/c real? (not/c negative?))) #f)]
[h (or/c (box/c (and/c real? (not/c negative?))) #f)])
void?]{
Gets the current extent of the editor's graphical representation.
@ -622,8 +639,8 @@ Gets the current extent of the editor's graphical representation.
}
@defmethod[(get-file [directory (or/c path? false/c)])
(or/c path-string? false/c)]{
@defmethod[(get-file [directory (or/c path? #f)])
(or/c path-string? #f)]{
@methspec{
Called when the user must be queried for a filename to load an
@ -644,8 +661,8 @@ If the editor is displayed in a single canvas, then the canvas's
}}
@defmethod[(get-filename [temp (box/c (or/c any/c false/c)) #f])
(or/c path-string? false/c)]{
@defmethod[(get-filename [temp (box/c (or/c any/c #f)) #f])
(or/c path-string? #f)]{
Returns the path name of the last file saved from or loaded into this
editor, @scheme[#f] if the editor has no filename.
@ -665,7 +682,7 @@ a discussion of flattened vs. non-flattened text.
@defmethod[(get-focus-snip)
(or/c (is-a?/c snip%) false/c)]{
(or/c (is-a?/c snip%) #f)]{
@index['("keyboard focus" "snips")]{Returns} the snip within the
editor that gets the keyboard focus when the editor has the focus, or
@ -698,7 +715,7 @@ See also @method[editor<%> set-inactive-caret-threshold] and
@defmethod[(get-keymap)
(or/c (is-a?/c keymap%) false/c)]{
(or/c (is-a?/c keymap%) #f)]{
Returns the main keymap currently used by the editor.
@ -788,7 +805,7 @@ If the result is @scheme[#t], then the editor accepts only plain-text
}
@defmethod[(get-snip-data [thesnip (is-a?/c snip%)])
(or/c (is-a?/c editor-data%) false/c)]{
(or/c (is-a?/c editor-data%) #f)]{
@methspec{
@ -805,8 +822,8 @@ Returns @scheme[#f].
@defmethod[(get-snip-location [thesnip (is-a?/c snip%)]
[x (or/c (box/c real?) false/c) #f]
[y (or/c (box/c real?) false/c) #f]
[x (or/c (box/c real?) #f) #f]
[y (or/c (box/c real?) #f) #f]
[bottom-right? any/c #f])
boolean?]{
@ -850,8 +867,8 @@ Returns the style list currently in use by the editor.
}
@defmethod[(get-view-size [w (or/c (box/c (and/c real? (not/c negative?))) false/c)]
[h (or/c (box/c (and/c real? (not/c negative?))) false/c)])
@defmethod[(get-view-size [w (or/c (box/c (and/c real? (not/c negative?))) #f)]
[h (or/c (box/c (and/c real? (not/c negative?))) #f)])
void?]{
Returns the visible area into which the editor is currently being
@ -868,8 +885,8 @@ If the @techlink{display} is an editor canvas, see also
}
@defmethod[(global-to-local [x (or/c (box/c real?) false/c)]
[y (or/c (box/c real?) false/c)])
@defmethod[(global-to-local [x (or/c (box/c real?) #f)]
[y (or/c (box/c real?) #f)])
void?]{
Converts the given coordinates from top-level @techlink{display} coordinates
@ -949,7 +966,7 @@ The @scheme[show-errors?] argument is no longer used.
}
@defmethod[(insert-image [filename (or/c path-string? false/c) #f]
@defmethod[(insert-image [filename (or/c path-string? #f) #f]
[type (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict) 'unknown]
[relative-path? any/c #f]
[inline? any/c #t])
@ -974,7 +991,7 @@ calling
@defmethod[(insert-port [port input-port]
[format (one-of/c 'guess 'same 'copy 'standard
'text 'text-force-cr) 'guess]
[show-errors? any/c #t])
[replace-styles? any/c #t])
(one-of/c 'standard 'text 'text-force-cr)]{
Use @method[editor<%> insert-file], instead.
@ -991,8 +1008,8 @@ The @scheme[port] must support position setting with @scheme[file-position].
For information on @scheme[format], see
@method[editor<%> load-file].
The @scheme[show-errors?] argument is no longer used.
if @scheme[replace-styles?] is true, then styles in the current style
list are replaced by style specifications in @scheme[port]'s stream.
}
@defmethod[(invalidate-bitmap-cache [x real? 0.0]
@ -1030,13 +1047,20 @@ Returns @scheme[#t] if the editor is currently locked, @scheme[#f]
@defmethod[(is-modified?)
boolean?]{
Returns @scheme[#t] is the editor has been modified since the last
Returns @scheme[#t] if the editor has been modified since the last
save or load (or the last call to @method[editor<%> set-modified]
with @scheme[#f]), @scheme[#f] otherwise.
}
@defmethod[(is-printing?)
boolean?]{
Returns @scheme[#t] if the editor is currently being printed through
the @method[editor<%> print] method, @scheme[#f] otherwise.}
@defmethod[(kill [time (and/c exact? integer?) 0])
void?]{
@ -1056,7 +1080,7 @@ See also @method[editor<%> cut].
}
@defmethod[(load-file [filename (or/c path-string? false/c) #f]
@defmethod[(load-file [filename (or/c path-string? #f) #f]
[format (one-of/c 'guess 'same 'copy 'standard
'text 'text-force-cr) 'guess]
[show-errors? any/c #t])
@ -1074,7 +1098,7 @@ prompted for a name.
The possible values for @scheme[format] are listed below. A single set of
@scheme[format] values are used for loading and saving files:
@itemize{
@itemize[
@item{@scheme['guess] --- guess the format based on
extension and/or contents; when saving a file, this is the same as
@ -1097,7 +1121,7 @@ extension and/or contents; when saving a file, this is the same as
(@scheme[text%] only); when writing, change automatic newlines (from
word-wrapping) into real carriage returns}
}
]
In a @scheme[text%] instance, the format returned from @method[text%
get-file-format] is always one of @scheme['standard], @scheme['text],
@ -1117,8 +1141,8 @@ See also @method[editor<%> on-load-file], @method[editor<%>
}
@defmethod[(local-to-global [x (box/c real?)]
[y (box/c real?)])
@defmethod[(local-to-global [x (or/c (box/c real?) #f)]
[y (or/c (box/c real?) #f)])
void?]{
Converts the given coordinates from editor @techlink{location}
@ -1499,7 +1523,7 @@ Creates a @scheme[editor-snip%] with either a sub-editor from
}}
@defmethod[(on-new-image-snip [filename (or/c path? false/c)]
@defmethod[(on-new-image-snip [filename (or/c path? #f)]
[kind (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)]
[relative-path? any/c]
[inline? any/c])
@ -1689,7 +1713,7 @@ To extend or re-implement copying, override the @xmethod[text%
@defmethod[(print [interactive? any/c #t]
[fit-on-page? any/c #t]
[output-mode (one-of/c 'standard 'postscript) 'standard]
[parent (or/c (or/c @scheme[frame%] (is-a?/c dialog%)) false/c) #f]
[parent (or/c (or/c @scheme[frame%] (is-a?/c dialog%)) #f) #f]
[force-ps-page-bbox? any/c #t]
[as-eps? any/c #f])
void?]{
@ -1713,7 +1737,7 @@ The @scheme[output-mode] setting is used for Windows and Mac OS X. It
using the platform-specific standard printing mechanism. The possible
values are
@itemize{
@itemize[
@item{@scheme['standard] --- print using the platform-standard
mechanism (via a @scheme[printer-dc%]) under Windows and
@ -1722,7 +1746,7 @@ The @scheme[output-mode] setting is used for Windows and Mac OS X. It
@item{@scheme['postscript] --- print to a PostScript file (via a
@scheme[post-script-dc%])}
}
]
If @scheme[parent] is not @scheme[#f], it is used as the parent window
for configuration dialogs (for either PostScript or platform-standard
@ -1750,18 +1774,26 @@ The printing margins are determined by @method[ps-setup%
}
@defmethod[(print-to-dc [dc (is-a?/c dc<%>)])
@defmethod[(print-to-dc [dc (is-a?/c dc<%>)]
[page-number exact-integer? -1])
void?]{
Prints the editor into the given drawing context. See also
@method[editor<%> print].
If @scheme[page-number] is a non-negative integer, then just the
indicated page is printed, where pages are numbered from
@scheme[1]. (So, supplying @scheme[0] as @scheme[page-number] produces
no output.) When @scheme[page-number] is negative, the
@method[dc<%> start-page] and @scheme[dc<%> end-page] methods of @scheme[dc] are
called for each page.
}
@defmethod[(put-file [directory (or/c path? false/c)]
[default-name (or/c path? false/c)])
(or/c path-string? false/c)]{
@defmethod[(put-file [directory (or/c path? #f)]
[default-name (or/c path? #f)])
(or/c path-string? #f)]{
@methspec{
Called when the user must be queried for a filename to save an
@ -1794,7 +1826,7 @@ See @method[editor<%> read-header-from-file].
@defmethod[(read-from-file [stream (is-a?/c editor-stream-in%)]
[overwrite-styles? any/c #t])
[overwrite-styles? any/c #f])
boolean?]{
Reads new contents for the editor from a stream. The return value is
@ -1807,7 +1839,7 @@ The stream provides either new mappings for names in the editor's
when the editor was written to the stream; see also @method[editor<%>
write-to-file]).
@itemize{
@itemize[
@item{In the former case, if the @scheme[overwrite-styles?] argument
is @scheme[#f], then each style name in the loaded file that is already
@ -1818,7 +1850,7 @@ The stream provides either new mappings for names in the editor's
@item{In the latter case, the editor's style list will be changed to
the previously-read list.}
}
]
}
@ -1860,7 +1892,7 @@ See also @method[editor<%> add-undo].
[width (and/c real? (not/c negative?))]
[height (and/c real? (not/c negative?))]
[draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)]
[background (or/c (is-a?/c color%) false/c)])
[background (or/c (is-a?/c color%) #f)])
void?]{
Repaints a region of the editor, generally called by an editor
@ -1940,7 +1972,7 @@ If @scheme[redraw-now?] is @scheme[#f], the editor will require
}
@defmethod[(save-file [filename (or/c path-string? false/c) #f]
@defmethod[(save-file [filename (or/c path-string? #f) #f]
[format (one-of/c 'guess 'same 'copy 'standard
'text 'text-force-cr) 'same]
[show-errors? any/c #t])
@ -2074,7 +2106,7 @@ Normally, this method is called only by @xmethod[editor-canvas%
}
@defmethod[(set-admin [admin (or/c (is-a?/c editor-admin%) false/c)])
@defmethod[(set-admin [admin (or/c (is-a?/c editor-admin%) #f)])
void?]{
Sets the editor's administrator. This method is only called by an
@ -2087,7 +2119,7 @@ get-admin]}]
}
@defmethod[(set-caret-owner [snip (or/c (is-a?/c snip%) false/c)]
@defmethod[(set-caret-owner [snip (or/c (is-a?/c snip%) #f)]
[domain (one-of/c 'immediate 'display 'global) 'immediate])
void?]{
@ -2105,7 +2137,7 @@ If @scheme[#f] is provided as the new owner, then the local focus is
The domain of focus-setting is one of:
@itemize{
@itemize[
@item{@scheme['immediate] --- only set the focus owner within the
editor}
@ -2117,7 +2149,7 @@ The domain of focus-setting is one of:
@item{@scheme['global] --- make this editor or the new focus
owner get the keyboard focus among all elements in the editor's frame}
}
]
@MonitorMethod[@elem{The focus state of an editor} @elem{by the
system} @elem{@method[editor<%> on-focus]} @elem{focus}]
@ -2127,8 +2159,8 @@ See also @method[editor<%> get-focus-snip].
}
@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) false/c)]
[override? any/c @scheme[#t]])
@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) #f)]
[override? any/c #t])
void?]{
Sets the custom cursor for the editor to @scheme[cursor]. If
@ -2148,7 +2180,7 @@ An embedding editor's custom cursor can override the cursor of an
}
@defmethod[(set-filename [filename (or/c path-string? false/c)]
@defmethod[(set-filename [filename (or/c path-string? #f)]
[temporary? any/c #f])
void?]{
@ -2172,7 +2204,7 @@ Sets the threshold for painting an inactive selection. See
}
@defmethod[(set-keymap [keymap (or/c (is-a?/c keymap%) false/c) #f])
@defmethod[(set-keymap [keymap (or/c (is-a?/c keymap%) #f) #f])
void?]{
Sets the current keymap for the editor. A @scheme[#f] argument removes
@ -2336,7 +2368,7 @@ recalculated on demand.
See also @method[editor<%> invalidate-bitmap-cache].}
@defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) false/c)])
@defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) #f)])
void?]{
Notifies the editor that a style in its style list has changed. This

48
collects/scribblings/gui/editor-overview.scrbl
View File

@ -7,7 +7,7 @@
The editor toolbox provides a foundation for two common kinds of
applications:
@itemize{
@itemize[
@item{@italic{Programs that need a sophisticated text editor} ---
The simple text field control is inadequate for text-intensive
@ -19,7 +19,7 @@ The editor toolbox provides a foundation for two common kinds of
lines and boxes, but many applications need an interactive canvas,
where the user can drag and resize individual objects.}
}
]
Both kinds of applications need an extensible editor that can handle
text, images, programmer-defined items, and even embedded
@ -27,7 +27,7 @@ Both kinds of applications need an extensible editor that can handle
editor toolbox therefore provides two kinds of editors via two
classes:
@itemize{
@itemize[
@item{@scheme[text%] --- in a @deftech{text editor}, items are
automatically positioned in a paragraph flow.}
@ -35,7 +35,7 @@ Both kinds of applications need an extensible editor that can handle
@item{@scheme[pasteboard%] --- in a @deftech{pasteboard editor},
items are explicitly positioned and dragable.}
}
]
This editor architecture addresses the full range of real-world
issues for an editor---including cut-and-paste, extensible file
@ -160,7 +160,7 @@ Applications that use the editor classes typically derive new versions
The editor toolbox supports extensible and nestable editors by
decomposing an editor assembly into three functional parts:
@itemize{
@itemize[
@item{The @deftech{editor} itself stores the state of the text or
pasteboard and handles most events and editing operations. The
@ -183,7 +183,7 @@ The editor toolbox supports extensible and nestable editors by
@scheme[editor-snip%] class also acts as a display for embedded
editors.}
}
]
These three parts are illustrated by a simple word processor. The
editor corresponds to the text document. The editor object receives
@ -275,7 +275,7 @@ Styles are hierarchical: each style is defined in terms of another
style is encoded in a @deftech{style delta} (or simply
@deftech{delta}). A delta encodes changes such as
@itemize{
@itemize[
@item{change the font family to @italic{X};}
@ -285,7 +285,7 @@ Styles are hierarchical: each style is defined in terms of another
@item{change everything to match the style description @italic{Z}.}
}
]
Style objects are never created separately; rather, they are always
created through a @deftech{style list}, an instance of the
@ -298,7 +298,7 @@ Style objects are never created separately; rather, they are always
Each new style is defined in one of two ways:
@itemize{
@itemize[
@item{A @deftech{derived style} is defined in terms of a base style
and a delta. Every style (except for the root style) has a base
@ -317,7 +317,7 @@ Each new style is defined in one of two ways:
character style is the shift style. However, FrameMaker allows only
those two levels; with join styles support any number of levels.)}
}
]
@index*['("Standard style") (list @elem{@scheme["Standard"]
style})]{Usually}, when text is inserted into a text editor, it
@ -383,7 +383,7 @@ The editor file data format can be embedded within another file, and
Graceful and extensible encoding of snips requires that
two issues are addressed:
@itemize{
@itemize[
@item{The encoding function for a snip can be associated with the snip
itself. To convert a snip from an encoded representation (e.g., as
@ -407,7 +407,7 @@ Graceful and extensible encoding of snips requires that
each editor data object has an @deftech{editor data class}, which is
an instance of the @scheme[editor-data-class%] class.}
}
]
Snip classes, snip data, and snip data classes solve problems related
to encoding and decoding snips. In an application that has no need
@ -472,7 +472,7 @@ Just as a snip must be associated with a snip class to be decoded (see
To store and load information about a snip or region in an editor:
@itemize{
@itemize[
@item{derive new classes from @scheme[editor-data%] and
@scheme[editor-data-class%].}
@ -488,7 +488,7 @@ To store and load information about a snip or region in an editor:
not for file-saving encoding; see @|globaleditordatadiscuss| for
information on extending the file format.}
}
]
@subsection[#:tag "globaleditordata"]{Global Data: Headers and Footers}
@ -497,7 +497,7 @@ The editor file format provides for adding extra global data in
special header and footer sections. To save and load special header
and/or footer records:
@itemize{
@itemize[
@item{Pick a name for each header/footer record. This name should not
conflict with any other header/footer record name in use, and no one
@ -512,7 +512,7 @@ The editor file format provides for adding extra global data in
@method[editor<%> read-header-from-file] and/or @method[editor<%>
read-footer-from-file] methods.}
}
]
When an editor is saved, the methods @method[editor<%>
write-headers-to-file] and @method[editor<%> write-footers-to-file]
@ -564,7 +564,7 @@ In plain text editors, there is a simple correlation between
Text can be extracted from an editor in either of two forms:
@itemize{
@itemize[
@item{@deftech{Simple text}, where there is one character per
@techlink{item}. @techlink{Item}s that are characters are mapped to
@ -582,7 +582,7 @@ Text can be extracted from an editor in either of two forms:
``flattened'' because the editor's @techlink{item}s have been reduced
to a linear sequence of characters.}
}
]
@section[#:tag "drawcaretinfo"]{Caret Ownership}
@ -604,7 +604,7 @@ When an editor or snip is drawn, an argument to the drawing method
specifies whether the caret should be drawn with the data. This
argument can be any of (in increasing order):
@itemize{
@itemize[
@item{@indexed-scheme['no-caret] --- The caret should not be drawn at
all.}
@ -616,7 +616,7 @@ When an editor or snip is drawn, an argument to the drawing method
@item{@indexed-scheme['show-caret] --- The caret should be drawn to show
keyboard focus ownership.}
}
]
The @scheme['show-inactive-caret] display mode is useful for showing
selection ranges in text editors that do not have the focus. This
@ -668,7 +668,7 @@ Note that there is no attempt to save clickback information when a
Instances of @scheme[editor<%>] have three levels of internal
locking:
@itemize{
@itemize[
@item{write locking --- When an editor is internally locked for
writing, the abstract content of the editor cannot be changed (e.g.,
@ -696,7 +696,7 @@ Instances of @scheme[editor<%>] have three levels of internal
snips. The @method[editor<%> locked-for-read?] method reports
whether an editor is currently locked for reading.}
}
]
The internal lock for an editor is @italic{not} affected by calls to
@method[editor<%> lock].
@ -727,7 +727,7 @@ Nevertheless, the editor supports certain concurrent patterns
refreshes do not prevent editor modifications, the following are
guaranteed:
@itemize{
@itemize[
@item{When an editor's @method[editor<%> refresh] method is
called during an edit sequence (which is started by
@ -749,7 +749,7 @@ Nevertheless, the editor supports certain concurrent patterns
delegated to the edit-sequence thread, to be called when the edit
sequence is complete.}
}
]
Thus, disabling an @scheme[editor-canvas%] object (using
@method[window<%> enable]) is sufficient to ensure that a

20
collects/scribblings/gui/editor-stream-in-base-class.scrbl
View File

@ -24,15 +24,27 @@ Returns @scheme[#t] if there has been an error reading from the
@defmethod[(read [data (and/c vector? (not immutable?))])
exact-nonnegative-integer?]{
Reads Latin-1 characters to fill the supplied vector. The return value is the
number of characters read, which may be less than the number
Like @method[editor-stream-in-base% read-bytes], but fills a supplied
vector with Latin-1 characters instead of filling a byte string. This method
is implemented by default via @method[editor-stream-in-base% read-bytes].}
@defmethod[(read-bytes [bstr (and/c bytes? (not immutable?))])
exact-nonnegative-integer?]{
Reads bytes to fill the supplied byte string. The return value is the
number of bytes read, which may be less than the number
requested if the stream is emptied. If the stream is emptied, the
next call to @method[editor-stream-in-base% bad?] must return
@scheme[#t].
@scheme[#t].}
@defmethod[(read-byte) (or/c byte? #f)]{
Reads a single byte and return it, or returns @scheme[#f] if no more
bytes are available. The default implementation of this method uses
@method[editor-stream-in-base% read-bytes].
}
@defmethod[(seek [pos exact-nonnegative-integer?])
void?]{

10
collects/scribblings/gui/editor-stream-in-class.scrbl
View File

@ -54,12 +54,18 @@ Returns the next integer value in the stream.
@defmethod[(get-fixed [v (box/c (and/c exact? integer?))])
(is-a?/c editor-stream-in%)]{
@boxisfill[(scheme v) @elem{a fixed-size integer from the stream obtained through
@method[editor-stream-in% get-fixed-exact]}]
}
@defmethod[(get-fixed-exact)
(and/c exact? integer?)]{
Gets a fixed-sized integer from the stream. See
@method[editor-stream-out% put-fixed] for more information.
Reading from a bad stream always gives @scheme[0].
@boxisfill[(scheme v) @elem{the fixed-size integer from the stream}]
}
@defmethod[(get-inexact)

10
collects/scribblings/gui/editor-stream-out-base-class.scrbl
View File

@ -39,6 +39,12 @@ Returns the current stream position.
@defmethod[(write [data (listof char?)])
void?]{
Writes data (encoded as Latin-1 characters) to the stream.
Writes data (encoded as Latin-1 characters) to the stream. This method
is implemented by default via @method[editor-stream-out-base%
write-bytes].}
@defmethod[(write-bytes [bstr bytes?]) void?]{
Writes data to the stream.}}
}}

15
collects/scribblings/gui/editor-stream-out-class.scrbl
View File

@ -62,8 +62,9 @@ This method is called by @scheme[write-editor-global-header].
Writes @scheme[v], or @scheme[n] bytes of @scheme[v].
When @scheme[n] is supplied, use @method[editor-stream-in%
get-unterminated-bytes] to read the bytes later.
When @scheme[n] is supplied with a byte-string @scheme[v], use
@method[editor-stream-in% get-unterminated-bytes] to read the bytes
later.
If @scheme[n] is not supplied and @scheme[v] is a byte string, then
for historical reasons, the actual number of bytes written includes a
@ -85,9 +86,15 @@ Puts a fixed-sized integer into the stream. This method is needed
fixed-size number.
Numbers written to a stream with @method[editor-stream-out% put-fixed]
must be read with @method[editor-stream-in% get-fixed].
must be read with @method[editor-stream-in% get-fixed-exact]
or @method[editor-stream-in% get-fixed].}
@defmethod[(put-unterminated [v bytes?]) (is-a?/c editor-stream-out%)]{
The same as calling @method[editor-stream-out% put] with
@scheme[(bytes-length v)] and @scheme[v].}
}
@defmethod[(tell)
exact-nonnegative-integer?]{

4
collects/scribblings/gui/editor-wordbreak-map-class.scrbl
View File

@ -16,13 +16,13 @@ A global object @scheme[the-editor-wordbreak-map] is created
A wordbreak objects implements a mapping from each character to a list
of symbols. The following symbols are legal elements of the list:
@itemize{
@itemize[
@item{@indexed-scheme['caret]}
@item{@indexed-scheme['line]}
@item{@indexed-scheme['selection]}
@item{@indexed-scheme['user1]}
@item{@indexed-scheme['user2]}
}
]
The presence of a flag in a character's value indicates that the
character does not break a word when searching for breaks using the

4
collects/scribblings/gui/eventspace-funcs.scrbl
View File

@ -158,7 +158,7 @@ If @scheme[v] is @indexed-scheme['wait], and @scheme[yield] is called
in the handler thread of an eventspace, then @scheme[yield] starts
processing events in that eventspace until
@itemize{
@itemize[
@item{no top-level windows in the eventspace are visible;}
@ -170,7 +170,7 @@ If @scheme[v] is @indexed-scheme['wait], and @scheme[yield] is called
with @scheme['root] (i.e., creating a @scheme['root] menu bar
prevents an eventspace from ever unblocking).}
}
]
When called in a non-handler thread, @scheme[yield] returns
immediately. In either case, the result is @scheme[#t].

10
collects/scribblings/gui/frame-class.scrbl
View File

@ -60,7 +60,7 @@ they are created).
The @scheme[style] flags adjust the appearance of the frame on
some platforms:
@itemize{
@itemize[
@item{@scheme['no-resize-border] --- omits the resizeable border
around the window (Windows, X MWM) or grow box in the bottom right
@ -102,7 +102,7 @@ some platforms:
background (Mac OS X); this style is ignored when
@scheme['no-caption] is specified}
}
]
If the @scheme['mdi-child] style is specified, the @scheme[parent] must be
a frame with the @scheme['mdi-parent] style, otherwise @|MismatchExn|.
@ -112,7 +112,7 @@ Even if the frame is not shown, a few notification events may be
resources (e.g., memory) cannot be reclaimed until some events are
handled, or the frame's eventspace is shut down.
@WindowKWs[] @AreaContKWs[] @AreaKWs[]
@WindowKWs[@scheme[enabled]] @AreaContKWs[] @AreaKWs[]
}
@ -274,7 +274,7 @@ Sets the large or small icon bitmap for this frame. Future changes to
The icon is used in a platform-specific way:
@itemize{
@itemize[
@item{Windows --- the small icon is used for the frame's icon (in the
top-left) and in the task bar, and the large icon is used for
@ -286,7 +286,7 @@ The icon is used in a platform-specific way:
as Windows, and others use the small icon when iconifying the
frame; the large icon is ignored.}
}
]
The bitmap for either icon can be any size, but most platforms scale
the small bitmap to 16 by 16 pixels and the large bitmap to 32 by 32

Some files were not shown because too many files have changed in this diff Show More