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

Scheme-implemented editor classes; on-demand instantiation of module phases

Browse Source 
svn: r14445

original commit: 1d26e97a35e7c2bd67130b70680a7870b41ef45c
This commit is contained in:
Matthew Flatt 2009-04-07 17:12:22 +00:00
parent 9d63c4e072
commit bbf44e7a56
45 changed files with 16804 additions and 1017 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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?))

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)))

15
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"
@ -182,8 +193,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%

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))]))

11
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%
(define wx-editor-canvas%
(class (make-canvas-glue%
(make-editor-canvas% (make-control% wx:editor-canvas%
0 0 #t #t)))))
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)

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

@ -0,0 +1,27 @@
#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))
(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])
(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 (delay-refresh?) #f)
(def/public (popup-menu [popup-menu% m] [real? x] [real? y]) #f)
(def/public (modified [any? mod?]) (void)))

1133
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 (delay-refresh?)
(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%))

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,737 @@
#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 ([r (send c chain-handle-key-event obj event grab try-prefixed? score)])
(if (r . > . 0)
(begin
(reset)
r)
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

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,140 @@
#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?)
;; 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)
;; 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)
(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?))))

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

@ -0,0 +1,761 @@
#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))
(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)))
;; ----------------------------------------
(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))))
(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)))
;; ----------------------------------------
(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 ([s (make-bytes 1)])
(let loop ([prev-byte 0])
(if (not (= 1 (send f read-bytes s)))
(bad!)
(let ([b (bytes-ref s 0)])
(case (integer->char b)
[(#\#)
(let ([pos (send f tell)])
(if (and (= 1 (send f read-bytes s))
(= (bytes-ref s 0) (char->integer #\|)))
;; skip to end of comment
(let cloop ([saw-bar? #f]
[saw-hash? #f]
[nesting 0])
(if (not (= 1 (send f read-bytes s)))
(bad!)
(cond
[(and saw-bar? (= (bytes-ref s 0) (char->integer #\#)))
(if (zero? nesting)
(loop (char->integer #\space))
(cloop #f #f (sub1 nesting)))]
[(and saw-hash? (= (bytes-ref s 0) (char->integer #\|)))
(cloop #t #f (add1 nesting))]
[else (cloop (= (bytes-ref s 0) (char->integer #\|))
(= (bytes-ref s 0) (char->integer #\#))
nesting)])))
(begin
(send f seek pos)
(char->integer #\#))))]
[(#\;)
;; skip to end of comment
(let cloop ()
(if (not (= 1 (send f read-bytes s)))
(bad!)
(if (or (= (bytes-ref s 0) (char->integer #\newline))
(= (bytes-ref s 0) (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)]
[s (make-bytes 1)])
(send f read-bytes s)
(let ([d? (= (bytes-ref s 0) (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* ([s (make-bytes 1)]
[l (cons (integer->char c0)
(let loop ([counter 50])
(if (zero? counter)
null
(if (= 1 (send f read-bytes s))
(let ([s (bytes-ref s 0)])
(if (is-delim? s)
null
(cons (integer->char s)
(loop (sub1 counter)))))
null))))])
(inc-item-count)
(let ([n (string->number (list->string l))])
(cond
[(or (not n)
(not (real? n))
(and get-exact? (not (exact-integer? n))))
(set! is-bad? #t)
(if get-exact? 0 0.0)]
[get-exact? n]
[else
(exact->inexact n)]))))))
(define/private (get-a-string limit recur?)
(let* ([orig-len (if recur?
(if (limit . < . 16)
limit
16)
(get-exact))]
[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 [box? vb])
(let ([v (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)))])
(set-box! vb v)))
#|
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)
((tell) . > . (car boundaries)))
(set! is-bad? #t)
(error 'editor-stream-in%
"overread (caused by file corruption?; ~a vs ~a)" (tell) (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)])
(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! 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%)

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

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,307 @@
#lang scheme/base
(require scheme/class
"private.ss"
"snip.ss"
"snip-flags.ss")
(provide 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))))

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

@ -0,0 +1,151 @@
#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])
(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)
(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"

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?]{

124
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)]
@ -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])
@ -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?]{
@ -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
@ -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?]{
@ -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

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

@ -24,14 +24,18 @@ 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[(seek [pos exact-nonnegative-integer?])
void?]{

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.}}
}}

14
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,14 @@ 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].}
@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?]{

9
collects/scribblings/gui/pasteboard-class.scrbl
View File

@ -499,7 +499,8 @@ Deletes @scheme[snip] when provided, or deletes the currently selected
}
@defmethod[(do-copy [time (and/c exact? integer?)]
@defmethod[#:mode override
(do-copy [time (and/c exact? integer?)]
[extend? any/c])
void?]{
@ -523,7 +524,8 @@ Copies the current selection, extending the current clipboard contexts
}}
@defmethod[(do-paste [time (and/c exact? integer?)])
@defmethod[#:mode override
(do-paste [time (and/c exact? integer?)])
void?]{
@methspec{
@ -544,7 +546,8 @@ Pastes.
}}
@defmethod[(do-paste-x-selection [time (and/c exact? integer?)])
@defmethod[#:mode override
(do-paste-x-selection [time (and/c exact? integer?)])
void?]{
@methspec{

130
collects/scribblings/gui/text-class.scrbl
View File

@ -324,12 +324,12 @@ See also @method[text% hide-caret].
@defmethod*[#:mode extend
([(change-style [delta (or/c (is-a?/c style-delta%) false/c)]
([(change-style [delta (or/c (is-a?/c style-delta%) #f)]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]
[counts-as-mod? any/c #t])
void?]
[(change-style [style (or/c (is-a?/c style<%>) false/c)]
[(change-style [style (or/c (is-a?/c style<%>) #f)]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]
[counts-as-mod? any/c #t])
@ -422,7 +422,8 @@ Deletes the specified range or the currently selected text (when no
}
@defmethod[(do-copy [start exact-nonnegative-integer?]
@defmethod[#:mode override
(do-copy [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[time (and/c exact? integer?)]
[extend? any/c])
@ -446,7 +447,8 @@ Copy the data from @scheme[start] to @scheme[end], extending the current
}}
@defmethod[(do-paste [start exact-nonnegative-integer?]
@defmethod[#:mode override
(do-paste [start exact-nonnegative-integer?]
[time (and/c exact? integer?)])
void?]{
@methspec{
@ -467,7 +469,8 @@ Pastes into the @techlink{position} @scheme[start].
}}
@defmethod[(do-paste-x-selection [start exact-nonnegative-integer?]
@defmethod[#:mode override
(do-paste-x-selection [start exact-nonnegative-integer?]
[time (and/c exact? integer?)])
void?]{
@methspec{
@ -500,7 +503,7 @@ See also @method[text% delete].
@defmethod[(find-line [y real?]
[on-it? (or/c (box/c any/c) false/c) #f])
[on-it? (or/c (box/c any/c) #f) #f])
exact-nonnegative-integer?]{
Given a @techlink{location} in the editor, returns the line at the
@ -516,8 +519,17 @@ Given a @techlink{location} in the editor, returns the line at the
}
@defmethod[(find-next-non-string-snip [after (or/c (is-a?/c snip%) false/c)])
(or/c (is-a?/c snip%) false/c)]{
@defmethod[(find-newline [direction (one-of/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof])
(or/c exact-nonnegative-integer? #f)]{
Like @method[text% find-string], but specifically finds a paragraph
break (possibly more efficiently than searching text).}
@defmethod[(find-next-non-string-snip [after (or/c (is-a?/c snip%) #f)])
(or/c (is-a?/c snip%) #f)]{
Given a snip, returns the next snip in the editor (after the given
one) that is not an instance of @scheme[string-snip%]. If
@ -530,9 +542,9 @@ Given a snip, returns the next snip in the editor (after the given
@defmethod[(find-position [x real?]
[y real?]
[at-eol? (or/c (box/c any/c) false/c) #f]
[on-it? (or/c (box/c any/c) false/c) #f]
[edge-close? (or/c (box/c real?) false/c) #f])
[at-eol? (or/c (box/c any/c) #f) #f]
[on-it? (or/c (box/c any/c) #f) #f]
[edge-close? (or/c (box/c real?) #f) #f])
exact-nonnegative-integer?]{
Given a @techlink{location} in the editor, returns the @techlink{position} at the
@ -557,9 +569,9 @@ See @|ateoldiscuss| for a discussion of the @scheme[at-eol?] argument.
@defmethod[(find-position-in-line [line exact-nonnegative-integer?]
[x real?]
[at-eol? (or/c (box/c any/c) false/c) #f]
[on-it? (or/c (box/c any/c) false/c) #f]
[edge-close? (or/c (box/c real?) false/c) #f])
[at-eol? (or/c (box/c any/c) #f) #f]
[on-it? (or/c (box/c any/c) #f) #f]
[edge-close? (or/c (box/c real?) #f) #f])
exact-nonnegative-integer?]{
Given a @techlink{location} within a line of the editor, returns the
@ -579,8 +591,8 @@ See @method[text% find-position] for a discussion of
@defmethod[(find-snip [pos exact-nonnegative-integer?]
[direction (one-of/c 'before-or-none 'before 'after 'after-or-none)]
[s-pos (or/c (box/c exact-nonnegative-integer?) false/c) #f])
(or/c (is-a?/c snip%) false/c)]{
[s-pos (or/c (box/c exact-nonnegative-integer?) #f) #f])
(or/c (is-a?/c snip%) #f)]{
Returns the snip at a given @techlink{position}, or @scheme[#f] if an appropriate
snip cannot be found.
@ -615,7 +627,7 @@ can be any of the following:
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof]
[get-start? any/c #t]
[case-sensitive? any/c #t])
(or/c exact-nonnegative-integer? false/c)]{
(or/c exact-nonnegative-integer? #f)]{
Finds an exact-match string in the editor and returns its @techlink{position}.
If the string is not found, @scheme[#f] is returned.
@ -656,8 +668,8 @@ Finds all occurrences of a string using @method[text% find-string]. If
}
@defmethod[(find-wordbreak [start (or/c (box/c exact-nonnegative-integer?) false/c)]
[end (or/c (box/c exact-nonnegative-integer?) false/c)]
@defmethod[(find-wordbreak [start (or/c (box/c exact-nonnegative-integer?) #f)]
[end (or/c (box/c exact-nonnegative-integer?) #f)]
[reason (one-of/c 'caret 'line 'selection 'user1 'user2)])
void?]{
@ -804,8 +816,8 @@ Returns @scheme[#t] if the editor is in overwrite mode, @scheme[#f]
}
@defmethod[(get-position [start (or/c (box/c exact-nonnegative-integer?) false/c)]
[end (or/c (box/c exact-nonnegative-integer?) false/c) #f])
@defmethod[(get-position [start (or/c (box/c exact-nonnegative-integer?) #f)]
[end (or/c (box/c exact-nonnegative-integer?) #f) #f])
void?]{
Returns the current selection range in @techlink{position}s. If
@ -823,7 +835,7 @@ and @method[text% get-end-position].
@defmethod[(get-region-data [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?])
(or/c (is-a?/c editor-data%) false/c)]{
(or/c (is-a?/c editor-data%) #f)]{
Gets extra data associated with a given region. See
@|editordatadiscuss| for more information.
@ -854,7 +866,7 @@ Returns an inexact number that increments every time the editor is
@defmethod[(get-snip-position [snip (is-a?/c snip%)])
(or/c exact-nonnegative-integer? false/c)]{
(or/c exact-nonnegative-integer? #f)]{
Returns the starting @techlink{position} of a given snip or
@scheme[#f] if the snip is not in this editor.
@ -862,9 +874,9 @@ Returns the starting @techlink{position} of a given snip or
}
@defmethod[(get-snip-position-and-location [snip (is-a?/c snip%)]
[pos (or/c (box/c exact-nonnegative-integer?) false/c)]
[x (or/c (box/c real?) false/c) #f]
[y (or/c (box/c real?) false/c) #f])
[pos (or/c (box/c exact-nonnegative-integer?) #f)]
[x (or/c (box/c real?) #f) #f]
[y (or/c (box/c real?) #f) #f])
boolean?]{
Gets a snip's @techlink{position} and top left @techlink{location} in editor
@ -911,9 +923,9 @@ See also @method[text% set-styles-sticky].
}
@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) false/c) #f]
[tab-width (or/c (box/c real?) false/c) #f]
[in-units (or/c (box/c any/c) false/c) #f])
@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) #f) #f]
[tab-width (or/c (box/c real?) #f) #f]
[in-units (or/c (box/c any/c) #f) #f])
(listof real?)]{
Returns the current tab-position array as a list.
@ -964,8 +976,8 @@ Returns the distance from the top of the editor to the alignment
}
@defmethod[(get-visible-line-range [start (or/c (box/c exact-nonnegative-integer?) false/c)]
[end (or/c (box/c exact-nonnegative-integer?) false/c)]
@defmethod[(get-visible-line-range [start (or/c (box/c exact-nonnegative-integer?) #f)]
[end (or/c (box/c exact-nonnegative-integer?) #f)]
[all? any/c #t])
void?]{
@ -985,8 +997,8 @@ If the editor is displayed by multiple canvases and @scheme[all?] is
}
@defmethod[(get-visible-position-range [start (or/c (box/c exact-nonnegative-integer?) false/c)]
[end (or/c (box/c exact-nonnegative-integer?) false/c)]
@defmethod[(get-visible-position-range [start (or/c (box/c exact-nonnegative-integer?) #f)]
[end (or/c (box/c exact-nonnegative-integer?) #f)]
[all? any/c #t])
void?]{
@ -1523,7 +1535,9 @@ If the paragraph ends with invisible @techlink{item}s (such as a carriage
@defmethod[(paragraph-start-line [paragraph exact-nonnegative-integer?])
exact-nonnegative-integer?]{
Returns the starting line of a given paragraph. @|ParagraphNumbering| @|LineNumbering|
Returns the starting line of a given paragraph. If @scheme[paragraph]
is greater than the highest-numbered paragraph, then the editor's end
@tech{position} is returned. @|ParagraphNumbering| @|LineNumbering|
@|FCAMW| @|EVD|
@ -1548,13 +1562,17 @@ If the paragraph starts with invisible @techlink{item}s and @scheme[visible?] is
@defmethod[#:mode override
(paste [time (and/c exact? integer?) 0]
[start (or/c exact-nonnegative-integer? (one/of 'end)) 'end]
[start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same])
void?]{
Pastes into the specified range. If @scheme[start] is @scheme['end], then
the current selection end @techlink{position} is used. If @scheme[end] is
@scheme['same], then @scheme[start] is used for @scheme[end].
Pastes into the specified range. If @scheme[start] is @scheme['start],
then the current selection start @techlink{position} is used. If
@scheme[start] is @scheme['end], then the current selection end
@techlink{position} is used. If @scheme[end] is @scheme['same], then
@scheme[start] is used for @scheme[end], unless @scheme[start] is
@scheme['start], in which case the current selection end
@techlink{position} is used.
See @|timediscuss| for a discussion of the @scheme[time] argument. If
@scheme[time] is outside the platform-specific range of times,
@ -1586,13 +1604,17 @@ If the previous operation on the editor was not a paste, calling
@defmethod[#:mode override
(paste-x-selection [time (and/c exact? integer?)]
[start (or/c exact-nonnegative-integer? (one/of 'end)) 'end]
[start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same])
void?]{
Pastes into the specified range. If @scheme[start] is @scheme['end], then
the current selection end @techlink{position} is used. If @scheme[end] is
@scheme['same], then @scheme[start] is used for @scheme[end].
Pastes into the specified range. If @scheme[start] is @scheme['start],
then the current selection start @techlink{position} is used. If
@scheme[start] is @scheme['end], then the current selection end
@techlink{position} is used. If @scheme[end] is @scheme['same], then
@scheme[start] is used for @scheme[end], unless @scheme[start] is
@scheme['start], in which case the current selection end
@techlink{position} is used.
See @|timediscuss| for a discussion of the @scheme[time] argument. If
@scheme[time] is outside the platform-specific range of times,
@ -1616,8 +1638,8 @@ See @|ateoldiscuss| for a discussion of @scheme[at-eol?].
@defmethod[(position-location [start exact-nonnegative-integer?]
[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]
[top? any/c #t]
[at-eol? any/c #f]
[whole-line? any/c #f])
@ -1647,10 +1669,10 @@ maximum bottom @techlink{location} for the whole line is returned in @scheme[y].
@defmethod[(position-locations [start exact-nonnegative-integer?]
[top-x (or/c (box/c real?) false/c) #f]
[top-y (or/c (box/c real?) false/c) #f]
[bottom-x (or/c (box/c real?) false/c) #f]
[bottom-y (or/c (box/c real?) false/c) #f]
[top-x (or/c (box/c real?) #f) #f]
[top-y (or/c (box/c real?) #f) #f]
[bottom-x (or/c (box/c real?) #f) #f]
[bottom-y (or/c (box/c real?) #f) #f]
[at-eol? any/c #f]
[whole-line? any/c #f])
void?]{
@ -1750,8 +1772,8 @@ If @scheme[on?] is not @scheme[#f], then the selection will be
}
@defmethod[(set-autowrap-bitmap [bitmap (or/c (is-a?/c bitmap%) false/c)])
(or/c (is-a?/c bitmap%) false/c)]{
@defmethod[(set-autowrap-bitmap [bitmap (or/c (is-a?/c bitmap%) #f)])
(or/c (is-a?/c bitmap%) #f)]{
Sets the bitmap that is drawn at the end of a line when it is
automatically line-wrapped.
@ -1790,7 +1812,7 @@ See also
exact-nonnegative-integer?
exact-nonnegative-integer?)
. -> . any)]
[hilite-delta (or/c (is-a?/c style-delta%) false/c) #f]
[hilite-delta (or/c (is-a?/c style-delta%) #f) #f]
[call-on-down? any/c #f])
void?]{
@ -2010,8 +2032,8 @@ Setting tabs is disallowed when the editor is internally locked for
}
@defmethod[(set-wordbreak-func [f ((is-a?/c text%) (or/c (box/c exact-nonnegative-integer?) false/c)
(or/c (box/c exact-nonnegative-integer?) false/c)
@defmethod[(set-wordbreak-func [f ((is-a?/c text%) (or/c (box/c exact-nonnegative-integer?) #f)
(or/c (box/c exact-nonnegative-integer?) #f)
symbol?
. -> . any)])
void?]{
@ -2036,7 +2058,7 @@ Since the wordbreak function will be called when line breaks are being
}
@defmethod[(set-wordbreak-map [map (or/c (is-a?/c editor-wordbreak-map%) false/c)])
@defmethod[(set-wordbreak-map [map (or/c (is-a?/c editor-wordbreak-map%) #f)])
void?]{
Sets the wordbreaking map that is used by the standard wordbreaking

66
collects/tests/mred/media8.mre
View File

@ -1,17 +1,20 @@
#reader(lib"read.ss""wxme")WXME0108 ##
#|
This file is in PLT Scheme editor format.
Open this file in DrScheme version 370 or later to read it.
Open this file in DrScheme version 370 or later to read it.
Most likely, it was created by saving a program in DrScheme version
370 or later, and it probably contains a program with non-text
elements (such as images or comment boxes).
www.plt-scheme.org
Most likely, it was created by saving a program in DrScheme,
and it probably contains a program with non-text elements
(such as images or comment boxes).
http://www.plt-scheme.org
|#
4 7 #"wxtext\0"
3 1 6 #"wxtab\0"
1 1 8 #"wxmedia\0"
3 1 8 #"wximage\0"
4 1 8 #"wximage\0"
2 0 1 6 #"wxloc\0"
00000000000 1 26 0 9 #"Standard\0"
00000000000 1 19 0 9 #"Standard\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0"
0 70 1 #"\0"
@ -50,25 +53,11 @@
0 75 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 1 #"\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 1 1 1 #"\0"
0 71 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0"
0 72 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0"
0 73 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0"
0 74 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0"
0 75 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0"
0 -1 1 #"\0"
1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1
00000000002 0 00000000000 2 00000000000 41 0 1 3 44
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 1 00000000002
0 00000000000 2 00000000000 40 0 1 3 44
#"This is a line of plain text (default font)."
0 0 1 29 1 #"\n"
0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 2 3 0 9
0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 2 3 0 9
#"Standard\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0"
@ -76,13 +65,13 @@
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 00000000000
1 0 1 3 38 #"This is a line of plain text in a box."
0 00000000000 0 0 1 29 1 #"\n"
0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 3 3 0 9
0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 3 3 0 9
#"Standard\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 00000000000
1 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 4 3 0 9
1 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 4 3 0 9
#"Standard\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0"
@ -97,7 +86,7 @@
0 0 5 3 29 #"This has a yellow background."
0 0 1 29 1 #"\n"
0 0 7 3 34 #"Top aligned (compared to the box)."
0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 5 5 0 9
0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 5 5 0 9
#"Standard\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0"
@ -112,7 +101,7 @@
0 0 1 29 1 #"\n"
0 0 4 3 3 #"Red"
0 0 4 29 1 #"\n"
0 2 4 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 6 4 0 9
0 2 4 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 6 4 0 9
#"Standard\0"
0 70 1 #"\0"
1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0"
@ -138,15 +127,14 @@
0 0 7 29 1 #"\n"
0 0 12 3 19 #"(2 points smaller.)"
0 0 7 29 1 #"\n"
0 0 19 3 11 #"Decorative."
0 0 20 3 1 #" "
0 0 21 3 6 #"Roman."
0 0 20 3 1 #" "
0 0 22 3 7 #"Script."
0 0 20 3 1 #" "
0 0 23 3 6 #"Swiss."
0 0 20 3 1 #" "
0 0 24 3 6 #"Fixed."
0 0 25 3 53 #" (Last line changed to bottom-aligned for version 8.)"
0 0 20 29 1 #"\n"
0 0 13 3 11 #"Decorative."
0 0 7 3 1 #" "
0 0 14 3 6 #"Roman."
0 0 7 3 1 #" "
0 0 15 3 7 #"Script."
0 0 7 3 1 #" "
0 0 16 3 6 #"Swiss."
0 0 7 3 1 #" "
0 0 17 3 6 #"Fixed."
0 0 7 29 1 #"\n"
0 00000000000

44
collects/tests/mred/test-editor-admin.ss Normal file
View File

@ -0,0 +1,44 @@
#lang scheme/base
(require scheme/class
scheme/gui/base)
(provide test-editor-admin%)
(define the-dc
(new (class* bitmap-dc% ()
(super-new)
(define/override (get-text-extent s [font #f] [combine? #f] [offset 0])
(values (* 10.0 (string-length s)) 10.0 1.0 1.0))
(define/override (set-pen . p) (void))
(define/override (get-pen . p) #f)
(define/override (set-brush . b) (void))
(define/override (get-brush . b) #f)
(define/override (set-clipping-rect . b) (void))
(define/override (get-clipping-region . b) #f)
(define/override (draw-text s x y combine? offset count) (void))
(define/override (cache-font-metrics-key) 100))))
(define test-editor-admin%
(class editor-admin%
(super-new)
(define/override (get-dc [x #f] [y #f])
(when x (set-box! x 1.0))
(when y (set-box! y 1.0))
the-dc)
(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 100.0))
(when h (set-box! h 100.0)))
(define/override (get-view x y w h [full? #f])
(do-get-view x y w h))
(define/override (get-max-view x y w h [full? #f])
(do-get-view x y w h))
(define/override (scroll-to x y w h refresh? bias)
(void))))

1337
collects/tests/mred/wxme.ss Normal file
View File

File diff suppressed because it is too large Load Diff