...
original commit: 015c7c88b35b1759af9912048010a9e7a04a09c0
This commit is contained in:
parent
96ad62b6ee
commit
1c935b93fc
|
@ -9,6 +9,8 @@
|
|||
[text : framework:text^]
|
||||
[pasteboard : framework:pasteboard^])
|
||||
|
||||
(rename [-keymap<%> keymap<%>])
|
||||
|
||||
(define basic<%>
|
||||
(interface (editor<%>)
|
||||
editing-this-file?
|
||||
|
@ -24,7 +26,6 @@
|
|||
(inherit get-filename save-file
|
||||
refresh-delayed?
|
||||
get-canvas
|
||||
get-keymap
|
||||
get-max-width get-admin set-filename)
|
||||
(rename [super-set-modified set-modified]
|
||||
[super-on-focus on-focus]
|
||||
|
@ -140,9 +141,28 @@
|
|||
(apply super-init args)
|
||||
(auto-wrap (default-auto-wrap?)))))
|
||||
|
||||
(define -keymap<%> (interface (basic<%>)))
|
||||
(define keymap-mixin
|
||||
(mixin (basic<%>) (-keymap<%>) args
|
||||
(public
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(list (keymap:get-global)))])
|
||||
(inherit get-keymap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(let ([keymap (get-keymap)])
|
||||
(keymap:set-keymap-error-handler keymap)
|
||||
(keymap:set-keymap-implied-shifts keymap)
|
||||
(add-editor-keymap-functions keymap)
|
||||
(add-text-keymap-functions keymap)
|
||||
(add-pasteboard-keymap-functions keymap)
|
||||
(for-each (lambda (k)
|
||||
(send keymap chain-to-keymap k #f))
|
||||
(get-keymaps))))))
|
||||
|
||||
(define file<%> (interface (basic<%>)))
|
||||
(define file-mixin
|
||||
(define file-mixin ;; wx - should come from -keymap<%>
|
||||
(mixin (basic<%>) (file<%>) args
|
||||
(inherit get-keymap
|
||||
get-filename lock get-style-list
|
||||
|
@ -178,8 +198,6 @@
|
|||
(sequence
|
||||
(apply super-init args)
|
||||
(let ([keymap (get-keymap)])
|
||||
(keymap:set-keymap-error-handler keymap)
|
||||
(keymap:set-keymap-implied-shifts keymap)
|
||||
(send keymap chain-to-keymap (keymap:get-file) #f)))))
|
||||
|
||||
(define backup-autosave<%>
|
||||
|
|
12
collects/framework/framework.ss
Normal file
12
collects/framework/framework.ss
Normal file
|
@ -0,0 +1,12 @@
|
|||
(read-case-sensitive #t)
|
||||
(compile-allow-cond-fallthrough #t)
|
||||
(compile-allow-set!-undefined #t)
|
||||
(require-library "mred-interfaces.ss" "framework")
|
||||
(require-library "sig.ss" "framework")
|
||||
(invoke-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [M : mred-interfaces^ (mred-interfaces@)]
|
||||
[C : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[F : framework^ ((require-library "frameworkr.ss" "framework") C M)])
|
||||
(export)))
|
|
@ -12,10 +12,9 @@
|
|||
; are not normally thought of as shifted. It will have to be
|
||||
; changed for different keyboards.
|
||||
(define shifted-key-list
|
||||
'("?" ":" "~" "\""
|
||||
'("?" ":" "~" "\"" "|"
|
||||
"<" ">" "{" "}" "[" "]" "(" ")"
|
||||
"!" "@" "#" "$" "%" "^" "&" "*" "_" "+"
|
||||
"|"))
|
||||
"!" "@" "#" "$" "%" "^" "&" "*" "_" "+"))
|
||||
|
||||
(define keyerr
|
||||
(lambda (str)
|
||||
|
@ -553,11 +552,6 @@
|
|||
[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)
|
||||
|
||||
|
|
|
@ -1,37 +1,30 @@
|
|||
(printf "mred:creating thread~n")
|
||||
(thread
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(fprintf (current-error-port) "mred: ")
|
||||
(raise exn))])
|
||||
(letrec ([restart
|
||||
(lambda ()
|
||||
(printf "mred:initializing loop~n")
|
||||
(let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
|
||||
[(continue) (make-semaphore 0)]
|
||||
[(error) #f]
|
||||
[(answer) (void)])
|
||||
(printf "mred:made connection~n")
|
||||
(let loop ()
|
||||
(let ([sexp (read in)])
|
||||
(if (eof-object? sexp)
|
||||
(begin
|
||||
(close-input-port in)
|
||||
(close-output-port out)
|
||||
(exit))
|
||||
(begin
|
||||
(queue-callback (lambda ()
|
||||
(set! error #f)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(set! error exn))])
|
||||
(set! answer (eval sexp)))
|
||||
(semaphore-post continue)))
|
||||
(semaphore-wait continue)
|
||||
(write
|
||||
(if error
|
||||
(list 'error (exn-message error))
|
||||
(list 'normal answer))
|
||||
out)
|
||||
(loop)))))))])
|
||||
restart)))
|
||||
(letrec ([restart
|
||||
(lambda ()
|
||||
(let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
|
||||
[(continue) (make-semaphore 0)]
|
||||
[(error) #f]
|
||||
[(answer) (void)])
|
||||
(let loop ()
|
||||
(let ([sexp (read in)])
|
||||
(if (eof-object? sexp)
|
||||
(begin
|
||||
(close-input-port in)
|
||||
(close-output-port out)
|
||||
(exit))
|
||||
(begin
|
||||
(queue-callback (lambda ()
|
||||
(set! error #f)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(set! error exn))])
|
||||
(set! answer (eval sexp)))
|
||||
(semaphore-post continue)))
|
||||
(semaphore-wait continue)
|
||||
(write
|
||||
(if error
|
||||
(list 'error (exn-message error))
|
||||
(list 'normal answer))
|
||||
out)
|
||||
(loop)))))))])
|
||||
restart))
|
||||
|
|
Loading…
Reference in New Issue
Block a user