From 74e787e9ab1459908f8b222983ac9c5945c7e8c0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 31 Aug 1998 21:36:26 +0000 Subject: [PATCH] ... original commit: f4aadc8a0507be7e00334a1a939cb4441974b734 --- collects/framework/fileutil.ss | 53 ++ collects/framework/icon.ss | 95 ++++ collects/framework/keys.ss | 18 +- collects/framework/prefs.ss | 12 +- collects/framework/sig.ss | 26 +- collects/mred/app.ss | 10 - collects/mred/exit.ss | 59 -- collects/mred/keys.ss | 957 --------------------------------- collects/mred/prefs.ss | 660 ----------------------- 9 files changed, 181 insertions(+), 1709 deletions(-) create mode 100644 collects/framework/fileutil.ss create mode 100644 collects/framework/icon.ss delete mode 100644 collects/mred/app.ss delete mode 100644 collects/mred/exit.ss delete mode 100644 collects/mred/keys.ss delete mode 100644 collects/mred/prefs.ss diff --git a/collects/framework/fileutil.ss b/collects/framework/fileutil.ss new file mode 100644 index 00000000..ed4d7b32 --- /dev/null +++ b/collects/framework/fileutil.ss @@ -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 "~"))))) + diff --git a/collects/framework/icon.ss b/collects/framework/icon.ss new file mode 100644 index 00000000..422dabd7 --- /dev/null +++ b/collects/framework/icon.ss @@ -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)))))) diff --git a/collects/framework/keys.ss b/collects/framework/keys.ss index 8aee6bd6..7c28ca27 100644 --- a/collects/framework/keys.ss +++ b/collects/framework/keys.ss @@ -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) diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 580488c0..55af5ed5 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -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) "")) + (set-preference pref-sym + new-value) (set-edit-font (get-preference font-size-pref-sym))))) "Change")] ;; WARNING!!! CHECK INIT ARGS wx: diff --git a/collects/framework/sig.ss b/collects/framework/sig.ss index 3e08adb4..13f21437 100644 --- a/collects/framework/sig.ss +++ b/collects/framework/sig.ss @@ -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 diff --git a/collects/mred/app.ss b/collects/mred/app.ss deleted file mode 100644 index 222c5a15..00000000 --- a/collects/mred/app.ss +++ /dev/null @@ -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)))) \ No newline at end of file diff --git a/collects/mred/exit.ss b/collects/mred/exit.ss deleted file mode 100644 index 063f2dee..00000000 --- a/collects/mred/exit.ss +++ /dev/null @@ -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))))))) \ No newline at end of file diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss deleted file mode 100644 index e2b8287a..00000000 --- a/collects/mred/keys.ss +++ /dev/null @@ -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)) diff --git a/collects/mred/prefs.ss b/collects/mred/prefs.ss deleted file mode 100644 index 47ce3077..00000000 --- a/collects/mred/prefs.ss +++ /dev/null @@ -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))