diff --git a/collects/framework/app.ss b/collects/framework/app.ss new file mode 100644 index 00000000..222c5a15 --- /dev/null +++ b/collects/framework/app.ss @@ -0,0 +1,10 @@ +(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/framework/autosave.ss b/collects/framework/autosave.ss new file mode 100644 index 00000000..4f04997a --- /dev/null +++ b/collects/framework/autosave.ss @@ -0,0 +1,41 @@ +(unit/sig framework:autosave^ + (import [exit : framework:exit^] + [preferences : framework:preferences^]) + + (define register + (let* ([objects null] + [timer + (make-object + (class timer% () + (inherit start) + (override + [notify + (lambda () + (when (preferences:get-preference 'framework:autosaving-on?) + (set! objects + (let loop ([list objects]) + (if (null? list) + null + (let ([object (weak-box-value (car list))]) + (if object + (begin + (send object do-autosave) + (cons (car list) (loop (cdr list)))) + (loop (cdr list)))))))) + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t)))]) + (sequence + (super-init) + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t)))))]) + (lambda (b) + (set! objects + (let loop ([objects objects]) + (cond + [(null? objects) (list (make-weak-box b))] + [else (let ([weak-box (car objects)]) + (if (weak-box-value weak-box) + (cons weak-box (loop (cdr objects))) + (loop (cdr objects))))]))))))) + + diff --git a/collects/framework/exit.ss b/collects/framework/exit.ss new file mode 100644 index 00000000..64c7ef5d --- /dev/null +++ b/collects/framework/exit.ss @@ -0,0 +1,55 @@ +(unit/sig mred:exit^ + (import [preferences : framework:preferences^] + [gui-utils : framework:gui-utils^]) + (rename (-exit exit)) + + (define callbacks '()) + + (define insert-callback + (lambda (f) + (set! callbacks (cons f callbacks)) + f)) + + (define remove-callback + (lambda (cb) + (set! callbacks + (let loop ([cb-list 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-callbacks + (lambda () + (let loop ([cb-list 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 (preferences:get-preference 'mred:verify-exit) + (if (gui-utils:get-choice message capW "Cancel") + #t + #f) + #t)) + (or just-ran-callbacks? + (run-callbacks))) + (exit) + #f)) + (lambda () (set! exiting? #f))))))) \ No newline at end of file diff --git a/collects/framework/handler.ss b/collects/framework/handler.ss new file mode 100644 index 00000000..78aaaade --- /dev/null +++ b/collects/framework/handler.ss @@ -0,0 +1,211 @@ +; File Formats and Modes + + (unit/sig framework:handler^ + (import [gui-utils : framework:gui-utils^] + [finder : framework:finder^] + [group : framework:group^] + [hyper:frame : framework:hyper:frame^] + [edit : framework:edit^] + [preferences : framework:preferences^] + [mzlib:file : mzlib:file^] + [mred:editor-frame : mred:editor-frame^]) + + (define-struct handler (name extension handler)) + + (define format-handlers '()) + + (define make-insert-handler + (letrec ([string-list? + (lambda (l) + (cond + [(null? l) #t] + [(not (pair? l)) #f] + [else + (and (string? (car l)) + (string-list? (cdr l)))]))]) + (lambda (who name extension handler) + (cond + [(not (string? name)) + (error who "name was not a string")] + [(and (not (procedure? extension)) + (not (string? extension)) + (not (string-list? extension))) + (error who + "extension was not a string, list of strings, or a predicate")] + [(not (procedure? handler)) + (error who "handler was not a function")] + [else (make-handler name + extension + handler)])))) + + (define insert-format-handler + (lambda args + (set! format-handlers + (cons (apply make-insert-handler 'insert-format-handler args) + format-handlers)))) + + (define find-handler + (lambda (name handlers) + (let/ec exit + (let ([extension (if (string? name) + (or (mzlib:file:filename-extension name) + "") + "")]) + (for-each + (lambda (handler) + (let ([ext (handler-extension handler)]) + (when (or (and (procedure? ext) + (ext name)) + (and (string? ext) + (string=? ext extension)) + (and (pair? ext) + (ormap (lambda (ext) + (string=? ext extension)) + ext))) + (exit (handler-handler handler))))) + handlers) + #f)))) + + (define find-format-handler + (lambda (name) + (find-handler name format-handlers))) + + ; Finding format & mode handlers by name + (define find-named-handler + (lambda (name handlers) + (let loop ([l handlers]) + (cond + [(null? l) #f] + [(string-ci=? (handler-name (car l)) name) + (handler-handler (car l))] + [else (loop (cdr l))])))) + + (define find-named-format-handler + (lambda (name) + (find-named-handler name format-handlers))) + + (define edit-file-consult-group (make-parameter #t)) + + ; Open a file for editing + (define edit-file + (opt-lambda (filename + [make-default + (lambda (filename) + (make-object mred:editor-frame:editor-frame% + filename #t))] + [consult-group? (edit-file-consult-group)]) + (gui-utils:show-busy-cursor + (lambda () + (if filename + (let ([already-open (and consult-group? + (send mred:group:the-frame-group + locate-file + filename))]) + (if already-open + (begin + (send already-open show #t) + already-open) + (let ([handler + (if (string? filename) + (find-format-handler filename) + #f)]) + (if handler + (handler filename) + (make-default filename))))) + (make-default filename)))))) + + (define get-url-from-user + (lambda () + (let* ([frame (make-object dialog-box% (get-top-level-focus-window) "Choose URL")] + [main (make-object vertical-panel% frame)] + [one-line (make-object editor-canvas% main)] + [_ (send one-line set-line-count 1)] + [valid? #f] + [ok-callback (lambda x (set! valid? #t) (send frame show #f))] + [answer (make-object edit:return% ok-callback)] + [bottom (make-object horizontal-panel% main)] + [space (make-object horizontal-panel% bottom)] + [bookmarks (preferences:get 'framework:bookmarks)] + [bk-choice + (make-object choice% bottom + (lambda (box evt) + (let ([which (send evt get-command-int)]) + (when (<= 0 which) + (send* answer + (begin-edit-sequence) + (erase) + (insert (list-ref bookmarks which)) + (end-edit-sequence))))) + "Bookmarks" -1 -1 -1 -1 bookmarks)] + [browse (make-object button% + bottom + (lambda x + (let ([ans (finder:get-file)]) + (when ans + (send* answer + (begin-edit-sequence) + (erase) + (insert "file:") + (insert ans) + (end-edit-sequence))))) + "Browse...")] + [cancel (make-object button% bottom + (lambda x + (send frame show #f)) + "Cancel")] + [ok (make-object button% bottom + ok-callback + "Ok")]) + (let ([w (max (send ok get-width) + (send cancel get-width) + (send browse get-width))]) + (send ok user-min-width w) + (send cancel user-min-width w) + (send browse user-min-width w)) + (unless (null? bookmarks) + (send answer insert (car bookmarks)) + (send answer set-position 0 -1)) + (send one-line set-focus) + (send one-line set-media answer) + (send frame set-size -1 -1 20 20) + (send frame center 'both) + (send frame show #t) + (and valid? + (send answer get-text))))) + + (define open-url + (opt-lambda ([input-url #f]) + (let ([url (or input-url (get-url-from-user))]) + (and url + (make-object hyper:frame:hyper-view-frame% url))))) + + ; Query the user for a file and then edit it + + (define *open-directory* ; object to remember last directory + (make-object + (class null () + (private + [the-dir #f]) + (public + [get (lambda () the-dir)] + [set-from-file! + (lambda (file) + (set! the-dir (mzlib:file:path-only file)))] + [set-to-default + (lambda () + (set! the-dir (current-directory)))]) + (sequence + (set-to-default))))) + + (define open-file + (lambda () + (let ([file + (parameterize ([finder:dialog-parent-parameter + (get-top-level-focus-window)]) + (finder:get-file + (send *open-directory* get)))]) + (when file + (send *open-directory* + set-from-file! file)) + (and file + (edit-file file)))))) diff --git a/collects/framework/keys.ss b/collects/framework/keys.ss new file mode 100644 index 00000000..8aee6bd6 --- /dev/null +++ b/collects/framework/keys.ss @@ -0,0 +1,865 @@ +(unit/sig framework:keymap^ + (import [preferences : framework:preferences^] + [finder : framework:finder^] + [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. + (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)))) + + (define setup-global-search-keymap + (let* ([send-frame + (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)) + #t)))]) + (lambda (kmap) + (let* ([map (lambda (key func) + (send kmap map-function key func))] + [map-meta (lambda (key func) + (send-map-function-meta kmap key func))] + [add (lambda (name func) + (send kmap add-key-function name func))] + [add-m (lambda (name func) + (send kmap add-mouse-function name func))]) + + (add "move-to-search-or-search" (send-frame 'move-to-search-or-search)) ;; key 1 + (add "move-to-search-or-reverse-search" (send-frame 'move-to-search-or-reverse-search)) ;; key 1b, backwards + (add "find-string" (send-frame 'search)) ;; key 2 + (add "toggle-search-focus" (send-frame 'toggle-search-focus)) ;; key 3 + (add "hide-search" (send-frame 'hide-search)) ;; key 4 + + (case (system-type) + [(unix) + (map "c:s" "move-to-search-or-search") + (map-meta "%" "move-to-search-or-search") + (map "c:r" "move-to-search-or-reverse-search") + (map "f3" "find-string") + (map "c:i" "toggle-search-focus") + (map "c:g" "hide-search")] + [(windows) + (map "c:f" "move-to-search-or-search") + (map "c:r" "move-to-search-or-reverse-search") + (map "f3" "find-string") + (map "c:g" "find-string") + (map "c:i" "toggle-search-focus")] + [(macos) + (map "c:s" "move-to-search-or-search") + (map "c:g" "hide-search") + (map "d:f" "move-to-search-or-search") + (map "d:r" "move-to-search-or-reverse-search") + (map "d:g" "find-string") + (map "d:o" "toggle-search-focus")]))))) + + (define setup-global-file-keymap + (let* ([save-file-as + (lambda (edit event) + (let ([file (finder:put-file)]) + (if file + (send edit save-file file))) + #t)] + [save-file + (lambda (edit event) + (if (null? (send edit get-filename)) + (save-file-as edit event) + (send edit save-file)) + #t)] + [load-file + (lambda (edit event) + (handler:open-file) + #t)]) + (lambda (kmap) + (map (lambda (k) (send kmap implies-shift k)) shifted-key-list) + (let* ([map (lambda (key func) + (send kmap map-function key func))] + [map-meta (lambda (key func) + (send-map-function-meta kmap key func))] + [add (lambda (name func) + (send kmap add-key-function name func))] + [add-m (lambda (name func) + (send kmap add-mouse-function name func))]) + + (add "save-file" save-file) + (add "save-file-as" save-file-as) + (add "load-file" load-file) + + (map "c:x;c:s" "save-file") + (map "d:s" "save-file") + (map "c:x;c:w" "save-file-as") + (map "c:x;c:f" "load-file"))))) + + ; This installs the standard keyboard mapping + (define setup-global-keymap + ; Define some useful keyboard functions + (let* ([ring-bell + (lambda (edit event) + (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 (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 #f 'caret) + (let ([word-1-end (box (unbox word-1-start))]) + (send edit find-wordbreak #f word-1-end 'caret) + (let ([word-2-end (box (unbox word-1-end))]) + (send edit find-wordbreak #f word-2-end 'caret) + (let ([word-2-start (box (unbox word-2-end))]) + (send edit find-wordbreak word-2-start #f '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 '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 '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 () '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 + '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 (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 (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 (preferences:get 'framework: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 + (add-editor-keymap-functions kmap) + (add-text-keymap-functions kmap) + (add-pasteboard-keymap-functions kmap) + + ; Map names to keyboard functions + (add "toggle-overwrite" toggle-overwrite) + + (add "exit" (lambda (edit event) + (let ([frame (send edit get-frame)]) + (if (and frame + (is-a? frame frame:standard-menus<%>)) + ((ivar frame file-menu:quit)) + (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 keymap%)) + (setup-global-keymap global-keymap) + + (define global-file-keymap (make-object keymap%)) + (setup-global-file-keymap global-file-keymap) + + (define global-search-keymap (make-object keymap%)) + (setup-global-search-keymap global-search-keymap)) diff --git a/collects/framework/main.ss b/collects/framework/main.ss new file mode 100644 index 00000000..a3e06f52 --- /dev/null +++ b/collects/framework/main.ss @@ -0,0 +1,39 @@ +(unit/sig () + (import [preferences : framework:preferences^] + [exit : framework:exit^]) + + ;; preferences + + (preferences:set-default 'mred:autosave-delay 300 number?) + (preferences:set-default 'mred:autosaving-on? #t + (lambda (x) + (or (not x) + (eq? x #t)))) + (preferences:set-default 'mred:verify-exit #t + (lambda (x) + (or (not x) + (eq? x #t)))) + + + (preferences:set-default 'mred:delete-forward? + (not (eq? (system-type) 'unix)) + (lambda (x) + (or (not x) + (eq? x #t)))) + + (preferences:read) + + + ;; misc other stuff + + (exit:insert-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)))) + + (wx:application-file-handler edit-file)) diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss new file mode 100644 index 00000000..580488c0 --- /dev/null +++ b/collects/framework/prefs.ss @@ -0,0 +1,601 @@ +(unit/sig framework:preferences^ + (import [exn : framework:exn^] + [exit : framework:exit^] + [mzlib:pretty-print : mzlib:pretty-print^] + [mzlib:function : mzlib:function^]) + + (define preferences-filename (find-system-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 () + (message-box + "No Default" + (format + "no default for ~a" + p)) + (raise (exn:make-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-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 (exn:make-during-preferences + (if (exn? exn) + (exn-message exn) + (format "~s" exn)) + ((debug-info-handler))))))) + (get-callbacks p)))) + + (define get + (lambda (p) + (let ([ans (hash-table-get preferences p + (lambda () + (raise (exn:make-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)))] + [pref (if (check-callbacks p unmarshalled) + unmarshalled + default)]) + (hash-table-put! preferences p (make-pref pref)) + pref)] + [(pref? ans) (pref-value ans)] + [else (error 'prefs.ss "robby error.1: ~a" ans)])))) + + (define set + (lambda (p value) + (let* ([pref (hash-table-get preferences p (lambda () #f))]) + (cond + [(pref? pref) + (when (check-callbacks p value) + (set-pref-value! pref value))] + [(or (marshalled? pref) + (not pref)) + (when (check-callbacks p value) + (hash-table-put! preferences p (make-pref value)))] + [else + (error 'prefs.ss "robby error.0: ~a" pref)])))) + + (define set-un/marshall + (lambda (p marshall unmarshall) + (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall)))) + + (define restore-defaults + (lambda () + (hash-table-for-each + defaults + (lambda (p v) (set-preference p v))))) + + (define set-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))) + (hash-table-get preferences p + (lambda () + (hash-table-put! preferences p (make-pref value)))) + (hash-table-put! defaults p (make-default value checker)))) + + (define save + (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 (exn:make-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 () + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (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))))) + + (define read + (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))]) + (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 () + (let/ec k + (when (file-exists? preferences-filename) + (let ([err + (lambda (input msg) + (message-box "Preferences" + (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))))]) + (let loop ([input (with-handlers + ([(lambda (exn) #t) + (lambda (exn) + (message-box + "Error reading preferences" + (format "Error reading preferences~n~a" + (exn-message exn))) + (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")])))))))) + + (define-struct ppanel (title container panel)) + + (define font-families-name/const + (list (list "Default" 'default) + (list "Decorative" 'decorative) + (list "Roman" 'roman) + (list "Decorative" 'script) + (list "Swiss" 'swiss) + (list "Modern" '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 (find-graphical-system-path 'setup-file)) + (define (build-font-preference-symbol family) + (string->symbol (string-append "framework:" 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) + (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 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 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 'framework:highlight-parens "Highlight between matching parens" id id) + (make-check 'framework:fixup-parens "Correct parens" id id) + (make-check 'framework:paren-match "Flash paren match" id id) + (make-check 'framework:autosaving-on? "Auto-save files" id id) + (make-check 'framework:delete-forward? "Map delete to backspace" not not) + (make-check 'framework:file-dialogs "Use platform-specific file dialogs" + (lambda (x) (if x 'std 'common)) + (lambda (x) (eq? x 'std))) + + (make-check 'framework:verify-exit "Verify exit" id id) + (make-check 'framework:verify-change-format "Ask before changing save format" id id) + (make-check 'framework:auto-set-wrap? "Wordwrap editor buffers" id id) + + (make-check 'framework:show-status-line "Show status-line" id id) + (make-check 'framework:line-offsets "Count line and column numbers from one" id id) + (make-check 'framework:menu-bindings "Enable keybindings in menus" id id) + (unless (eq? (system-type) 'unix) + (make-check 'framework:print-output-mode "Automatically print to postscript file" + (lambda (b) (if b 1 0)) + (lambda (n) (= n 1)))) + + + (make-check 'framework: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 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 edit%)] + [_ (send edit insert ex-string)] + [set-edit-font + (lambda (size) + (let ([delta (make-object style-delta% '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 horizontal-panel% main '(border))] + [label (make-object message% horiz name)] + + [message (make-object message% horiz + (let ([b (box "")]) + (if (and (get-resource + font-section + (build-font-entry name) + b) + (not (string=? (unbox b) + ""))) + (unbox b) + font-default-string)))] + [button + (make-object + button% horiz + (lambda (button evt) + (let ([new-value + (get-font-from-user + (format "Please choose a new ~a font" name) + fonts)]) + (when new-value + (set-preference pref-sym (or (send new-value get-face) "")) + (set-edit-font (get-preference font-size-pref-sym))))) + "Change")] + ;; WARNING!!! CHECK INIT ARGS wx: + [canvas (make-object editor-canvas% horiz "" + (list 'hide-hscroll + 'hide-vscroll))]) + (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 + 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 horizontal-panel% main '(border))] + [size-slider + (make-object slider% size-panel + (lambda (slider evt) + (set-preference font-size-pref-sym + (send slider get-value))) + "Size" + (let ([b (box 0)]) + (if (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 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-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-dialog + (lambda () + (run-once + (lambda () + (when preferences-dialog + (send preferences-dialog show #f)))))) + + (define show-dialog + (lambda () + (run-once + (lambda () + (save-user-preferences) + (if preferences-dialog + (send preferences-dialog show #t) + (set! preferences-dialog + (make-preferences-dialog))))))) + + (define make-preferences-dialog + (lambda () + (letrec* ([frame + (make-object (class-asi frame% + (public [added-pane (lambda () + (ensure-constructed) + (refresh-menu) + (send popup-menu set-selection (sub1 (length ppanels))) + (send single-panel active-child + (ppanel-panel (car (list-tail ppanels (sub1 (length ppanels)))))))])) + '() "Preferences")] + [panel (make-object vertical-panel% frame)] + [popup-callback + (lambda (choice command-event) + (send single-panel active-child + (ppanel-panel (list-ref ppanels (send command-event get-command-int)))))] + [make-popup-menu + (lambda () + (let ([menu (make-object choice% "Category" + (map ppanel-title ppanels) + panel popup-callback)]) + (send menu stretchable-in-x #f) + menu))] + [popup-menu (make-popup-menu)] + [single-panel (make-object single-panel% panel '(border))] + [bottom-panel (make-object horizontal-panel% panel)] + [ensure-constructed + (lambda () + (for-each (lambda (ppanel) + (unless (ppanel-panel ppanel) + (let ([panel ((ppanel-container ppanel) single-panel)]) + (unless (is-a? panel panel%) + (error 'preferences-dialog + "expected the preference panel to be a panel%. Got ~a instead~n" + panel)) + (set-ppanel-panel! ppanel panel)))) + ppanels) + (send single-panel change-children (lambda (l) (map ppanel-panel ppanels))) + (send single-panel active-child (ppanel-panel (car ppanels))))] + [refresh-menu + (lambda () + (let ([new-popup (make-popup-menu)]) + (send new-popup set-selection (send popup-menu get-selection)) + (set! popup-menu new-popup) + (send panel change-children + (lambda (l) (list new-popup + single-panel + bottom-panel)))))] + [ok-callback (lambda args + (save-user-preferences) + (hide-preferences-dialog))] + [ok-button (make-object button% bottom-panel ok-callback "OK")] + [cancel-callback (lambda args + (hide-preferences-dialog) + (read-user-preferences))] + [cancel-button (make-object button% bottom-panel cancel-callback "Cancel")]) + (send ok-button user-min-width (send cancel-button get-width)) + (send* bottom-panel + (stretchable-in-y #f) + (major-align-right)) + (ensure-constructed) + (send popup-menu set-selection 0) + (send frame show #t) + frame)))) diff --git a/collects/framework/sig.ss b/collects/framework/sig.ss index c15118cc..3e08adb4 100644 --- a/collects/framework/sig.ss +++ b/collects/framework/sig.ss @@ -1,3 +1,10 @@ +(require-library "refer.ss") +(require-library "cores.ss") +(require-library "match.ss") +(require-library "dates.ss") +(require-library "functios.ss") +(require-library "macro.ss") + (define-signature framework:frame^ (empty<%> standard-menus<%> @@ -24,3 +31,374 @@ pasteboard% pasteboard-info% pasteboard-info-file%)) + +(define-signature mred:graph^ + (node-snip% + make-node-snip% + graph-pasteboard% + make-graph-pasteboard%)) + +(define-signature mred:connections^ + (connections-frame% + connections-dialog-box% + connections-media-edit% + connections-media-pasteboard% + connections-media-canvas% + connections-panel% + + make-connections-frame% + make-connections-media-buffer% + make-connections-media-canvas% + make-connections-panel%)) + +(define-signature mred:version^ + (add-version-spec + version)) + +(define-signature mred:html^ + (html-convert)) + +(define-signature mred:panel^ + (make-edit-panel% + horizontal-edit-panel% + vertical-edit-panel%)) + +(define-signature mred:url^ + ((struct url (scheme host port path params query fragment)) + unixpath->path + get-pure-port ; url [x list (str)] -> in-port + get-impure-port ; url [x list (str)] -> in-port + display-pure-port ; in-port -> () + purify-port ; in-port -> list (mime-header) + netscape/string->url ; (string -> url) + string->url ; str -> url + url->string + call/input-url ; url x (url -> in-port) x + ; (in-port -> ()) + ; [x list (str)] -> () + combine-url/relative)) ; url x str -> url + +(define-signature framework:exn^ + ((struct exn ()) + (struct exn:unknown-preference ()) + (struct exn:during-preferences ()) + (struct exn:url ()))) + +(define-signature mred:hyper-loader^ + (open-hyper-make + open-hyper-view + hyper-text-require)) + +(define-signature framework:application^ + (current-app-name)) + +(define-signature mred:exn-external^ + (exn? exn:unknown-preference? exn:during-preferences? exn:url?)) + +(define-signature framework:preferences^ + (get + add-callback + set + set-default + set-un/marshall + + save + read + restore-defaults + + add-panel + show-dialog + hide-dialog)) + +(define-signature framework:autosave^ + (register)) + +(define-signature mred:exit^ + (insert-callback + remove-callback + run-callbacks + exit)) + +(define-signature mred:gui-utils^ + (get-font-from-user + get-colour-from-user + get-text-from-user + message-box + cursor-delay + show-busy-cursor + delay-action + local-busy-cursor + get-choice + unsaved-warning + read-snips/chars-from-buffer + open-input-buffer + print-paper-names + get-single-choice)) + +(define-signature mred:console^ + (credits-proc + credits + copyright-string + welcome-message + + separator-snip% + + console-max-save-previous-exprs + + show-interactions-history + + make-scheme-mode-edit% + scheme-mode-edit% + + make-console-edit% + console-edit% + + transparent-io-edit% + make-transparent-io-edit% + + make-console-frame% + console-frame%)) + +(define-signature mred:path-utils^ + (generate-autosave-name + generate-backup-name)) + +(define-signature mred:finder^ + (filter-match? + dialog-parent-parameter + common-put-file + common-get-file + std-put-file + std-get-file + common-get-file-list + current-find-file-directory + get-file + put-file)) + +(define-signature mred:find-string^ + (make-find-frame% + find-frame% + find-string)) + +(define-signature mred:edit^ + (make-std-buffer% + make-pasteboard% + make-info-buffer% + make-info-edit% + make-file-buffer% + make-searching-edit% + make-backup-autosave-buffer% + make-return-edit% + + media-edit% + info-edit% + searching-edit% + clever-file-format-edit% + file-edit% + backup-autosave-edit% + edit% + return-edit% + + pasteboard% + info-pasteboard% + file-pasteboard% + backup-autosave-pasteboard% + + make-snip% + snip% + media-snip%)) + +(define-signature mred:canvas^ + (make-wrapping-canvas% + wrapping-canvas% + + make-one-line-canvas% + one-line-canvas% + + make-frame-title-canvas% + frame-title-canvas% + + make-wide-snip-canvas% + wide-snip-canvas% + + number-control%)) + +(define-signature mred:frame^ + (frame-width + frame-height + + make-simple-frame% + make-menu-frame% + make-standard-menus-frame% + make-searchable-frame% + + make-info-frame% + make-edit-info-frame% + + make-file-frame% + + make-pasteboard-frame% + make-pasteboard-file-frame% + make-pasteboard-info-frame% + + empty-frame% + menu-frame% + standard-menus-frame% + simple-menu-frame% + searchable-frame% + info-frame% + info-file-frame% + pasteboard-frame% + pasteboard-info-frame% + pasteboard-info-file-frame%)) + +(define-signature mred:editor-frame^ + (make-editor-frame% + editor-frame% + make-status-frame%)) + +(define-signature mred:group^ + (frame-group% + the-frame-group)) + +(define-signature framework:handler^ + (handler? handler-name handler-extension handler-handler + format-handlers + insert-format-handler + find-format-handler + find-named-format-handler + edit-file + open-url + open-file)) + +(define-signature mred:icon^ + (get-icon + + get-paren-highlight-bitmap + get-autowrap-bitmap + get-reset-console-bitmap + + get-lock-bitmap + get-lock-mdc + get-unlock-bitmap + get-unlock-mdc + get-anchor-bitmap + get-anchor-mdc + + get-gc-on-dc + get-gc-off-dc + get-gc-width + get-gc-height)) + +(define-signature mred:keymap^ + (keyerr + set-keymap-error-handler + shifted-key-list + set-keymap-implied-shifts + make-meta-prefix-list + send-map-function-meta + + setup-global-keymap + setup-global-search-keymap + setup-global-file-keymap + + global-keymap + global-search-keymap + global-file-keymap)) + +(define-signature mred:match-cache^ + (match-cache%)) + +(define-signature mred:menu^ + (max-manual-menu-id + generate-menu-id + make-menu% + menu% + make-menu-bar% + menu-bar%)) + +(define-signature mred:project^ + (project-frame-group% + 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 mred:scheme-mode^ + (scheme-mode-allow-console-eval + scheme-mode-tabify-on-return? + scheme-mode-match-round-to-square? + scheme-media-wordbreak-map + scheme-init-wordbreak-map + setup-global-scheme-mode-keymap + setup-global-scheme-interaction-mode-keymap + global-scheme-mode-keymap + global-scheme-interaction-mode-keymap + make-scheme-mode% + make-scheme-interaction-mode% + scheme-mode% + scheme-interaction-mode% + scheme-mode-style-list)) + +(define-signature mred:paren^ + (balanced? + forward-match + backward-match + skip-whitespace)) + + +(define-signature mred:hyper-edit^ + ((struct hypertag (name position)) + (struct hyperlink (anchor-start anchor-end url-string)) + hyper-buffer-data% + hyper-data-class + make-hyper-edit% + hyper-edit%)) + +(define-signature mred:hyper-dialog^ + (hyper-tag-dialog% + hyper-get-current-tags)) + +(define-signature mred:hyper-frame^ + (hyper-frame-group + make-hyper-canvas% + hyper-canvas% + make-hyper-basic-frame% + hyper-basic-frame% + make-hyper-view-frame% + hyper-view-frame% + make-hyper-make-frame% + hyper-make-frame% + open-hyper-view + open-hyper-make + hyper-text-require)) + +(define-signature mred^ + ((unit constants : mred:constants^) + (open mred:version^) + (open mred:exn-external^) + (open mred:connections^) (open mred:container^) (open mred:preferences^) + (open mred:autoload^) (open mred:autosave^) (open mred:exit^) + (open mred:gui-utils^) (open mred:console^) (open mred:path-utils^) + (open mred:finder^) + (open mred:find-string^) (open mred:edit^) (open mred:canvas^) + (open mred:frame^) (open mred:editor-frame^) + (open mred:group^) (open mred:handler^) (open mred:icon^) (open mred:keymap^) + (open mred:match-cache^) (open mred:menu^) (open mred:mode^) + (open mred:panel^) (open mred:paren^) (open mred:project^) + (open mred:scheme-paren^) (open mred:scheme-mode^) + (open mred:hyper-edit^) (open mred:hyper-dialog^) (open mred:hyper-frame^) + (open mred:testable-window^) + (unit test : mred:self-test-export^) + (open mred:url^) + (open mred:graph^) + (open mred:application^) + (open mred:control^))) + diff --git a/collects/framework/version.ss b/collects/framework/version.ss new file mode 100644 index 00000000..62516208 --- /dev/null +++ b/collects/framework/version.ss @@ -0,0 +1,27 @@ + (unit/sig mred:version^ + (import [wx : wx^] + [mzlib:function : mzlib:function^] + [mzlib:string^ : mzlib:string^]) + + (rename [-version version]) + + (mred:debug:printf 'invoke "mred:version@") + + (define specs null) + + (define -version + (lambda () + (mzlib:functionfoldr + (lambda (entry sofar) + (match entry + [(sep num) (string-append sofar sep num)])) + (version) + specs))) + + (define add-spec + (lambda (sep num) + (set! specs (cons (list (mzlib:string:expr->string sep) + (mzlib:string:expr->string num)) + specs)))) + + '(add-version-spec ': 5)) diff --git a/notes/mred/MrEd 100 Framework b/notes/mred/MrEd 100 Framework index debc7dec..1f4a2329 100644 --- a/notes/mred/MrEd 100 Framework +++ b/notes/mred/MrEd 100 Framework @@ -11,6 +11,8 @@ Subtle Changes: - overriding `windows-menu' with #f no longer eliminates the windows menu. Now, it is an error. + - mred:original-output-port, mred:original-error-port, and + mred:original-input-port are gone The eliminated classes are: @@ -78,6 +80,8 @@ The eliminated classes are: mred:editor-frame% mred:transparent-io-edit% + mred:autoload + The moved functions and classes are: :: web browswer @@ -142,6 +146,37 @@ The remaining existant classes: Old to new name mapping: + mred:handler? -> handler:handler? + mred:handler-name -> handler:handler-name + mred:handler-extension -> handler:handler-extension + mred:handler-handler -> handler:handler-handler + mred:format-handlers -> handler:format-handlers + mred:insert-format-handler -> handler:insert-format-handler + mred:find-format-handler -> handler:find-format-handler + mred:find-named-format-handler -> handler:find-named-format-handler + mred:edit-file -> handler:edit-file + mred:open-url -> handler:open-url + mred:open-file -> handler:open-file + + mred:register-autosave -> autosave:register + + mred:make-exn -> exn:make-exn + mred:exn? -> exn:exn? + mred:make-exn:unkown-preference -> exn:make-unkown-preference + mred:exn:unkown-preference? -> exn:unkown-preference? + mred:exn:make-during-preferences -> exn:make-during-preferences + mred:exn:during-preferences? -> exn:during-preferences? + mred:exn:make-url -> exn:make-url + mred:exn:url? -> exn:url? + + mred:insert-exit-callback -> exit:insert-callback + mred:remove-exit-callback -> exit:remove-callback + mred:run-exit-callbacks -> exit:run-callbacks + mred:exit -> exit:exit + + mred:add-version-spec -> version:add-spec + mred:version -> version:version + mred:empty-frame% -> frame:empty% mred:standard-menus-frame% -> frame:standard-menus% mred:simple-menu-frame% -> frame:simple-menu%