suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: 0a0cdb5079f69d7fa03712b3e3e6818bfcba9269
This commit is contained in:
Robby Findler 1998-08-31 18:26:59 +00:00
parent 895df93ccb
commit 8418866da8
10 changed files with 2262 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/framework/app.ss Normal file
View File

@ -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))))

41
collects/framework/autosave.ss Normal file
View File

@ -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))))])))))))

55
collects/framework/exit.ss Normal file
View File

@ -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)))))))

211
collects/framework/handler.ss Normal file
View File

@ -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))))))

865
collects/framework/keys.ss Normal file
View File

@ -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))

39
collects/framework/main.ss Normal file
View File

@ -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))

601
collects/framework/prefs.ss Normal file
View File

@ -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) "<UNKNOWN>"))
(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))))

378
collects/framework/sig.ss
View File

@ -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^)))

27
collects/framework/version.ss Normal file
View File

@ -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))

35
notes/mred/MrEd 100 Framework
View File

@ -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%