gui/gui-lib/framework/private/keymap.rkt
2015-05-12 11:24:54 -05:00

592 lines
23 KiB
Racket

#lang racket/base
(require string-constants
racket/class
racket/match
racket/list
racket/unit
mred/mred-sig
"../preferences.rkt"
"sig.rkt"
"keymap-global.rkt")
(provide keymap@)
(define-unit keymap@
(import mred^
[prefix finder: framework:finder^]
[prefix handler: framework:handler^]
[prefix frame: framework:frame^]
[prefix editor: framework:editor^]
[prefix text: framework:text^])
(export (rename framework:keymap^
[-get-file get-file]))
(init-depend mred^)
;; if I put this in main.rkt with the others, it doesn't happen
;; early enough... ? JBC, 2011-07-12
(preferences:set-default 'framework:automatic-parens #f boolean?)
(define user-keybindings-files (make-hash))
(define (add-user-keybindings-file spec)
(hash-ref
user-keybindings-files
spec
(λ ()
(let* ([path (spec->path spec)]
[sexp (and (file-exists? path)
(parameterize ([read-accept-reader #t])
(call-with-input-file path read)))])
(match sexp
[`(module ,name ,lang ,x ...)
(cond
[(valid-keybindings-lang? lang)
(let ([km (dynamic-require spec '#%keymap)])
(hash-set! user-keybindings-files spec km)
(send user-keymap chain-to-keymap km #t))]
[else
(error 'add-user-keybindings-file
(string-constant user-defined-keybinding-malformed-file/found-lang)
(path->string path)
lang)])]
[else (error 'add-user-keybindings-file
(string-constant user-defined-keybinding-malformed-file)
(path->string path))])))))
(define (valid-keybindings-lang? x)
(member x
(list `(lib "keybinding-lang.ss" "framework")
`(lib "keybinding-lang.rkt" "framework")
`(lib "framework/keybinding-lang.ss")
`(lib "framework/keybinding-lang.rkt")
`framework/keybinding-lang)))
(define (spec->path p)
(cond
[(path? p) p]
[else
(let* ([mod-name ((current-module-name-resolver) p #f #f #t)]
[str (symbol->string mod-name)]
[pth (substring str 1 (string-length str))])
(let-values ([(base name _) (split-path pth)])
(let ([filenames
(sort
(filter (λ (x) (substring? (path->string name) x))
(map path->string (directory-list base)))
(λ (x y) (> (string-length x) (string-length y))))])
(when (null? filenames)
(error 'spec->path "could not convert ~s, found no filenames for ~s" p mod-name))
(build-path base (car filenames)))))]))
(define (substring? s1 s2)
(and (<= (string-length s1)
(string-length s2))
(string=? s1 (substring s2 0 (string-length s1)))))
(define (remove-user-keybindings-file spec)
(let/ec k
(let ([km (hash-ref user-keybindings-files spec (λ () (k (void))))])
(send global remove-chained-keymap km)
(hash-remove! user-keybindings-files spec))))
(define (remove-chained-keymap ed keymap-to-remove)
(let ([ed-keymap (send ed get-keymap)])
(when (eq? keymap-to-remove ed-keymap)
(error 'keymap:remove-keymap "cannot remove initial keymap from editor"))
(let p-loop ([parent-keymap ed-keymap])
(unless (is-a? parent-keymap aug-keymap<%>)
(error 'keymap:remove-keymap
"found a keymap that is not a keymap:aug-keymap<%> ~e"
parent-keymap))
(let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)])
(cond
[(null? child-keymaps)
(void)]
[else
(let ([child-keymap (car child-keymaps)])
(cond
[(eq? child-keymap keymap-to-remove)
(send parent-keymap remove-chained-keymap child-keymap)
(c-loop (cdr child-keymaps))]
[else
(p-loop child-keymap)
(c-loop (cdr child-keymaps))]))])))))
(define (set-chained-keymaps parent-keymap children-keymaps)
(for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap))
(send parent-keymap get-chained-keymaps))
(for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
children-keymaps))
(define aug-keymap<%> (interface ((class->interface keymap%))
get-chained-keymaps
get-map-function-table
get-map-function-table/ht))
(define aug-keymap-mixin
(mixin ((class->interface keymap%)) (aug-keymap<%>)
(define chained-keymaps null)
(define/public (get-chained-keymaps) chained-keymaps)
(define/override (chain-to-keymap keymap prefix?)
(super chain-to-keymap keymap prefix?)
(set! chained-keymaps
(if prefix?
(cons keymap chained-keymaps)
(append chained-keymaps (list keymap)))))
(define/override (remove-chained-keymap keymap)
(super remove-chained-keymap keymap)
(set! chained-keymaps (remq keymap chained-keymaps)))
(define function-table (make-hasheq))
(define/public (get-function-table) function-table)
(define/override (map-function keyname fname)
(super map-function (canonicalize-keybinding-string keyname) fname)
(hash-set! function-table (string->symbol keyname) fname))
(define/public (get-map-function-table)
(get-map-function-table/ht (make-hasheq)))
(define/public (get-map-function-table/ht table)
(for ([(keyname fname) (in-hash function-table)])
(define cs (canonicalize-keybinding-string (format "~a" keyname)))
(define key (string->symbol cs))
(unless (hash-ref table key #f)
(when (on-this-platform? cs)
(hash-set! table key fname))))
(for ([chained-keymap (in-list chained-keymaps)])
(when (is-a? chained-keymap aug-keymap<%>)
(send chained-keymap get-map-function-table/ht table)))
table)
(define/private (on-this-platform? cs)
(define splits
(for/list ([x (in-list (split-out #\; (string->list cs)))])
(all-but-last (split-out #\: x))))
(define (has-key? k) (ormap (λ (x) (member (list k) x)) splits))
(cond
[(eq? (system-type) 'windows)
(cond
[(and (regexp-match? #rx"c:m" cs)
(not (regexp-match? #rx"~c:m" cs))
(not (regexp-match? #rx"~g:" cs)))
#f]
[(or (has-key? #\a) (has-key? #\d))
#f]
[else #t])]
[(eq? (system-type) 'macosx)
(cond
[(has-key? #\m)
#f]
[else #t])]
[(eq? (system-type) 'unix)
(cond
[(or (has-key? #\a) (has-key? #\d))
#f]
[else #t])]
[else
;; just in case new platforms come along ....
#t]))
(define/private (all-but-last l)
(cond
[(null? l) l]
[(null? (cdr l)) l]
[else (cons (car l) (all-but-last (cdr l)))]))
(super-new)))
(define aug-keymap% (aug-keymap-mixin keymap%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; ;;;;;;;;
;;;;;;; canonicalize-keybinding-string ;;;;;;;;
;;;;;;; ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; canonicalize-keybinding-string : string -> string
;; The result can be used with string=? to determine
;; if two key bindings refer to the same key.
;; Assumes a well-formed keystring.
(define (canonicalize-keybinding-string str)
(define chars (map char-downcase (string->list str)))
(define separated-keys
(map
canonicalize-single-keybinding-string
(split-out #\; chars)))
(join-strings ";" separated-keys))
;; join-strings : string (listof string) -> string
;; concatenates strs with sep between each of them
(define (join-strings sep strs)
(if (null? strs)
""
(apply
string-append
(cons
(car strs)
(let loop ([sepd-strs (cdr strs)])
(cond
[(null? sepd-strs) null]
[else (list*
sep
(car sepd-strs)
(loop (cdr sepd-strs)))]))))))
;; canonicalize-single-keybinding-string : (listof char) -> string
(define (canonicalize-single-keybinding-string chars)
(let* ([neg? (char=? (car chars) #\:)]
[mods/key (split-out #\: (if neg? (cdr chars) chars))]
[mods
(let loop ([mods mods/key])
(cond
[(null? mods) null]
[(null? (cdr mods)) null]
[else (cons (car mods) (loop (cdr mods)))]))]
[key (apply string (car (last-pair mods/key)))]
[canon-key
(cond
[(string=? key "enter") "return"]
[(string=? key "del") "delete"]
[(string=? key "ins") "insert"]
[else key])]
[shift (if neg? #f 'd/c)]
[control (if neg? #f 'd/c)]
[alt (if neg? #f 'd/c)]
[meta (if neg? #f 'd/c)]
[command (if neg? #f 'd/c)]
[lock 'd/c]
[altgr 'd/c]
[question-mark 'd/c]
[do-key
(λ (char val)
(cond
[(eq? val #t) (string char)]
[(eq? val #f) (string #\~ char)]
[(eq? val 'd/c) #f]))])
(for-each (λ (mod)
(let ([val (not (char=? (car mod) #\~))])
(case (if (char=? (car mod) #\~)
(cadr mod)
(car mod))
[(#\s) (set! shift val)]
[(#\c) (set! control val)]
[(#\a) (set! alt val)]
[(#\d) (set! command val)]
[(#\m) (set! meta val)]
[(#\l) (set! lock val)]
[(#\g) (set! altgr val)]
[(#\?) (set! question-mark val)])))
mods)
(join-strings ":"
(filter
values
(list
(do-key #\? question-mark)
(do-key #\a alt)
(do-key #\c control)
(do-key #\d command)
(do-key #\m meta)
(do-key #\s shift)
(do-key #\l lock)
(and (eq? 'windows (system-type))
control
meta
(do-key #\g altgr))
canon-key)))))
;; split-out : char (listof char) -> (listof (listof char))
;; splits a list of characters at its first argument
;; if the last character is the same as the first character,
;; it is not split into an empty list, but returned.
(define (split-out split-char chars)
(let loop ([chars chars]
[this-split null]
[all-split null])
(cond
[(null? chars)
(reverse (cons (reverse this-split) all-split))]
[else (let ([char (car chars)])
(cond
[(char=? split-char char)
(if (null? (cdr chars))
(loop null
(cons char this-split)
all-split)
(loop (cdr chars)
null
(cons (reverse this-split) all-split)))]
[else
(loop (cdr chars)
(cons char this-split)
all-split)]))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; ;;;;;;;;
;;;;;;; end canonicalize-keybinding-string ;;;;;;;;
;;;;;;; ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define make-meta-prefix-list keymap:make-meta-prefix-list)
(define send-map-function-meta keymap:send-map-function-meta)
(define region-click keymap:region-click)
(define add-to-right-button-menu keymap:add-to-right-button-menu)
(define add-to-right-button-menu/before keymap:add-to-right-button-menu/before)
(define (call/text-keymap-initializer thunk)
(let ([ctki (current-text-keymap-initializer)])
(parameterize ([current-text-keymap-initializer
(λ (keymap)
(send keymap chain-to-keymap global #t)
(ctki keymap))])
(thunk))))
(define (setup-global kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f])
(keymap:setup-global kmap #:alt-as-meta-keymap alt-as-meta-keymap)
(define (goto-line keystroke-edit event)
(define keystroke-frame
(and (is-a? keystroke-edit editor:basic<%>)
(send keystroke-edit get-top-level-window)))
(define edit
(cond
[(is-a? keystroke-frame frame:info<%>)
(send keystroke-frame get-info-editor)]
[(is-a? keystroke-edit text%) keystroke-edit]
[else #f]))
(when edit
(define num-str
(call/text-keymap-initializer
(λ ()
(get-text-from-user
(string-constant goto-line)
(string-constant goto-line)))))
(when (string? num-str)
(define possible-num (string->number num-str))
(define line-num (and possible-num (inexact->exact possible-num)))
(cond
[(and (number? line-num)
(integer? line-num)
(<= 1 line-num (+ (send edit last-paragraph) 1)))
(define pos (send edit paragraph-start-position (sub1 line-num)))
(send edit set-position pos)]
[else
(message-box
(string-constant goto-line)
(format
(string-constant goto-line-invalid-number)
num-str
(+ (send edit last-line) 1)))])))
#t)
(let ([add-m (λ (name func)
(send kmap add-function name func)
(when alt-as-meta-keymap
(send alt-as-meta-keymap add-function name func)))]
[map-meta (λ (key func)
(keymap:send-map-function-meta kmap key func
(regexp-match? has-control-regexp key)
#:alt-as-meta-keymap alt-as-meta-keymap))])
(add-m "goto-line" goto-line)
(map-meta "g" "goto-line")))
(define setup-search
(let* ([send-frame
(λ (invoke-method)
(λ (edit event)
(let ([frame
(cond
[(is-a? edit editor<%>)
(let ([canvas (or (send edit get-active-canvas)
(send edit get-canvas))])
(and canvas
(send canvas get-top-level-window)))]
[(is-a? edit area<%>)
(send edit get-top-level-window)]
[else #f])])
(if frame
(invoke-method frame)
(bell)))
#t))])
(λ (kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f])
(let* ([map (λ (key func)
(send kmap map-function key func))]
[map-meta (λ (key func)
(send-map-function-meta kmap key func
(regexp-match? has-control-regexp key)
#:alt-as-meta-keymap alt-as-meta-keymap))]
[add (λ (name func)
(send kmap add-function name func))]
[add-m (λ (name func)
(send kmap add-function name func)
(when alt-as-meta-keymap
(send alt-as-meta-keymap add-function name func)))])
(add-m "search forward"
(send-frame (λ (f) (send f search 'forward))))
(add "search backward"
(send-frame (λ (f) (send f search 'backward))))
(add "replace & search forward"
(send-frame (λ (f) (send f replace&search 'forward))))
(add "replace & search backward"
(send-frame (λ (f) (send f replace&search 'backward))))
(add "unhide search and toggle focus"
(send-frame (λ (f) (send f unhide-search-and-toggle-focus))))
(add "hide-search"
(send-frame (λ (f) (send f hide-search))))
(map "c:g" "hide-search")
(map "f3" "unhide search and toggle focus")
(map "c:s" "unhide search and toggle focus")
(map "c:r" "search backward")
(case (system-type)
[(unix)
(map-meta "%" "search forward")])))))
(define setup-file
(let* ([get-outer-editor ;; : text% -> text%
;; returns the outermost editor, if this editor is nested in an editor snip.
(λ (edit)
(let loop ([edit edit])
(let ([admin (send edit get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(loop (send (send (send admin get-snip) get-admin) get-editor))]
[else edit]))))]
[save-file-as
(λ (this-edit event)
(let ([edit (get-outer-editor this-edit)])
(parameterize ([finder:dialog-parent-parameter
(and (is-a? edit editor:basic<%>)
(send edit get-top-level-window))])
(let ([file (finder:put-file)])
(when file
(send edit save-file/gui-error file)))))
#t)]
[save-file
(λ (this-edit event)
(let ([edit (get-outer-editor this-edit)])
(if (send edit get-filename)
(send edit save-file/gui-error)
(save-file-as edit event)))
#t)]
[load-file
(λ (edit event)
(define (fallback)
(let ([fn (send edit get-filename)])
(handler:open-file
(and fn
(let-values ([(base name dir) (split-path fn)])
base)))))
(cond
[(is-a? edit editor:basic<%>)
(define fr (send edit get-top-level-window))
(cond
[(is-a? fr frame:standard-menus<%>)
(send fr file-menu:open-callback
(send fr file-menu:get-open-item)
event)]
[else (fallback)])]
[else (fallback)])
#t)])
(λ (kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f])
(let* ([map (λ (key func)
(send kmap map-function key func))]
[map-meta (λ (key func)
(send-map-function-meta kmap key func
(regexp-match? has-control-regexp key)
#:alt-as-meta-keymap alt-as-meta-keymap))]
[add (λ (name func)
(send kmap add-function name func))]
[add-m (λ (name func)
(send kmap add-function name func)
(when alt-as-meta-keymap
(send alt-as-meta-keymap add-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")))))
(define (setup-editor kmap)
(let ([add/map
(λ (func op key)
(send kmap add-function
func
(λ (editor evt)
(send editor do-edit-operation op)))
(send kmap map-function
(string-append
(case (system-type)
[(macosx macos) "d:"]
[(windows unix) "c:"]
[else (error 'keymap.rkt "unknown platform: ~s" (system-type))])
key)
func))])
(add/map "editor-undo" 'undo "z")
(unless (eq? (system-type) 'macosx)
(add/map "editor-redo" 'redo "y"))
(add/map "editor-cut" 'cut "x")
(add/map "editor-copy" 'copy "c")
(add/map "editor-paste" 'paste "v")
(add/map "editor-select-all" 'select-all "a")))
(define (generic-setup keymap)
(add-editor-keymap-functions keymap)
(add-pasteboard-keymap-functions keymap)
(add-text-keymap-functions keymap))
(define user-keymap (make-object aug-keymap%))
(define (get-user) user-keymap)
(define global (make-object aug-keymap%))
(define global-main (make-object aug-keymap%))
(define global-alt-as-meta (make-object aug-keymap%))
(send global chain-to-keymap global-main #f)
(generic-setup global-main)
(generic-setup global-alt-as-meta)
(setup-global global-main #:alt-as-meta-keymap global-alt-as-meta)
(define (get-global) global)
(define file (make-object aug-keymap%))
(define file-alt-as-meta (make-object aug-keymap%))
(generic-setup file)
(setup-file file #:alt-as-meta-keymap file-alt-as-meta)
(define (-get-file) file)
(define search (make-object aug-keymap%))
(define search-alt-as-meta (make-object aug-keymap%))
(generic-setup search)
(setup-search search #:alt-as-meta-keymap search-alt-as-meta)
(define (get-search) search)
(define editor (make-object aug-keymap%))
(setup-editor editor)
(define (get-editor) editor)
(preferences:set-default 'framework:alt-as-meta #f boolean?)
(define (adjust-alt-as-meta on?)
(send global-main remove-chained-keymap global-alt-as-meta)
(send file remove-chained-keymap file-alt-as-meta)
(send search remove-chained-keymap search-alt-as-meta)
(when on?
(send global-main chain-to-keymap global-alt-as-meta #f)
(send file chain-to-keymap file-alt-as-meta #f)
(send search chain-to-keymap search-alt-as-meta #f)))
(preferences:add-callback 'framework:alt-as-meta
(λ (p v) (adjust-alt-as-meta v)))
(adjust-alt-as-meta (preferences:get 'framework:alt-as-meta)))