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

...

Browse Source 
original commit: b7d777a27bca10e13c4b01af99c0a2a97aaa467b
This commit is contained in:
Robby Findler 1999-02-12 20:46:15 +00:00
parent c3c1312851
commit e55c276c94
6 changed files with 105 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/editor.ss
View File

@ -171,8 +171,6 @@
(sequence
(apply super-init args)
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(for-each (lambda (k) (send keymap chain-to-keymap k #f))
(get-keymaps))))))

2
collects/framework/finder.ss
View File

@ -326,7 +326,7 @@
[top-panel (make-object horizontal-panel% main-panel)]
[_1 (make-object message% top-panel prompt)]
[_1 (make-object message% prompt top-panel)]
[dir-choice (make-object choice% #f null top-panel do-dir)]

4
collects/framework/frameworks.ss
View File

@ -207,9 +207,7 @@
get-gc-off-bitmap))
(define-signature framework:keymap^
(set-keymap-error-handler
set-keymap-implied-shifts
send-map-function-meta
(send-map-function-meta
make-meta-prefix-list
setup-global

33
collects/framework/keymap.ss
View File

@ -8,18 +8,6 @@
[frame : framework:frame^])
(rename [-get-file get-file])
(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))
(keys:get-shifted-key-list)))
(define (make-meta-prefix-list key)
(list (string-append "m:" key)
@ -530,18 +518,14 @@
(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)) (keys:get-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))]
(send kmap add-function name func))]
[add-m (lambda (name func)
(send kmap add-mouse-function name func))])
(send kmap add-function name func))])
; Map names to keyboard functions
(add "toggle-overwrite" toggle-overwrite)
@ -748,8 +732,6 @@
(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")
@ -778,9 +760,9 @@
[map-meta (lambda (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
(send kmap add-key-function name func))]
(send kmap add-function name func))]
[add-m (lambda (name func)
(send kmap add-mouse-function name func))])
(send kmap add-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
@ -828,15 +810,14 @@
(handler:open-file)
#t)])
(lambda (kmap)
(map (lambda (k) (send kmap implies-shift k)) (keys:get-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))]
(send kmap add-function name func))]
[add-m (lambda (name func)
(send kmap add-mouse-function name func))])
(send kmap add-function name func))])
(add "save-file" save-file)
(add "save-file-as" save-file-as)
@ -848,8 +829,6 @@
(map "c:x;c:f" "load-file")))))
(define (generic-setup keymap)
(set-keymap-error-handler keymap)
(set-keymap-implied-shifts keymap)
(add-editor-keymap-functions keymap)
(add-pasteboard-keymap-functions keymap)
(add-text-keymap-functions keymap))

10
collects/framework/scheme.ss
View File

