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

...

Browse Source 
original commit: 4327ae6f324fccc98cdd14debede5221415d9ce4
This commit is contained in:
Robby Findler 1998-09-15 03:29:51 +00:00
parent bfa157d033
commit 0f6b235b98
16 changed files with 268 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/framework/autosave.ss
View File

@ -1,5 +1,6 @@
(unit/sig framework:autosave^
(import [exit : framework:exit^]
(import mred^
[exit : framework:exit^]
[preferences : framework:preferences^])
(define register
@ -11,7 +12,7 @@
(override
[notify
(lambda ()
(when (preferences:get-preference 'framework:autosaving-on?)
(when (preferences:get 'framework:autosaving-on?)
(set! objects
(let loop ([list objects])
(if (null? list)

124
collects/framework/editor.ss
View File

@ -1,5 +1,6 @@
(unit/sig framework:editor^
(import [autosave : framework:autosave^]
(import mred^
[autosave : framework:autosave^]
[finder : framework:finder^]
[path-utils : framework:path-utils^]
[keymap : framework:keymap^]
@ -8,7 +9,7 @@
[gui-utils : framework:gui-utils^])
(define basic<%>
(interface ()
(interface (editor<%>)
editing-this-file?
local-edit-sequence?
run-after-edit-sequence
@ -17,7 +18,7 @@
default-auto-wrap?))
(define make-basic%
(mixin editor<%> basic<%> args
(mixin (editor<%>) (basic<%>) args
(inherit modified? get-filename save-file canvases
refresh-delayed?
get-frame get-keymap
@ -127,8 +128,8 @@
(super-lock x))])
(public
[get-text-snip (lambda () (make-object media-snip% (make-object edit%)))]
[get-pasteboard-snip (lambda () (make-object media-snip% (make-object pasteboard%)))])
[get-text-snip (lambda () (make-object editor-snip% (make-object text%)))]
[get-pasteboard-snip (lambda () (make-object editor-snip% (make-object pasteboard%)))])
(override
[on-new-box
(lambda (type)
@ -159,10 +160,12 @@
(inherit auto-wrap)
(sequence
(apply super-init args)
(auto-wrap default-auto-wrap))))
(auto-wrap default-auto-wrap?))))
(define file<%> (interface (basic<%>)))
(define make-file%
(mixin basic<%> basic<%> args
(mixin (basic<%>) (file<%>) args
(inherit get-keymap find-snip
get-filename lock get-style-list
modified? change-style set-modified
@ -170,7 +173,7 @@
(rename [super-after-save-file after-save-file]
[super-after-load-file after-load-file])
(public [editing-this-file? #t])
(override [editing-this-file? #t])
(private
[check-lock
(lambda ()
@ -182,7 +185,7 @@
(file-or-directory-permissions
filename))))])
(lock lock?)))])
(public
(override
[after-save-file
(lambda (success)
(when success
@ -193,20 +196,26 @@
(lambda (sucessful?)
(when sucessful?
(check-lock))
(super-after-load-file sucessful?))]
[autowrap-bitmap (icon:get-autowrap-bitmap)])
(super-after-load-file sucessful?))])
(sequence
(apply super-init args)
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap keymap:global-file-keymap #f)))))
(send keymap chain-to-keymap keymap:file #f)))))
(define backup-autosave<%>
(interface (basic<%>)
backup?
autosave?
do-autosave
remove-autosave))
; wx: when should autosave files be removed?
; also, what about checking the autosave files when a file is
; opened?
(define make-backup-autosave%
(mixin basic<%> autosave<%> args
(mixin (basic<%>) (backup-autosave<%>) args
(inherit modified? get-filename save-file)
(rename [super-on-save-file on-save-file]
[super-on-change on-change]
@ -218,6 +227,7 @@
[auto-save-out-of-date? #t]
[auto-save-error? #f])
(public
[auto-save? #t]
[backup? #t])
(override
[on-save-file
@ -233,7 +243,7 @@
(set! freshen-backup? #f)
(when (file-exists? back-name)
(delete-file back-name)))
(with-handlers ([exn:i/o:filesystem:rename? void])
(with-handlers ([(lambda (x) #t) void])
(copy-file name back-name))))
#t)))]
[do-close
@ -245,7 +255,6 @@
(lambda ()
(super-on-change)
(set! auto-save-out-of-date? #t))]
[auto-save? #t]
[set-modified
(lambda (modified?)
(when auto-saved-name
@ -254,7 +263,9 @@
(begin
(delete-file auto-saved-name)
(set! auto-saved-name #f))))
(super-set-modified modified?))]
(super-set-modified modified?))])
(public
[autosave? #t]
[do-autosave
(lambda ()
(when (and auto-save?
@ -286,21 +297,68 @@
(set! auto-saved-name #f)))])
(sequence
(apply super-init args)
(autosave:register-autosave this))))
(autosave:register this))))
(define info<%> (interface (basic<%>)))
(define make-info%
(lambda (super-info-edit%)
(class-asi super-info-edit%
(inherit get-frame run-after-edit-sequence)
(rename [super-lock lock])
(public
[lock
(lambda (x)
(super-lock x)
(run-after-edit-sequence
(rec send-frame-update-lock-icon
(lambda ()
(let ([frame (get-frame)])
(when frame
(send frame lock-status-changed)))))
'framework:update-lock-icon))])))))
(mixin (basic<%>) (info<%>) args
(inherit get-frame run-after-edit-sequence)
(rename [super-lock lock])
(override
[lock
(lambda (x)
(super-lock x)
(run-after-edit-sequence
(rec send-frame-update-lock-icon
(lambda ()
(let ([frame (get-frame)])
(when frame
(send frame lock-status-changed)))))
'framework:update-lock-icon))])
(sequence (apply super-init args))))
(define make-clever-file-format%
(mixin (editor<%>) (editor<%>) args
(inherit get-file-format set-file-format find-snip)
(rename [super-on-save-file on-save-file]
[super-after-save-file after-save-file])
(private [restore-file-format void])
(override
[after-save-file
(lambda (success)
(restore-file-format)
(super-after-save-file success))]
[on-save-file
(let ([has-non-text-snips
(lambda ()
(let loop ([s (find-snip 0 'after)])
(cond
[(null? s) #f]
[(is-a? s text-snip%)
(loop (send s next))]
[else #t])))])
(lambda (name format)
(when (and (or (eq? format 'same)
(eq? format 'copy))
(not (eq? (get-file-format)
'std)))
(cond
[(eq? format 'copy)
(set! restore-file-format
(let ([f (get-file-format)])
(lambda ()
(set! restore-file-format void)
(set-file-format f))))
(set-file-format 'std)]
[(and (has-non-text-snips)
(or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
(set-file-format 'std)]
[else (void)]))
(or (super-on-save-file name format)
(begin
(restore-file-format)
#f))))])
(sequence (apply super-init args)))))

19
collects/framework/finder.ss
View File

@ -9,6 +9,9 @@
[mzlib:string : mzlib:string^]
[mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^])
(rename [put-file -put-file]
[get-file -get-file])
(define dialog-parent-parameter (make-parameter #f))
@ -344,7 +347,7 @@
number
number-of-visible-items
set-first-item
set-focus
focus
set-selection)
(public
@ -371,7 +374,7 @@
(cond
[(or (equal? code 'numpad-return)
(equal? code #\return)))
(equal? code #\return))
(do-ok)]
[(equal? code #\tab)
@ -423,7 +426,7 @@
(set-selection-and-edit
(min (sub1 num-items) (+ curr-pos num-vis))))]
[else #f]))]
[else #f])))]
[on-default-action
(lambda ()
@ -443,10 +446,10 @@
[set-focus-to-name-list
(lambda ()
(send name-list set-focus))]
(send name-list focus))]
[set-focus-to-directory-edit
(lambda ()
(send directory-panel set-focus))]
(send directory-panel focus))]
[save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
@ -515,7 +518,7 @@
(send* canvas
(set-line-count 1)
(set-media directory-edit)
(set-focus)
(focus)
(user-min-height 20)))
(when multi-mode?
@ -731,7 +734,7 @@
; external interfaces to file functions
(define put-file
(define -put-file
(lambda args
(let ([actual-fun
(case (preferences:get 'framework:file-dialogs)
@ -739,7 +742,7 @@
[(common) common-put-file])])
(apply actual-fun args))))
(define get-file
(define -get-file
(lambda args
(let ([actual-fun
(case (preferences:get 'framework:file-dialogs)

10
collects/framework/frame.ss
View File

@ -523,7 +523,7 @@
(do-title)
(let ([canvas (get-canvas)])
(send (get-edit) load-file filename)
(send canvas set-focus)))))
(send canvas focus)))))
(define searchable<%> (interface ()
get-edit-to-search
@ -702,7 +702,7 @@
(unless startup?
(send
(send (get-edit-to-search) get-canvas)
set-focus))
focus))
(set! hidden? #t))]
[unhide-search
(lambda ()
@ -779,7 +779,7 @@
(send (get-edit-to-search) get-canvas)]
[else
find-canvas])
set-focus))]
focus))]
[move-to-search-or-search
(lambda ()
(when hidden?
@ -787,7 +787,7 @@
(if (or (send find-canvas is-focus-on?)
(send replace-canvas is-focus-on?))
(search 1)
(send find-canvas set-focus)))]
(send find-canvas focus)))]
[move-to-search-or-reverse-search
(lambda ()
(when hidden?
@ -795,7 +795,7 @@
(if (or (send find-canvas is-focus-on?)
(send replace-canvas is-focus-on?))
(search -1)
(send find-canvas set-focus)))]
(send find-canvas focus)))]
[search
(opt-lambda ([direction searching-direction] [beep? #t])

16
collects/framework/guiutils.ss
View File

@ -55,8 +55,8 @@
(define unsaved-warning
(opt-lambda (filename action [can-save-now? #f])
(let* ([result (void)]
[dialog%
(class dialog-box% ()
[unsaved-dialog%
(class dialog% ()
(inherit show center)
(private
[on-dont-save
@ -95,22 +95,22 @@
button-panel
on-cancel)])
(if (not can-save-now?)
(begin (send cancel set-focus)
(begin (send cancel focus)
(send now show #f))
(send now set-focus))))
(send now focus))))
(center 'both)
(show #t)))])
(make-object dialog%)
(make-object unsaved-dialog%)
result)))
(define get-choice
(opt-lambda (message true-choice false-choice
[title "Warning"][x -1][y -1])
(let* ([result (void)]
[dialog%
(class dialog-box% ()
[choice-dialog%
(class dialog% ()
(inherit show center)
(private
[on-true
@ -143,7 +143,7 @@
(center 'both)
(show #t))))])
(make-object dialog%)
(make-object choice-dialog%)
result)))
(define read-snips/chars-from-buffer

3
collects/framework/handler.ss
View File

@ -5,6 +5,7 @@
[group : framework:group^]
[text : framework:text^]
[preferences : framework:preferences^]
[frame : framework:frame^]
[mzlib:file : mzlib:file^])
(define-struct handler (name extension handler))
@ -88,7 +89,7 @@
(opt-lambda (filename
[make-default
(lambda (filename)
(make-object frame:info-file-frame% filename))]
(make-object frame:info-file% filename))]
[consult-group? (edit-file-consult-group)])
(gui-utils:show-busy-cursor
(lambda ()

2
collects/framework/icon.ss
View File

@ -1,5 +1,5 @@
(unit/sig framework:icon^
(import)
(import mred^)
(define icon-path
(with-handlers ([void (lambda (x) (collection-path "system"))])

44
collects/framework/keys.ss
View File

@ -3,7 +3,8 @@
[preferences : framework:preferences^]
[finder : framework:finder^]
[handler : framework:handler^]
[scheme-paren : framework:scheme-paren^])
[scheme-paren : framework:scheme-paren^]
[frame : framework:frame^])
; This is a list of keys that are typed with the SHIFT key, but
; are not normally thought of as shifted. It will have to be
@ -70,7 +71,7 @@
[flash-paren-match
(lambda (edit event)
(send edit on-default-char event)
(let ([pos (scheme-paren:scheme-backward-match
(let ([pos (scheme-paren:backward-match
edit
(send edit get-start-position)
0)])
@ -488,15 +489,15 @@
(lambda (edit event)
(if building-macro
(send build-macro-km break-sequence)
(letrec* ([km (send edit get-keymap)]
[done
(lambda ()
(if build-protect?
(send km set-break-sequence-callback done)
(begin
(set! building-macro #f)
(send km set-break-sequence-callback void)
(send km remove-grab-key-function))))])
(letrec ([km (send edit get-keymap)]
[done
(lambda ()
(if build-protect?
(send km set-break-sequence-callback done)
(begin
(set! building-macro #f)
(send km set-break-sequence-callback void)
(send km remove-grab-key-function))))])
(set! building-macro '())
(set! build-macro-km km)
(send km set-grab-key-function
@ -772,19 +773,18 @@
(lambda (method)
(lambda (edit event)
(let ([frame
(let ([frame
(cond
[(is-a? obj editor<%>)
(let ([canvas (send obj get-active-canvas)])
(and canvas
(send canvas get-top-level-window)))]
[(is-a? obj area<%>)
(send obj get-top-level-window)]
[else #f])]))])
(cond
[(is-a? edit editor<%>)
(let ([canvas (send edit get-active-canvas)])
(and canvas
(send canvas get-top-level-window)))]
[(is-a? edit area<%>)
(send edit get-top-level-window)]
[else #f])])
(if frame
((ivar/proc frame method))
(bell))
#t)))])
(bell)))
#t))])
(lambda (kmap)
(let* ([map (lambda (key func)
(send kmap map-function key func))]

2
collects/framework/main.ss
View File

@ -210,5 +210,5 @@
(exn-message exn))))])
(save-user-preferences))))
;(wx:application-file-handler edit-file)
;(wx:application-file-handler edit-file) ;; how to handle drag and drop?
)

4
collects/framework/panel.ss
View File

@ -38,7 +38,7 @@
(if (<= num-children 1)
(helper parent)
(begin (send parent delete-child canvas/panel)
(send (car (ivar parent children)) set-focus))))))])
(send (car (ivar parent children)) focus))))))])
(send media remove-canvas canvas)
(helper canvas))
(bell))))]
@ -72,7 +72,7 @@
(send* media (remove-canvas canvas)
(add-canvas left-split)
(add-canvas right-split))
(send* left-split (set-media media) (set-focus))
(send* left-split (set-media media) (focus))
(send* right-split (set-media media))))]))))
(define horizontal-edit%

2
collects/framework/pasteboard.ss
View File

@ -6,4 +6,4 @@
(define file% (editor:make-file% basic%))
(define clever-file-format% (editor:make-clever-file-format% file%))
(define backup-autosave% (editor:make-backup-autosave% clever-file-format%))
(define info% (editor:make-info% searching%)))
(define info% (editor:make-info% backup-autosave%)))

111
collects/framework/prefs.ss
View File

@ -383,7 +383,7 @@
(let* ([pref-sym (build-font-preference-symbol name)]
[family-const-pair (assoc name font-families-name/const)]
[edit (make-object edit%)]
[edit (make-object text%)]
[_ (send edit insert ex-string)]
[set-edit-font
(lambda (size)
@ -537,60 +537,61 @@
(define make-preferences-dialog
(lambda ()
(letrec* ([frame
(make-object (class-asi frame%
(public [added-pane (lambda ()
(ensure-constructed)
(refresh-menu)
(send popup-menu set-selection (sub1 (length ppanels)))
(send single-panel active-child
(ppanel-panel (car (list-tail ppanels (sub1 (length ppanels)))))))]))
'() "Preferences")]
[panel (make-object vertical-panel% frame)]
[popup-callback
(lambda (choice command-event)
(send single-panel active-child
(ppanel-panel (list-ref ppanels (send command-event get-command-int)))))]
[make-popup-menu
(lambda ()
(let ([menu (make-object choice% "Category"
(map ppanel-title ppanels)
panel popup-callback)])
(send menu stretchable-in-x #f)
menu))]
[popup-menu (make-popup-menu)]
[single-panel (make-object single-panel% panel '(border))]
[bottom-panel (make-object horizontal-panel% panel)]
[ensure-constructed
(lambda ()
(for-each (lambda (ppanel)
(unless (ppanel-panel ppanel)
(let ([panel ((ppanel-container ppanel) single-panel)])
(unless (is-a? panel panel%)
(error 'preferences-dialog
"expected the preference panel to be a panel%. Got ~a instead~n"
panel))
(set-ppanel-panel! ppanel panel))))
ppanels)
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
(send single-panel active-child (ppanel-panel (car ppanels))))]
[refresh-menu
(lambda ()
(let ([new-popup (make-popup-menu)])
(send new-popup set-selection (send popup-menu get-selection))
(set! popup-menu new-popup)
(send panel change-children
(lambda (l) (list new-popup
single-panel
bottom-panel)))))]
[ok-callback (lambda args
(save)
(hide-dialog))]
[ok-button (make-object button% bottom-panel ok-callback "OK")]
[cancel-callback (lambda args
(hide-dialog)
(read))]
[cancel-button (make-object button% bottom-panel cancel-callback "Cancel")])
(letrec ([frame
(make-object (class-asi frame%
(public [added-pane (lambda ()
(ensure-constructed)
(refresh-menu)
(send popup-menu set-selection (sub1 (length ppanels)))
(send single-panel active-child
(ppanel-panel (car (list-tail ppanels (sub1 (length ppanels)))))))]))
'() "Preferences")]
[panel (make-object vertical-panel% frame)]
[popup-callback
(lambda (choice command-event)
(send single-panel active-child
(ppanel-panel (list-ref ppanels (send command-event get-command-int)))))]
[make-popup-menu
(lambda ()
(let ([menu (make-object choice% "Category"
(map ppanel-title ppanels)
panel popup-callback)])
(send menu stretchable-in-x #f)
menu))]
[popup-menu (make-popup-menu)]
[single-panel (make-object vertical-panel%; This should be single-panel%. wx:
panel '(border))]
[bottom-panel (make-object horizontal-panel% panel)]
[ensure-constructed
(lambda ()
(for-each (lambda (ppanel)
(unless (ppanel-panel ppanel)
(let ([panel ((ppanel-container ppanel) single-panel)])
(unless (is-a? panel panel%)
(error 'preferences-dialog
"expected the preference panel to be a panel%. Got ~a instead~n"
panel))
(set-ppanel-panel! ppanel panel))))
ppanels)
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
(send single-panel active-child (ppanel-panel (car ppanels))))]
[refresh-menu
(lambda ()
(let ([new-popup (make-popup-menu)])
(send new-popup set-selection (send popup-menu get-selection))
(set! popup-menu new-popup)
(send panel change-children
(lambda (l) (list new-popup
single-panel
bottom-panel)))))]
[ok-callback (lambda args
(save)
(hide-dialog))]
[ok-button (make-object button% bottom-panel ok-callback "OK")]
[cancel-callback (lambda args
(hide-dialog)
(read))]
[cancel-button (make-object button% bottom-panel cancel-callback "Cancel")])
(send ok-button user-min-width (send cancel-button get-width))
(send* bottom-panel
(stretchable-in-y #f)

13
collects/framework/scheme.ss
View File

@ -3,7 +3,7 @@
; Scheme mode for MrEd.
(unit/sig framework:scheme-mode^
(unit/sig framework:scheme^
(import mred^
[preferences : framework:preferences^]
[match-cache : framework:match-cache^]
@ -51,10 +51,9 @@
(define init-wordbreak-map
(lambda (map)
(let ([v (send map get-map (char->integer #\-))])
(unless (zero? (bitwise-and v wx:const-break-for-line))
(send map set-map
(char->integer #\-)
(- v wx:const-break-for-line))))))
(send map set-map
(char->integer #\-)
'(line)))))
(define wordbreak-map (make-object editor-wordbreak-map%))
(init-wordbreak-map scheme-media-wordbreak-map)
@ -760,7 +759,7 @@
(let ([k (make-object keymap%)])
(set-keymap k)
k))])
(send keymap chain-to-keymap scheme-keymap #t))))))
(send keymap chain-to-keymap scheme-keymap #t)))))
(define setup-keymap
(lambda (keymap)
@ -882,7 +881,7 @@
(map-meta "c:space" "select-forward-sexp")
(map-meta "c:t" "transpose-sexp"))
(send keymap map-function "c:c;c:b" "remove-parens-forward"))))
(send keymap map-function "c:c;c:b" "remove-parens-forward")))
(define keymap (make-object keymap%))
(setup-keymap keymap))

48
collects/framework/sig.ss
View File

@ -1,10 +1,10 @@
(require-library "refer.ss")
(require-library "cores.ss")
(require-library "match.ss")
(require-library "dates.ss")
(require-library "functios.ss")
(require-library "macro.ss")
(require-relative-library "macro.ss")
(define-signature framework:frame^
(empty<%>
@ -102,14 +102,15 @@
put-file))
(define-signature framework:editor^
(editor:basic<%>
editor:info<%>
editor:autosave<%>
(basic<%>
info<%>
backup-autosave<%>
editor:make-basic%
editor:make-info%
editor:make-file%
editor:make-backup-autosave%))
make-clever-file-format%
make-basic%
make-info%
make-file%
make-backup-autosave%))
(define-signature framework:pasteboard^
(basic%
@ -119,23 +120,20 @@
info%))
(define-signature framework:text^
(text:basic<%>
text:searching<%>
(basic<%>
searching<%>
text:make-basic%
text:make-return%
text:make-searching%
text:make-clever-file-format%
text:make-scheme%
make-basic%
make-return%
make-searching%
text:basic%
text:return%
text:searching%
text:info%
text:clever-file-format%
text:file%
text:backup-autosave%
text:scheme%))
basic%
return%
searching%
info%
file%
clever-file-format%
backup-autosave%))
(define-signature framework:pasteboard%
(pasteboard:basic%
@ -267,7 +265,7 @@
balanced?
backward-containing-sexp))
(define-signature framework:scheme-mode^
(define-signature framework:scheme^
(wordbreak-map
init-wordbreak-map
style-list
@ -313,4 +311,4 @@
[unit panel : framework:panel^]
[unit frame : framework:frame^]
[unit scheme-mode : framework:scheme-mode^]))
[unit scheme : framework:scheme^]))

73
collects/framework/text.ss
View File

@ -1,14 +1,18 @@
(unit/sig framework:text^
(import mred^
(import mred-interfaces^
[editor : framework:editor^]
[preferences : framework:preferences^]
[keymap : framework:keymap^])
[keymap : framework:keymap^]
[mzlib:function : mzlib:function^])
(define-struct range (start end b/w-bitmap color caret-space?))
(define-struct rectangle (left top right bottom b/w-bitmap color))
;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap,
;; unless matthew makes it primitive
(define basic<%>
(interface ()
(interface (editor:basic<%> text<%>)
highlight-range
styles-fixed?
set-styles-fixed
@ -16,7 +20,7 @@
autowrap-bitmap))
(define make-basic%
(mixin (interface (editor:basic<%> text<%>)) basic<%> args
(mixin (editor:basic<%> text<%>) (basic<%>) args
(inherit canvases get-max-width get-admin split-snip get-snip-position
delete find-snip invalidate-bitmap-cache
set-autowrap-bitmap get-keymap mode set-mode-direct
@ -304,59 +308,15 @@
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap keymap:global-keymap #f)))))
(send keymap chain-to-keymap keymap:global #f)))))
(define make-clever-file-format%
(mixin text<%> text<%> args
(inherit get-file-format set-file-format find-snip)
(rename [super-on-save-file on-save-file]
[super-after-save-file after-save-file])
(private [restore-file-format void])
(public
[after-save-file
(lambda (success)
(restore-file-format)
(super-after-save-file success))]
[on-save-file
(let ([has-non-text-snips
(lambda ()
(let loop ([s (find-snip 0 'after)])
(cond
[(null? s) #f]
[(is-a? s text-snip%)
(loop (send s next))]
[else #t])))])
(lambda (name format)
(when (and (or (eq? format 'same)
(eq? format 'copy))
(not (eq? (get-file-format)
'std)))
(cond
[(eq? format 'copy)
(set! restore-file-format
(let ([f (get-file-format)])
(lambda ()
(set! restore-file-format void)
(set-file-format f))))
(set-file-format 'std)]
[(and (has-non-text-snips)
(or (not (preferences:get-preference 'framework:verify-change-format))
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
(set-file-format 'std)]
[else (void)]))
(or (super-on-save-file name format)
(begin
(restore-file-format)
#f))))])
(sequence (apply super-init args))))
(define file<%> (interface (basic<%>)))
(define searching<%>
(interface ()
find-string-embedded))
(define make-searching%
(mixin (interface (editor:basic<%> text<%>)) searching<%> args
(mixin (editor:basic<%> text<%>) (searching<%>) args
(inherit get-end-position get-start-position last-position
find-string get-snip-position get-admin find-snip
get-keymap)
@ -443,10 +403,10 @@
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap keymap:global-search-keymap #f)))))
(send keymap chain-to-keymap keymap:search #f)))))
(define make-return%
(mixin text<%> text<%> args
(mixin (text<%>) (text<%>) (return . args)
(rename [super-on-local-char on-local-char])
(override
[on-local-char
@ -462,7 +422,7 @@
(apply super-init args))))
(define make-info%
(mixin (interface (editor:basic<%> text<%>)) (interface (editor:basic<%> text<%>)) args
(mixin (editor:basic<%> text<%>) (editor:basic<%> text<%>) args
(inherit get-frame get-start-position get-end-position
run-after-edit-sequence)
(rename [super-after-set-position after-set-position]
@ -509,11 +469,10 @@
(enqueue-for-frame 'edit-position-changed
'framework:edit-position-changed))])))
(define basic% (make-basic (editor:make-basic% text%)))
(define basic% (make-basic% (editor:make-basic% text%)))
(define return% (make-return% basic%))
(define file% (editor:make-file% basic%))
(define clever-file-format% (editor:make-clever-file-format% file%))
(define backup-autosave% (editor:make-backup-autosave% clever-file-format%))
(define searching% (make-searching backup-autosave%))
(define searching% (make-searching% backup-autosave%))
(define info% (make-info% (editor:make-info% searching%))))

22
notes/mred/MrEd_100_Framework.txt
View File

@ -9,6 +9,7 @@ into a separate application.
Subtle Changes:
- the editor `auto-save?' ivar is now called `autosave?'
- overriding `windows-menu' with #f no longer eliminates the windows
menu. Now, it is an error.
- mred:original-output-port, mred:original-error-port, and
@ -148,6 +149,22 @@ The remaining existant classes:
Old to new name mapping:
mred:scheme-paren-pairs -> scheme-paren:paren-pairs
mred:scheme-quote-pairs -> scheme-paren:quote-pairs
mred:scheme-comments -> scheme-paren:comments
mred:scheme-backward-match -> scheme-paren:forward-match
mred:scheme-forward-match-> scheme-paren:backward-match
mred:scheme-balanced? -> scheme-paren:balanced?
mred:scheme-backward-containing-sexp -> scheme-paren:backward-containing-sexp
mred:setup-global-keymap -> keymap:setup-global
mred:setup-global-search -> keymap:setup-search
mred:setup-global-file -> keymap:setup-file
mred:global-keymap -> keymap:global
mred:global-search-keymap -> keymap:serach
mred:global-file-keymap -> keyamp:file
mred:match-cache% -> match-cache:%
mred:handler? -> handler:handler?
@ -248,9 +265,10 @@ NOTE: some used but non-existant interfaces from mred engine:
; text:make-basic% adds ranges, wrapping, move/copy-to-edit
text:make-basic% : (interface (editor:basic<%> text<%>)) -> text:basic<%>
text:make-return% : text<%> -> editor:basic<%>
text:make-return% : editor:basic<%> -> editor:basic<%>
text:make-searching% : (interface (editor:basic<%> text<%>)) -> text:searching<%>
text:make-clever-file-format% : text<%> -> editor<%>
text:make-info% : (interface (editor:basic<%> text<%>)) -> (interface (editor:basic<%> text<%>))
text:make-clever-file-format% : text<%> -> clever-file-format<%>
text:make-scheme% : (interface (editor:basic<%> text<%>)) -> editor:scheme<%>
editor-canvas:make-frame-title% : editor-canvas<%> -> editor-canvas<%>