...
original commit: f4aadc8a0507be7e00334a1a939cb4441974b734
This commit is contained in:
Robby Findler
parent
8418866da8
commit
74e787e9ab
53
collects/framework/fileutil.ss
Normal file
53
collects/framework/fileutil.ss
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
|
||||
(unit/sig framework:path-utils^
|
||||
(import)
|
||||
|
||||
(define generate-autosave-name
|
||||
(lambda (name)
|
||||
(let-values ([(base name dir?)
|
||||
(if (null? name)
|
||||
(values (current-directory) "mredauto" #f)
|
||||
(split-path name))])
|
||||
(let* ([base (if (string? base)
|
||||
base
|
||||
(current-directory))]
|
||||
[path (if (relative-path? base)
|
||||
(build-path (current-directory) base)
|
||||
base)]
|
||||
[without-ext
|
||||
(if (eq? (system-type) 'windows)
|
||||
(list->string
|
||||
(let loop ([list (string->list name)])
|
||||
(if (or (null? list)
|
||||
(char=? (car list) #\.))
|
||||
()
|
||||
(cons (car list)
|
||||
(loop (cdr list))))))
|
||||
name)])
|
||||
(let loop ([n 1])
|
||||
(let ([new-name
|
||||
(build-path path
|
||||
(if (eq? (system-type) 'windows)
|
||||
(string-append without-ext
|
||||
"."
|
||||
(number->string n))
|
||||
(string-append "#"
|
||||
name
|
||||
"#"
|
||||
(number->string n)
|
||||
"#")))])
|
||||
(if (file-exists? new-name)
|
||||
(loop (add1 n))
|
||||
new-name)))))))
|
||||
(define generate-backup-name
|
||||
(lambda (name)
|
||||
(if (eq? (system-type) 'windows)
|
||||
(list->string
|
||||
(let loop ([list (string->list name)])
|
||||
(if (or (null? list)
|
||||
(char=? (car list) #\.))
|
||||
'(#\. #\b #\a #\k)
|
||||
(cons (car list)
|
||||
(loop (cdr list))))))
|
||||
(string-append name "~")))))
|
||||
|
||||
95
collects/framework/icon.ss
Normal file
95
collects/framework/icon.ss
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
(unit/sig framework:icon^
|
||||
(import)
|
||||
|
||||
(define icon-path
|
||||
(with-handlers ([void (lambda (x) (collection-path "system"))])
|
||||
(collection-path "icons")))
|
||||
|
||||
(define (load-icon % name type)
|
||||
(let ([p (build-path icon-path name)]
|
||||
[bitmap #f])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(lambda ()
|
||||
(if bitmap
|
||||
bitmap
|
||||
(begin (set! bitmap (make-object % p type))
|
||||
bitmap)))))
|
||||
|
||||
(define (load-bitmap/mdc % name type)
|
||||
(let* ([p (build-path icon-path name)]
|
||||
[bitmap #f]
|
||||
[memory-dc #f]
|
||||
[force
|
||||
(lambda ()
|
||||
(set! bitmap (make-object % p type))
|
||||
(set! memory-dc (make-object memory-dc%))
|
||||
(when (send bitmap ok?)
|
||||
(send memory-dc select-object bitmap)))])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(values
|
||||
(lambda ()
|
||||
(or bitmap
|
||||
(begin (force)
|
||||
bitmap)))
|
||||
(lambda ()
|
||||
(or memory-dc
|
||||
(begin (force)
|
||||
memory-dc))))))
|
||||
|
||||
(define-values (get-anchor-bitmap get-anchor-mdc)
|
||||
(load-bitmap/mdc bitmap% "anchor.gif" 'gif))
|
||||
(define-values (get-lock-bitmap get-lock-mdc)
|
||||
(load-bitmap/mdc bitmap% "lock.gif" 'gif))
|
||||
(define-values (get-unlock-bitmap get-unlock-mdc)
|
||||
(load-bitmap/mdc bitmap% "unlock.gif" 'gif))
|
||||
|
||||
(define get-autowrap-bitmap (load-icon bitmap% "return.xbm" 'xbm))
|
||||
(define get-paren-highlight-bitmap (load-icon bitmap% "paren.xbm" 'xbm))
|
||||
(define get-reset-console-bitmap (load-icon bitmap% "reset.xbm" 'xbm))
|
||||
|
||||
(define get
|
||||
(let ([icon #f]
|
||||
[p (build-path icon-path "mred.xbm")])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(lambda ()
|
||||
(or icon
|
||||
(begin
|
||||
(set! icon (make-object icon% p 'xbm))
|
||||
icon)))))
|
||||
|
||||
(define-values (get-gc-on-dc get-gc-width get-gc-height)
|
||||
(let* ([get-bitmap (load-icon bitmap%
|
||||
"recycle.gif"
|
||||
'gif)]
|
||||
[bitmap #f]
|
||||
[mdc #f]
|
||||
[fetch
|
||||
(lambda ()
|
||||
(unless mdc
|
||||
(set! mdc (make-object memory-dc%))
|
||||
(set! bitmap (get-bitmap))
|
||||
(send mdc select-object bitmap)))])
|
||||
(values (lambda () (fetch) mdc)
|
||||
(lambda () (fetch) (if (send bitmap ok?)
|
||||
(send bitmap get-width)
|
||||
10))
|
||||
(lambda () (fetch) (if (send bitmap ok?)
|
||||
(send bitmap get-height)
|
||||
10)))))
|
||||
|
||||
(define get-gc-off-dc
|
||||
(let ([mdc #f])
|
||||
(lambda ()
|
||||
(if mdc
|
||||
mdc
|
||||
(begin
|
||||
(set! mdc (make-object memory-dc%))
|
||||
(send mdc select-object
|
||||
(make-object bitmap%
|
||||
(get-gc-width)
|
||||
(get-gc-height)))
|
||||
(send mdc clear)
|
||||
mdc))))))
|
||||
|
|
@ -4,7 +4,6 @@
|
|||
[handler : framework:handler^]
|
||||
[scheme-paren : framework:scheme-paren^])
|
||||
|
||||
|
||||
; 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.
|
||||
|
|
@ -43,11 +42,18 @@
|
|||
(lambda (method)
|
||||
(lambda (edit event)
|
||||
(let ([frame
|
||||
(let loop ([p (send event wx:get-event-object)]) ;;???
|
||||
(if (is-a? p frame%)
|
||||
p
|
||||
(loop (send p get-parent))))])
|
||||
((ivar/proc frame method))
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -413,11 +413,15 @@
|
|||
button% horiz
|
||||
(lambda (button evt)
|
||||
(let ([new-value
|
||||
(get-font-from-user
|
||||
(format "Please choose a new ~a font" name)
|
||||
fonts)])
|
||||
(mred:gui-utils:get-single-choice
|
||||
(format "Please choose a new ~a font"
|
||||
name)
|
||||
"Fonts"
|
||||
fonts
|
||||
null -1 -1 #t 300 400)])
|
||||
(when new-value
|
||||
(set-preference pref-sym (or (send new-value get-face) "<UNKNOWN>"))
|
||||
(set-preference pref-sym
|
||||
new-value)
|
||||
(set-edit-font (get-preference font-size-pref-sym)))))
|
||||
"Change")]
|
||||
;; WARNING!!! CHECK INIT ARGS wx:
|
||||
|
|
|
|||
|
|
@ -271,8 +271,8 @@
|
|||
open-url
|
||||
open-file))
|
||||
|
||||
(define-signature mred:icon^
|
||||
(get-icon
|
||||
(define-signature framework:icon^
|
||||
(get
|
||||
|
||||
get-paren-highlight-bitmap
|
||||
get-autowrap-bitmap
|
||||
|
|
@ -306,8 +306,8 @@
|
|||
global-search-keymap
|
||||
global-file-keymap))
|
||||
|
||||
(define-signature mred:match-cache^
|
||||
(match-cache%))
|
||||
(define-signature framework:match-cache^
|
||||
(%))
|
||||
|
||||
(define-signature mred:menu^
|
||||
(max-manual-menu-id
|
||||
|
|
@ -322,14 +322,14 @@
|
|||
make-project-frame%
|
||||
project-frame%))
|
||||
|
||||
(define-signature mred:scheme-paren^
|
||||
(scheme-paren-pairs
|
||||
scheme-quote-pairs
|
||||
scheme-comments
|
||||
scheme-forward-match
|
||||
scheme-backward-match
|
||||
scheme-balanced?
|
||||
scheme-backward-containing-sexp))
|
||||
(define-signature framework:scheme-paren^
|
||||
(paren-pairs
|
||||
quote-pairs
|
||||
comments
|
||||
forward-match
|
||||
backward-match
|
||||
balanced?
|
||||
backward-containing-sexp))
|
||||
|
||||
(define-signature mred:scheme-mode^
|
||||
(scheme-mode-allow-console-eval
|
||||
|
|
@ -347,7 +347,7 @@
|
|||
scheme-interaction-mode%
|
||||
scheme-mode-style-list))
|
||||
|
||||
(define-signature mred:paren^
|
||||
(define-signature framework:paren^
|
||||
(balanced?
|
||||
forward-match
|
||||
backward-match
|
||||
|
|
|
|||
|
|
@ -1,10 +0,0 @@
|
|||
(unit/sig mred:application^
|
||||
(import)
|
||||
|
||||
(define current-app-name (make-parameter
|
||||
"MrEd"
|
||||
(lambda (x)
|
||||
(unless (string? x)
|
||||
(error 'current-app-name
|
||||
"the app name must be a string"))
|
||||
x))))
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
(unit/sig mred:exit^
|
||||
(import [wx : wx^]
|
||||
[mred:constants : mred:constants^]
|
||||
[mred:preferences : mred:preferences^]
|
||||
[mred:gui-utils : mred:gui-utils^])
|
||||
(rename (-exit exit))
|
||||
|
||||
(mred:debug:printf 'invoke "mred: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 exiting? #f)
|
||||
|
||||
(define run-exit-callbacks
|
||||
(lambda ()
|
||||
(let loop ([cb-list exit-callbacks])
|
||||
(cond
|
||||
[(null? cb-list) #t]
|
||||
[(not ((car cb-list))) #f]
|
||||
[else (loop (cdr cb-list))]))))
|
||||
|
||||
(define -exit
|
||||
(opt-lambda ([just-ran-callbacks? #f])
|
||||
(unless exiting?
|
||||
(dynamic-wind
|
||||
(lambda () (set! exiting? #t))
|
||||
(lambda ()
|
||||
(if (and (let*-values ([(w capW)
|
||||
(if (eq? wx:platform 'windows)
|
||||
(values "exit" "Exit")
|
||||
(values "quit" "Quit"))]
|
||||
[(message)
|
||||
(string-append "Are you sure you want to "
|
||||
w
|
||||
"?")])
|
||||
(if (mred:preferences:get-preference 'mred:verify-exit)
|
||||
(if (mred:gui-utils:get-choice message capW "Cancel")
|
||||
#t
|
||||
#f)
|
||||
#t))
|
||||
(or just-ran-callbacks?
|
||||
(run-exit-callbacks)))
|
||||
(exit)
|
||||
#f))
|
||||
(lambda () (set! exiting? #f)))))))
|
||||
|
|
@ -1,957 +0,0 @@
|
|||
(unit/sig mred:keymap^
|
||||
(import [wx : wx^]
|
||||
[mred:constants : mred:constants^]
|
||||
[mred:preferences : mred:preferences^]
|
||||
[mred:exit : mred:exit^]
|
||||
[mred:finder : mred:finder^]
|
||||
[mred:handler : mred:handler^]
|
||||
[mred:find-string : mred:find-string^]
|
||||
[mred:scheme-paren : mred:scheme-paren^]
|
||||
[mred:gui-utils : mred:gui-utils^]
|
||||
[mred:test : mred:testable-window^])
|
||||
|
||||
(mred:debug:printf 'invoke "mred:keymap@")
|
||||
|
||||
; 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))
|
||||
(newline (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)
|
||||
;(printf "mapping ~a to ~a~n" key func)
|
||||
(send keymap map-function key func))
|
||||
(make-meta-prefix-list key))))
|
||||
|
||||
(mred:preferences:set-preference-default 'mred:delete-forward?
|
||||
(not (eq? wx:platform 'unix))
|
||||
(lambda (x)
|
||||
(or (not x)
|
||||
(eq? x #t))))
|
||||
|
||||
(define setup-global-search-keymap
|
||||
(let* ([send-frame
|
||||
(lambda (method)
|
||||
(lambda (edit event)
|
||||
(let ([frame
|
||||
(let loop ([p (send event get-event-object)])
|
||||
(if (is-a? p wx:frame%)
|
||||
p
|
||||
(loop (send p get-parent))))])
|
||||
((ivar/proc frame method))
|
||||
#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 wx:platform
|
||||
[(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")]
|
||||
[(macintosh)
|
||||
(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* ([rcs
|
||||
(let ([last-checkin-string ""])
|
||||
(mred:preferences:set-preference-default
|
||||
'rcs-pathname (list "/usr/local/RCS/" "/usr/bin/" "/usr/local/bin/")
|
||||
(lambda (x)
|
||||
(and (list? x)
|
||||
(andmap string? x))))
|
||||
(lambda (edit event)
|
||||
(let/ec k
|
||||
(let* ([rcs-binaries (list "ci" "co" "rlog")]
|
||||
[rcs-pathname (let loop ([paths (mred:preferences:get-preference 'rcs-pathname)])
|
||||
(cond
|
||||
[(null? paths) (k (wx:message-box "could not find RCS binaries."))]
|
||||
[else (if (andmap (lambda (b)
|
||||
(file-exists? (build-path (car paths) b)))
|
||||
rcs-binaries)
|
||||
(car paths)
|
||||
(loop (cdr paths)))]))]
|
||||
[filename (send edit get-filename)]
|
||||
[username (wx:get-user-id)])
|
||||
(when (null? filename)
|
||||
(k (wx:message-box "no file associated with this edit")))
|
||||
(let-values ([(my-out my-in my-pid my-err)
|
||||
(apply values (process* (build-path rcs-pathname "rlog")
|
||||
"-L" "-R" (string-append "-l" username) filename))])
|
||||
(let-values ([(their-out their-in their-pid their-err)
|
||||
(apply values (process* (build-path rcs-pathname "rlog")
|
||||
"-L" "-R" "-l" filename))])
|
||||
(let ([my-lock? (not (eof-object? (read my-out)))]
|
||||
[locked? (not (eof-object? (read their-out)))])
|
||||
(for-each close-input-port (list my-out my-err their-out their-err))
|
||||
(for-each close-output-port (list my-in their-in))
|
||||
(cond
|
||||
[(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename))
|
||||
(system* (build-path rcs-pathname "ci") "-t-" filename)
|
||||
(wx:message-box "Initial Checkin Completed")]
|
||||
[my-lock?
|
||||
(when (send edit modified?)
|
||||
(case (mred:gui-utils:unsaved-warning (send edit get-filename) "Checkin" #t)
|
||||
[(save) (send edit save-file (send edit get-filename)
|
||||
(send edit get-file-format))]
|
||||
[(cancel) (k (void))]
|
||||
[else (void)]))
|
||||
(let* ([msg (mred:gui-utils:get-text-from-user
|
||||
"Please Enter Log Message"
|
||||
"Check In"
|
||||
last-checkin-string)]
|
||||
[result (system* (build-path rcs-pathname "ci")
|
||||
"-u" (string-append "-m" msg) filename)])
|
||||
(set! last-checkin-string (or msg ""))
|
||||
(if result
|
||||
(send edit load-file
|
||||
(send edit get-filename)
|
||||
(send edit get-file-format))
|
||||
(mred:gui-utils:message-box "Checkin Unsucessful")))]
|
||||
[locked? (mred:gui-utils:message-box "Someone else has the lock")]
|
||||
[else
|
||||
(let ([current-dir (current-directory)])
|
||||
(let-values ([(base name _) (split-path filename)])
|
||||
(unless (eq? 'relative base)
|
||||
(current-directory base))
|
||||
(let ([res (system* (build-path rcs-pathname "co")
|
||||
"-q" "-l" name)])
|
||||
(current-directory current-dir)
|
||||
(if res
|
||||
(send edit load-file
|
||||
(send edit get-filename)
|
||||
(send edit get-file-format))
|
||||
(wx:message-box "Checkout Failed")))))]))))))))]
|
||||
[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)])
|
||||
(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 "rcs" rcs)
|
||||
|
||||
(add "save-file" save-file)
|
||||
(add "save-file-as" save-file-as)
|
||||
(add "load-file" load-file)
|
||||
|
||||
(when (eq? wx:platform 'unix)
|
||||
'(map "c:x;c:q" "rcs"))
|
||||
(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 some useful keyboard functions
|
||||
(let* ([ring-bell
|
||||
(lambda (edit event)
|
||||
(wx:bell))]
|
||||
|
||||
[toggle-anchor
|
||||
(lambda (edit event)
|
||||
(send edit set-anchor
|
||||
(not (send edit get-anchor))))]
|
||||
[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)]
|
||||
[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)]
|
||||
[collapse-variable-space
|
||||
(lambda (leave-one? edit event)
|
||||
(letrec ([end-pos (send edit last-position)]
|
||||
[find-nonwhite
|
||||
(lambda (pos d)
|
||||
(let ([c (send edit get-character pos)])
|
||||
(cond
|
||||
[(char=? #\newline c) pos]
|
||||
[(or (and (< pos 0) (= d -1))
|
||||
(and (> pos end-pos) (= d 1)))
|
||||
(if (= d -1)
|
||||
-1
|
||||
end-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)])
|
||||
(when (= 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))
|
||||
(when 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)
|
||||
(call/ec
|
||||
(lambda (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 char-case1 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 ([word-end (let ([b (box sel-start)])
|
||||
(send edit find-wordbreak () b
|
||||
wx:const-break-for-caret)
|
||||
(min real-end (unbox b)))])
|
||||
(send edit begin-edit-sequence)
|
||||
(let loop ([pos sel-start]
|
||||
[char-case char-case1])
|
||||
(when (< pos word-end)
|
||||
(let ([c (send edit get-character pos)])
|
||||
(cond
|
||||
[(char-alphabetic? c)
|
||||
(send edit insert
|
||||
(list->string
|
||||
(list (char-case c)))
|
||||
pos (add1 pos))
|
||||
(loop (add1 pos) char-case2)]
|
||||
[else
|
||||
(loop (add1 pos) char-case)]))))
|
||||
(send* edit
|
||||
(end-edit-sequence)
|
||||
(set-position word-end))))))]
|
||||
|
||||
[capitalize-word
|
||||
(lambda (edit event)
|
||||
(capitalize-it edit char-upcase char-downcase))]
|
||||
[upcase-word
|
||||
(lambda (edit event)
|
||||
(capitalize-it edit char-upcase char-upcase))]
|
||||
[downcase-word
|
||||
(lambda (edit event)
|
||||
(capitalize-it edit 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 (mred:gui-utils: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 (mred:gui-utils: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 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)]
|
||||
[delete-key
|
||||
(lambda (edit event)
|
||||
(let ([kmap (send edit get-keymap)])
|
||||
(send kmap call-function
|
||||
(if (mred:preferences:get-preference 'mred:delete-forward?)
|
||||
"delete-next-character"
|
||||
"delete-previous-character")
|
||||
edit event #t)))]
|
||||
[toggle-overwrite
|
||||
(lambda (edit event)
|
||||
(send edit set-overwrite-mode
|
||||
(not (send edit get-overwrite-mode))))])
|
||||
(lambda (kmap)
|
||||
; Redirect keymapping 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 "toggle-overwrite" toggle-overwrite)
|
||||
|
||||
(add "exit" (lambda (edit event)
|
||||
(let ([frame (send edit get-frame)])
|
||||
(if frame
|
||||
((ivar frame file-menu:quit))
|
||||
(wx:bell)))))
|
||||
|
||||
(add "ring-bell" ring-bell)
|
||||
|
||||
(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)
|
||||
|
||||
(add "delete-key" delete-key)
|
||||
|
||||
; 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 "up" "previous-line")
|
||||
(map "s:c:p" "select-up")
|
||||
(map "s:up" "select-up")
|
||||
|
||||
(map "c:n" "next-line")
|
||||
(map "down" "next-line")
|
||||
(map "s:c:n" "select-down")
|
||||
(map "s:down" "select-down")
|
||||
|
||||
(map "c:e" "end-of-line")
|
||||
(map "d:RIGHT" "end-of-line")
|
||||
(map "m:RIGHT" "end-of-line")
|
||||
(map "END" "end-of-line")
|
||||
(map "d:s:RIGHT" "select-to-end-of-line")
|
||||
(map "m:s:RIGHT" "select-to-end-of-line")
|
||||
(map "s:END" "select-to-end-of-line")
|
||||
(map "s:c:e" "select-to-end-of-line")
|
||||
|
||||
(map "c:a" "beginning-of-line")
|
||||
(map "d:LEFT" "beginning-of-line")
|
||||
(map "m:LEFT" "beginning-of-line")
|
||||
(map "HOME" "beginning-of-line")
|
||||
(map "d:s:LEFT" "select-to-beginning-of-line")
|
||||
(map "m:s:LEFT" "select-to-beginning-of-line")
|
||||
(map "s:HOME" "select-to-beginning-of-line")
|
||||
(map "s:c:a" "select-to-beginning-of-line")
|
||||
|
||||
(map "c:f" "forward-character")
|
||||
(map "right" "forward-character")
|
||||
(map "s:c:f" "forward-select")
|
||||
(map "s:right" "forward-select")
|
||||
|
||||
(map "c:b" "backward-character")
|
||||
(map "left" "backward-character")
|
||||
(map "s:c:b" "backward-select")
|
||||
(map "s:left" "backward-select")
|
||||
|
||||
(map-meta "f" "forward-word")
|
||||
(map "a:RIGHT" "forward-word")
|
||||
(map "c:RIGHT" "forward-word")
|
||||
(map-meta "s:f" "forward-select-word")
|
||||
(map "a:s:RIGHT" "forward-select-word")
|
||||
(map "c:s:RIGHT" "forward-select-word")
|
||||
|
||||
(map-meta "b" "backward-word")
|
||||
(map "a:LEFT" "backward-word")
|
||||
|
||||
(map "c:left" "backward-word")
|
||||
(map-meta "s:b" "backward-select-word")
|
||||
(map "a:s:LEFT" "backward-select-word")
|
||||
(map "c:s:left" "backward-select-word")
|
||||
|
||||
(map-meta "<" "beginning-of-file")
|
||||
(map "d:UP" "beginning-of-file")
|
||||
(map "c:HOME" "beginning-of-file")
|
||||
(map "s:c:home" "select-to-beginning-of-file")
|
||||
(map "s:d:up" "select-to-beginning-of-file")
|
||||
|
||||
(map-meta ">" "end-of-file")
|
||||
(map "d:DOWN" "end-of-file")
|
||||
(map "c:end" "end-of-file")
|
||||
(map "s:c:end" "select-to-end-of-file")
|
||||
(map "s:d:down" "select-to-end-of-file")
|
||||
|
||||
(map "c:v" "next-page")
|
||||
(map "a:DOWN" "next-page")
|
||||
(map "pagedown" "next-page")
|
||||
(map "c:DOWN" "next-page")
|
||||
(map "s:c:v" "select-page-down")
|
||||
(map "a:s:DOWN" "select-page-down")
|
||||
(map "s:pagedown" "select-page-down")
|
||||
(map "s:c:DOWN" "select-page-down")
|
||||
|
||||
(map-meta "v" "previous-page")
|
||||
(map "a:up" "previous-page")
|
||||
(map "pageup" "previous-page")
|
||||
(map "c:up" "previous-page")
|
||||
(map-meta "s:v" "select-page-up")
|
||||
(map "s:a:up" "select-page-up")
|
||||
(map "s:pageup" "select-page-up")
|
||||
(map "s:c:up" "select-page-up")
|
||||
|
||||
(map "c:h" "delete-previous-character")
|
||||
(map "c:d" "delete-next-character")
|
||||
(map "del" "delete-key")
|
||||
|
||||
(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 "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-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 "insert" "toggle-overwrite")
|
||||
(map-meta "o" "toggle-overwrite")
|
||||
|
||||
(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 "c:x;c:c" "exit")
|
||||
|
||||
(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)
|
||||
|
||||
(define global-file-keymap (make-object wx:keymap%))
|
||||
(setup-global-file-keymap global-file-keymap)
|
||||
|
||||
(define global-search-keymap (make-object wx:keymap%))
|
||||
(setup-global-search-keymap global-search-keymap))
|
||||
|
|
@ -1,660 +0,0 @@
|
|||
(unit/sig mred:preferences^
|
||||
(import [wx : wx^]
|
||||
[mred:constants : mred:constants^]
|
||||
[mred:exn : mred:exn^]
|
||||
[mred : mred:container^]
|
||||
[mred:exit : mred:exit^]
|
||||
[mred:gui-utils : mred:gui-utils^]
|
||||
[mred:canvas : mred:canvas^]
|
||||
[mred:edit : mred:edit^]
|
||||
[mzlib:pretty-print : mzlib:pretty-print^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(mred:debug:printf 'invoke "mred:preferences@")
|
||||
|
||||
(define preferences-filename (wx:find-path 'pref-file))
|
||||
|
||||
(define preferences (make-hash-table))
|
||||
(define marshall-unmarshall (make-hash-table))
|
||||
(define callbacks (make-hash-table))
|
||||
(define defaults (make-hash-table))
|
||||
|
||||
(define-struct un/marshall (marshall unmarshall))
|
||||
(define-struct marshalled (data))
|
||||
(define-struct pref (value))
|
||||
(define-struct default (value checker))
|
||||
|
||||
|
||||
(define guard
|
||||
(lambda (when p value thunk failure)
|
||||
(let ([h
|
||||
(lambda (x)
|
||||
(let ([msg
|
||||
(format "exception raised ~a for ~a with ~a: ~a~n"
|
||||
when p value
|
||||
(exn-message x))])
|
||||
(failure x)))])
|
||||
(with-handlers ([(lambda (x) #t) h])
|
||||
(thunk)))))
|
||||
|
||||
(define unmarshall
|
||||
(lambda (p marshalled)
|
||||
(let/ec k
|
||||
(let* ([data (marshalled-data marshalled)]
|
||||
[unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall
|
||||
p
|
||||
(lambda () (k data))))])
|
||||
(guard "unmarshalling" p marshalled
|
||||
(lambda () (unmarshall-fn data))
|
||||
(lambda (exn)
|
||||
(hash-table-get
|
||||
defaults
|
||||
p
|
||||
(lambda ()
|
||||
(wx:message-box
|
||||
(format
|
||||
"no default for ~a"
|
||||
p))
|
||||
(raise (mred:exn:make-exn:during-preferences
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~s" exn))
|
||||
((debug-info-handler))))))))))))
|
||||
|
||||
(define get-callbacks
|
||||
(lambda (p)
|
||||
(hash-table-get callbacks
|
||||
p
|
||||
(lambda () null))))
|
||||
|
||||
(define add-preference-callback
|
||||
(lambda (p callback)
|
||||
(hash-table-put! callbacks p (append (get-callbacks p) (list callback)))
|
||||
(lambda ()
|
||||
(hash-table-put!
|
||||
callbacks p
|
||||
(mzlib:function:remove callback
|
||||
(get-callbacks p)
|
||||
eq?)))))
|
||||
|
||||
(define check-callbacks
|
||||
(lambda (p value)
|
||||
(andmap (lambda (x)
|
||||
(guard "calling callback" p value
|
||||
(lambda () (x p value))
|
||||
(lambda (exn)
|
||||
(raise (mred:exn:make-exn:during-preferences
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~s" exn))
|
||||
((debug-info-handler)))))))
|
||||
(get-callbacks p))))
|
||||
|
||||
(define get-preference
|
||||
(lambda (p)
|
||||
(let ([ans (hash-table-get preferences p
|
||||
(lambda ()
|
||||
(raise (mred:exn:make-exn:unknown-preference
|
||||
(format "attempted to get unknown preference: ~a" p)
|
||||
((debug-info-handler))))))])
|
||||
(cond
|
||||
[(marshalled? ans)
|
||||
(let* ([default-s
|
||||
(hash-table-get
|
||||
defaults p
|
||||
(lambda ()
|
||||
(error 'get-preference
|
||||
"no default pref for: ~a~n"
|
||||
p)))]
|
||||
[default (default-value default-s)]
|
||||
[checker (default-checker default-s)]
|
||||
[unmarshalled (let ([unmarsh (unmarshall p ans)])
|
||||
(if (checker unmarsh)
|
||||
unmarsh
|
||||
(begin
|
||||
(printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s (pred: ~s)~n"
|
||||
p unmarsh default checker)
|
||||
default)))]
|
||||
[_ (mred:debug:printf 'prefs "get-preference checking callbacks: ~a to ~a"
|
||||
p unmarshalled)]
|
||||
[pref (if (check-callbacks p unmarshalled)
|
||||
unmarshalled
|
||||
default)])
|
||||
(hash-table-put! preferences p (make-pref pref))
|
||||
(mred:debug:printf 'prefs "get-preference.1 returning ~a as ~a"
|
||||
p pref)
|
||||
pref)]
|
||||
[(pref? ans)
|
||||
(let ([ans (pref-value ans)])
|
||||
(mred:debug:printf 'prefs "get-preference.2 returning ~a as ~a"
|
||||
p ans)
|
||||
ans)]
|
||||
[else (error 'prefs.ss "robby error.1: ~a" ans)]))))
|
||||
|
||||
(define set-preference
|
||||
(lambda (p value)
|
||||
(let* ([pref (hash-table-get preferences p (lambda () #f))])
|
||||
(cond
|
||||
[(pref? pref)
|
||||
(mred:debug:printf 'prefs "set-preference.1 checking callbacks: ~a to ~a" p value)
|
||||
(when (check-callbacks p value)
|
||||
(mred:debug:printf 'prefs "set-preference.1 setting ~a to ~a"
|
||||
p value)
|
||||
(set-pref-value! pref value))]
|
||||
[(or (marshalled? pref)
|
||||
(not pref))
|
||||
(mred:debug:printf 'prefs "set-preference.2 checking callbacks: ~a to ~a" p value)
|
||||
(when (check-callbacks p value)
|
||||
(mred:debug:printf 'prefs "set-preference.2 setting ~a to ~a"
|
||||
p value)
|
||||
(hash-table-put! preferences p (make-pref value)))]
|
||||
[else
|
||||
(error 'prefs.ss "robby error.0: ~a" pref)]))))
|
||||
|
||||
(define set-preference-un/marshall
|
||||
(lambda (p marshall unmarshall)
|
||||
(hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))))
|
||||
|
||||
(define restore-defaults
|
||||
(lambda ()
|
||||
(mred:debug:printf 'prefs "setting prefs to default values")
|
||||
(hash-table-for-each
|
||||
defaults
|
||||
(lambda (p v) (set-preference p v)))
|
||||
(mred:debug:printf 'prefs "finished setting prefs to default values")))
|
||||
|
||||
(define set-preference-default
|
||||
(lambda (p value checker)
|
||||
(let ([t (checker value)])
|
||||
(unless t
|
||||
(error 'set-preference-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker t value)))
|
||||
(mred:debug:printf 'prefs "setting default value for ~a to ~a" p value)
|
||||
(hash-table-get preferences p
|
||||
(lambda ()
|
||||
(hash-table-put! preferences p (make-pref value))))
|
||||
(hash-table-put! defaults p (make-default value checker))))
|
||||
|
||||
;; this is here becuase exit has to come before
|
||||
;; prefs.ss in the loading order.
|
||||
(set-preference-default 'mred:verify-exit #t
|
||||
(lambda (x)
|
||||
(or (not x)
|
||||
(eq? x #t))))
|
||||
|
||||
(define save-user-preferences
|
||||
(let ([marshall-pref
|
||||
(lambda (p ht-value)
|
||||
(cond
|
||||
[(marshalled? ht-value) (list p (marshalled-data ht-value))]
|
||||
[(pref? ht-value)
|
||||
(let* ([value (pref-value ht-value)]
|
||||
[marshalled
|
||||
(let/ec k
|
||||
(guard "marshalling" p value
|
||||
(lambda ()
|
||||
((un/marshall-marshall
|
||||
(hash-table-get marshall-unmarshall p
|
||||
(lambda ()
|
||||
(k value))))
|
||||
value))
|
||||
(lambda (exn)
|
||||
(raise (mred:exn:make-exn:during-preferences
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~s" exn))
|
||||
((debug-info-handler)))))))])
|
||||
(list p marshalled))]
|
||||
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))])
|
||||
(lambda ()
|
||||
(mred:debug:printf 'prefs "saving user preferences")
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(mred:gui-utils:message-box
|
||||
(format "Error saving preferences~n~a"
|
||||
(exn-message exn))
|
||||
"Error saving preferences"))])
|
||||
(call-with-output-file preferences-filename
|
||||
(lambda (p)
|
||||
(mzlib:pretty-print:pretty-print
|
||||
(hash-table-map preferences marshall-pref) p))
|
||||
'truncate 'text))
|
||||
(mred:debug:printf 'prefs "saved user preferences"))))
|
||||
|
||||
(mred:exit:insert-exit-callback
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(mred:gui-utils:message-box
|
||||
(format "Error saving preferences: ~a"
|
||||
(exn-message exn))
|
||||
"Saving Prefs"))])
|
||||
(save-user-preferences))))
|
||||
|
||||
(define read-user-preferences
|
||||
(let ([parse-pref
|
||||
(lambda (p marshalled)
|
||||
(let/ec k
|
||||
(let* ([ht-pref (hash-table-get preferences p (lambda () #f))]
|
||||
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
|
||||
(mred:debug:printf 'prefs "read-user-preferences; p: ~a ht-pref: ~a; marshalled: ~a"
|
||||
p ht-pref marshalled)
|
||||
(cond
|
||||
[(and (pref? ht-pref) unmarshall-struct)
|
||||
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
|
||||
|
||||
;; in this case, assume that no marshalling/unmarshalling
|
||||
;; is going to take place with the pref, since an unmarshalled
|
||||
;; pref was already there.
|
||||
[(pref? ht-pref)
|
||||
(set-preference p marshalled)]
|
||||
|
||||
[(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)]
|
||||
[(and (not ht-pref) unmarshall-struct)
|
||||
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
|
||||
[(not ht-pref)
|
||||
(hash-table-put! preferences p (make-marshalled marshalled))]
|
||||
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))])
|
||||
(lambda ()
|
||||
(mred:debug:printf 'prefs "reading user preferences")
|
||||
(let/ec k
|
||||
(when (file-exists? preferences-filename)
|
||||
(let ([err
|
||||
(lambda (input msg)
|
||||
(wx:message-box (let* ([max-len 150]
|
||||
[s1 (format "~s" input)]
|
||||
[ell "..."]
|
||||
[s2 (if (<= (string-length s1) max-len)
|
||||
s1
|
||||
(string-append (substring s1 0 (- max-len
|
||||
(string-length ell)))
|
||||
ell))])
|
||||
(format "found bad pref: ~a~n~a" msg s2))
|
||||
"Preferences"))])
|
||||
(let loop ([input (with-handlers
|
||||
([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(wx:message-box
|
||||
(format "Error reading preferences~n~a"
|
||||
(exn-message exn))
|
||||
"Error reading preferences")
|
||||
(k #f))])
|
||||
(call-with-input-file preferences-filename
|
||||
read
|
||||
'text))])
|
||||
(cond
|
||||
[(pair? input)
|
||||
(let ([err-msg
|
||||
(let/ec k
|
||||
(let ([first (car input)])
|
||||
(unless (pair? first)
|
||||
(k "expected pair of pair"))
|
||||
(let ([arg1 (car first)]
|
||||
[t1 (cdr first)])
|
||||
(unless (pair? t1)
|
||||
(k "expected pair of two pairs"))
|
||||
(let ([arg2 (car t1)]
|
||||
[t2 (cdr t1)])
|
||||
(unless (null? t2)
|
||||
(k "expected null after two pairs"))
|
||||
(parse-pref arg1 arg2)
|
||||
(k #f)))))])
|
||||
(when err-msg
|
||||
(err input err-msg)))
|
||||
(loop (cdr input))]
|
||||
[(null? input) (void)]
|
||||
[else (err input "expected a pair")])))))
|
||||
(mred:debug:printf 'prefs "read user preferences"))))
|
||||
|
||||
(define-struct ppanel (title container panel))
|
||||
|
||||
(define font-families-name/const
|
||||
(list (list "Default" wx:const-default)
|
||||
(list "Decorative" wx:const-decorative)
|
||||
(list "Roman" wx:const-roman)
|
||||
(list "Decorative" wx:const-script)
|
||||
(list "Swiss" wx:const-swiss)
|
||||
(list "Modern" wx:const-modern)))
|
||||
|
||||
(define font-families (map car font-families-name/const))
|
||||
|
||||
(define font-size-entry "defaultFontSize")
|
||||
(define font-default-string "Default Value")
|
||||
(define font-default-size 12)
|
||||
(define font-section "mred")
|
||||
(define build-font-entry (lambda (x) (string-append "Screen" x "__")))
|
||||
(define font-file (wx:find-path 'setup-file))
|
||||
(define (build-font-preference-symbol family)
|
||||
(string->symbol (string-append "mred:" family)))
|
||||
|
||||
(let ([set-default
|
||||
(lambda (build-font-entry default pred)
|
||||
(lambda (family)
|
||||
(let ([name (build-font-preference-symbol family)]
|
||||
[font-entry (build-font-entry family)])
|
||||
(set-preference-default name
|
||||
default
|
||||
(cond
|
||||
[(string? default) string?]
|
||||
[(number? default) number?]
|
||||
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
|
||||
(add-preference-callback
|
||||
name
|
||||
(lambda (p new-value)
|
||||
(wx:write-resource
|
||||
font-section
|
||||
font-entry
|
||||
(if (and (string? new-value)
|
||||
(string=? font-default-string new-value))
|
||||
""
|
||||
new-value)
|
||||
font-file))))))])
|
||||
(for-each (set-default build-font-entry font-default-string
|
||||
string?)
|
||||
font-families)
|
||||
((set-default (lambda (x) x)
|
||||
font-default-size
|
||||
number?)
|
||||
font-size-entry))
|
||||
|
||||
(define (later-on)
|
||||
(local [(define sema (make-semaphore 1))
|
||||
(define running #f)
|
||||
(define (start-one thunk)
|
||||
(local [(define (do-one)
|
||||
(thunk)
|
||||
(semaphore-wait sema)
|
||||
(set! running #f)
|
||||
(semaphore-post sema))]
|
||||
(semaphore-wait sema)
|
||||
(when running
|
||||
(kill-thread running))
|
||||
(set! running (thread do-one))
|
||||
(semaphore-post sema)))]
|
||||
start-one))
|
||||
|
||||
(define ppanels
|
||||
(list
|
||||
(make-ppanel
|
||||
"General"
|
||||
(lambda (parent)
|
||||
(let* ([main (make-object mred:vertical-panel% parent)]
|
||||
[make-check
|
||||
(lambda (pref title bool->pref pref->bool)
|
||||
(let* ([callback
|
||||
(lambda (_ command)
|
||||
(set-preference pref (bool->pref (send command checked?))))]
|
||||
[pref-value (get-preference pref)]
|
||||
[initial-value (pref->bool pref-value)]
|
||||
[c (make-object mred:check-box% main callback title)])
|
||||
(send c set-value initial-value)
|
||||
(add-preference-callback pref
|
||||
(lambda (p v)
|
||||
(send c set-value (pref->bool v))))))]
|
||||
[id (lambda (x) x)])
|
||||
(send main minor-align-left)
|
||||
(make-check 'mred:highlight-parens "Highlight between matching parens" id id)
|
||||
(make-check 'mred:fixup-parens "Correct parens" id id)
|
||||
(make-check 'mred:paren-match "Flash paren match" id id)
|
||||
(make-check 'mred:autosaving-on? "Auto-save files" id id)
|
||||
(make-check 'mred:delete-forward? "Map delete to backspace" not not)
|
||||
(make-check 'mred:file-dialogs "Use platform-specific file dialogs"
|
||||
(lambda (x) (if x 'std 'common))
|
||||
(lambda (x) (eq? x 'std)))
|
||||
|
||||
(make-check 'mred:verify-exit "Verify exit" id id)
|
||||
(make-check 'mred:verify-change-format "Ask before changing save format" id id)
|
||||
(make-check 'mred:auto-set-wrap? "Wordwrap editor buffers" id id)
|
||||
|
||||
(make-check 'mred:show-status-line "Show status-line" id id)
|
||||
(make-check 'mred:line-offsets "Count line and column numbers from one" id id)
|
||||
(make-check 'mred:menu-bindings "Enable keybindings in menus" id id)
|
||||
(unless (eq? wx:platform 'unix)
|
||||
(make-check 'mred:print-output-mode "Automatically print to postscript file"
|
||||
(lambda (b) (if b 1 0))
|
||||
(lambda (n) (= n 1))))
|
||||
|
||||
|
||||
(make-check 'mred:display-line-numbers "Display line numbers in buffer; not character offsets" id id)
|
||||
|
||||
main))
|
||||
#f)
|
||||
(make-ppanel
|
||||
"Default Fonts"
|
||||
(lambda (parent)
|
||||
(letrec* ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
|
||||
[ex-string "The quick brown fox jumped over the lazy dogs."]
|
||||
[main (make-object mred:vertical-panel% parent)]
|
||||
[fonts (cons font-default-string (wx:get-font-list))]
|
||||
[make-family-panel
|
||||
(lambda (name)
|
||||
(let* ([pref-sym (build-font-preference-symbol name)]
|
||||
[family-const-pair (assoc name font-families-name/const)]
|
||||
|
||||
[edit (make-object mred:edit:media-edit%)]
|
||||
[_ (send edit insert ex-string)]
|
||||
[set-edit-font
|
||||
(lambda (size)
|
||||
(let ([delta (make-object wx:style-delta% wx:const-change-size size)]
|
||||
[face (get-preference pref-sym)])
|
||||
(if (and (string=? face font-default-string)
|
||||
family-const-pair)
|
||||
(send delta set-family (cadr family-const-pair))
|
||||
(send delta set-delta-face (get-preference pref-sym)))
|
||||
|
||||
(send edit change-style delta 0 (send edit last-position))))]
|
||||
|
||||
[horiz (make-object mred:horizontal-panel% main -1 -1 -1 -1 wx:const-border)]
|
||||
[label (make-object mred:message% horiz name)]
|
||||
|
||||
[message (make-object mred:message% horiz
|
||||
(let ([b (box "")])
|
||||
(if (and (wx:get-resource
|
||||
font-section
|
||||
(build-font-entry name)
|
||||
b)
|
||||
(not (string=? (unbox b)
|
||||
"")))
|
||||
(unbox b)
|
||||
font-default-string)))]
|
||||
[button
|
||||
(make-object
|
||||
mred:button% horiz
|
||||
(lambda (button evt)
|
||||
(let ([new-value
|
||||
(mred:gui-utils:get-single-choice
|
||||
(format "Please choose a new ~a font"
|
||||
name)
|
||||
"Fonts"
|
||||
fonts
|
||||
null -1 -1 #t 300 400)])
|
||||
(unless (null? new-value)
|
||||
(set-preference pref-sym
|
||||
new-value)
|
||||
(set-edit-font (get-preference font-size-pref-sym)))))
|
||||
"Change")]
|
||||
[canvas (make-object mred:media-canvas% horiz -1 -1 -1 -1 ""
|
||||
(bitwise-ior wx:const-mcanvas-hide-h-scroll
|
||||
wx:const-mcanvas-hide-v-scroll))])
|
||||
(set-edit-font (get-preference font-size-pref-sym))
|
||||
(send canvas set-media edit)
|
||||
(add-preference-callback
|
||||
pref-sym
|
||||
(lambda (p new-value)
|
||||
(send horiz change-children
|
||||
(lambda (l)
|
||||
(let ([new-message (make-object
|
||||
mred:message%
|
||||
horiz
|
||||
new-value)])
|
||||
(set! message new-message)
|
||||
(update-message-sizes font-message-get-widths
|
||||
font-message-user-min-sizes)
|
||||
(list label
|
||||
new-message
|
||||
button
|
||||
canvas))))))
|
||||
(vector set-edit-font
|
||||
(lambda () (send message get-width))
|
||||
(lambda (width) (send message user-min-width width))
|
||||
(lambda () (send label get-width))
|
||||
(lambda (width) (send label user-min-width width)))))]
|
||||
[set-edit-fonts/messages (map make-family-panel font-families)]
|
||||
[collect (lambda (n) (map (lambda (x) (vector-ref x n)) set-edit-fonts/messages))]
|
||||
[set-edit-fonts (collect 0)]
|
||||
[font-message-get-widths (collect 1)]
|
||||
[font-message-user-min-sizes (collect 2)]
|
||||
[category-message-get-widths (collect 3)]
|
||||
[category-message-user-min-sizes (collect 4)]
|
||||
[update-message-sizes
|
||||
(lambda (gets sets)
|
||||
(let ([width (mzlib:function:foldl (lambda (x l) (max l (x))) 0 gets)])
|
||||
(for-each (lambda (set) (set width)) sets)))]
|
||||
[size-panel (make-object mred:horizontal-panel% main -1 -1 -1 -1 wx:const-border)]
|
||||
[size-slider
|
||||
(make-object mred:slider% size-panel
|
||||
(lambda (slider evt)
|
||||
(set-preference font-size-pref-sym
|
||||
(send slider get-value)))
|
||||
"Size"
|
||||
(let ([b (box 0)])
|
||||
(if (wx:get-resource font-section
|
||||
font-size-entry
|
||||
b)
|
||||
(unbox b)
|
||||
font-default-size))
|
||||
1 127 50)]
|
||||
[guard-change-font (later-on)])
|
||||
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
|
||||
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
|
||||
(add-preference-callback
|
||||
font-size-pref-sym
|
||||
(lambda (p value)
|
||||
(guard-change-font
|
||||
(lambda ()
|
||||
(map (lambda (f) (f value)) set-edit-fonts)))
|
||||
(unless (= value (send size-slider get-value))
|
||||
(send size-slider set-value value))
|
||||
#t))
|
||||
(make-object mred:message% main
|
||||
"Restart to see font changes")
|
||||
main))
|
||||
#f)))
|
||||
|
||||
(define make-run-once
|
||||
(lambda ()
|
||||
(let ([semaphore (make-semaphore 1)])
|
||||
(lambda (t)
|
||||
(dynamic-wind (lambda () (semaphore-wait semaphore))
|
||||
t
|
||||
(lambda () (semaphore-post semaphore)))))))
|
||||
|
||||
(define run-once (make-run-once))
|
||||
|
||||
(define preferences-dialog #f)
|
||||
|
||||
(define add-preference-panel
|
||||
(lambda (title container)
|
||||
(run-once
|
||||
(lambda ()
|
||||
(let ([new-ppanel (make-ppanel title container #f)])
|
||||
(set! ppanels
|
||||
(let loop ([ppanels ppanels])
|
||||
(cond
|
||||
[(null? ppanels) (list new-ppanel)]
|
||||
[(string=? (ppanel-title (car ppanels))
|
||||
title)
|
||||
(loop (cdr ppanels))]
|
||||
[else (cons (car ppanels)
|
||||
(loop (cdr ppanels)))])))
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog added-pane)))))))
|
||||
|
||||
(define hide-preferences-dialog
|
||||
(lambda ()
|
||||
(run-once
|
||||
(lambda ()
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog show #f))))))
|
||||
|
||||
(define show-preferences-dialog
|
||||
(lambda ()
|
||||
(mred:gui-utils:show-busy-cursor
|
||||
(lambda ()
|
||||
(run-once
|
||||
(lambda ()
|
||||
(save-user-preferences)
|
||||
(if preferences-dialog
|
||||
(send preferences-dialog show #t)
|
||||
(set! preferences-dialog
|
||||
(let ([cursor-off (mred:gui-utils:delay-action
|
||||
2 wx:begin-busy-cursor
|
||||
wx:end-busy-cursor)])
|
||||
(begin0 (make-preferences-dialog)
|
||||
(cursor-off)))))))))))
|
||||
|
||||
(define make-preferences-dialog
|
||||
(lambda ()
|
||||
(letrec* ([frame
|
||||
(make-object (class-asi mred:frame%
|
||||
(public [added-pane (lambda ()
|
||||
(ensure-constructed)
|
||||
(refresh-menu)
|
||||
(send popup-menu set-selection (sub1 (length ppanels)))
|
||||
(send single-panel active-child
|
||||
(ppanel-panel (car (list-tail ppanels (sub1 (length ppanels)))))))]))
|
||||
'() "Preferences")]
|
||||
[panel (make-object mred:vertical-panel% frame)]
|
||||
[popup-callback
|
||||
(lambda (choice command-event)
|
||||
(send single-panel active-child
|
||||
(ppanel-panel (list-ref ppanels (send command-event get-command-int)))))]
|
||||
[make-popup-menu
|
||||
(lambda ()
|
||||
(let ([menu (make-object mred:choice% panel popup-callback
|
||||
"Category" -1 -1 -1 -1
|
||||
(map ppanel-title ppanels))])
|
||||
(send menu stretchable-in-x #f)
|
||||
menu))]
|
||||
[popup-menu (make-popup-menu)]
|
||||
[single-panel (make-object mred:single-panel% panel -1 -1 -1 -1 wx:const-border)]
|
||||
[bottom-panel (make-object mred:horizontal-panel% panel)]
|
||||
[ensure-constructed
|
||||
(lambda ()
|
||||
(for-each (lambda (ppanel)
|
||||
(unless (ppanel-panel ppanel)
|
||||
(let ([panel ((ppanel-container ppanel) single-panel)])
|
||||
(unless (is-a? panel mred:panel%)
|
||||
(error 'preferences-dialog
|
||||
"expected the preference panel to be a mred:panel%. Got ~a instead~n"
|
||||
panel))
|
||||
(set-ppanel-panel! ppanel panel))))
|
||||
ppanels)
|
||||
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
|
||||
(send single-panel active-child (ppanel-panel (car ppanels))))]
|
||||
[refresh-menu
|
||||
(lambda ()
|
||||
(let ([new-popup (make-popup-menu)])
|
||||
(send new-popup set-selection (send popup-menu get-selection))
|
||||
(set! popup-menu new-popup)
|
||||
(send panel change-children
|
||||
(lambda (l) (list new-popup
|
||||
single-panel
|
||||
bottom-panel)))))]
|
||||
[ok-callback (lambda args
|
||||
(save-user-preferences)
|
||||
(hide-preferences-dialog))]
|
||||
[ok-button (make-object mred:button% bottom-panel ok-callback "OK")]
|
||||
[cancel-callback (lambda args
|
||||
(hide-preferences-dialog)
|
||||
(read-user-preferences))]
|
||||
[cancel-button (make-object mred:button% bottom-panel cancel-callback "Cancel")])
|
||||
(send ok-button user-min-width (send cancel-button get-width))
|
||||
(send* bottom-panel
|
||||
(stretchable-in-y #f)
|
||||
(major-align-right))
|
||||
(ensure-constructed)
|
||||
(send popup-menu set-selection 0)
|
||||
(send frame show #t)
|
||||
frame)))
|
||||
|
||||
(read-user-preferences))
|
||||
Loading…
Reference in New Issue
Block a user