Initial revision
original commit: 6155845eea0c0f1310ce4f106f0f51200cc06b57
This commit is contained in:
Robby Findler
parent
5c82f510da
commit
0cdcedd1e5
230
collects/mred/edit.ss
Normal file
230
collects/mred/edit.ss
Normal file
|
|
@ -0,0 +1,230 @@
|
|||
(define-sigfunctor (mred:edit@ mred:edit^)
|
||||
(import mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^
|
||||
mred:keymap^ mzlib:function^)
|
||||
|
||||
(define make-std-buffer%
|
||||
(lambda (buffer%)
|
||||
(class buffer% args
|
||||
(inherit modified? get-filename save-file set-max-width)
|
||||
(rename
|
||||
[super-set-filename set-filename]
|
||||
[super-set-modified set-modified]
|
||||
[super-on-change on-change]
|
||||
[super-on-save-file on-save-file])
|
||||
(private
|
||||
[auto-saved-name #f]
|
||||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f])
|
||||
(public
|
||||
[get-file (lambda (d) (let ([v (mred:finder^:get-file d)])
|
||||
(if v
|
||||
v
|
||||
'())))]
|
||||
[put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)])
|
||||
(if v
|
||||
v
|
||||
'())))]
|
||||
|
||||
[auto-set-wrap? #f]
|
||||
[set-auto-set-wrap
|
||||
(lambda (v)
|
||||
(set! auto-set-wrap? v)
|
||||
(if (not v)
|
||||
(set-max-width -1)))]
|
||||
|
||||
[active-canvas #f]
|
||||
[set-active-canvas
|
||||
(lambda (c)
|
||||
(set! active-canvas c))]
|
||||
|
||||
[canvases '()]
|
||||
[add-canvas
|
||||
(lambda (canvas)
|
||||
(set! canvases (cons canvas canvases)))]
|
||||
[remove-canvas
|
||||
(lambda (canvas)
|
||||
(set! canvases (mzlib:function^:remove canvas canvases)))]
|
||||
|
||||
[mode #f]
|
||||
[set-mode
|
||||
(lambda (m)
|
||||
#f)]
|
||||
|
||||
[set-modified
|
||||
(lambda (modified?)
|
||||
(if auto-saved-name
|
||||
(if (not modified?)
|
||||
(begin
|
||||
(delete-file auto-saved-name)
|
||||
(set! auto-saved-name #f))
|
||||
(set! auto-save-out-of-date? #t)))
|
||||
(super-set-modified modified?)
|
||||
(for-each (lambda (canvas) (send canvas edit-modified modified?))
|
||||
canvases))]
|
||||
[set-filename
|
||||
(opt-lambda (name [temp? #f])
|
||||
(super-set-filename name temp?)
|
||||
(for-each (lambda (canvas) (send canvas edit-renamed name))
|
||||
canvases))]
|
||||
|
||||
[on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
(set! auto-save-out-of-date? #t))]
|
||||
[auto-save? #t]
|
||||
[do-autosave
|
||||
(lambda ()
|
||||
(when (and auto-save?
|
||||
(not auto-save-error?)
|
||||
(modified?)
|
||||
(or (not auto-saved-name)
|
||||
auto-save-out-of-date?))
|
||||
(let* ([orig-name (get-filename)]
|
||||
[auto-name (mred:path-utils^:generate-autosave-name orig-name)]
|
||||
[success (save-file auto-name wx:const-media-ff-copy)])
|
||||
(if success
|
||||
(begin
|
||||
(if auto-saved-name
|
||||
(delete-file auto-saved-name))
|
||||
(set! auto-saved-name auto-name)
|
||||
(set! auto-save-out-of-date? #f))
|
||||
(begin
|
||||
(wx:message-box
|
||||
(format "Error autosaving ~s.~n~a~n~a"
|
||||
(if (null? orig-name) "Untitled" orig-name)
|
||||
"Autosaving is turned off"
|
||||
"until the file is saved.")
|
||||
"Warning")
|
||||
(set! auto-save-error? #t))))))]
|
||||
[remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
(delete-file auto-saved-name)
|
||||
(set! auto-saved-name #f)))]
|
||||
|
||||
[backup? #t]
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
(set! auto-save-error? #f)
|
||||
(if (super-on-save-file name format)
|
||||
(begin
|
||||
(if (and backup?
|
||||
(not (= format wx:const-media-ff-copy)))
|
||||
(if (file-exists? name)
|
||||
(let ([back-name (mred:path-utils^:generate-backup-name name)])
|
||||
(unless (file-exists? back-name)
|
||||
(rename-file name back-name)))))
|
||||
#t)
|
||||
#f))]
|
||||
|
||||
[get-canvas
|
||||
(lambda ()
|
||||
(cond
|
||||
[(and active-canvas
|
||||
(member active-canvas canvases))
|
||||
active-canvas]
|
||||
[(null? canvases) #f]
|
||||
[else (car canvases)]))]
|
||||
[get-frame
|
||||
(lambda ()
|
||||
(let ([c (get-canvas)])
|
||||
(if c
|
||||
(let ([f (send c get-parent)])
|
||||
(if (null? f)
|
||||
#f
|
||||
f))
|
||||
#f)))])
|
||||
(sequence
|
||||
(apply super-init args)))))
|
||||
|
||||
(define edits%
|
||||
(class-asi wx:snip%
|
||||
(private
|
||||
[edits null])
|
||||
(public
|
||||
[add
|
||||
(lambda (edit)
|
||||
(unless (let loop ([e edits])
|
||||
(cond
|
||||
[(null? e) #f]
|
||||
[else (if (eq? this (car e))
|
||||
#t
|
||||
(loop (cdr e)))]))
|
||||
(set! edits (cons edit edits))))])))
|
||||
|
||||
(define edits (make-object edits%))
|
||||
|
||||
(define make-edit%
|
||||
(lambda (super%)
|
||||
(class (make-std-buffer% super%) args
|
||||
(inherit mode canvases
|
||||
flash-on get-keymap get-start-position
|
||||
on-default-char on-default-event
|
||||
set-file-format get-style-list)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-on-local-event on-local-event]
|
||||
[super-on-local-char on-local-char]
|
||||
[super-on-insert on-insert]
|
||||
[super-on-delete on-delete]
|
||||
[super-after-insert after-insert]
|
||||
[super-after-delete after-delete])
|
||||
(public
|
||||
[set-mode
|
||||
(lambda (m)
|
||||
(if mode
|
||||
(send mode deinstall this))
|
||||
(if (is-a? m mred:mode^:mode%)
|
||||
(begin
|
||||
(set! mode m)
|
||||
(set-file-format (ivar m file-format))
|
||||
(send (send (get-style-list)
|
||||
find-named-style "Standard")
|
||||
set-delta (ivar m standard-style-delta))
|
||||
(send m install this))
|
||||
(begin
|
||||
(set! mode #f)
|
||||
(send (send (get-style-list)
|
||||
find-named-style "Standard")
|
||||
set-delta (make-object wx:style-delta%)))))]
|
||||
[on-focus
|
||||
(lambda (on?)
|
||||
(super-on-focus on?)
|
||||
(when mode
|
||||
(send mode on-focus this on?)))]
|
||||
[on-local-event
|
||||
(lambda (mouse)
|
||||
(if (or (not mode)
|
||||
(not (send mode on-event this mouse)))
|
||||
(super-on-local-event mouse)))]
|
||||
[on-insert
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-insert this start len))
|
||||
(super-on-insert start len)))]
|
||||
[on-delete
|
||||
(lambda (start len)
|
||||
(if (or (not mode) (send mode on-delete this start len))
|
||||
(super-on-delete start len)))]
|
||||
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(if mode (send mode after-insert this start len))
|
||||
(super-after-insert start len))]
|
||||
[after-delete
|
||||
(lambda (start len)
|
||||
(if mode (send mode after-delete this start len))
|
||||
(super-after-delete start len))])
|
||||
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(send edits add this)
|
||||
(let ([keymap (get-keymap)])
|
||||
(mred:keymap^:set-keymap-error-handler keymap)
|
||||
(mred:keymap^:set-keymap-implied-shifts keymap)
|
||||
(send keymap chain-to-keymap mred:keymap^:global-keymap #f))))))
|
||||
|
||||
(define edit% (make-edit% wx:media-edit%))
|
||||
|
||||
(define make-pasteboard% make-std-buffer%)
|
||||
(define pasteboard% (make-pasteboard% wx:media-pasteboard%)))
|
||||
|
||||
|
||||
36
collects/mred/exit.ss
Normal file
36
collects/mred/exit.ss
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
;; [Robby]
|
||||
;; exit doesn't actually exit, now.
|
||||
|
||||
(define-sigfunctor (mred:exit@ mred:exit^)
|
||||
(import)
|
||||
(rename (-exit exit))
|
||||
|
||||
(define exit-callbacks '())
|
||||
|
||||
(define insert-exit-callback
|
||||
(lambda (f)
|
||||
(set! exit-callbacks (cons f exit-callbacks))
|
||||
f))
|
||||
|
||||
(define remove-exit-callback
|
||||
(lambda (cb)
|
||||
(set! exit-callbacks
|
||||
(let loop ([cb-list exit-callbacks])
|
||||
(cond
|
||||
[(null? cb-list) ()]
|
||||
[(eq? cb (car cb-list)) (cdr cb-list)]
|
||||
[else (cons (car cb-list) (loop (cdr cb-list)))])))))
|
||||
|
||||
(define -exit
|
||||
(lambda ()
|
||||
(set! exit-callbacks
|
||||
(let loop ([cb-list exit-callbacks])
|
||||
(cond
|
||||
[(null? cb-list) ()]
|
||||
[(not ((car cb-list))) cb-list]
|
||||
[else (loop (cdr cb-list))])))
|
||||
(if (null? exit-callbacks)
|
||||
(begin (exit)
|
||||
#t)
|
||||
#f))))
|
||||
|
||||
432
collects/mred/finder.ss
Normal file
432
collects/mred/finder.ss
Normal file
|
|
@ -0,0 +1,432 @@
|
|||
(define-sigfunctor (mred:finder@ mred:finder^)
|
||||
(import mzlib:string^ mzlib:function^ mzlib:file^)
|
||||
|
||||
(define filter-match?
|
||||
(lambda (filter name msg)
|
||||
(let-values ([(base name dir?) (split-path name)])
|
||||
(if (mzlib:string^:regexp-match-exact? filter name)
|
||||
#t
|
||||
(begin
|
||||
(wx:message-box msg "Error")
|
||||
#f)))))
|
||||
|
||||
(define last-directory #f)
|
||||
|
||||
(define make-relative
|
||||
(lambda (s) s))
|
||||
|
||||
(define current-find-file-directory
|
||||
(opt-lambda ([dir 'get])
|
||||
(cond
|
||||
[(eq? dir 'get)
|
||||
(if (not last-directory)
|
||||
(set! last-directory (current-directory)))
|
||||
last-directory]
|
||||
[(and (string? dir)
|
||||
(directory-exists? dir))
|
||||
(set! last-directory dir)
|
||||
#t]
|
||||
[else #f])))
|
||||
|
||||
(define finder-dialog%
|
||||
(class wx:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||
result-box start-dir
|
||||
start-name prompt
|
||||
file-filter file-filter-msg)
|
||||
(inherit
|
||||
new-line tab fit center
|
||||
show
|
||||
popup-menu)
|
||||
|
||||
(private
|
||||
[WIDTH 500]
|
||||
[HEIGHT 500]
|
||||
|
||||
dirs current-dir
|
||||
last-selected
|
||||
|
||||
[select-counter 0])
|
||||
|
||||
(private
|
||||
[set-directory
|
||||
(lambda (dir) ; dir is normalied
|
||||
(set! current-dir dir)
|
||||
(set! last-directory dir)
|
||||
(let-values
|
||||
([(dir-list menu-list)
|
||||
(let loop ([this-dir dir]
|
||||
[dir-list ()]
|
||||
[menu-list ()])
|
||||
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
|
||||
(if (eq? wx:platform 'windows)
|
||||
(mzlib:string^:string-lowercase! in-dir))
|
||||
(let* ([dir-list (cons this-dir dir-list)]
|
||||
[menu-list (cons in-dir menu-list)])
|
||||
(if base-dir
|
||||
(loop base-dir dir-list menu-list)
|
||||
; No more
|
||||
(values dir-list menu-list)))))])
|
||||
(set! dirs dir-list)
|
||||
|
||||
(send dir-choice clear)
|
||||
(let loop ([choices menu-list])
|
||||
(unless (null? choices)
|
||||
(send dir-choice append (car choices))
|
||||
(loop (cdr choices))))
|
||||
(send dir-choice set-selection (sub1 (length dirs)))
|
||||
(send dir-choice set-size -1 -1 -1 -1))
|
||||
|
||||
(send name-list clear)
|
||||
(send name-list set
|
||||
(mzlib:function^:quicksort
|
||||
(let loop ([l (directory-list dir)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([s (car l)]
|
||||
[rest (loop (cdr l))])
|
||||
(if (directory-exists? (build-path dir s))
|
||||
(cons
|
||||
(string-append s
|
||||
(case wx:platform
|
||||
(unix "/")
|
||||
(windows "\\")
|
||||
(macintosh ":")))
|
||||
rest)
|
||||
(if (or (not file-filter)
|
||||
(mzlib:string^:regexp-match-exact? file-filter s))
|
||||
(cons s rest)
|
||||
rest)))))
|
||||
(if (eq? wx:platform 'unix) string<? string-ci<?)))
|
||||
(set! last-selected -1))])
|
||||
|
||||
(public
|
||||
[do-dir
|
||||
(lambda (choice event)
|
||||
(let ([which (send event get-selection)])
|
||||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
[do-goto
|
||||
(opt-lambda (button event [default ""])
|
||||
(let ([orig-dir (wx:get-text-from-user
|
||||
"Directory" "Go to Directory"
|
||||
default)])
|
||||
(if (string? orig-dir)
|
||||
(let ([dir (mzlib:file^:normalize-path orig-dir current-dir)])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory dir)
|
||||
(begin
|
||||
(wx:message-box
|
||||
(string-append "Bad directory: " dir)
|
||||
"Error")
|
||||
(do-goto button event orig-dir)))))))]
|
||||
|
||||
[on-default-action
|
||||
(lambda (which)
|
||||
(if (eq? which name-list)
|
||||
(let* ([which (send name-list get-string-selection)]
|
||||
[dir (build-path current-dir
|
||||
(make-relative which))])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory (mzlib:file^:normalize-path dir))
|
||||
(if save-mode?
|
||||
(send name-field set-value which)
|
||||
(if multi-mode?
|
||||
(do-add)
|
||||
(do-ok)))))
|
||||
(if (eq? which name-field)
|
||||
(do-ok))))]
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
[do-name-list
|
||||
(lambda args #f)]
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
||||
[do-into-dir
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? name)
|
||||
(set-directory (mzlib:file^:normalize-path name)))))))]
|
||||
|
||||
[do-ok
|
||||
(lambda args
|
||||
(if multi-mode?
|
||||
(let loop ([n (sub1 select-counter)][result ()])
|
||||
(if (< n 0)
|
||||
(begin
|
||||
(set-box! result-box result)
|
||||
(show #f))
|
||||
(loop (sub1 n)
|
||||
(cons (send result-list get-string n)
|
||||
result))))
|
||||
(let ([name
|
||||
(if save-mode?
|
||||
(send name-field get-value)
|
||||
(send name-list get-string-selection))])
|
||||
(cond
|
||||
[(not (string? name)) 'nothing-selected]
|
||||
[(string=? name "")
|
||||
(wx:message-box "You must specify a file name"
|
||||
"Error")]
|
||||
[(and save-mode?
|
||||
file-filter
|
||||
(not (mzlib:string^:regexp-match-exact? file-filter name)))
|
||||
(wx:message-box file-filter-msg "Error")]
|
||||
[else
|
||||
(let ([file (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? file)
|
||||
(if save-mode?
|
||||
(wx:message-box
|
||||
"That is the name of a directory."
|
||||
"Error")
|
||||
(set-directory (mzlib:file^:normalize-path file)))
|
||||
(if (or (not save-mode?)
|
||||
(not (file-exists? file))
|
||||
replace-ok?
|
||||
(= (wx:message-box
|
||||
(string-append
|
||||
"The file "
|
||||
name
|
||||
" already exists. "
|
||||
"Replace it?")
|
||||
"Warning"
|
||||
wx:const-yes-no)
|
||||
wx:const-yes))
|
||||
(begin
|
||||
(set-box! result-box (mzlib:file^:normalize-path file))
|
||||
(show #f)))))]))))]
|
||||
|
||||
[add-one
|
||||
(lambda (name)
|
||||
(unless (or (directory-exists? name)
|
||||
(> (send result-list find-string name) -1))
|
||||
(set! select-counter (add1 select-counter))
|
||||
(send result-list append (mzlib:file^:normalize-path name))))]
|
||||
[do-add
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)))))]
|
||||
[do-add-all
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(let ([name (send name-list get-string n)])
|
||||
(if (and (string? name)
|
||||
(positive? (string-length name)))
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)
|
||||
(loop (add1 n)))))))]
|
||||
[do-remove
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(if (< n select-counter)
|
||||
(if (send result-list selected? n)
|
||||
(begin
|
||||
(send result-list delete n)
|
||||
(set! select-counter (sub1 select-counter))
|
||||
(loop n))
|
||||
(loop (add1 n))))))]
|
||||
|
||||
[do-cancel
|
||||
(lambda args
|
||||
(set-box! result-box #f)
|
||||
(show #f))]
|
||||
|
||||
[on-close (lambda () #f)])
|
||||
(sequence
|
||||
|
||||
(super-init () (if save-mode? "Put File" "Get File")
|
||||
#t 300 300 WIDTH HEIGHT)
|
||||
|
||||
(make-object wx:message% this prompt)
|
||||
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[dir-choice (make-object wx:choice%
|
||||
this do-dir '() -1 -1 -1 -1
|
||||
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
||||
|
||||
[name-list (begin
|
||||
(new-line)
|
||||
(make-object wx:list-box%
|
||||
this do-name-list
|
||||
() wx:const-single
|
||||
-1 -1
|
||||
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
|
||||
() wx:const-needed-sb))]
|
||||
|
||||
[result-list
|
||||
(if multi-mode?
|
||||
(make-object wx:list-box%
|
||||
this do-result-list
|
||||
()
|
||||
(if (eq? wx:window-system 'motif)
|
||||
wx:const-extended
|
||||
wx:const-multiple)
|
||||
-1 -1
|
||||
(* 1/2 WIDTH) 300
|
||||
() wx:const-needed-sb))])
|
||||
(sequence
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[name-field
|
||||
(if save-mode?
|
||||
(let ([v (make-object wx:text%
|
||||
this do-name
|
||||
"Name: " ""
|
||||
-1 -1
|
||||
400 -1
|
||||
wx:const-process-enter)])
|
||||
(if (string? start-name)
|
||||
(send v set-value start-name))
|
||||
(new-line)
|
||||
v))]
|
||||
[into-dir-button
|
||||
(if save-mode?
|
||||
(make-object wx:button%
|
||||
this do-into-dir "Open Directory"))]
|
||||
[goto-button (make-object wx:button%
|
||||
this do-goto "Go to Directory...")]
|
||||
[add-button (if multi-mode?
|
||||
(make-object wx:button%
|
||||
this do-add
|
||||
"Add"))]
|
||||
[add-all-button (if multi-mode?
|
||||
(make-object wx:button%
|
||||
this do-add-all
|
||||
"Add All"))]
|
||||
[remove-button (if multi-mode?
|
||||
(make-object wx:button%
|
||||
this do-remove
|
||||
"Remove"))])
|
||||
(sequence
|
||||
(if multi-mode?
|
||||
(tab 40)
|
||||
(tab 100)))
|
||||
(private
|
||||
[cancel-button (make-object wx:button%
|
||||
this do-cancel
|
||||
"Cancel")]
|
||||
[ok-button
|
||||
(let ([w (send cancel-button get-width)])
|
||||
(make-object wx:button%
|
||||
this do-ok
|
||||
"OK" -1 -1 w))])
|
||||
(sequence
|
||||
(fit)
|
||||
|
||||
(cond
|
||||
[(and start-dir
|
||||
(not (null? start-dir))
|
||||
(directory-exists? start-dir))
|
||||
(set-directory (mzlib:file^:normalize-path start-dir))]
|
||||
[last-directory (set-directory last-directory)]
|
||||
[else (set-directory (current-directory))])
|
||||
|
||||
(center wx:const-both)
|
||||
|
||||
(show #t))))
|
||||
|
||||
(define common-put-file
|
||||
(opt-lambda ([name ()][directory ()][replace? #f]
|
||||
[prompt "Select File"][filter #f]
|
||||
[filter-msg "That name does not have the right form"])
|
||||
(let* ([directory (if (and (null? directory)
|
||||
(string? name))
|
||||
(mzlib:file^:path-only name)
|
||||
directory)]
|
||||
[name (if (string? name)
|
||||
(mzlib:file^:file-name-from-path name)
|
||||
name)]
|
||||
[v (box #f)])
|
||||
(make-object finder-dialog% #t replace? #f v
|
||||
directory name prompt filter filter-msg)
|
||||
(unbox v))))
|
||||
|
||||
(define common-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(let ([v (box #f)])
|
||||
(make-object finder-dialog% #f #f #f v directory '() prompt
|
||||
filter filter-msg)
|
||||
(unbox v))))
|
||||
|
||||
(define common-get-file-list
|
||||
(opt-lambda ([directory ()][prompt "Select Files"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(let ([v (box ())])
|
||||
(make-object finder-dialog% #f #f #t v directory '() prompt
|
||||
filter filter-msg)
|
||||
(unbox v))))
|
||||
|
||||
(define std-put-file
|
||||
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
|
||||
[filter #f]
|
||||
[filter-msg
|
||||
"That filename does not have the right form."])
|
||||
(let* ([directory (if (and (null? directory)
|
||||
(string? name))
|
||||
(or (mzlib:file^:path-only name) null)
|
||||
directory)]
|
||||
[name (if (string? name)
|
||||
(mzlib:file^:file-name-from-path name)
|
||||
name)]
|
||||
[f (wx:file-selector prompt directory name
|
||||
'()
|
||||
(if (eq? wx:platform 'windows)
|
||||
"*.*"
|
||||
"*")
|
||||
wx:const-save)])
|
||||
(if (or (null? f) (and filter (not (filter-match? filter
|
||||
f
|
||||
filter-msg))))
|
||||
#f
|
||||
(let* ([f (mzlib:file^:normalize-path f)]
|
||||
[dir (mzlib:file^:path-only f)]
|
||||
[name (mzlib:file^:file-name-from-path f)])
|
||||
(cond
|
||||
[(not (and (string? dir) (directory-exists? dir)))
|
||||
(wx:message-box "Error" "That directory does not exist.")
|
||||
#f]
|
||||
[(equal? name "")
|
||||
(wx:message-box "Error" "Empty filename.")
|
||||
#f]
|
||||
[else f]))))))
|
||||
|
||||
(define std-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg
|
||||
"That filename does not have the right form."])
|
||||
(let ([f (wx:file-selector prompt directory)])
|
||||
(if (null? f)
|
||||
#f
|
||||
(if (or (not filter) (filter-match? filter f filter-msg))
|
||||
(let ([f (mzlib:file^:normalize-path f)])
|
||||
(cond
|
||||
[(directory-exists? f)
|
||||
(wx:message-box "Error"
|
||||
"That is a directory name.")
|
||||
#f]
|
||||
[(not (file-exists? f))
|
||||
(wx:message-box "That file does not exist.")
|
||||
#f]
|
||||
[else f]))
|
||||
#f)))))
|
||||
|
||||
; By default, use platform-specific get/put
|
||||
(define put-file std-put-file)
|
||||
(define get-file std-get-file))
|
||||
746
collects/mred/keys.ss
Normal file
746
collects/mred/keys.ss
Normal file
|
|
@ -0,0 +1,746 @@
|
|||
(define-sigfunctor (mred:keymap@ mred:keymap^)
|
||||
(import mred:finder^ mred:handler^ mred:find-string^ mred:scheme-paren^)
|
||||
|
||||
'(printf "mred:keymap@~n")
|
||||
|
||||
; 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
|
||||
; changed for different keyboards.
|
||||
(define shifted-key-list
|
||||
'("<" ">" "?" ":" "~" "\""
|
||||
"{" "}"
|
||||
"!" "@" "#" "$" "%" "^" "&" "*" "(" ")" "_" "+"
|
||||
"|"))
|
||||
|
||||
(define keyerr
|
||||
(lambda (str)
|
||||
(display str (current-error-port))))
|
||||
|
||||
(define (set-keymap-error-handler keymap)
|
||||
(send keymap set-error-callback keyerr))
|
||||
|
||||
(define (set-keymap-implied-shifts keymap)
|
||||
(map (lambda (k) (send keymap implies-shift k))
|
||||
shifted-key-list))
|
||||
|
||||
(define (make-meta-prefix-list key)
|
||||
(list (string-append "m:" key)
|
||||
(string-append "c:[;" key)
|
||||
(string-append "ESC;" key)))
|
||||
|
||||
(define send-map-function-meta
|
||||
(lambda (keymap key func)
|
||||
(for-each (lambda (key)
|
||||
(send keymap map-function key func))
|
||||
(make-meta-prefix-list key))))
|
||||
|
||||
; This installs the standard keyboard mapping
|
||||
(define setup-global-keymap
|
||||
; Define some useful keyboard functions
|
||||
(let* ([ring-bell
|
||||
(lambda (edit event)
|
||||
(send (let loop ([p (send event get-event-object)])
|
||||
(let ([parent (send p get-parent)])
|
||||
(if (null? parent)
|
||||
p
|
||||
(loop parent))))
|
||||
clear-mini-panel%)
|
||||
(wx:bell))]
|
||||
[save-file-as
|
||||
(lambda (edit event)
|
||||
(let ([file (mred:finder^:put-file)])
|
||||
(if file
|
||||
(send edit save-file file)))
|
||||
#t)]
|
||||
[save-file
|
||||
(lambda (edit event)
|
||||
(if (null? (send edit get-filename))
|
||||
(save-file-as edit event)
|
||||
(send edit save-file))
|
||||
#t)]
|
||||
[load-file
|
||||
(lambda (edit event)
|
||||
(mred:handler^:open-file)
|
||||
#t)]
|
||||
[find-string
|
||||
(lambda (edit event . extras)
|
||||
(let ([x-box (box 0)]
|
||||
[y-box (box 0)]
|
||||
[canvas (send event get-event-object)])
|
||||
(send event position x-box y-box)
|
||||
(send canvas client-to-screen x-box y-box)
|
||||
(mred:find-string^:find-string canvas ()
|
||||
(- (unbox x-box) 30)
|
||||
(- (unbox y-box) 30)
|
||||
(cons 'ignore-case extras))))]
|
||||
[find-string-reverse
|
||||
(lambda (edit event)
|
||||
(find-string edit event 'reverse))]
|
||||
[find-string-replace
|
||||
(lambda (edit event)
|
||||
(find-string edit event 'replace))]
|
||||
|
||||
[toggle-anchor
|
||||
(lambda (edit event)
|
||||
(send edit set-anchor
|
||||
(not (send edit get-anchor))))]
|
||||
[flash-paren-match
|
||||
(lambda (edit event)
|
||||
(send edit on-default-char event)
|
||||
(let ([pos (mred:scheme-paren^:scheme-backward-match
|
||||
edit
|
||||
(send edit get-start-position)
|
||||
0)])
|
||||
(when pos
|
||||
(send edit flash-on pos (+ 1 pos))))
|
||||
#t)]
|
||||
[center-view-on-line
|
||||
(lambda (edit event)
|
||||
(let ([new-mid-line (send edit position-line
|
||||
(send edit get-start-position))]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(send edit get-visible-line-range bt bb)
|
||||
(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
|
||||
[top-pos (send edit line-start-position
|
||||
(max (- new-mid-line half) 0))]
|
||||
[bottom-pos (send edit line-start-position
|
||||
(min (+ new-mid-line half)
|
||||
(send edit position-line
|
||||
(send edit last-position))))])
|
||||
(send edit scroll-to-position
|
||||
top-pos
|
||||
#f
|
||||
bottom-pos)))
|
||||
#t)]
|
||||
[collapse-variable-space
|
||||
(lambda (leave-one? edit event)
|
||||
(letrec ([find-nonwhite
|
||||
(lambda (pos d)
|
||||
(let ([c (send edit get-character pos)])
|
||||
(cond
|
||||
[(char=? #\newline c) pos]
|
||||
[(char-whitespace? c)
|
||||
(find-nonwhite (+ pos d) d)]
|
||||
[else pos])))])
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(if (= sel-start sel-end)
|
||||
(let ([start (+ (find-nonwhite (- sel-start 1) -1)
|
||||
(if leave-one? 2 1))]
|
||||
[end (find-nonwhite sel-start 1)])
|
||||
(if (< start end)
|
||||
(begin
|
||||
(send edit begin-edit-sequence)
|
||||
(send edit delete start end)
|
||||
(if (and leave-one?
|
||||
(not (char=? #\space
|
||||
(send edit get-character
|
||||
(sub1 start)))))
|
||||
(send edit insert " " (sub1 start) start))
|
||||
(send edit set-position start)
|
||||
(send edit end-edit-sequence))
|
||||
(if leave-one?
|
||||
(let ([at-start
|
||||
(send edit get-character sel-start)]
|
||||
[after-start
|
||||
(send edit get-character
|
||||
(sub1 sel-start))])
|
||||
(cond
|
||||
[(char-whitespace? at-start)
|
||||
(if (not (char=? at-start #\space))
|
||||
(send edit insert " " sel-start
|
||||
(add1 sel-start)))
|
||||
(send edit set-position (add1 sel-start))]
|
||||
[(char-whitespace? after-start)
|
||||
(if (not (char=? after-start #\space))
|
||||
(send edit insert " " (sub1 sel-start)
|
||||
sel-start))]
|
||||
[else (send edit insert " ")])))))))))]
|
||||
|
||||
[collapse-space
|
||||
(lambda (edit event)
|
||||
(collapse-variable-space #t edit event))]
|
||||
|
||||
[remove-space
|
||||
(lambda (edit event)
|
||||
(collapse-variable-space #f edit event))]
|
||||
|
||||
[collapse-newline
|
||||
(lambda (edit event)
|
||||
(letrec ([find-nonwhite
|
||||
(lambda (pos d offset)
|
||||
(catch
|
||||
escape
|
||||
(let ([max (if (> offset 0)
|
||||
(send edit last-position)
|
||||
-1)])
|
||||
(let loop ([pos pos])
|
||||
(if (= pos max)
|
||||
(escape pos)
|
||||
(let ([c (send edit get-character
|
||||
(+ pos offset))])
|
||||
(cond
|
||||
[(char=? #\newline c)
|
||||
(loop (+ pos d))
|
||||
(escape pos)]
|
||||
[(char-whitespace? c)
|
||||
(loop (+ pos d))]
|
||||
[else pos])))))))])
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(if (= sel-start sel-end)
|
||||
(let* ([pos-line
|
||||
(send edit position-line sel-start #f)]
|
||||
[pos-line-start
|
||||
(send edit line-start-position pos-line)]
|
||||
[pos-line-end
|
||||
(send edit line-end-position pos-line)]
|
||||
|
||||
[whiteline?
|
||||
(let loop ([pos pos-line-start])
|
||||
(if (>= pos pos-line-end)
|
||||
#t
|
||||
(and (char-whitespace?
|
||||
(send edit get-character pos))
|
||||
(loop (add1 pos)))))]
|
||||
|
||||
[start (find-nonwhite pos-line-start -1 -1)]
|
||||
[end (find-nonwhite pos-line-end 1 0)]
|
||||
|
||||
[start-line
|
||||
(send edit position-line start #f)]
|
||||
[start-line-start
|
||||
(send edit line-start-position start-line)]
|
||||
[end-line
|
||||
(send edit position-line end #f)]
|
||||
[end-line-start
|
||||
(send edit line-start-position (add1 end-line))])
|
||||
(cond
|
||||
[(and whiteline?
|
||||
(= start-line pos-line)
|
||||
(= end-line pos-line))
|
||||
; Special case: just delete this line
|
||||
(send edit delete pos-line-start (add1 pos-line-end))]
|
||||
[(and whiteline? (< start-line pos-line))
|
||||
; Can delete before & after
|
||||
(send* edit
|
||||
(begin-edit-sequence)
|
||||
(delete (add1 pos-line-end) end-line-start)
|
||||
(delete start-line-start pos-line-start)
|
||||
(end-edit-sequence))]
|
||||
[else
|
||||
; Only delete after
|
||||
(send edit delete (add1 pos-line-end)
|
||||
end-line-start)]))))))]
|
||||
|
||||
[open-line
|
||||
(lambda (edit event)
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(if (= sel-start sel-end)
|
||||
(send* edit
|
||||
(insert #\newline)
|
||||
(set-position sel-start)))))]
|
||||
|
||||
[transpose-chars
|
||||
(lambda (edit event)
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(when (= sel-start sel-end)
|
||||
(let ([sel-start
|
||||
(if (= sel-start
|
||||
(send edit line-end-position
|
||||
(send edit position-line sel-start)))
|
||||
(sub1 sel-start)
|
||||
sel-start)])
|
||||
(let ([s (send edit get-text
|
||||
sel-start (add1 sel-start))])
|
||||
(send* edit
|
||||
(begin-edit-sequence)
|
||||
(delete sel-start (add1 sel-start))
|
||||
(insert s (- sel-start 1))
|
||||
(set-position (add1 sel-start))
|
||||
(end-edit-sequence)))))))]
|
||||
|
||||
[transpose-words
|
||||
(lambda (edit event)
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(when (= sel-start sel-end)
|
||||
(let ([word-1-start (box sel-start)])
|
||||
(send edit find-wordbreak word-1-start ()
|
||||
wx:const-break-for-caret)
|
||||
(let ([word-1-end (box (unbox word-1-start))])
|
||||
(send edit find-wordbreak () word-1-end
|
||||
wx:const-break-for-caret)
|
||||
(let ([word-2-end (box (unbox word-1-end))])
|
||||
(send edit find-wordbreak () word-2-end
|
||||
wx:const-break-for-caret)
|
||||
(let ([word-2-start (box (unbox word-2-end))])
|
||||
(send edit find-wordbreak word-2-start ()
|
||||
wx:const-break-for-caret)
|
||||
(let ([text-1 (send edit get-text
|
||||
(unbox word-1-start)
|
||||
(unbox word-1-end))]
|
||||
[text-2 (send edit get-text
|
||||
(unbox word-2-start)
|
||||
(unbox word-2-end))])
|
||||
(send* edit
|
||||
(begin-edit-sequence)
|
||||
(insert text-1
|
||||
(unbox word-2-start)
|
||||
(unbox word-2-end))
|
||||
(insert text-2
|
||||
(unbox word-1-start)
|
||||
(unbox word-1-end))
|
||||
(set-position (unbox word-2-end))
|
||||
(end-edit-sequence))))))))))]
|
||||
|
||||
[capitalize-it
|
||||
(lambda (edit all? char-case char-case2)
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)]
|
||||
[real-end (send edit last-position)])
|
||||
(when (= sel-start sel-end)
|
||||
(let ([end-box (box sel-start)])
|
||||
(send edit find-wordbreak () end-box
|
||||
wx:const-break-for-caret)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(send edit begin-edit-sequence))
|
||||
(lambda ()
|
||||
(let loop ([pos sel-start][char-case char-case])
|
||||
(if (< pos real-end)
|
||||
(let ([c (send edit get-character pos)])
|
||||
(if (char-alphabetic? c)
|
||||
(begin
|
||||
(send edit insert
|
||||
(list->string
|
||||
(list (char-case c)))
|
||||
pos (add1 pos))
|
||||
(if (and all? (< (add1 pos)
|
||||
(unbox end-box)))
|
||||
(loop (add1 pos) char-case2)))
|
||||
(loop (add1 pos) char-case))))))
|
||||
(lambda ()
|
||||
(send edit end-edit-sequence)))
|
||||
(send edit set-position (unbox end-box))))))]
|
||||
|
||||
[capitalize-word
|
||||
(lambda (edit event)
|
||||
(capitalize-it edit #t char-upcase char-downcase))]
|
||||
[upcase-word
|
||||
(lambda (edit event)
|
||||
(capitalize-it edit #t char-upcase char-upcase))]
|
||||
[downcase-word
|
||||
(lambda (edit event)
|
||||
(capitalize-it edit #t char-downcase char-downcase))]
|
||||
|
||||
[kill-word
|
||||
(lambda (edit event)
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(let ([end-box (box sel-end)])
|
||||
(send edit find-wordbreak () end-box
|
||||
wx:const-break-for-caret)
|
||||
(send edit kill 0 sel-start (unbox end-box)))))]
|
||||
|
||||
[backward-kill-word
|
||||
(lambda (edit event)
|
||||
(let ([sel-start (send edit get-start-position)]
|
||||
[sel-end (send edit get-end-position)])
|
||||
(let ([start-box (box sel-start)])
|
||||
(send edit find-wordbreak start-box ()
|
||||
wx:const-break-for-caret)
|
||||
(send edit kill 0 (unbox start-box) sel-end))))]
|
||||
|
||||
[region-click
|
||||
(lambda (edit event f)
|
||||
(when (send event button-down?)
|
||||
(let ([x-box (box (send event get-x))]
|
||||
[y-box (box (send event get-y))]
|
||||
[eol-box (box #f)])
|
||||
(send edit global-to-local x-box y-box)
|
||||
(let ([click-pos (send edit find-position
|
||||
(unbox x-box)
|
||||
(unbox y-box)
|
||||
eol-box)]
|
||||
[start-pos (send edit get-start-position)]
|
||||
[end-pos (send edit get-end-position)])
|
||||
(let ([eol (unbox eol-box)])
|
||||
(if (< start-pos click-pos)
|
||||
(f click-pos eol start-pos click-pos)
|
||||
(f click-pos eol click-pos end-pos)))))))]
|
||||
[copy-click-region
|
||||
(lambda (edit event)
|
||||
(region-click edit event
|
||||
(lambda (click eol start end)
|
||||
(send edit flash-on start end)
|
||||
(send edit copy #f 0 start end))))]
|
||||
[cut-click-region
|
||||
(lambda (edit event)
|
||||
(region-click edit event
|
||||
(lambda (click eol start end)
|
||||
(send edit cut #f 0 start end))))]
|
||||
[paste-click-region
|
||||
(lambda (edit event)
|
||||
(region-click edit event
|
||||
(lambda (click eol start end)
|
||||
(send edit set-position click)
|
||||
(send edit paste 0 click))))]
|
||||
|
||||
[mouse-copy-clipboard
|
||||
(lambda (edit event)
|
||||
(send edit copy #f (send event get-time-stamp)))]
|
||||
|
||||
[mouse-paste-clipboard
|
||||
(lambda (edit event)
|
||||
(send edit paste (send event get-time-stamp)))]
|
||||
|
||||
[mouse-cut-clipboard
|
||||
(lambda (edit event)
|
||||
(send edit cut #f (send event get-time-stamp)))]
|
||||
|
||||
[select-click-word
|
||||
(lambda (edit event)
|
||||
(region-click edit event
|
||||
(lambda (click eol start end)
|
||||
(let ([start-box (box click)]
|
||||
[end-box (box click)])
|
||||
(send edit find-wordbreak
|
||||
start-box
|
||||
end-box
|
||||
wx:const-break-for-selection)
|
||||
(send edit set-position
|
||||
(unbox start-box)
|
||||
(unbox end-box))))))]
|
||||
[select-click-line
|
||||
(lambda (edit event)
|
||||
(region-click edit event
|
||||
(lambda (click eol start end)
|
||||
(let* ([line (send edit position-line
|
||||
click eol)]
|
||||
[start (send edit line-start-position
|
||||
line #f)]
|
||||
[end (send edit line-end-position
|
||||
line #f)])
|
||||
(send edit set-position start end)))))]
|
||||
|
||||
[goto-line
|
||||
(lambda (edit event)
|
||||
(let ([num-str (wx:get-text-from-user "Goto Line:" "Goto Line")])
|
||||
(if (string? num-str)
|
||||
(let ([line-num (string->number num-str)])
|
||||
(if line-num
|
||||
(let ([pos (send edit line-start-position
|
||||
(sub1 line-num))])
|
||||
(send edit set-position pos))))))
|
||||
#t)]
|
||||
[goto-position
|
||||
(lambda (edit event)
|
||||
(let ([num-str (wx:get-text-from-user "Goto Position:"
|
||||
"Goto Position")])
|
||||
(if (string? num-str)
|
||||
(let ([pos (string->number num-str)])
|
||||
(if pos
|
||||
(send edit set-position (sub1 pos))))))
|
||||
#t)]
|
||||
[repeater
|
||||
(lambda (n edit)
|
||||
(let* ([km (send edit get-keymap)]
|
||||
[done
|
||||
(lambda ()
|
||||
(send km set-break-sequence-callback void)
|
||||
(send km remove-grab-key-function))])
|
||||
(send km set-grab-key-function
|
||||
(lambda (name local-km edit event)
|
||||
(if (null? name)
|
||||
(let ([k (send event get-key-code)])
|
||||
(if (<= (char->integer #\0) k (char->integer #\9))
|
||||
(set! n (+ (* n 10) (- k (char->integer #\0))))
|
||||
(begin
|
||||
(done)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(send edit begin-edit-sequence))
|
||||
(lambda ()
|
||||
(let loop ([n n])
|
||||
(unless (zero? n)
|
||||
(send edit on-char event)
|
||||
(loop (sub1 n)))))
|
||||
(lambda ()
|
||||
(send edit end-edit-sequence))))))
|
||||
(begin
|
||||
(done)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(send edit begin-edit-sequence))
|
||||
(lambda ()
|
||||
(let loop ([n n])
|
||||
(unless (zero? n)
|
||||
(send local-km call-function name edit event)
|
||||
(loop (sub1 n)))))
|
||||
(lambda ()
|
||||
(send edit end-edit-sequence)))))
|
||||
#t))
|
||||
(send km set-break-sequence-callback done)
|
||||
#t))]
|
||||
[make-make-repeater
|
||||
(lambda (n)
|
||||
(lambda (edit event)
|
||||
(repeater n edit)))]
|
||||
[current-macro '()]
|
||||
[building-macro #f] [build-macro-km #f] [build-protect? #f]
|
||||
[do-macro
|
||||
(lambda (edit event)
|
||||
; If c:x;e during record, copy the old macro
|
||||
(when building-macro
|
||||
(set! building-macro (append (reverse current-macro)
|
||||
(cdr building-macro))))
|
||||
(let ([bm building-macro]
|
||||
[km (send edit get-keymap)])
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! building-macro #f)
|
||||
(send edit begin-edit-sequence))
|
||||
(lambda ()
|
||||
(let/ec escape
|
||||
(for-each
|
||||
(lambda (f)
|
||||
(let ([name (car f)]
|
||||
[event (cdr f)])
|
||||
(if (null? name)
|
||||
(send edit on-char event)
|
||||
(if (not (send km call-function
|
||||
name edit event #t))
|
||||
(escape #t)))))
|
||||
current-macro)))
|
||||
(lambda ()
|
||||
(send edit end-edit-sequence)
|
||||
(set! building-macro bm))))
|
||||
#t)]
|
||||
[start-macro
|
||||
(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))))])
|
||||
(set! building-macro '())
|
||||
(set! build-macro-km km)
|
||||
(send km set-grab-key-function
|
||||
(lambda (name local-km edit event)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! build-protect? #t))
|
||||
(lambda ()
|
||||
(if (null? name)
|
||||
(send edit on-default-char event)
|
||||
(send local-km call-function name edit event)))
|
||||
(lambda ()
|
||||
(set! build-protect? #f)))
|
||||
(when building-macro
|
||||
(set! building-macro
|
||||
(cons (cons name
|
||||
(duplicate-key-event event))
|
||||
building-macro)))
|
||||
#t))
|
||||
(send km set-break-sequence-callback done)))
|
||||
#t)]
|
||||
[end-macro
|
||||
(lambda (edit event)
|
||||
(when building-macro
|
||||
(set! current-macro (reverse building-macro))
|
||||
(set! build-protect? #f)
|
||||
(send build-macro-km break-sequence))
|
||||
#t)])
|
||||
(lambda (kmap)
|
||||
; Redirect keymappng error messages to stderr
|
||||
(send kmap set-error-callback keyerr)
|
||||
; Set the implied shifting map
|
||||
(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))])
|
||||
|
||||
; Standards
|
||||
(wx:add-media-buffer-functions kmap)
|
||||
(wx:add-media-editor-functions kmap)
|
||||
(wx:add-media-pasteboard-functions kmap)
|
||||
|
||||
; Map names to keyboard functions
|
||||
(add "ring-bell" ring-bell)
|
||||
|
||||
(add "save-file" save-file)
|
||||
(add "save-file-as" save-file-as)
|
||||
(add "load-file" load-file)
|
||||
|
||||
(add "find-string" find-string)
|
||||
(add "find-string-reverse" find-string-reverse)
|
||||
(add "find-string-replace" find-string-replace)
|
||||
|
||||
(add "flash-paren-match" flash-paren-match)
|
||||
|
||||
(add "toggle-anchor" toggle-anchor)
|
||||
(add "center-view-on-line" center-view-on-line)
|
||||
(add "collapse-space" collapse-space)
|
||||
(add "remove-space" remove-space)
|
||||
(add "collapse-newline" collapse-newline)
|
||||
(add "open-line" open-line)
|
||||
(add "transpose-chars" transpose-chars)
|
||||
(add "transpose-words" transpose-words)
|
||||
(add "capitalize-word" capitalize-word)
|
||||
(add "upcase-word" upcase-word)
|
||||
(add "downcase-word" downcase-word)
|
||||
(add "kill-word" kill-word)
|
||||
(add "backward-kill-word" backward-kill-word)
|
||||
|
||||
(let loop ([n 9])
|
||||
(unless (negative? n)
|
||||
(let ([s (number->string n)])
|
||||
(add (string-append "command-repeat-" s)
|
||||
(make-make-repeater n))
|
||||
(loop (sub1 n)))))
|
||||
|
||||
(add "do-saved-macro" do-macro)
|
||||
(add "start-macro-record" start-macro)
|
||||
(add "end-macro-record" end-macro)
|
||||
|
||||
(add-m "copy-clipboard" mouse-copy-clipboard)
|
||||
(add-m "cut-clipboard" mouse-cut-clipboard)
|
||||
(add-m "paste-clipboard" mouse-paste-clipboard)
|
||||
(add-m "copy-click-region" copy-click-region)
|
||||
(add-m "cut-click-region" cut-click-region)
|
||||
(add-m "paste-click-region" paste-click-region)
|
||||
(add-m "select-click-word" select-click-word)
|
||||
(add-m "select-click-line" select-click-line)
|
||||
|
||||
(add "goto-line" goto-line)
|
||||
(add "goto-position" goto-position)
|
||||
|
||||
; Map keys to functions
|
||||
(map "c:g" "ring-bell")
|
||||
(map-meta "c:g" "ring-bell")
|
||||
(map "c:x;c:g" "ring-bell")
|
||||
(map "c:c;c:g" "ring-bell")
|
||||
|
||||
(map ")" "flash-paren-match")
|
||||
(map "]" "flash-paren-match")
|
||||
(map "}" "flash-paren-match")
|
||||
(map "\"" "flash-paren-match")
|
||||
|
||||
(map "c:p" "previous-line")
|
||||
(map "c:n" "next-line")
|
||||
(map "c:e" "end-of-line")
|
||||
(map "d:RIGHT" "end-of-line")
|
||||
(map "d:s:RIGHT" "select-to-end-of-line")
|
||||
(map "m:RIGHT" "end-of-line")
|
||||
(map "m:s:RIGHT" "select-to-end-of-line")
|
||||
(map "c:a" "beginning-of-line")
|
||||
(map "d:LEFT" "beginning-of-line")
|
||||
(map "d:s:LEFT" "select-to-beginning-of-line")
|
||||
(map "m:LEFT" "beginning-of-line")
|
||||
(map "m:s:LEFT" "select-to-beginning-of-line")
|
||||
(map "END" "end-of-line")
|
||||
(map "HOME" "beginning-of-line")
|
||||
|
||||
(map "c:h" "delete-previous-character")
|
||||
(map "c:d" "delete-next-character")
|
||||
|
||||
(map "c:f" "forward-character")
|
||||
(map "c:b" "backward-character")
|
||||
|
||||
(map-meta "f" "forward-word")
|
||||
(map "a:RIGHT" "forward-word")
|
||||
(map "a:s:RIGHT" "forward-select-word")
|
||||
(map-meta "b" "backward-word")
|
||||
(map "a:LEFT" "backward-word")
|
||||
(map "a:s:LEFT" "backward-select-word")
|
||||
(map-meta "d" "kill-word")
|
||||
(map-meta "del" "backward-kill-word")
|
||||
(map-meta "c" "capitalize-word")
|
||||
(map-meta "u" "upcase-word")
|
||||
(map-meta "l" "downcase-word")
|
||||
|
||||
(map-meta "<" "beginning-of-file")
|
||||
(map "d:UP" "beginning-of-file")
|
||||
(map-meta ">" "end-of-file")
|
||||
(map "d:DOWN" "end-of-file")
|
||||
|
||||
(map "c:v" "next-page")
|
||||
(map "a:DOWN" "next-page")
|
||||
(map-meta "v" "previous-page")
|
||||
(map "a:up" "previous-page")
|
||||
(map "c:l" "center-view-on-line")
|
||||
|
||||
(map "c:k" "delete-to-end-of-line")
|
||||
(map "c:y" "paste-clipboard")
|
||||
(map-meta "y" "paste-next")
|
||||
(map "a:v" "paste-clipboard")
|
||||
(map "d:v" "paste-clipboard")
|
||||
(map "c:_" "undo")
|
||||
(map "c:+" "redo")
|
||||
(map "a:z" "undo")
|
||||
(map "d:z" "undo")
|
||||
(map "c:x;u" "undo")
|
||||
(map "c:w" "cut-clipboard")
|
||||
(map "a:x" "cut-clipboard")
|
||||
(map "d:x" "cut-clipboard")
|
||||
(map-meta "w" "copy-clipboard")
|
||||
(map "a:c" "copy-clipboard")
|
||||
(map "d:c" "copy-clipboard")
|
||||
|
||||
(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")
|
||||
|
||||
(map "c:s" "find-string")
|
||||
(map "c:r" "find-string-reverse")
|
||||
(map-meta "%" "find-string-replace")
|
||||
|
||||
(map-meta "space" "collapse-space")
|
||||
(map-meta "\\" "remove-space")
|
||||
(map "c:x;c:o" "collapse-newline")
|
||||
(map "c:o" "open-line")
|
||||
(map "c:t" "transpose-chars")
|
||||
(map-meta "t" "transpose-words")
|
||||
|
||||
(map "c:space" "toggle-anchor")
|
||||
|
||||
(map-meta "g" "goto-line")
|
||||
(map-meta "p" "goto-position")
|
||||
|
||||
(map "c:u" "command-repeat-0")
|
||||
(let loop ([n 9])
|
||||
(unless (negative? n)
|
||||
(let ([s (number->string n)])
|
||||
(map-meta s (string-append "command-repeat-" s))
|
||||
(loop (sub1 n)))))
|
||||
|
||||
(map "c:x;e" "do-saved-macro")
|
||||
(map "c:x;(" "start-macro-record")
|
||||
(map "c:x;)" "end-macro-record")
|
||||
|
||||
(map "leftbuttontriple" "select-click-line")
|
||||
(map "leftbuttondouble" "select-click-word")
|
||||
|
||||
(map "rightbutton" "copy-click-region")
|
||||
(map "rightbuttondouble" "cut-click-region")
|
||||
(map "middlebutton" "paste-click-region")
|
||||
(map "c:rightbutton" "copy-clipboard")))))
|
||||
|
||||
(define global-keymap (make-object wx:keymap%))
|
||||
(setup-global-keymap global-keymap))
|
||||
Loading…
Reference in New Issue
Block a user