Added gen-mred-interfaces.ss
original commit: 9cade9db198566d7bb6dee49e0757ede959ba8f2
This commit is contained in:
Robby Findler
parent
5506ab2b49
commit
9b010392b5
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig mred:application^
|
||||
(unit/sig framework:application^
|
||||
(import)
|
||||
|
||||
(define current-app-name (make-parameter
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig mred:exit^
|
||||
(unit/sig framework:exit^
|
||||
(import [preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
(rename (-exit exit))
|
||||
|
|
@ -36,14 +36,14 @@
|
|||
(lambda () (set! exiting? #t))
|
||||
(lambda ()
|
||||
(if (and (let*-values ([(w capW)
|
||||
(if (eq? wx:platform 'windows)
|
||||
(if (eq? (system-type) 'windows)
|
||||
(values "exit" "Exit")
|
||||
(values "quit" "Quit"))]
|
||||
[(message)
|
||||
(string-append "Are you sure you want to "
|
||||
w
|
||||
"?")])
|
||||
(if (preferences:get-preference 'mred:verify-exit)
|
||||
(if (preferences:get 'framework:verify-exit)
|
||||
(if (gui-utils:get-choice message capW "Cancel")
|
||||
#t
|
||||
#f)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,71 @@
|
|||
(unit/sig framework:frame^
|
||||
(import [group framework:group^])
|
||||
(import mred^
|
||||
[group framework:group^]
|
||||
[preferences : framework:preferences^]
|
||||
[icon : framework:icon^]
|
||||
[handler : framework:handler^]
|
||||
[application : framework:application^]
|
||||
[panel : framework:panel^]
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
|
||||
(define frame-width 600)
|
||||
(define frame-height 650)
|
||||
(let-values ([(w h) (get-display-size)])
|
||||
(when (< w frame-width)
|
||||
(set! frame-width (- (unbox w) 65)))
|
||||
(when (< w frame-height)
|
||||
(set! frame-height (- (unbox h) 65))))
|
||||
|
||||
(define empty<%> (interface ()
|
||||
get-panel%
|
||||
make-root-panel))
|
||||
(define make-empty%
|
||||
(mixin frame% empty<%> args
|
||||
(rename [super-on-activate on-activate])
|
||||
|
||||
(override
|
||||
[can-close?
|
||||
(lambda ()
|
||||
(send group:the-frame-group
|
||||
can-remove-frame?
|
||||
this))]
|
||||
[on-close
|
||||
(lambda ()
|
||||
(send group:the-frame-group
|
||||
remove-frame
|
||||
this))])
|
||||
(public
|
||||
[get-panel% (lambda () vertical-panel%)]
|
||||
[get-menu-bar% (lambda () menu-bar%)]
|
||||
[make-root-panel
|
||||
(lambda (% parent)
|
||||
(make-object % parent))])
|
||||
(rename [super-show show])
|
||||
(override
|
||||
[show
|
||||
(lambda (on?)
|
||||
(super-show on?)
|
||||
(when on?
|
||||
'(unless (member this (send group:the-frame-group
|
||||
get-frames))
|
||||
(send group:the-frame-group
|
||||
insert-frame this))))]
|
||||
[on-activate
|
||||
(lambda (active?)
|
||||
(super-on-activate active?)
|
||||
'(when active?
|
||||
(send group:the-frame-group set-active-frame this)))])
|
||||
|
||||
(sequence
|
||||
(apply super-init args))
|
||||
(public
|
||||
[menu-bar (make-object (get-menu-bar%) this)]
|
||||
[panel (make-root-panel (get-panel%) this)])))
|
||||
|
||||
(define standard-menus<%>
|
||||
(interface ()
|
||||
(interface (empty<%>)
|
||||
get-menu%
|
||||
get-menu-item%
|
||||
|
||||
|
|
@ -16,7 +76,7 @@
|
|||
edit-menu:between-cut-and-copy
|
||||
edit-menu:between-paste-and-clear
|
||||
edit-menu:between-redo-and-cut
|
||||
edit-menu:between-replace-and-preferences
|
||||
edit-menu:between-find-and-preferences
|
||||
edit-menu:between-select-all-and-find
|
||||
edit-menu:clear
|
||||
edit-menu:clear-help-string
|
||||
|
|
@ -45,10 +105,6 @@
|
|||
edit-menu:redo-help-string
|
||||
edit-menu:redo-menu
|
||||
edit-menu:redo-string
|
||||
edit-menu:replace
|
||||
edit-menu:replace-help-string
|
||||
edit-menu:replace-menu
|
||||
edit-menu:replace-string
|
||||
edit-menu:select-all
|
||||
edit-menu:select-all-help-string
|
||||
edit-menu:select-all-menu
|
||||
|
|
@ -108,66 +164,6 @@
|
|||
help-menu:after-about
|
||||
windows-menu))
|
||||
|
||||
(define empty-standard-menus<%> (interface (standard-menus<%> empty<%>)))
|
||||
(define edit<%> (interface () FILL-ME-IN))
|
||||
(define searchable<%> (interface ()))
|
||||
(define pasteboard<%> (interface ()))
|
||||
(define info<%> (interface ()))
|
||||
(define info-file<%> (interface ()))
|
||||
|
||||
(define frame-width 600)
|
||||
(define frame-height 650)
|
||||
(let ([w (box 0)]
|
||||
[h (box 0)])
|
||||
(wx:display-size w h)
|
||||
(when (< (unbox w) frame-width)
|
||||
(set! frame-width (- (unbox w) 65)))
|
||||
(when (< (unbox h) frame-height)
|
||||
(set! frame-height (- (unbox h) 65))))
|
||||
|
||||
(define make-empty%
|
||||
(mixin frame% empty<%> args
|
||||
(rename [super-on-activate on-activate])
|
||||
|
||||
(override
|
||||
[can-close?
|
||||
(lambda ()
|
||||
(send group:the-frame-group
|
||||
can-remove-frame?
|
||||
this))]
|
||||
[on-close
|
||||
(lambda ()
|
||||
(send group:the-frame-group
|
||||
remove-frame
|
||||
this))])
|
||||
(public
|
||||
[get-panel% (lambda () vertical-panel%)]
|
||||
[get-menu-bar% (lambda () menu-bar%)]
|
||||
[make-root-panel
|
||||
(lambda (% parent)
|
||||
(make-object % parent))])
|
||||
(rename [super-show show])
|
||||
(override
|
||||
[show
|
||||
(lambda (on?)
|
||||
(super-show on?)
|
||||
(when on?
|
||||
'(unless (member this (send group:the-frame-group
|
||||
get-frames))
|
||||
(send group:the-frame-group
|
||||
insert-frame this))))]
|
||||
[on-activate
|
||||
(lambda (active?)
|
||||
(super-on-activate active?)
|
||||
'(when active?
|
||||
(send group:the-frame-group set-active-frame this)))])
|
||||
|
||||
(sequence
|
||||
(apply super-init args))
|
||||
(public
|
||||
[menu-bar (make-object (get-menu-bar%) this)]
|
||||
[panel (make-root-panel (get-panel%) this)])))
|
||||
|
||||
(define make-standard-menus%
|
||||
(begin-elaboration-time
|
||||
(let-struct between (menu name procedure)
|
||||
|
|
@ -248,14 +244,14 @@
|
|||
(let ([between-nothing (lambda (menu) (void))]
|
||||
[between-separator (lambda (menu) (make-object separator-menu-item% menu))])
|
||||
(list (make-an-item 'file-menu:new "Open a new file"
|
||||
'(lambda (item control) (mred:handler:edit-file #f) #t)
|
||||
'(lambda (item control) (handler:edit-file #f) #t)
|
||||
#\n "&New" "")
|
||||
(make-between 'file-menu 'between-new-and-open between-nothing)
|
||||
(make-an-item 'file-menu:open "Open a file from disk"
|
||||
'(lambda (item control) (mred:handler:open-file) #t)
|
||||
'(lambda (item control) (handler:open-file) #t)
|
||||
#\o "&Open" "...")
|
||||
(make-an-item 'file-menu:open-url "Open a Uniform Resource Locater"
|
||||
'(lambda (item control) (mred:handler:open-url) #t)
|
||||
'(lambda (item control) (handler:open-url) #t)
|
||||
#f "Open &URL" "...")
|
||||
(make-an-item 'file-menu:revert
|
||||
"Revert this file to the copy on disk"
|
||||
|
|
@ -296,16 +292,14 @@
|
|||
(make-an-item 'edit-menu:find "Search for a string in the buffer"
|
||||
'(lambda (item control) (send this move-to-search-or-search) #t)
|
||||
#\f "Find" "")
|
||||
(make-an-item 'edit-menu:replace "Search and replace a string in the buffer"
|
||||
#f #f "Replace" "")
|
||||
(make-between 'edit-menu 'between-replace-and-preferences between-separator)
|
||||
(make-between 'edit-menu 'between-find-and-preferences between-separator)
|
||||
(make-an-item 'edit-menu:preferences "Configure your preferences"
|
||||
'(lambda (item control) (mred:preferences:show-preferences-dialog) #t)
|
||||
'(lambda (item control) (preferences:show-dialog) #t)
|
||||
#f "Preferences..." "")
|
||||
(make-between 'edit-menu 'after-standard-items between-nothing)
|
||||
|
||||
(make-an-item 'help-menu:about "About this application"
|
||||
'(lambda (item control) (mred:console:credits))
|
||||
#f
|
||||
#f
|
||||
"About "
|
||||
"...")
|
||||
|
|
@ -336,8 +330,23 @@
|
|||
(build-item-menu-clause x)))
|
||||
items))))))))
|
||||
|
||||
(define make-edit%
|
||||
(mixin empty-standard-menus<%> frame:simple-menu<%> ([name (mred:application:current-app-name)])
|
||||
(define editor<%> (interface (standard-menus<%>)
|
||||
WIDTH
|
||||
HEIGHT
|
||||
title-prefix
|
||||
get-entire-label
|
||||
get-label-prefix
|
||||
set-label-prefix
|
||||
|
||||
get-canvas%
|
||||
get-edit%
|
||||
make-edit
|
||||
save-as
|
||||
get-canvas
|
||||
get-edit))
|
||||
|
||||
(define make-editor%
|
||||
(mixin standard-menus<%> simple-menu<%> (file-name)
|
||||
(inherit panel get-client-size set-icon get-menu-bar
|
||||
make-menu show active-edit active-canvas)
|
||||
(rename [super-can-close? can-close?]
|
||||
|
|
@ -352,9 +361,9 @@
|
|||
(lambda ()
|
||||
(and (send (get-edit) do-close)
|
||||
(super-can-close?)))]
|
||||
[get-panel% (lambda () mred:panel:vertical-edit-panel%)])
|
||||
[get-panel% (lambda () panel:vertical-edit-panel%)])
|
||||
(public
|
||||
[title-prefix name])
|
||||
[title-prefix (application:current-app-name)])
|
||||
|
||||
(private
|
||||
[label ""]
|
||||
|
|
@ -387,38 +396,38 @@
|
|||
(set! label t)
|
||||
(do-label)))])
|
||||
(public
|
||||
[get-canvas% (lambda () mred:canvas:frame-title-canvas%)]
|
||||
[get-edit% (lambda () mred:edit:media-edit%)]
|
||||
[get-canvas% (lambda () editor-canvas%)]
|
||||
[get-edit% (lambda () text%)]
|
||||
[make-edit (lambda () (make-object (get-edit%)))])
|
||||
|
||||
(public
|
||||
[save-as
|
||||
(opt-lambda ([format 'same])
|
||||
(let ([file (parameterize ([mred:finder:dialog-parent-parameter
|
||||
this])
|
||||
(let ([file (parameterize ([finder:dialog-parent-parameter this])
|
||||
(finder:put-file))])
|
||||
(when file
|
||||
(send (get-edit) save-file file format))))]
|
||||
(send (get-edit) save-file file format))))])
|
||||
(override
|
||||
[file-menu:revert
|
||||
(lambda ()
|
||||
(let* ([b (box #f)]
|
||||
[edit (get-edit)]
|
||||
[filename (send edit get-filename b)])
|
||||
(if (or (null? filename) (unbox b))
|
||||
(wx:bell)
|
||||
(if (or (not filename) (unbox b))
|
||||
(bell)
|
||||
(let-values ([(start end)
|
||||
(if (is-a? edit wx:media-edit%)
|
||||
(if (is-a? edit text%)
|
||||
(values (send edit get-start-position)
|
||||
(send edit get-end-position))
|
||||
(values #f #f))])
|
||||
(send edit begin-edit-sequence)
|
||||
(let ([status (send edit load-file
|
||||
filename
|
||||
wx:const-media-ff-same
|
||||
'same
|
||||
#f)])
|
||||
(if status
|
||||
(begin
|
||||
(when (is-a? edit wx:media-edit%)
|
||||
(when (is-a? edit text%)
|
||||
(send edit set-position start end))
|
||||
(send edit end-edit-sequence))
|
||||
(begin
|
||||
|
|
@ -448,7 +457,7 @@
|
|||
(send file-menu append-separator))]
|
||||
[file-menu:print (lambda ()
|
||||
(send (get-edit) print
|
||||
'()
|
||||
#f
|
||||
#t
|
||||
#t
|
||||
(preferences:get 'framework:print-output-mode))
|
||||
|
|
@ -459,95 +468,40 @@
|
|||
(lambda (menu evt)
|
||||
(let ([edit (active-edit)])
|
||||
(when edit
|
||||
(send edit do-edit const)))
|
||||
(send edit do-edit-operation const)))
|
||||
#t))])
|
||||
|
||||
(public
|
||||
[edit-menu:undo (edit-menu:do wx:const-edit-undo)]
|
||||
[edit-menu:redo (edit-menu:do wx:const-edit-redo)]
|
||||
[edit-menu:cut (edit-menu:do wx:const-edit-cut)]
|
||||
[edit-menu:clear (edit-menu:do wx:const-edit-clear)]
|
||||
[edit-menu:copy (edit-menu:do wx:const-edit-copy)]
|
||||
[edit-menu:paste (edit-menu:do wx:const-edit-paste)]
|
||||
[edit-menu:select-all (edit-menu:do wx:const-edit-select-all)]
|
||||
[edit-menu:replace (lambda (menu evt)
|
||||
(when (active-canvas)
|
||||
(mred:find-string:find-string
|
||||
(active-canvas)
|
||||
(active-edit)
|
||||
-1 -1 (list 'replace 'ignore-case))))]
|
||||
(override
|
||||
[edit-menu:undo (edit-menu:do 'undo)]
|
||||
[edit-menu:redo (edit-menu:do 'redo)]
|
||||
[edit-menu:cut (edit-menu:do 'cut)]
|
||||
[edit-menu:clear (edit-menu:do 'clear)]
|
||||
[edit-menu:copy (edit-menu:do 'copy)]
|
||||
[edit-menu:paste (edit-menu:do 'paste)]
|
||||
[edit-menu:select-all (edit-menu:do 'select-all)]
|
||||
|
||||
[edit-menu:between-replace-and-preferences
|
||||
[edit-menu:between-find-and-preferences
|
||||
(lambda (edit-menu)
|
||||
(send edit-menu append-separator)
|
||||
(send edit-menu append-item "Insert Text Box"
|
||||
(edit-menu:do wx:const-edit-insert-text-box))
|
||||
(edit-menu:do 'insert-text-box))
|
||||
(send edit-menu append-item "Insert Graphic Box"
|
||||
(edit-menu:do wx:const-edit-insert-graphic-box))
|
||||
(edit-menu:do 'insert-graphic-box))
|
||||
(send edit-menu append-item "Insert Image..."
|
||||
(edit-menu:do wx:const-edit-insert-image))
|
||||
(edit-menu:do 'insert-image))
|
||||
(send edit-menu append-item "Toggle Wrap Text"
|
||||
(lambda ()
|
||||
(let ([edit (active-edit)])
|
||||
(when edit
|
||||
(send edit set-auto-set-wrap (not (ivar edit auto-set-wrap?)))
|
||||
(send (active-canvas) force-redraw)))))
|
||||
(send edit auto-wrap (not (send edit auto-wrap)))))))
|
||||
(send edit-menu append-separator))])
|
||||
|
||||
(public
|
||||
[help-menu:about (lambda (menu evt) (mred:console:credits))]
|
||||
[help-menu:about-string (mred:application:current-app-name)]
|
||||
[help-menu:compare string-ci<?]
|
||||
[help-menu:insert-items
|
||||
(lambda (items)
|
||||
(for-each (lambda (x) (apply (ivar (ivar this help-menu) append-item) x))
|
||||
items))]
|
||||
[help-menu:after-about
|
||||
(let ([reg (regexp "<TITLE>(.*)</TITLE>")])
|
||||
(lambda (help-menu)
|
||||
(let* ([dir (with-handlers ([void (lambda (x) #f)]) (collection-path "doc"))])
|
||||
(if (and dir (directory-exists? dir))
|
||||
(let* ([dirs (directory-list dir)]
|
||||
[find-title
|
||||
(lambda (name)
|
||||
(lambda (port)
|
||||
(let loop ([l (read-line port)])
|
||||
(if (eof-object? l)
|
||||
name
|
||||
(let ([match (regexp-match reg l)])
|
||||
(if match
|
||||
(cadr match)
|
||||
(loop (read-line port))))))))]
|
||||
[build-item
|
||||
(lambda (local-dir output)
|
||||
(let* ([f (build-path dir local-dir "index.htm")])
|
||||
(if (file-exists? f)
|
||||
(let ([title (call-with-input-file f (find-title local-dir))])
|
||||
(cons
|
||||
(list title
|
||||
(lambda ()
|
||||
(let* ([f (make-object mred:hyper-frame:hyper-view-frame%
|
||||
(string-append "file:" f))])
|
||||
(send f set-title-prefix title)
|
||||
f)))
|
||||
output))
|
||||
(begin (mred:debug:printf 'help-menu "couldn't find ~a" f)
|
||||
output))))]
|
||||
[item-pairs
|
||||
(mzlib:function:quicksort
|
||||
(mzlib:function:foldl build-item null dirs)
|
||||
(lambda (x y) (help-menu:compare (car x) (car y))))])
|
||||
(unless (null? item-pairs)
|
||||
(send help-menu append-separator))
|
||||
(help-menu:insert-items item-pairs))
|
||||
(mred:debug:printf 'help-menu "couldn't find PLTHOME/doc directory")))))])
|
||||
(override
|
||||
[help-menu:about (lambda (menu evt) (message-box (format "Welcome to ~a" (application:current-app-name))))]
|
||||
[help-menu:about-string (application:current-app-name)])
|
||||
|
||||
(sequence
|
||||
(mred:debug:printf 'super-init "before simple-frame%")
|
||||
(super-init () name -1 -1 WIDTH HEIGHT
|
||||
(+ wx:const-default-frame wx:const-sdi)
|
||||
name)
|
||||
(mred:debug:printf 'super-init "after simple-frame%"))
|
||||
(super-init name #f WIDTH HEIGHT '(default-frame sdi)))
|
||||
|
||||
(public
|
||||
[get-canvas (let ([c #f])
|
||||
|
|
@ -563,13 +517,26 @@
|
|||
(send (get-canvas) set-media e))
|
||||
e))])
|
||||
(sequence
|
||||
(let ([icon (mred:icon:get-icon)])
|
||||
(let ([icon (icon:get-icon)])
|
||||
(when (send icon ok?)
|
||||
(set-icon icon)))
|
||||
(do-title)
|
||||
(let ([canvas (get-canvas)])
|
||||
(send (get-edit) load-file filename)
|
||||
(send canvas set-focus)))))
|
||||
|
||||
(define searchable<%> (interface ()
|
||||
get-edit-to-search
|
||||
hide-search
|
||||
unhide-search
|
||||
set-search-direction
|
||||
replace&search
|
||||
replace-all
|
||||
replace
|
||||
toggle-search-focus
|
||||
move-to-search-or-show-search
|
||||
move-to-search-or-reverse-search
|
||||
search))
|
||||
(define make-searchable%
|
||||
(let* ([anchor 0]
|
||||
[searching-direction 1]
|
||||
|
|
@ -578,8 +545,8 @@
|
|||
(lambda (edit)
|
||||
(let loop ([edit edit])
|
||||
(let ([snip (send edit get-focus-snip)])
|
||||
(if (or (null? snip)
|
||||
(not (is-a? snip wx:media-snip%)))
|
||||
(if (or (not snip)
|
||||
(not (is-a? snip editor-snip%)))
|
||||
edit
|
||||
(loop (send snip get-this-media))))))]
|
||||
[clear-highlight
|
||||
|
|
@ -587,7 +554,7 @@
|
|||
(begin (old-highlight)
|
||||
(set! old-highlight void)))]
|
||||
[reset-anchor
|
||||
(let ([color (make-object wx:colour% "BLUE")])
|
||||
(let ([color (make-object color% "BLUE")])
|
||||
(lambda (edit)
|
||||
(old-highlight)
|
||||
(let ([position
|
||||
|
|
@ -623,14 +590,14 @@
|
|||
(lambda (found-edit)
|
||||
(send found-edit set-position anchor)
|
||||
(when beep?
|
||||
(wx:bell))
|
||||
(bell))
|
||||
#f)]
|
||||
[found
|
||||
(lambda (edit first-pos)
|
||||
(let ([last-pos (+ first-pos (* searching-direction
|
||||
(string-length string)))])
|
||||
(send* edit
|
||||
(set-caret-owner null wx:const-focus-display)
|
||||
(set-caret-owner #f 'display)
|
||||
(set-position
|
||||
(min first-pos last-pos)
|
||||
(max first-pos last-pos)))
|
||||
|
|
@ -683,30 +650,31 @@
|
|||
(class editor-canvas% args
|
||||
(inherit get-parent frame set-line-count)
|
||||
(rename [super-on-set-focus on-set-focus])
|
||||
(public
|
||||
[lines 2]
|
||||
[style-flags wx:const-mcanvas-hide-h-scroll]
|
||||
(override
|
||||
[style-flags '(h-scroll)]
|
||||
[on-set-focus
|
||||
(lambda ()
|
||||
(send find-edit set-searching-frame frame)
|
||||
(super-on-set-focus))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-line-count 1)))])
|
||||
(set-line-count 2)))])
|
||||
(for-each (lambda (keymap)
|
||||
(send keymap chain-to-keymap
|
||||
keymap:global-search-keymap
|
||||
#t))
|
||||
(list (send find-edit get-keymap)
|
||||
(send replace-edit get-keymap)))
|
||||
(mixin frame:edit<%> frame:searchable<%> args
|
||||
(mixin edit<%> searchable<%> args
|
||||
(inherit active-edit active-canvas get-edit)
|
||||
(rename [super-make-root-panel make-root-panel]
|
||||
[super-on-activate on-activate]
|
||||
[super-do-close do-close])
|
||||
(private
|
||||
[super-root 'unitiaialized-super-root])
|
||||
(public
|
||||
(override
|
||||
[edit-menu:find (lambda (menu evt) (search))])
|
||||
(override
|
||||
[make-root-panel
|
||||
(lambda (% parent)
|
||||
(let* ([s-root (super-make-root-panel
|
||||
|
|
@ -715,14 +683,15 @@
|
|||
[root (make-object % s-root)])
|
||||
(set! super-root s-root)
|
||||
root))])
|
||||
(public
|
||||
(override
|
||||
[on-activate
|
||||
(lambda (on?)
|
||||
(unless hidden?
|
||||
(if on?
|
||||
(reset-anchor (get-edit-to-search))
|
||||
(clear-highlight)))
|
||||
(super-on-activate on?))]
|
||||
(super-on-activate on?))])
|
||||
(public
|
||||
[get-edit-to-search
|
||||
(lambda ()
|
||||
(get-edit))]
|
||||
|
|
@ -740,18 +709,18 @@
|
|||
(set! hidden? #f)
|
||||
(send super-root add-child search-panel)
|
||||
(reset-anchor (get-edit-to-search)))])
|
||||
(public
|
||||
(override
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(let ([close-canvas
|
||||
(lambda (canvas edit)
|
||||
(send edit remove-canvas canvas)
|
||||
(send canvas set-media ()))])
|
||||
(send canvas set-media #f))])
|
||||
(close-canvas find-canvas find-edit)
|
||||
(close-canvas replace-canvas replace-edit))
|
||||
(when (eq? this (ivar find-edit searching-frame))
|
||||
(send find-edit set-searching-frame #f)))]
|
||||
(send find-edit set-searching-frame #f)))])
|
||||
[set-search-direction
|
||||
(lambda (x)
|
||||
(set! searching-direction x)
|
||||
|
|
@ -863,16 +832,16 @@
|
|||
middle-middle-panel
|
||||
(lambda x (replace-all)))]
|
||||
|
||||
[dir-radio (make-object radio-box% middle-right-panel
|
||||
(lambda (dir-radio evt)
|
||||
(let ([forward (if (= 0 (send evt get-command-int))
|
||||
1
|
||||
-1)])
|
||||
(set-search-direction forward)
|
||||
(reset-anchor (get-edit-to-search))))
|
||||
null
|
||||
-1 -1 -1 -1
|
||||
(list "Forward" "Backward"))]
|
||||
[dir-radio (make-object radio-box%
|
||||
#f
|
||||
(list "Forward" "Backward")
|
||||
middle-right-panel
|
||||
(lambda (dir-radio evt)
|
||||
(let ([forward (if (= 0 (send evt get-command-int))
|
||||
1
|
||||
-1)])
|
||||
(set-search-direction forward)
|
||||
(reset-anchor (get-edit-to-search)))))]
|
||||
[close-button (make-object button% middle-right-panel
|
||||
(lambda args (hide-search)) "Hide")]
|
||||
[hidden? #f])
|
||||
|
|
@ -897,6 +866,12 @@
|
|||
(send replace-edit add-canvas replace-canvas)
|
||||
(hide-search #t)))))
|
||||
|
||||
(define info<%> (interface (edit<%>)
|
||||
determine-width
|
||||
get-info-edit
|
||||
lock-status-changed
|
||||
update-info
|
||||
info-panel))
|
||||
(define make-info%
|
||||
(let* ([time-edit (make-object text%)]
|
||||
[time-semaphore (make-semaphore 1)]
|
||||
|
|
@ -934,12 +909,12 @@
|
|||
(update-time)
|
||||
(sleep 30)
|
||||
(loop))))])
|
||||
(mixin frame:edit<%> frame:info<%> args
|
||||
(mixin edit<%> info<%> args
|
||||
(rename [super-make-root-panel make-root-panel])
|
||||
(private
|
||||
[rest-panel 'uninitialized-root]
|
||||
[super-root 'uninitialized-super-root])
|
||||
(public
|
||||
(override
|
||||
[make-root-panel
|
||||
(lambda (% parent)
|
||||
(let* ([s-root (super-make-root-panel
|
||||
|
|
@ -954,7 +929,7 @@
|
|||
[determine-width
|
||||
(let ([magic-space 25])
|
||||
(lambda (string canvas edit)
|
||||
(send edit set-autowrap-bitmap null)
|
||||
(send edit set-autowrap-bitmap #f)
|
||||
(send canvas call-as-primary-owner
|
||||
(lambda ()
|
||||
(let ([lb (box 0)]
|
||||
|
|
@ -965,7 +940,7 @@
|
|||
(send edit last-position)
|
||||
rb)
|
||||
(send edit position-location 0 lb)
|
||||
(send canvas user-min-width
|
||||
(send canvas min-width
|
||||
(+ magic-space (- (unbox rb) (unbox lb)))))))))])
|
||||
|
||||
(rename [super-do-close do-close])
|
||||
|
|
@ -976,17 +951,17 @@
|
|||
(lambda (p v)
|
||||
(if v
|
||||
(register-gc-blit)
|
||||
(wx:unregister-collecting-blit gc-canvas))
|
||||
(unregister-collecting-blit gc-canvas))
|
||||
(send super-root change-children
|
||||
(lambda (l)
|
||||
(if v
|
||||
(list rest-panel info-panel)
|
||||
(list rest-panel))))))])
|
||||
(public
|
||||
(override
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(send time-canvas set-media null)
|
||||
(send time-canvas set-media #f)
|
||||
(unregister-collecting-blit gc-canvas)
|
||||
(close-panel-callback))])
|
||||
|
||||
|
|
@ -1029,9 +1004,9 @@
|
|||
super-root)])
|
||||
(private
|
||||
[lock-message (make-object message%
|
||||
(let ([b (mred:icon:get-unlock-bitmap)])
|
||||
(let ([b (icon:get-unlock-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (mred:icon:get-unlock-mdc) b)
|
||||
(cons (icon:get-unlock-mdc) b)
|
||||
"Unlocked"))
|
||||
info-panel
|
||||
'(border))]
|
||||
|
|
@ -1040,17 +1015,17 @@
|
|||
[gc-canvas (make-object canvas% info-panel '(border))]
|
||||
[register-gc-blit
|
||||
(lambda ()
|
||||
(let ([mdc (mred:icon:get-gc-on-dc)])
|
||||
(let ([mdc (icon:get-gc-on-dc)])
|
||||
(when (send mdc ok?)
|
||||
(register-collecting-blit gc-canvas
|
||||
0 0
|
||||
(mred:icon:get-gc-width)
|
||||
(mred:icon:get-gc-height)
|
||||
(mred:icon:get-gc-on-dc)
|
||||
(mred:icon:get-gc-off-dc)))))])
|
||||
(icon:get-gc-width)
|
||||
(icon:get-gc-height)
|
||||
(icon:get-gc-on-dc)
|
||||
(icon:get-gc-off-dc)))))])
|
||||
|
||||
(sequence
|
||||
(unless (mred:preferences:get-preference 'mred:show-status-line)
|
||||
(unless (preferences:get-preference 'framework:show-status-line)
|
||||
(send super-root change-children
|
||||
(lambda (l)
|
||||
(list rest-panel))))
|
||||
|
|
@ -1081,170 +1056,175 @@
|
|||
(semaphore-post time-semaphore)
|
||||
(update-time)))))
|
||||
|
||||
(define edit-info<%> (interface (info<%>)
|
||||
overwrite-status-changed
|
||||
anchor-status-changed
|
||||
edit-position-changed-offset
|
||||
edit-position-changed))
|
||||
(define make-edit-info%
|
||||
(mixin (interface (frame:info<%> frame:edit<%>)) frame:edit-info<%> args
|
||||
(inherit get-info-edit)
|
||||
(rename [super-do-close do-close])
|
||||
(private
|
||||
[remove-pref-callback
|
||||
(preferences:add-callback
|
||||
'framework:line-offsets
|
||||
(lambda (p v)
|
||||
(edit-position-changed-offset v)
|
||||
#t))])
|
||||
(public
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(remove-pref-callback))])
|
||||
|
||||
(public
|
||||
[overwrite-status-changed
|
||||
(let ([last-state? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(let ([overwrite-now? (send info-edit get-overwrite-mode)])
|
||||
(unless (eq? overwrite-now? last-state?)
|
||||
(send overwrite-message
|
||||
show
|
||||
overwrite-now?)
|
||||
(set! last-state? overwrite-now?)))))))]
|
||||
[anchor-status-changed
|
||||
(let ([last-state? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(let ([anchor-now? (send info-edit get-anchor)])
|
||||
(unless (eq? anchor-now? last-state?)
|
||||
(send anchor-message
|
||||
show
|
||||
anchor-now?)
|
||||
(set! last-state? anchor-now?)))))))]
|
||||
|
||||
[edit-position-changed-offset
|
||||
(let ([last-start #f]
|
||||
[last-end #f])
|
||||
(lambda (offset?)
|
||||
(let* ([edit (get-info-edit)]
|
||||
[make-one
|
||||
(lambda (pos)
|
||||
(let* ([line (send edit position-line pos)]
|
||||
[line-start (send edit line-start-position line)]
|
||||
[char (- pos line-start)])
|
||||
(if (preferences:get 'framework:display-line-numbers)
|
||||
(format "~a:~a"
|
||||
(if offset?
|
||||
(add1 line)
|
||||
line)
|
||||
(if offset?
|
||||
(add1 char)
|
||||
char))
|
||||
(format "~a"
|
||||
(if offset?
|
||||
(+ pos 1)
|
||||
pos)))))])
|
||||
(when edit
|
||||
(let ([start (send edit get-start-position)]
|
||||
[end (send edit get-end-position)])
|
||||
(unless (and last-start
|
||||
(= last-start start)
|
||||
(= last-end end))
|
||||
(set! last-start start)
|
||||
(set! last-end end)
|
||||
(when (object? position-edit)
|
||||
(send* position-edit
|
||||
(lock #f)
|
||||
(erase)
|
||||
(insert
|
||||
(if (= start end)
|
||||
(make-one start)
|
||||
(string-append (make-one start)
|
||||
"-"
|
||||
(make-one end))))
|
||||
(lock #t)))))))))]
|
||||
[edit-position-changed
|
||||
(lambda ()
|
||||
(edit-position-changed-offset
|
||||
(preferences:get 'framework:line-offsets)))])
|
||||
(rename [super-update-info update-info])
|
||||
(public
|
||||
[update-info
|
||||
(lambda ()
|
||||
(super-update-info)
|
||||
(overwrite-status-changed)
|
||||
(anchor-status-changed)
|
||||
(edit-position-changed))])
|
||||
(sequence
|
||||
(apply super-init args))
|
||||
|
||||
(inherit info-panel)
|
||||
(private
|
||||
[anchor-message
|
||||
(make-object message%
|
||||
(let ([b (mred:icon:get-anchor-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (mred:icon:get-anchor-mdc) b)
|
||||
"Anchor"))
|
||||
info-panel '(border))]
|
||||
[overwrite-message
|
||||
(make-object mred:container:canvas-message%
|
||||
"Overwrite"
|
||||
info-panel
|
||||
'(border))]
|
||||
[position-canvas (make-object editor-canvas% info-panel)]
|
||||
[_2 (send position-canvas set-line-count 1)]
|
||||
[position-edit (make-object text%)])
|
||||
|
||||
(inherit determine-width)
|
||||
(sequence
|
||||
(let ([move-front
|
||||
(lambda (x l)
|
||||
(cons x (mzlib:function:remq x l)))])
|
||||
(send info-panel change-children
|
||||
(lambda (l)
|
||||
(move-front
|
||||
anchor-message
|
||||
(move-front
|
||||
overwrite-message
|
||||
(move-front
|
||||
position-canvas
|
||||
l))))))
|
||||
(send anchor-message show #f)
|
||||
(send overwrite-message show #f)
|
||||
(send* position-canvas
|
||||
(set-media position-edit)
|
||||
(stretchable-in-x #f))
|
||||
(determine-width "0000:000-0000:000"
|
||||
position-canvas
|
||||
position-edit)
|
||||
(edit-position-changed)
|
||||
(send position-edit lock #t))))
|
||||
(mixin info<%> edit-info<%> args
|
||||
(inherit get-info-edit)
|
||||
(rename [super-do-close do-close])
|
||||
(private
|
||||
[remove-pref-callback
|
||||
(preferences:add-callback
|
||||
'framework:line-offsets
|
||||
(lambda (p v)
|
||||
(edit-position-changed-offset v)
|
||||
#t))])
|
||||
(override
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(remove-pref-callback))])
|
||||
|
||||
(public
|
||||
[overwrite-status-changed
|
||||
(let ([last-state? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(let ([overwrite-now? (send info-edit get-overwrite-mode)])
|
||||
(unless (eq? overwrite-now? last-state?)
|
||||
(send overwrite-message
|
||||
show
|
||||
overwrite-now?)
|
||||
(set! last-state? overwrite-now?)))))))]
|
||||
[anchor-status-changed
|
||||
(let ([last-state? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(let ([anchor-now? (send info-edit get-anchor)])
|
||||
(unless (eq? anchor-now? last-state?)
|
||||
(send anchor-message
|
||||
show
|
||||
anchor-now?)
|
||||
(set! last-state? anchor-now?)))))))]
|
||||
|
||||
[edit-position-changed-offset
|
||||
(let ([last-start #f]
|
||||
[last-end #f])
|
||||
(lambda (offset?)
|
||||
(let* ([edit (get-info-edit)]
|
||||
[make-one
|
||||
(lambda (pos)
|
||||
(let* ([line (send edit position-line pos)]
|
||||
[line-start (send edit line-start-position line)]
|
||||
[char (- pos line-start)])
|
||||
(if (preferences:get 'framework:display-line-numbers)
|
||||
(format "~a:~a"
|
||||
(if offset?
|
||||
(add1 line)
|
||||
line)
|
||||
(if offset?
|
||||
(add1 char)
|
||||
char))
|
||||
(format "~a"
|
||||
(if offset?
|
||||
(+ pos 1)
|
||||
pos)))))])
|
||||
(when edit
|
||||
(let ([start (send edit get-start-position)]
|
||||
[end (send edit get-end-position)])
|
||||
(unless (and last-start
|
||||
(= last-start start)
|
||||
(= last-end end))
|
||||
(set! last-start start)
|
||||
(set! last-end end)
|
||||
(when (object? position-edit)
|
||||
(send* position-edit
|
||||
(lock #f)
|
||||
(erase)
|
||||
(insert
|
||||
(if (= start end)
|
||||
(make-one start)
|
||||
(string-append (make-one start)
|
||||
"-"
|
||||
(make-one end))))
|
||||
(lock #t)))))))))]
|
||||
[edit-position-changed
|
||||
(lambda ()
|
||||
(edit-position-changed-offset
|
||||
(preferences:get 'framework:line-offsets)))])
|
||||
(rename [super-update-info update-info])
|
||||
(override
|
||||
[update-info
|
||||
(lambda ()
|
||||
(super-update-info)
|
||||
(overwrite-status-changed)
|
||||
(anchor-status-changed)
|
||||
(edit-position-changed))])
|
||||
(sequence
|
||||
(apply super-init args))
|
||||
|
||||
(inherit info-panel)
|
||||
(private
|
||||
[anchor-message
|
||||
(make-object message%
|
||||
(let ([b (icon:get-anchor-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (icon:get-anchor-mdc) b)
|
||||
"Anchor"))
|
||||
info-panel '(border))]
|
||||
[overwrite-message
|
||||
(make-object message%
|
||||
"Overwrite"
|
||||
info-panel
|
||||
'(border))]
|
||||
[position-canvas (make-object editor-canvas% info-panel)]
|
||||
[_2 (send position-canvas set-line-count 1)]
|
||||
[position-edit (make-object text%)])
|
||||
|
||||
(inherit determine-width)
|
||||
(sequence
|
||||
(let ([move-front
|
||||
(lambda (x l)
|
||||
(cons x (mzlib:function:remq x l)))])
|
||||
(send info-panel change-children
|
||||
(lambda (l)
|
||||
(move-front
|
||||
anchor-message
|
||||
(move-front
|
||||
overwrite-message
|
||||
(move-front
|
||||
position-canvas
|
||||
l))))))
|
||||
(send anchor-message show #f)
|
||||
(send overwrite-message show #f)
|
||||
(send* position-canvas
|
||||
(set-media position-edit)
|
||||
(stretchable-in-x #f))
|
||||
(determine-width "0000:000-0000:000"
|
||||
position-canvas
|
||||
position-edit)
|
||||
(edit-position-changed)
|
||||
(send position-edit lock #t))))
|
||||
|
||||
(define file<%> (interface (edit<%>)))
|
||||
(define make-file%
|
||||
(lambda (super%)
|
||||
(rec mred:file-frame%
|
||||
(class-asi super%
|
||||
(inherit get-edit)
|
||||
(rename [super-can-close? can-close?])
|
||||
(public
|
||||
[can-close?
|
||||
(lambda ()
|
||||
(let* ([edit (get-edit)]
|
||||
[user-allowed-or-not-modified
|
||||
(or (not (send edit modified?))
|
||||
(case (mred:gui-utils:unsaved-warning
|
||||
(let ([fn (send edit get-filename)])
|
||||
(if (string? fn)
|
||||
fn
|
||||
"Untitled"))
|
||||
"Close"
|
||||
#t)
|
||||
[(continue) #t]
|
||||
[(save) (send edit save-file)]
|
||||
[else #f]))])
|
||||
(and user-allowed-or-not-modified
|
||||
(super-can-close?))))])))))
|
||||
(mixin edit<%> file<%> args
|
||||
(inherit get-edit)
|
||||
(rename [super-can-close? can-close?])
|
||||
(override
|
||||
[on-close?
|
||||
(lambda ()
|
||||
(let* ([edit (get-edit)]
|
||||
[user-allowed-or-not-modified
|
||||
(or (not (send edit modified?))
|
||||
(case (gui-utils:unsaved-warning
|
||||
(let ([fn (send edit get-filename)])
|
||||
(if (string? fn)
|
||||
fn
|
||||
"Untitled"))
|
||||
"Close"
|
||||
#t)
|
||||
[(continue) #t]
|
||||
[(save) (send edit save-file)]
|
||||
[else #f]))])
|
||||
(and user-allowed-or-not-modified
|
||||
(super-can-close?))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define empty% (make-empty% frame%))
|
||||
(define standard-menus% (make-standard-menus% empty%))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(unit/sig mred:group^
|
||||
(import [exit : framework:exit^]
|
||||
(import mred^
|
||||
[exit : framework:exit^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
|
||||
|
|
|
|||
|
|
@ -1,155 +1,205 @@
|
|||
(unit/sig framework:gui-utils^
|
||||
(import mred^)
|
||||
|
||||
(unit/sig framework:gui-utils^
|
||||
(import)
|
||||
(define cursor-delay
|
||||
(let ([x 0.25])
|
||||
(case-lambda
|
||||
[() x]
|
||||
[(v) (set! x v) x])))
|
||||
|
||||
(define cursor-delay
|
||||
(let ([x 0.25])
|
||||
(case-lambda
|
||||
[() x]
|
||||
[(v) (set! x v) x])))
|
||||
(define show-busy-cursor
|
||||
(lambda (thunk)
|
||||
(local-busy-cursor #f thunk)))
|
||||
|
||||
(define show-busy-cursor
|
||||
(lambda (thunk)
|
||||
(local-busy-cursor #f thunk)))
|
||||
(define delay-action
|
||||
(lambda (delay-time open close)
|
||||
(let ([semaphore (make-semaphore 1)]
|
||||
[open? #f]
|
||||
[skip-it? #f])
|
||||
(thread
|
||||
(lambda ()
|
||||
(sleep delay-time)
|
||||
(semaphore-wait semaphore)
|
||||
(unless skip-it?
|
||||
(set! open? #t)
|
||||
(open))
|
||||
(semaphore-post semaphore)))
|
||||
(lambda ()
|
||||
(semaphore-wait semaphore)
|
||||
(set! skip-it? #t)
|
||||
(when open?
|
||||
(close))
|
||||
(semaphore-post semaphore)))))
|
||||
|
||||
(define delay-action
|
||||
(lambda (delay-time open close)
|
||||
(let ([semaphore (make-semaphore 1)]
|
||||
[open? #f]
|
||||
[skip-it? #f])
|
||||
(thread
|
||||
(define local-busy-cursor
|
||||
(let ([watch (make-object wx:cursor% wx:const-cursor-watch)])
|
||||
(opt-lambda (win thunk [delay (cursor-delay)])
|
||||
(let* ([old-cursor #f]
|
||||
[cursor-off void])
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(sleep delay-time)
|
||||
(semaphore-wait semaphore)
|
||||
(unless skip-it?
|
||||
(set! open? #t)
|
||||
(open))
|
||||
(semaphore-post semaphore)))
|
||||
(lambda ()
|
||||
(semaphore-wait semaphore)
|
||||
(set! skip-it? #t)
|
||||
(when open?
|
||||
(close))
|
||||
(semaphore-post semaphore)))))
|
||||
(set! cursor-off
|
||||
(delay-action
|
||||
delay
|
||||
(lambda ()
|
||||
(if win
|
||||
(set! old-cursor (send win set-cursor watch))
|
||||
(wx:begin-busy-cursor)))
|
||||
(lambda ()
|
||||
(if win
|
||||
(send win set-cursor old-cursor)
|
||||
(wx:end-busy-cursor))))))
|
||||
(lambda () (thunk))
|
||||
(lambda () (cursor-off)))))))
|
||||
|
||||
(define local-busy-cursor
|
||||
(let ([watch (make-object wx:cursor% wx:const-cursor-watch)])
|
||||
(opt-lambda (win thunk [delay (cursor-delay)])
|
||||
(let* ([old-cursor #f]
|
||||
[cursor-off void])
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! cursor-off
|
||||
(delay-action
|
||||
delay
|
||||
(lambda ()
|
||||
(if win
|
||||
(set! old-cursor (send win set-cursor watch))
|
||||
(wx:begin-busy-cursor)))
|
||||
(lambda ()
|
||||
(if win
|
||||
(send win set-cursor old-cursor)
|
||||
(wx:end-busy-cursor))))))
|
||||
(lambda () (thunk))
|
||||
(lambda () (cursor-off)))))))
|
||||
(define unsaved-warning
|
||||
(opt-lambda (filename action [can-save-now? #f])
|
||||
(let* ([result (void)]
|
||||
[dialog%
|
||||
(class dialog-box% ()
|
||||
(inherit show new-line fit tab center set-size)
|
||||
(private
|
||||
[on-dont-save
|
||||
(lambda args
|
||||
(set! result 'continue)
|
||||
(show #f))]
|
||||
[on-save-now
|
||||
(lambda rags
|
||||
(set! result 'save)
|
||||
(show #f))]
|
||||
[on-cancel
|
||||
(lambda args
|
||||
(set! result 'cancel)
|
||||
(show #f))])
|
||||
(sequence
|
||||
(super-init "Warning")
|
||||
(let* ([panel (make-object vertical-panel% this)]
|
||||
[msg
|
||||
(make-object message%
|
||||
(string-append "The file \""
|
||||
filename
|
||||
"\" is not saved.")
|
||||
panel)]
|
||||
[button-panel
|
||||
(make-object horizontal-panel% panel)])
|
||||
(make-object button%
|
||||
(string-append action " Anyway")
|
||||
button-panel
|
||||
on-dont-save)
|
||||
(let ([now (make-object button%
|
||||
"Save"
|
||||
button-panel
|
||||
on-save-now)]
|
||||
[cancel (make-object button%
|
||||
"Cancel"
|
||||
button-panel
|
||||
on-cancel)])
|
||||
(if (not can-save-now?)
|
||||
(begin (send cancel set-focus)
|
||||
(send now show #f))
|
||||
(send now set-focus)))
|
||||
(send msg center wx:const-horizontal))
|
||||
|
||||
(set-size -1 -1 10 10)
|
||||
(center wx:const-both)
|
||||
|
||||
(show #t)))])
|
||||
(make-object dialog%)
|
||||
result)))
|
||||
|
||||
(define read-snips/chars-from-buffer
|
||||
(opt-lambda (edit [start 0] [end (send edit last-position)])
|
||||
(let ([pos start]
|
||||
[box (box 0)])
|
||||
(lambda ()
|
||||
(let* ([snip (send edit find-snip pos
|
||||
wx:const-snip-after-or-null box)]
|
||||
[ans
|
||||
(cond
|
||||
[(<= end pos) eof]
|
||||
[(null? snip) eof]
|
||||
[(is-a? snip wx:text-snip%)
|
||||
(let ([t (send snip get-text (- pos (unbox box)) 1)])
|
||||
(unless (= (string-length t) 1)
|
||||
(error 'read-snips/chars-from-buffer
|
||||
"unexpected string, t: ~s; pos: ~a box: ~a"
|
||||
t pos box))
|
||||
(string-ref t 0))]
|
||||
[else snip])])
|
||||
(set! pos (add1 pos))
|
||||
ans)))))
|
||||
|
||||
(define unsaved-warning
|
||||
(opt-lambda (filename action [can-save-now? #f])
|
||||
(let* ([result (void)]
|
||||
[dialog%
|
||||
(class dialog-box% ()
|
||||
(inherit show new-line fit tab center set-size)
|
||||
(private
|
||||
[on-dont-save
|
||||
(lambda args
|
||||
(set! result 'continue)
|
||||
(show #f))]
|
||||
[on-save-now
|
||||
(lambda rags
|
||||
(set! result 'save)
|
||||
(show #f))]
|
||||
[on-cancel
|
||||
(lambda args
|
||||
(set! result 'cancel)
|
||||
(show #f))])
|
||||
(sequence
|
||||
(super-init "Warning")
|
||||
(let* ([panel (make-object vertical-panel% this)]
|
||||
[msg
|
||||
(make-object message%
|
||||
(string-append "The file \""
|
||||
filename
|
||||
"\" is not saved.")
|
||||
panel)]
|
||||
[button-panel
|
||||
(make-object horizontal-panel% panel)])
|
||||
(make-object button%
|
||||
(string-append action " Anyway")
|
||||
button-panel
|
||||
on-dont-save)
|
||||
(let ([now (make-object button%
|
||||
"Save"
|
||||
button-panel
|
||||
on-save-now)]
|
||||
[cancel (make-object button%
|
||||
"Cancel"
|
||||
button-panel
|
||||
on-cancel)])
|
||||
(if (not can-save-now?)
|
||||
(begin (send cancel set-focus)
|
||||
(send now show #f))
|
||||
(send now set-focus)))
|
||||
(send msg center wx:const-horizontal))
|
||||
(define get-choice
|
||||
(opt-lambda (message true-choice false-choice
|
||||
[title "Warning"][x -1][y -1])
|
||||
(let* ([result (void)]
|
||||
[dialog%
|
||||
(class wx:dialog-box% ()
|
||||
(inherit show new-line fit tab center)
|
||||
(private
|
||||
[on-true
|
||||
(lambda args
|
||||
(set! result #t)
|
||||
(show #f))]
|
||||
[on-false
|
||||
(lambda rags
|
||||
(set! result #f)
|
||||
(show #f))])
|
||||
(sequence
|
||||
(super-init () title #t x y)
|
||||
(let* ([messages
|
||||
(let loop ([m message])
|
||||
(let ([match (regexp-match (format "([^~n]*)~n(.*)")
|
||||
m)])
|
||||
(if match
|
||||
(cons (cadr match)
|
||||
(loop (caddr match)))
|
||||
(list m))))]
|
||||
[msgs (map
|
||||
(lambda (message)
|
||||
(begin0
|
||||
(make-object wx:message% this message)
|
||||
(new-line)))
|
||||
messages)])
|
||||
|
||||
(set-size -1 -1 10 10)
|
||||
(center wx:const-both)
|
||||
(send (make-object wx:button% this
|
||||
on-true true-choice)
|
||||
set-focus)
|
||||
(tab 50)
|
||||
(make-object wx:button% this on-false false-choice)
|
||||
(fit)
|
||||
|
||||
(show #t)))])
|
||||
(make-object dialog%)
|
||||
result)))
|
||||
|
||||
(define read-snips/chars-from-buffer
|
||||
(opt-lambda (edit [start 0] [end (send edit last-position)])
|
||||
(let ([pos start]
|
||||
[box (box 0)])
|
||||
(lambda ()
|
||||
(let* ([snip (send edit find-snip pos
|
||||
wx:const-snip-after-or-null box)]
|
||||
[ans
|
||||
(cond
|
||||
[(<= end pos) eof]
|
||||
[(null? snip) eof]
|
||||
[(is-a? snip wx:text-snip%)
|
||||
(let ([t (send snip get-text (- pos (unbox box)) 1)])
|
||||
(unless (= (string-length t) 1)
|
||||
(error 'read-snips/chars-from-buffer
|
||||
"unexpected string, t: ~s; pos: ~a box: ~a"
|
||||
t pos box))
|
||||
(string-ref t 0))]
|
||||
[else snip])])
|
||||
(set! pos (add1 pos))
|
||||
ans)))))
|
||||
(if (and (< x 0) (< y 0))
|
||||
(map (lambda (msg)
|
||||
(send msg center wx:const-horizontal))
|
||||
msgs)))
|
||||
|
||||
(center wx:const-both)
|
||||
|
||||
(show #t)))])
|
||||
(make-object dialog%)
|
||||
result)))
|
||||
|
||||
(define open-input-buffer
|
||||
(lambda (buffer)
|
||||
(let ([pos 0])
|
||||
(make-input-port
|
||||
(lambda ()
|
||||
(let ([c (send buffer get-character pos)])
|
||||
(if (char=? c #\null)
|
||||
eof
|
||||
(begin
|
||||
(set! pos (add1 pos))
|
||||
c))))
|
||||
(lambda ()
|
||||
#t)
|
||||
(lambda ()
|
||||
(void))))))
|
||||
|
||||
; For use with wx:set-print-paper-name
|
||||
(define print-paper-names
|
||||
(list
|
||||
"A4 210 x 297 mm"
|
||||
"A3 297 x 420 mm"
|
||||
"Letter 8 1/2 x 11 in"
|
||||
"Legal 8 1/2 x 14 in")))
|
||||
(define open-input-buffer
|
||||
(lambda (buffer)
|
||||
(let ([pos 0])
|
||||
(make-input-port
|
||||
(lambda ()
|
||||
(let ([c (send buffer get-character pos)])
|
||||
(if (char=? c #\null)
|
||||
eof
|
||||
(begin
|
||||
(set! pos (add1 pos))
|
||||
c))))
|
||||
(lambda ()
|
||||
#t)
|
||||
(lambda ()
|
||||
(void))))))
|
||||
|
||||
; For use with wx:set-print-paper-name
|
||||
(define print-paper-names
|
||||
(list
|
||||
"A4 210 x 297 mm"
|
||||
"A3 297 x 420 mm"
|
||||
"Letter 8 1/2 x 11 in"
|
||||
"Legal 8 1/2 x 14 in")))
|
||||
|
|
|
|||
|
|
@ -1,211 +1,142 @@
|
|||
; File Formats and Modes
|
||||
(unit/sig framework:handler^
|
||||
(import mred^
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[finder : framework:finder^]
|
||||
[group : framework:group^]
|
||||
[text : framework:text^]
|
||||
[preferences : framework:preferences^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
|
||||
(define-struct handler (name extension handler))
|
||||
|
||||
(unit/sig framework:handler^
|
||||
(import [gui-utils : framework:gui-utils^]
|
||||
[finder : framework:finder^]
|
||||
[group : framework:group^]
|
||||
[hyper:frame : framework:hyper:frame^]
|
||||
[edit : framework:edit^]
|
||||
[preferences : framework:preferences^]
|
||||
[mzlib:file : mzlib:file^]
|
||||
[mred:editor-frame : mred:editor-frame^])
|
||||
|
||||
(define-struct handler (name extension handler))
|
||||
(define format-handlers '())
|
||||
|
||||
(define format-handlers '())
|
||||
(define make-insert-handler
|
||||
(letrec ([string-list?
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (pair? l)) #f]
|
||||
[else
|
||||
(and (string? (car l))
|
||||
(string-list? (cdr l)))]))])
|
||||
(lambda (who name extension handler)
|
||||
(cond
|
||||
[(not (string? name))
|
||||
(error who "name was not a string")]
|
||||
[(and (not (procedure? extension))
|
||||
(not (string? extension))
|
||||
(not (string-list? extension)))
|
||||
(error who
|
||||
"extension was not a string, list of strings, or a predicate")]
|
||||
[(not (procedure? handler))
|
||||
(error who "handler was not a function")]
|
||||
[else (make-handler name
|
||||
extension
|
||||
handler)]))))
|
||||
|
||||
(define insert-format-handler
|
||||
(lambda args
|
||||
(set! format-handlers
|
||||
(cons (apply make-insert-handler 'insert-format-handler args)
|
||||
format-handlers))))
|
||||
|
||||
(define make-insert-handler
|
||||
(letrec ([string-list?
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (pair? l)) #f]
|
||||
[else
|
||||
(and (string? (car l))
|
||||
(string-list? (cdr l)))]))])
|
||||
(lambda (who name extension handler)
|
||||
(cond
|
||||
[(not (string? name))
|
||||
(error who "name was not a string")]
|
||||
[(and (not (procedure? extension))
|
||||
(not (string? extension))
|
||||
(not (string-list? extension)))
|
||||
(error who
|
||||
"extension was not a string, list of strings, or a predicate")]
|
||||
[(not (procedure? handler))
|
||||
(error who "handler was not a function")]
|
||||
[else (make-handler name
|
||||
extension
|
||||
handler)]))))
|
||||
|
||||
(define insert-format-handler
|
||||
(lambda args
|
||||
(set! format-handlers
|
||||
(cons (apply make-insert-handler 'insert-format-handler args)
|
||||
format-handlers))))
|
||||
(define find-handler
|
||||
(lambda (name handlers)
|
||||
(let/ec exit
|
||||
(let ([extension (if (string? name)
|
||||
(or (mzlib:file:filename-extension name)
|
||||
"")
|
||||
"")])
|
||||
(for-each
|
||||
(lambda (handler)
|
||||
(let ([ext (handler-extension handler)])
|
||||
(when (or (and (procedure? ext)
|
||||
(ext name))
|
||||
(and (string? ext)
|
||||
(string=? ext extension))
|
||||
(and (pair? ext)
|
||||
(ormap (lambda (ext)
|
||||
(string=? ext extension))
|
||||
ext)))
|
||||
(exit (handler-handler handler)))))
|
||||
handlers)
|
||||
#f))))
|
||||
|
||||
(define find-format-handler
|
||||
(lambda (name)
|
||||
(find-handler name format-handlers)))
|
||||
|
||||
(define find-handler
|
||||
(lambda (name handlers)
|
||||
(let/ec exit
|
||||
(let ([extension (if (string? name)
|
||||
(or (mzlib:file:filename-extension name)
|
||||
"")
|
||||
"")])
|
||||
(for-each
|
||||
(lambda (handler)
|
||||
(let ([ext (handler-extension handler)])
|
||||
(when (or (and (procedure? ext)
|
||||
(ext name))
|
||||
(and (string? ext)
|
||||
(string=? ext extension))
|
||||
(and (pair? ext)
|
||||
(ormap (lambda (ext)
|
||||
(string=? ext extension))
|
||||
ext)))
|
||||
(exit (handler-handler handler)))))
|
||||
handlers)
|
||||
#f))))
|
||||
|
||||
(define find-format-handler
|
||||
(lambda (name)
|
||||
(find-handler name format-handlers)))
|
||||
; Finding format & mode handlers by name
|
||||
(define find-named-handler
|
||||
(lambda (name handlers)
|
||||
(let loop ([l handlers])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(string-ci=? (handler-name (car l)) name)
|
||||
(handler-handler (car l))]
|
||||
[else (loop (cdr l))]))))
|
||||
|
||||
(define find-named-format-handler
|
||||
(lambda (name)
|
||||
(find-named-handler name format-handlers)))
|
||||
|
||||
; Finding format & mode handlers by name
|
||||
(define find-named-handler
|
||||
(lambda (name handlers)
|
||||
(let loop ([l handlers])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(string-ci=? (handler-name (car l)) name)
|
||||
(handler-handler (car l))]
|
||||
[else (loop (cdr l))]))))
|
||||
|
||||
(define find-named-format-handler
|
||||
(lambda (name)
|
||||
(find-named-handler name format-handlers)))
|
||||
(define edit-file-consult-group (make-parameter #t))
|
||||
|
||||
(define edit-file-consult-group (make-parameter #t))
|
||||
; Open a file for editing
|
||||
(define edit-file
|
||||
(opt-lambda (filename
|
||||
[make-default
|
||||
(lambda (filename)
|
||||
(make-object frame:info-file-frame% filename))]
|
||||
[consult-group? (edit-file-consult-group)])
|
||||
(gui-utils:show-busy-cursor
|
||||
(lambda ()
|
||||
(if filename
|
||||
(let ([already-open (and consult-group?
|
||||
(send group:the-frame-group
|
||||
locate-file
|
||||
filename))])
|
||||
(if already-open
|
||||
(begin
|
||||
(send already-open show #t)
|
||||
already-open)
|
||||
(let ([handler
|
||||
(if (string? filename)
|
||||
(find-format-handler filename)
|
||||
#f)])
|
||||
(if handler
|
||||
(handler filename)
|
||||
(make-default filename)))))
|
||||
(make-default filename))))))
|
||||
|
||||
; Query the user for a file and then edit it
|
||||
|
||||
; Open a file for editing
|
||||
(define edit-file
|
||||
(opt-lambda (filename
|
||||
[make-default
|
||||
(lambda (filename)
|
||||
(make-object mred:editor-frame:editor-frame%
|
||||
filename #t))]
|
||||
[consult-group? (edit-file-consult-group)])
|
||||
(gui-utils:show-busy-cursor
|
||||
(lambda ()
|
||||
(if filename
|
||||
(let ([already-open (and consult-group?
|
||||
(send mred:group:the-frame-group
|
||||
locate-file
|
||||
filename))])
|
||||
(if already-open
|
||||
(begin
|
||||
(send already-open show #t)
|
||||
already-open)
|
||||
(let ([handler
|
||||
(if (string? filename)
|
||||
(find-format-handler filename)
|
||||
#f)])
|
||||
(if handler
|
||||
(handler filename)
|
||||
(make-default filename)))))
|
||||
(make-default filename))))))
|
||||
|
||||
(define get-url-from-user
|
||||
(lambda ()
|
||||
(let* ([frame (make-object dialog-box% (get-top-level-focus-window) "Choose URL")]
|
||||
[main (make-object vertical-panel% frame)]
|
||||
[one-line (make-object editor-canvas% main)]
|
||||
[_ (send one-line set-line-count 1)]
|
||||
[valid? #f]
|
||||
[ok-callback (lambda x (set! valid? #t) (send frame show #f))]
|
||||
[answer (make-object edit:return% ok-callback)]
|
||||
[bottom (make-object horizontal-panel% main)]
|
||||
[space (make-object horizontal-panel% bottom)]
|
||||
[bookmarks (preferences:get 'framework:bookmarks)]
|
||||
[bk-choice
|
||||
(make-object choice% bottom
|
||||
(lambda (box evt)
|
||||
(let ([which (send evt get-command-int)])
|
||||
(when (<= 0 which)
|
||||
(send* answer
|
||||
(begin-edit-sequence)
|
||||
(erase)
|
||||
(insert (list-ref bookmarks which))
|
||||
(end-edit-sequence)))))
|
||||
"Bookmarks" -1 -1 -1 -1 bookmarks)]
|
||||
[browse (make-object button%
|
||||
bottom
|
||||
(lambda x
|
||||
(let ([ans (finder:get-file)])
|
||||
(when ans
|
||||
(send* answer
|
||||
(begin-edit-sequence)
|
||||
(erase)
|
||||
(insert "file:")
|
||||
(insert ans)
|
||||
(end-edit-sequence)))))
|
||||
"Browse...")]
|
||||
[cancel (make-object button% bottom
|
||||
(lambda x
|
||||
(send frame show #f))
|
||||
"Cancel")]
|
||||
[ok (make-object button% bottom
|
||||
ok-callback
|
||||
"Ok")])
|
||||
(let ([w (max (send ok get-width)
|
||||
(send cancel get-width)
|
||||
(send browse get-width))])
|
||||
(send ok user-min-width w)
|
||||
(send cancel user-min-width w)
|
||||
(send browse user-min-width w))
|
||||
(unless (null? bookmarks)
|
||||
(send answer insert (car bookmarks))
|
||||
(send answer set-position 0 -1))
|
||||
(send one-line set-focus)
|
||||
(send one-line set-media answer)
|
||||
(send frame set-size -1 -1 20 20)
|
||||
(send frame center 'both)
|
||||
(send frame show #t)
|
||||
(and valid?
|
||||
(send answer get-text)))))
|
||||
(define *open-directory* ; object to remember last directory
|
||||
(make-object
|
||||
(class null ()
|
||||
(private
|
||||
[the-dir #f])
|
||||
(public
|
||||
[get (lambda () the-dir)]
|
||||
[set-from-file!
|
||||
(lambda (file)
|
||||
(set! the-dir (mzlib:file:path-only file)))]
|
||||
[set-to-default
|
||||
(lambda ()
|
||||
(set! the-dir (current-directory)))])
|
||||
(sequence
|
||||
(set-to-default)))))
|
||||
|
||||
(define open-url
|
||||
(opt-lambda ([input-url #f])
|
||||
(let ([url (or input-url (get-url-from-user))])
|
||||
(and url
|
||||
(make-object hyper:frame:hyper-view-frame% url)))))
|
||||
|
||||
; Query the user for a file and then edit it
|
||||
|
||||
(define *open-directory* ; object to remember last directory
|
||||
(make-object
|
||||
(class null ()
|
||||
(private
|
||||
[the-dir #f])
|
||||
(public
|
||||
[get (lambda () the-dir)]
|
||||
[set-from-file!
|
||||
(lambda (file)
|
||||
(set! the-dir (mzlib:file:path-only file)))]
|
||||
[set-to-default
|
||||
(lambda ()
|
||||
(set! the-dir (current-directory)))])
|
||||
(sequence
|
||||
(set-to-default)))))
|
||||
|
||||
(define open-file
|
||||
(lambda ()
|
||||
(let ([file
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-focus-window)])
|
||||
(finder:get-file
|
||||
(send *open-directory* get)))])
|
||||
(when file
|
||||
(send *open-directory*
|
||||
set-from-file! file))
|
||||
(and file
|
||||
(edit-file file))))))
|
||||
(define open-file
|
||||
(lambda ()
|
||||
(let ([file
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-focus-window)])
|
||||
(finder:get-file
|
||||
(send *open-directory* get)))])
|
||||
(when file
|
||||
(send *open-directory*
|
||||
set-from-file! file))
|
||||
(and file
|
||||
(edit-file file))))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(unit/sig framework:keymap^
|
||||
(import [preferences : framework:preferences^]
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[finder : framework:finder^]
|
||||
[handler : framework:handler^]
|
||||
[scheme-paren : framework:scheme-paren^])
|
||||
|
|
@ -37,101 +38,7 @@
|
|||
(send keymap map-function key func))
|
||||
(make-meta-prefix-list key))))
|
||||
|
||||
(define setup-global-search-keymap
|
||||
(let* ([send-frame
|
||||
(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])]))])
|
||||
(if frame
|
||||
((ivar/proc frame method))
|
||||
(bell))
|
||||
#t)))])
|
||||
(lambda (kmap)
|
||||
(let* ([map (lambda (key func)
|
||||
(send kmap map-function key func))]
|
||||
[map-meta (lambda (key func)
|
||||
(send-map-function-meta kmap key func))]
|
||||
[add (lambda (name func)
|
||||
(send kmap add-key-function name func))]
|
||||
[add-m (lambda (name func)
|
||||
(send kmap add-mouse-function name func))])
|
||||
|
||||
(add "move-to-search-or-search" (send-frame 'move-to-search-or-search)) ;; key 1
|
||||
(add "move-to-search-or-reverse-search" (send-frame 'move-to-search-or-reverse-search)) ;; key 1b, backwards
|
||||
(add "find-string" (send-frame 'search)) ;; key 2
|
||||
(add "toggle-search-focus" (send-frame 'toggle-search-focus)) ;; key 3
|
||||
(add "hide-search" (send-frame 'hide-search)) ;; key 4
|
||||
|
||||
(case (system-type)
|
||||
[(unix)
|
||||
(map "c:s" "move-to-search-or-search")
|
||||
(map-meta "%" "move-to-search-or-search")
|
||||
(map "c:r" "move-to-search-or-reverse-search")
|
||||
(map "f3" "find-string")
|
||||
(map "c:i" "toggle-search-focus")
|
||||
(map "c:g" "hide-search")]
|
||||
[(windows)
|
||||
(map "c:f" "move-to-search-or-search")
|
||||
(map "c:r" "move-to-search-or-reverse-search")
|
||||
(map "f3" "find-string")
|
||||
(map "c:g" "find-string")
|
||||
(map "c:i" "toggle-search-focus")]
|
||||
[(macos)
|
||||
(map "c:s" "move-to-search-or-search")
|
||||
(map "c:g" "hide-search")
|
||||
(map "d:f" "move-to-search-or-search")
|
||||
(map "d:r" "move-to-search-or-reverse-search")
|
||||
(map "d:g" "find-string")
|
||||
(map "d:o" "toggle-search-focus")])))))
|
||||
|
||||
(define setup-global-file-keymap
|
||||
(let* ([save-file-as
|
||||
(lambda (edit event)
|
||||
(let ([file (finder:put-file)])
|
||||
(if file
|
||||
(send edit save-file file)))
|
||||
#t)]
|
||||
[save-file
|
||||
(lambda (edit event)
|
||||
(if (send edit get-filename)
|
||||
(send edit save-file)
|
||||
(save-file-as edit event))
|
||||
#t)]
|
||||
[load-file
|
||||
(lambda (edit event)
|
||||
(handler:open-file)
|
||||
#t)])
|
||||
(lambda (kmap)
|
||||
(map (lambda (k) (send kmap implies-shift k)) shifted-key-list)
|
||||
(let* ([map (lambda (key func)
|
||||
(send kmap map-function key func))]
|
||||
[map-meta (lambda (key func)
|
||||
(send-map-function-meta kmap key func))]
|
||||
[add (lambda (name func)
|
||||
(send kmap add-key-function name func))]
|
||||
[add-m (lambda (name func)
|
||||
(send kmap add-mouse-function name func))])
|
||||
|
||||
(add "save-file" save-file)
|
||||
(add "save-file-as" save-file-as)
|
||||
(add "load-file" load-file)
|
||||
|
||||
(map "c:x;c:s" "save-file")
|
||||
(map "d:s" "save-file")
|
||||
(map "c:x;c:w" "save-file-as")
|
||||
(map "c:x;c:f" "load-file")))))
|
||||
|
||||
; This installs the standard keyboard mapping
|
||||
(define setup-global-keymap
|
||||
(define setup-global
|
||||
; Define some useful keyboard functions
|
||||
(let* ([ring-bell
|
||||
(lambda (edit event)
|
||||
|
|
@ -860,11 +767,104 @@
|
|||
(map "middlebutton" "paste-click-region")
|
||||
(map "c:rightbutton" "copy-clipboard")))))
|
||||
|
||||
(define global-keymap (make-object keymap%))
|
||||
(setup-global-keymap global-keymap)
|
||||
(define setup-search
|
||||
(let* ([send-frame
|
||||
(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])]))])
|
||||
(if frame
|
||||
((ivar/proc frame method))
|
||||
(bell))
|
||||
#t)))])
|
||||
(lambda (kmap)
|
||||
(let* ([map (lambda (key func)
|
||||
(send kmap map-function key func))]
|
||||
[map-meta (lambda (key func)
|
||||
(send-map-function-meta kmap key func))]
|
||||
[add (lambda (name func)
|
||||
(send kmap add-key-function name func))]
|
||||
[add-m (lambda (name func)
|
||||
(send kmap add-mouse-function name func))])
|
||||
|
||||
(add "move-to-search-or-search" (send-frame 'move-to-search-or-search)) ;; key 1
|
||||
(add "move-to-search-or-reverse-search" (send-frame 'move-to-search-or-reverse-search)) ;; key 1b, backwards
|
||||
(add "find-string" (send-frame 'search)) ;; key 2
|
||||
(add "toggle-search-focus" (send-frame 'toggle-search-focus)) ;; key 3
|
||||
(add "hide-search" (send-frame 'hide-search)) ;; key 4
|
||||
|
||||
(case (system-type)
|
||||
[(unix)
|
||||
(map "c:s" "move-to-search-or-search")
|
||||
(map-meta "%" "move-to-search-or-search")
|
||||
(map "c:r" "move-to-search-or-reverse-search")
|
||||
(map "f3" "find-string")
|
||||
(map "c:i" "toggle-search-focus")
|
||||
(map "c:g" "hide-search")]
|
||||
[(windows)
|
||||
(map "c:f" "move-to-search-or-search")
|
||||
(map "c:r" "move-to-search-or-reverse-search")
|
||||
(map "f3" "find-string")
|
||||
(map "c:g" "find-string")
|
||||
(map "c:i" "toggle-search-focus")]
|
||||
[(macos)
|
||||
(map "c:s" "move-to-search-or-search")
|
||||
(map "c:g" "hide-search")
|
||||
(map "d:f" "move-to-search-or-search")
|
||||
(map "d:r" "move-to-search-or-reverse-search")
|
||||
(map "d:g" "find-string")
|
||||
(map "d:o" "toggle-search-focus")])))))
|
||||
|
||||
(define global-file-keymap (make-object keymap%))
|
||||
(setup-global-file-keymap global-file-keymap)
|
||||
(define setup-file
|
||||
(let* ([save-file-as
|
||||
(lambda (edit event)
|
||||
(let ([file (finder:put-file)])
|
||||
(if file
|
||||
(send edit save-file file)))
|
||||
#t)]
|
||||
[save-file
|
||||
(lambda (edit event)
|
||||
(if (send edit get-filename)
|
||||
(send edit save-file)
|
||||
(save-file-as edit event))
|
||||
#t)]
|
||||
[load-file
|
||||
(lambda (edit event)
|
||||
(handler:open-file)
|
||||
#t)])
|
||||
(lambda (kmap)
|
||||
(map (lambda (k) (send kmap implies-shift k)) shifted-key-list)
|
||||
(let* ([map (lambda (key func)
|
||||
(send kmap map-function key func))]
|
||||
[map-meta (lambda (key func)
|
||||
(send-map-function-meta kmap key func))]
|
||||
[add (lambda (name func)
|
||||
(send kmap add-key-function name func))]
|
||||
[add-m (lambda (name func)
|
||||
(send kmap add-mouse-function name func))])
|
||||
|
||||
(add "save-file" save-file)
|
||||
(add "save-file-as" save-file-as)
|
||||
(add "load-file" load-file)
|
||||
|
||||
(map "c:x;c:s" "save-file")
|
||||
(map "d:s" "save-file")
|
||||
(map "c:x;c:w" "save-file-as")
|
||||
(map "c:x;c:f" "load-file")))))
|
||||
|
||||
(define global-search-keymap (make-object keymap%))
|
||||
(setup-global-search-keymap global-search-keymap))
|
||||
(define global (make-object keymap%))
|
||||
(setup-global global)
|
||||
|
||||
(define file (make-object keymap%))
|
||||
(setup-file file)
|
||||
|
||||
(define search (make-object keymap%))
|
||||
(setup-search search))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,9 @@
|
|||
|
||||
;; preferences
|
||||
|
||||
(mred:preferences:set-preference-default 'mred:verify-change-format #f boolean?)
|
||||
|
||||
(mred:preferences:set-preference-default 'mred:auto-set-wrap? #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
||||
|
||||
|
|
@ -18,8 +21,8 @@
|
|||
|
||||
|
||||
(preferences:set 'framework:print-output-mode
|
||||
0
|
||||
(lambda (x) (or (= x 0) (= x 1))))
|
||||
'standard
|
||||
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(unit/sig framework:preferences^
|
||||
(import [exn : framework:exn^]
|
||||
(import mred^
|
||||
[exn : framework:exn^]
|
||||
[exit : framework:exit^]
|
||||
[mzlib:pretty-print : mzlib:pretty-print^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
|
||||
(require-library "refer.ss")
|
||||
(require-library "cores.ss")
|
||||
(require-library "match.ss")
|
||||
|
|
@ -9,7 +10,7 @@
|
|||
(empty<%>
|
||||
standard-menus<%>
|
||||
empty-standard-menus<%>
|
||||
edit<%>
|
||||
editor<%>
|
||||
searchable<%>
|
||||
pasteboard<%>
|
||||
info<%>
|
||||
|
|
@ -17,14 +18,14 @@
|
|||
|
||||
make-empty%
|
||||
make-standard-menus%
|
||||
make-edit%
|
||||
make-editor%
|
||||
make-searchable%
|
||||
make-info%
|
||||
make-file%
|
||||
|
||||
empty%
|
||||
standard-menus%
|
||||
edit%
|
||||
editor%
|
||||
searchable%
|
||||
info%
|
||||
info-file%
|
||||
|
|
@ -36,7 +37,7 @@
|
|||
(add-spec
|
||||
version))
|
||||
|
||||
(define-signature mred:panel^
|
||||
(define-signature framework:panel^
|
||||
(make-edit%
|
||||
edit<%>
|
||||
horizontal-edit%
|
||||
|
|
@ -44,9 +45,8 @@
|
|||
|
||||
(define-signature framework:exn^
|
||||
((struct exn ())
|
||||
(struct exn:unknown-preference ())
|
||||
(struct exn:during-preferences ())
|
||||
(struct exn:url ())))
|
||||
(struct unknown-preference ())
|
||||
(struct during-preferences ())))
|
||||
|
||||
(define-signature framework:application^
|
||||
(current-app-name))
|
||||
|
|
@ -82,6 +82,7 @@
|
|||
local-busy-cursor
|
||||
unsaved-warning
|
||||
read-snips/chars-from-buffer
|
||||
get-choice
|
||||
open-input-buffer))
|
||||
|
||||
(define-signature framework:path-utils^
|
||||
|
|
@ -100,7 +101,7 @@
|
|||
get-file
|
||||
put-file))
|
||||
|
||||
(define framework:editor^
|
||||
(define-signature framework:editor^
|
||||
(editor:basic<%>
|
||||
editor:info<%>
|
||||
editor:autosave<%>
|
||||
|
|
@ -110,6 +111,13 @@
|
|||
editor:make-file%
|
||||
editor:make-backup-autosave%))
|
||||
|
||||
(define-signature framework:pasteboard^
|
||||
(basic%
|
||||
file%
|
||||
clever-file-format%
|
||||
backup-autosave%
|
||||
info%))
|
||||
|
||||
(define-signature framework:text^
|
||||
(text:basic<%>
|
||||
text:searching<%>
|
||||
|
|
@ -196,7 +204,7 @@
|
|||
pasteboard-info%
|
||||
pasteboard-info-file%))
|
||||
|
||||
(define-signature mred:group^
|
||||
(define-signature framework:group^
|
||||
(frame-group%
|
||||
the-frame-group))
|
||||
|
||||
|
|
@ -207,7 +215,6 @@
|
|||
find-format-handler
|
||||
find-named-format-handler
|
||||
edit-file
|
||||
open-url
|
||||
open-file))
|
||||
|
||||
(define-signature framework:icon^
|
||||
|
|
@ -229,21 +236,22 @@
|
|||
get-gc-width
|
||||
get-gc-height))
|
||||
|
||||
(define-signature mred:keymap^
|
||||
(keyerr
|
||||
(define-signature framework:keymap^
|
||||
(shifted-key-list
|
||||
|
||||
keyerr
|
||||
set-keymap-error-handler
|
||||
shifted-key-list
|
||||
set-keymap-implied-shifts
|
||||
make-meta-prefix-list
|
||||
send-map-function-meta
|
||||
|
||||
setup-global-keymap
|
||||
setup-global-search-keymap
|
||||
setup-global-file-keymap
|
||||
setup-global
|
||||
setup-search
|
||||
setup-file
|
||||
|
||||
global-keymap
|
||||
global-search-keymap
|
||||
global-file-keymap))
|
||||
global
|
||||
search
|
||||
file))
|
||||
|
||||
(define-signature framework:match-cache^
|
||||
(%))
|
||||
|
|
@ -286,52 +294,34 @@
|
|||
backward-match
|
||||
skip-whitespace))
|
||||
|
||||
|
||||
(define-signature mred:hyper-edit^
|
||||
((struct hypertag (name position))
|
||||
(struct hyperlink (anchor-start anchor-end url-string))
|
||||
hyper-buffer-data%
|
||||
hyper-data-class
|
||||
make-hyper-edit%
|
||||
hyper-edit%))
|
||||
|
||||
(define-signature mred:hyper-dialog^
|
||||
(hyper-tag-dialog%
|
||||
hyper-get-current-tags))
|
||||
|
||||
(define-signature mred:hyper-frame^
|
||||
(hyper-frame-group
|
||||
make-hyper-canvas%
|
||||
hyper-canvas%
|
||||
make-hyper-basic-frame%
|
||||
hyper-basic-frame%
|
||||
make-hyper-view-frame%
|
||||
hyper-view-frame%
|
||||
make-hyper-make-frame%
|
||||
hyper-make-frame%
|
||||
open-hyper-view
|
||||
open-hyper-make
|
||||
hyper-text-require))
|
||||
|
||||
(define-signature mred^
|
||||
((unit constants : mred:constants^)
|
||||
(open mred:version^)
|
||||
(open mred:exn-external^)
|
||||
(open mred:connections^) (open mred:container^) (open mred:preferences^)
|
||||
(open mred:autoload^) (open mred:autosave^) (open mred:exit^)
|
||||
(open mred:gui-utils^) (open mred:console^) (open mred:path-utils^)
|
||||
(open mred:finder^)
|
||||
(open mred:find-string^) (open mred:edit^) (open mred:canvas^)
|
||||
(open mred:frame^) (open mred:editor-frame^)
|
||||
(open mred:group^) (open mred:handler^) (open mred:icon^) (open mred:keymap^)
|
||||
(open mred:match-cache^) (open mred:menu^) (open mred:mode^)
|
||||
(open mred:panel^) (open mred:paren^) (open mred:project^)
|
||||
(open mred:scheme-paren^) (open mred:scheme-mode^)
|
||||
(open mred:hyper-edit^) (open mred:hyper-dialog^) (open mred:hyper-frame^)
|
||||
(open mred:testable-window^)
|
||||
(unit test : mred:self-test-export^)
|
||||
(open mred:url^)
|
||||
(open mred:graph^)
|
||||
(open mred:application^)
|
||||
(open mred:control^)))
|
||||
([unit application : framework:application^]
|
||||
[unit version : framework:version^]
|
||||
[unit exn : framework:exn^]
|
||||
[unit exit : framework:exit^]
|
||||
[unit preferences : framework:preferences^]
|
||||
[unit autosave : framework:autosave^]
|
||||
[unit handler : framework:handler^]
|
||||
[unit keymap : framework:keymap^]
|
||||
[unit match-cache : framework:match-cache^]
|
||||
[unit paren : framework:paren^]
|
||||
[unit scheme-paren : framework:scheme-paren^]
|
||||
[unit path-utils : framework:path-utils^]
|
||||
[unit icon : framework:icon^]
|
||||
|
||||
[unit editor : framework:editor^]
|
||||
[unit pasteboard : framework:pasteboard^]
|
||||
[unit text : framework:text^]
|
||||
|
||||
[unit gui-utils : framework:gui-utils^]
|
||||
|
||||
[unit finder : framework:finder^]
|
||||
|
||||
[unit group : framework:group^]
|
||||
|
||||
[unit canvas : framework:canvas^]
|
||||
|
||||
[unit panel : framework:panel^]
|
||||
|
||||
[unit frame : framework:frame^]
|
||||
[unit scheme-mode : framework:scheme-mode^]))
|
||||
|
|
@ -1,15 +1,14 @@
|
|||
(unit/sig mred:version^
|
||||
(import [mzlib:string^ : mzlib:string^])
|
||||
(unit/sig framework:version^
|
||||
(import [mzlib:string : mzlib:string^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(rename [-version version])
|
||||
|
||||
(mred:debug:printf 'invoke "mred:version@")
|
||||
|
||||
(define specs null)
|
||||
|
||||
(define -version
|
||||
(lambda ()
|
||||
(mzlib:functionfoldr
|
||||
(mzlib:function:foldr
|
||||
(lambda (entry sofar)
|
||||
(match entry
|
||||
[(sep num) (string-append sofar sep num)]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user