-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathkeys.rkt
209 lines (193 loc) · 7.44 KB
/
keys.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
#lang s-exp framework/keybinding-lang
;; frame-key (see drracket docs)
;; Bind key using drracket's extension API
;; Automatically adds the default shortcut prefix (normally c:)
(define modifiers
(apply string-append
(map (λ (p) (case p
[(ctl) "c:"]
[(cmd) "d:"]
[(alt meta) "~c:m:"]
[(shift) "s:"]
[(option) "a:"]))
(get-default-shortcut-prefix))))
(define-syntax-rule (frame-key key command)
(keybinding
(string-append modifiers key)
(λ (ed evt)
(when (is-a? ed text:basic<%>)
(define fr (send ed get-top-level-window))
; note: fr could be #f
(when fr (send fr command))))))
;; -------------------------------------------------------------------------------
;; rebind (see drracket docs 3.3.9)
;; Bind key to duplicate an existing shortcut, using the name from the
;; "Show Active Keybindings" dialog
(define (rebind key command)
(keybinding
key
(λ (ed evt)
(send (send ed get-keymap) call-function
command ed evt #t))))
;; -------------------------------------------------------------------------------
;; menu-bind (see drracket docs 3.3.9)
;; Bind key to menu item by name
(define (menu-bind key menu-item)
(keybinding
key
(λ (ed evt)
(define canvas (send ed get-canvas))
(when canvas
(define menu-bar (find-menu-bar canvas))
(when menu-bar
(define item (find-item menu-bar menu-item))
(when item
(define menu-evt
(new control-event%
[event-type 'menu]
[time-stamp
(send evt get-time-stamp)]))
(send item command menu-evt)))))))
(define/contract (find-menu-bar c)
(-> (is-a?/c area<%>) (or/c #f (is-a?/c menu-bar%)))
(let loop ([c c])
(cond
[(is-a? c frame%) (send c get-menu-bar)]
[(is-a? c area<%>) (loop (send c get-parent))]
[else #f])))
(define/contract (find-item menu-bar label)
(-> (is-a?/c menu-bar%)
string?
(or/c (is-a?/c selectable-menu-item<%>) #f))
(let loop ([o menu-bar])
(cond
[(is-a? o selectable-menu-item<%>)
(and (equal? (send o get-plain-label) label)
o)]
[(is-a? o menu-item-container<%>)
(for/or ([i (in-list (send o get-items))])
(loop i))]
[else #f])))
;; -------------------------------------------------------------------------------
;; Sending expressions to the Interactions window (see drracket docs 3.3.10)
(require drracket/tool-lib)
(define/contract (send-toplevel-form defs shift-focus?)
(-> any/c boolean? any)
(when (is-a? defs drracket:unit:definitions-text<%>)
(define sp (send defs get-start-position))
(when (= sp (send defs get-end-position))
(cond
[(send defs find-up-sexp sp)
;; we are inside some top-level expression;
;; find the enclosing expression
(let loop ([pos sp])
(define next-up (send defs find-up-sexp pos))
(cond
[next-up (loop next-up)]
[else
(send-range-to-repl defs
pos
(send defs get-forward-sexp pos)
shift-focus?)]))]
[else
;; we are at the top-level
(define fw (send defs get-forward-sexp sp))
(define bw (send defs get-backward-sexp sp))
(cond
[(and (not fw) (not bw))
;; no expressions in the file, give up
(void)]
[(not fw)
;; no expression after the insertion point;
;; send the one before it
(send-range-to-repl defs
bw
(send defs get-forward-sexp bw)
shift-focus?)]
[else
;; send the expression after the insertion point
(send-range-to-repl defs
(send defs get-backward-sexp fw)
fw
shift-focus?)])]))))
(define/contract (send-selection defs shift-focus?)
(-> any/c boolean? any)
(when (is-a? defs drracket:unit:definitions-text<%>)
(send-range-to-repl defs
(send defs get-start-position)
(send defs get-end-position)
shift-focus?)))
(define/contract (send-range-to-repl defs start end shift-focus?)
(->i ([defs (is-a?/c drracket:unit:definitions-text<%>)]
[start exact-positive-integer?]
[end (start) (and/c exact-positive-integer? (>=/c start))]
[shift-focus? boolean?])
any)
(unless (= start end) ;; don't send empty regions
(define ints (send (send defs get-tab) get-ints))
(define frame (send (send defs get-tab) get-frame))
;; copy the expression over to the interactions window
(send defs move/copy-to-edit
ints start end
(send ints last-position)
#:try-to-move? #f)
;; erase any trailing whitespace
(let loop ()
(define last-pos (- (send ints last-position) 1))
(when (last-pos . > . 0)
(define last-char (send ints get-character last-pos))
(when (char-whitespace? last-char)
(send ints delete last-pos (+ last-pos 1))
(loop))))
;; put back a single newline
(send ints insert
"\n"
(send ints last-position)
(send ints last-position))
;; make sure the interactions is visible
;; and run the submitted expression
(send frame ensure-rep-shown ints)
(when shift-focus? (send (send ints get-canvas) focus))
(send ints do-submission)))
(define/contract (send-form defs shift-focus?)
(-> any/c boolean? any)
(when (is-a? defs drracket:unit:definitions-text<%>)
(define sp (send defs get-start-position))
(when (= sp (send defs get-end-position))
(define fw (send defs get-forward-sexp sp))
(define bw (send defs get-backward-sexp sp))
(cond
[(and (not fw) (not bw))
;; no expressions in the file, give up
(void)]
[(not fw)
;; no expression after the insertion point;
;; send the one before it
(send-range-to-repl defs
bw
(send defs get-forward-sexp bw)
shift-focus?)]
[else
;; send the expression after the insertion point
(send-range-to-repl defs
(send defs get-backward-sexp fw)
fw
shift-focus?)]))))
;; -------------------------------------------------------------------------------
(define-syntax-rule (keybind-toplevel-cmd key cmd)
(keybinding key
(λ (editor evt)
(let ((top (send editor get-top-level-window)))
(send top cmd)))))
;; Warning: user defined c:x; prefix bindings interfere with builtin c:x; bindings
(keybind-toplevel-cmd "m:-" close-current-tab)
(keybind-toplevel-cmd "m:=" create-new-tab)
;; (rebind "menu" "mouse-popup-menu")
(menu-bind "c:.;c:c" "Quit")
(rebind "m:o" "shift-focus")
(menu-bind "m:r" "Revert")
(menu-bind "m:h;p" "Preferences...")
(menu-bind "m:h;k" "Show Active Keybindings")
(keybinding "c:.;c:d" (λ (ed evt) (send-toplevel-form ed #f)))
(keybinding "c:.;c:e" (λ (ed evt) (send-form ed #f)))
(keybinding "c:.;c:r" (λ (ed evt) (send-selection ed #f)))