@ -754,12 +754,10 @@
(define setup-keymap
(lambda (keymap)
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(let ([add-pos-function ;; wx: this needs to be cleaned up!
(lambda (name ivar-sym)
(send keymap add-key-function name
(send keymap add-function name
(lambda (edit event)
((ivar/proc edit ivar-sym)
(send edit get-start-position)))))])
@ -775,7 +773,7 @@
(let ([add-edit-function
(lambda (name ivar-sym)
(send keymap add-key-function name
(send keymap add-function name
(lambda (edit event)
((ivar/proc edit ivar-sym)))))])
(add-edit-function "select-forward-sexp" 'select-forward-sexp)
@ -787,10 +785,10 @@
(add-edit-function "comment-out" 'comment-out-selection)
(add-edit-function "uncomment" 'uncomment-selection))
(send keymap add-key-function "balance-parens"
(send keymap add-function "balance-parens"
(lambda (edit event)
(send edit balance-parens event)))
(send keymap add-key-function "balance-quotes"
(send keymap add-function "balance-quotes"
(lambda (edit event)
(send edit balance-quotes event)))

168
collects/tests/framework/frame.ss
View File

@ -1,84 +1,102 @@
(let ([test-creation
(lambda (name class-expression)
(test
name
(lambda (x) x)
(lambda ()
(send-sexp-to-mred
`(send (make-object ,class-expression "test") show #t))
(wait-for-frame "test")
(send-sexp-to-mred
'(send (get-top-level-focus-window) show #f))
#t)))])
(define (test-creation name class-expression)
'(test
name
(lambda (x) x)
(lambda ()
(send-sexp-to-mred
`(send (make-object ,class-expression "test") show #t))
(wait-for-frame "test")
(send-sexp-to-mred
'(send (get-top-level-focus-window) show #f))
#t)))
(test-creation
'basic%-creation
'frame:basic%)
(test-creation
'basic-mixin-creation
'(frame:basic-mixin frame%))
(test-creation
'basic%-creation
'frame:basic%)
(test-creation
'basic-mixin-creation
'(frame:basic-mixin frame%))
(test-creation
'standard-menus%-creation
'frame:standard-menus%)
(test-creation
'standard-menus-mixin
'(frame:standard-menus-mixin frame:basic%))
(test-creation
'standard-menus%-creation
'frame:standard-menus%)
(test-creation
'standard-menus-mixin
'(frame:standard-menus-mixin frame:basic%))
(test-creation
'text%-creation
'frame:text%)
(test-creation
'text-mixin-creation
'(frame:text-mixin frame:editor%))
(test-creation
'text-mixin-creation
'(frame:text-mixin (frame:editor-mixin frame:standard-menus%)))
(test-creation
'text%-creation
'frame:text%)
(test-creation
'text-mixin-creation
'(frame:text-mixin frame:editor%))
(test-creation
'text-mixin-creation
'(frame:text-mixin (frame:editor-mixin frame:standard-menus%)))
(test-creation
'searchable%-creation
'frame:searchable%)
(test-creation
'searchable-mixin
'(frame:searchable-mixin frame:text%))
(test-creation
'searchable%-creation
'frame:searchable%)
(test-creation
'searchable-mixin
'(frame:searchable-mixin frame:text%))
(test-creation
'info-mixin-creation
'(frame:info-mixin frame:searchable%))
(test-creation
'text-info-mixin-creation
'(frame:text-info-mixin (frame:info-mixin frame:searchable%)))
(test-creation
'text-info%-creation
'frame:text-info%)
(test-creation
'info-mixin-creation
'(frame:info-mixin frame:searchable%))
(test-creation
'text-info-mixin-creation
'(frame:text-info-mixin (frame:info-mixin frame:searchable%)))
(test-creation
'text-info%-creation
'frame:text-info%)
(test-creation
'text-info-file%-creation
'frame:text-info-file%)
(test-creation
'text-info-file-mixin-creation
'(frame:file-mixin frame:text-info%))
(test-creation
'text-info-file%-creation
'frame:text-info-file%)
(test-creation
'text-info-file-mixin-creation
'(frame:file-mixin frame:text-info%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin frame:editor%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
(test-creation
'pasteboard%-creation
'frame:pasteboard%)
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin frame:editor%))
(test-creation
'pasteboard-mixin-creation
'(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
(test-creation
'pasteboard%-creation
'frame:pasteboard%)
(test-creation
'pasteboard-info-mixin-creation
'(frame:info-mixin frame:searchable%))
(test-creation
'pasteboard-info%-creation
'frame:pasteboard-info%)
(test-creation
'pasteboard-info-mixin-creation
'(frame:info-mixin frame:searchable%))
(test-creation
'pasteboard-info%-creation
'frame:pasteboard-info%)
(test-creation
'pasteboard-info-file-mixin-creation
'(frame:file-mixin frame:pasteboard-info%))
(test-creation
'pasteboard-info-file%-creation
'frame:pasteboard-info-file%))
(test-creation
'pasteboard-info-file-mixin-creation
'(frame:file-mixin frame:pasteboard-info%))
(test-creation
'pasteboard-info-file%-creation
'frame:pasteboard-info-file%)
(define (test-open name class-expression)
(test
name
(lambda (x) x)
(lambda ()
(send-sexp-to-mred
`(begin
(preferences:set
'framework:file-dialogs
'common)
(send (make-object ,class-expression "test open") show #t)))
(wait-for-frame "test open")
(send-sexp-to-mred
`(test:menu-select "File" "Open..."))
(wait-for-frame "Open File")
#t)))
(test-open "frame:editor open" 'frame:text%)