-
Notifications
You must be signed in to change notification settings - Fork 11
/
hmouse-drv.el
1782 lines (1625 loc) · 71.6 KB
/
hmouse-drv.el
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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; hmouse-drv.el --- Smart Key/Mouse driver functions. -*- lexical-binding: t; -*-
;;
;; Author: Bob Weiner
;;
;; Orig-Date: 04-Feb-90
;; Last-Mod: 25-Jun-24 at 02:13:58 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
;; Copyright (C) 1989-2024 Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
;;
;; This file is part of GNU Hyperbole.
;;; Commentary:
;;; Code:
;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************
(require 'hui-window)
(require 'hypb)
;;; ************************************************************************
;;; Public declarations
;;; ************************************************************************
(declare-function br-in-view-window-p "ext:br")
(declare-function br-next-listing-window "ext:br")
(declare-function br-to-view-window "ext:br")
(declare-function ace-window "ext:ace-window")
(declare-function ace-window-display-mode "ext:ace-window")
(declare-function aw-select "ext:ace-window")
(defvar aw-dispatch-alist)
(defvar aw-dispatch-always)
(defvar aw-frame-size)
(defvar aw-keys)
;; window-jump
(declare-function window-jump "ext:window-jump")
(defvar wj-vec-left)
(defvar wj-vec-right)
(defvar wj-vec-down)
(defvar wj-vec-up)
(defvar start-window)
(defvar aw-scope)
(defvar hkey-value) ; "hui-mouse.el"
(defvar hmouse-alist) ; "hui-mouse.el"
(defvar hkey-alist) ; "hui-mouse.el"
(defvar hmouse-set-point-command) ; "hui-mouse.el"
(defvar hyperbole-mode-map) ; "hyperbole.el"
(defvar action-key-default-function) ; defcustom hui-mouse
(defvar assist-key-default-function) ; defcustom hui-mouse
(declare-function mouse-drag-frame "mouse") ;; Obsolete from Emacs 28
(declare-function hkey-quit-window "hmouse-drv") ; Alias defined in this file.
(declare-function hattr:report "hbut")
(declare-function hattr:list "hbut")
(declare-function br-in-browser "hpath")
(declare-function hbut:label "hbut")
(declare-function hattr:get "hbut")
(declare-function hui:ebut-link-directly "hui")
(declare-function hui:ibut-link-directly "hui")
(declare-function hkey-set-key "hyperbole")
(declare-function org-todo "org")
;;; ************************************************************************
;;; Public variables
;;; ************************************************************************
(defvar hmouse-verify-release-window-flag t
"Non-nil means verify Smart Mouse Keys are released in or out of an Emacs frame.
Presently, this does nothing unless Emacs is running under the
macOS window system. It queries the Mac window manager for the
name of the owner of the top-most window at the point of release,
if any. Otherwise, if an Emacs frame is below another
application's window at the point of release, Emacs will report
that the release point was in its frame.
See function `hmouse-window-at-absolute-pixel-position' for more details.")
(defvar action-key-depressed-flag nil "Non-nil means Action Key is depressed.")
(defvar assist-key-depressed-flag nil "Non-nil means Assist Key is depressed.")
(defvar action-key-depress-args nil
"List of event args from most recent depress of the Action Mouse Key.")
(defvar assist-key-depress-args nil
"List of event args from most recent depress of the Assist Mouse Key.")
(defvar action-key-release-args nil
"List of event args from most recent release of the Action Mouse Key.")
(defvar assist-key-release-args nil
"List of event args from most recent release of the Assist Mouse Key.")
(defvar action-key-depress-buffer nil
"The last buffer in which the Action Key was depressed or nil.
This is set to nil when the depress is on an inactive minibuffer.")
(defvar assist-key-depress-buffer nil
"The last buffer in which the Assist Key was depressed or nil.
This is set to nil when the depress is on an inactive minibuffer.")
(defvar action-key-release-buffer nil
"The last buffer in which the Action Key was released or nil.")
(defvar assist-key-release-buffer nil
"The last buffer in which the Assist Key was released or nil.")
(defvar action-key-depress-window nil
"The last window in which the Action Key was depressed or nil.
This is set to nil when the depress is on an inactive minibuffer.")
(defvar assist-key-depress-window nil
"The last window in which the Assist Key was depressed or nil.
This is set to nil when the depress is on an inactive minibuffer.")
(defvar action-key-release-window nil
"The last window in which the Action Key was released or nil.")
(defvar assist-key-release-window nil
"The last window in which the Assist Key was released or nil.")
;; These store mouse positions when a Smart Mouse key is pressed.
(defvar action-key-depress-position nil
"The last mouse screen position at which the Action Key was depressed or nil.")
(defvar assist-key-depress-position nil
"The last mouse screen position at which the Assist Key was depressed or nil.")
(defvar action-key-release-position nil
"The last mouse screen position at which the Action Key was released or nil.")
(defvar assist-key-release-position nil
"The last mouse screen position at which the Assist Key was released or nil.")
(defvar action-key-depress-prev-point nil
"Marker at point prior to last Action Key depress.
Note that this may be a buffer different than where the depress occurs.")
(defvar assist-key-depress-prev-point nil
"Marker at point prior to last Assist Key depress.
Note that this may be a buffer different than where the depress occurs.")
(defvar action-key-release-prev-point nil
"Marker at point prior to last Action Key release.
Note that this may be a buffer different than where the release occurs.")
(defvar assist-key-release-prev-point nil
"Marker at point prior to last Assist Key release.
Note that this may be a buffer different than where the release occurs.")
(defvar action-key-cancelled nil
"When non-nil, cancels last Action Key depress.")
(defvar assist-key-cancelled nil
"When non-nil, cancels last Assist Key depress.")
(defvar action-key-help-flag nil
"Non-nil means it forces display of help for next Action Key release.")
(defvar assist-key-help-flag nil
"Non-nil means it forces display of help for next Assist Key release.")
(defvar assist-flag nil
"Non-nil means Hyperbole's Assist Key is in use rather than the Action Key.
Never set directly. Bound as a parameter when `hkey-execute' is called
and then used as a free variable.")
(defcustom hkey-debug nil
"Non-nil display a message with the context and values from Smart Key activation.
Default is nil."
:type 'boolean
:group 'hyperbole-commands)
(defvar hkey-region nil
"Used to pass the value of a region between a Smart Key depress and release.
This permits the Smart Keys to behave as paste keys.")
;;; ************************************************************************
;;; Private variables
;;; ************************************************************************
(defvar action-mouse-key-prev-window nil
"Window point was in prior to current invocation of `action/assist-mouse-key'.")
(defvar action-mouse-key-prefix-arg nil
"Prefix argument to pass to `smart-br-cmd-select'.")
(defvar hkey-help-msg "" "Holds last Smart Key help message.")
(defvar hkey--wconfig nil
"Window configuration within current frame prior to display of a help buffer.")
;;; ************************************************************************
;;; Hyperbole context-sensitive key driver functions
;;; ************************************************************************
(defun hkey-absolute-pixel-position ()
"Return the absolute pixel position of the mouse or the selected window's point."
(if (mouse-event-p last-input-event)
(mouse-absolute-pixel-position)
(window-absolute-pixel-position)))
;;; Smart Key Depress Functions
(defun action-key-depress (&rest args)
"Register depress of the Hyperbole Action Mouse Key."
(interactive)
(cond (assist-key-depressed-flag
(or action-key-help-flag
(setq assist-key-help-flag t)))
((hmouse-save-region)))
(setq action-key-depress-prev-point (point-marker)
action-key-depressed-flag t
action-key-depress-args (hmouse-set-point args)
action-key-depress-buffer (window-buffer (hmouse-depress-inactive-minibuffer-p args))
action-key-depress-window (or (hmouse-depress-inactive-minibuffer-p args)
(selected-window))
action-key-depress-position (hkey-absolute-pixel-position)
action-key-release-args nil
action-key-release-buffer nil
action-key-release-window nil
action-key-release-prev-point nil)
(when (and (not assist-key-depressed-flag)
(hmouse-modeline-event-p action-key-depress-args))
(mouse-drag-mode-line action-key-depress-args))
(when (eq last-command #'org-todo)
(setq this-command #'org-todo))
(run-hooks 'action-key-depress-hook))
(defun assist-key-depress (&rest args)
"Register depress of the Hyperbole Assist Mouse Key."
(interactive)
(cond (action-key-depressed-flag
(or assist-key-help-flag
(setq action-key-help-flag t)))
((hmouse-save-region)))
(setq assist-key-depress-prev-point (point-marker)
assist-key-depressed-flag t
assist-key-depress-args (hmouse-set-point args)
assist-key-depress-buffer (window-buffer (hmouse-depress-inactive-minibuffer-p args))
assist-key-depress-window (or (hmouse-depress-inactive-minibuffer-p args)
(selected-window))
assist-key-depress-position (hkey-absolute-pixel-position)
assist-key-release-args nil
assist-key-release-buffer nil
assist-key-release-window nil
assist-key-release-prev-point nil)
(when (and (not action-key-depressed-flag)
(hmouse-modeline-event-p assist-key-depress-args))
(mouse-drag-mode-line assist-key-depress-args))
(when (eq last-command #'org-todo)
(setq this-command #'org-todo))
(run-hooks 'assist-key-depress-hook))
(defun action-key-depress-emacs (event)
"Handle depress EVENT of the Hyperbole Action Mouse Key."
(interactive "e")
(action-key-depress event))
(defun assist-key-depress-emacs (event)
"Handle depress EVENT of the Hyperbole Assist Mouse Key."
(interactive "e")
(assist-key-depress event))
;;; Smart Key Release Functions
(defun action-mouse-key-emacs (event)
"Set point to the current mouse cursor position and execute `action-key'.
EVENT will be passed to `hmouse-release'."
(interactive "e")
(apply #'action-mouse-key (hmouse-key-release-args-emacs event)))
(defun assist-mouse-key-emacs (event)
"Set point to the current mouse cursor position and execute `assist-key'.
EVENT will be passed to `hmouse-release'."
(interactive "e")
(apply #'assist-mouse-key (hmouse-key-release-args-emacs event)))
(defun action-mouse-key (&rest args)
"Set point to the mouse or keyboard cursor position and execute `action-key'.
Any ARGS will be passed to `hmouse-release'."
(interactive)
;; Make this a no-op if some local mouse key binding overrode the global
;; action-key-depress command invocation.
(when action-key-depressed-flag
(hmouse-release nil)
(let ((hkey-alist hmouse-alist))
(cond (action-key-cancelled
(setq action-key-cancelled nil
assist-key-depressed-flag nil))
(assist-key-depressed-flag
(hmouse-function nil nil args))
((hkey-mouse-help nil args))
(t
(run-hooks 'action-key-release-hook)
(hmouse-function #'action-key-internal nil args)))
;; Need to clear these variables so that mouse pasting does
;; not occur repeatedly from a single region selection.
(setq hkey-region nil
hkey-value nil))))
(defun assist-mouse-key (&rest args)
"Set point to the mouse or keyboard cursor position and execute `assist-key'.
Any ARGS will be passed to `hmouse-release'."
(interactive)
;; Make this a no-op if some local mouse key binding overrode the global
;; assist-key-depress command invocation.
(when assist-key-depressed-flag
(hmouse-release t)
(let ((hkey-alist hmouse-alist))
(cond (assist-key-cancelled
(setq assist-key-cancelled nil
action-key-depressed-flag nil))
(action-key-depressed-flag
(hmouse-function nil t args))
((hkey-mouse-help t args))
(t
(run-hooks 'assist-key-release-hook)
(hmouse-function #'assist-key-internal t args)))
;; Need to clear this variable so that mouse pasting does
;; not occur repeatedly from a single region selection.
(setq hkey-region nil
hkey-value nil))))
;;; Smart Key Commands
(defun action-key-clear-variables ()
"Clear all Action Key variables."
;; Clear all these variables so there can be no confusion between
;; mouse presses and keyboard presses.
(setq action-key-depress-prev-point nil
action-key-depress-position nil
action-key-depress-args nil
action-key-depress-buffer nil
action-key-depress-window nil
action-key-release-position nil
action-key-release-args nil
action-key-release-buffer nil
action-key-release-window nil
action-key-release-prev-point nil))
(defun assist-key-clear-variables ()
"Clear all Assist Key variables."
;; Clear all these variables so there can be no confusion between
;; mouse presses and keyboard presses.
(setq assist-key-depress-prev-point nil
assist-key-depress-position nil
assist-key-depress-args nil
assist-key-depress-buffer nil
assist-key-depress-window nil
assist-key-release-position nil
assist-key-release-args nil
assist-key-release-buffer nil
assist-key-release-window nil
assist-key-release-prev-point nil))
(defun action-key ()
"Use one key to perform functions that vary by context.
If no matching context is found, the default function set with
the `action-key-default-function' variable is run. Return t
unless the `action-key-default-function' variable is not bound to
a valid function."
(interactive)
(action-key-clear-variables)
(unwind-protect
(prog1 (action-key-internal)
(run-hooks 'action-key-depress-hook 'action-key-release-hook))
(setq action-key-depressed-flag nil)))
(defun action-key-internal ()
"Action key internal."
(setq action-key-depressed-flag t)
(when action-key-cancelled
(setq action-key-cancelled nil
assist-key-depressed-flag nil))
(or (hkey-execute nil)
(when (fboundp action-key-default-function)
(funcall action-key-default-function)
t)))
(defun assist-key ()
"Use one key to perform functions that vary by context.
If no matching context is found, the default function set with
the `assist-key-default-function' variable is run. Return
non-nil unless `assist-key-default-function' variable is not
bound to a valid function."
(interactive)
(assist-key-clear-variables)
(unwind-protect
(prog1 (assist-key-internal)
(run-hooks 'assist-key-depress-hook 'assist-key-release-hook))
(setq assist-key-depressed-flag nil)))
(defun assist-key-internal ()
"Assist key internal."
(setq assist-key-depressed-flag t)
(when assist-key-cancelled
(setq assist-key-cancelled nil
action-key-depressed-flag nil))
(or (hkey-execute t)
(when (fboundp assist-key-default-function)
(funcall assist-key-default-function)
t)))
(defun hkey-either (&optional arg)
"Execute `action-key' or with non-nil ARG execute `assist-key'."
(interactive "P")
(when (and (featurep 'hycontrol)
(or hycontrol-windows-mode hycontrol-frames-mode))
;; Ignore any prefix arg set by HyControl and use prefix arg
;; only if it was given by a user as any number of C-u presses
;; and is therefore a list.
(unless (listp arg) (setq arg nil)))
(if arg (assist-key) (action-key)))
;;; ************************************************************************
;;; Hyperbole ace-window selection functions
;;; https://github.com/abo-abo/ace-window
;;; ************************************************************************
;; A call to (hkey-ace-window-setup) or (require 'ace-window) must be
;; made prior to calling any other function in this section since
;; Hyperbole does not require ace-window itself.
;;;###autoload
(defun hkey-ace-window-setup (&optional key)
"Bind optional keyboard KEY and setup display of items specified by short ids.
The ace-window package, (see \"https://elpa.gnu.org/packages/ace-window.html\"),
assigns short ids to each Emacs window and lets you jump to or
operate upon a specific window by giving its letter. Hyperbole
can insert an operation into ace-window that allows you to
display items such as Dired or buffer menu items in a specific
window.
To enable this feature, in your Emacs initialization file after
Hyperbole is initialized, if you already have a key bound for
ace-window, then call:
(hkey-ace-window-setup)
otherwise, choose a binding like {\\`M-o'} and send it to the same
function to bind it:
(hkey-ace-window-setup \"\M-o\")
Then whenever point is on an item you want displayed in another
window, use {\\`M-o' i <id-of-window-to-display-item-in>} and watch the
magic happen."
(require 'ace-window)
(when key (hkey-set-key key 'ace-window))
(setq aw-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)
;; allows {i} operation to work when only 2 windows exist
aw-dispatch-always t)
;; New ace-window frames (window id = z) inherit the size of the
;; prior selected frame; same as HyWindow.
(setq aw-frame-size '(0 . 0)
aw-dispatch-alist (delq (assq ?i aw-dispatch-alist)
(delq (assq ?r aw-dispatch-alist)
(delq (assq ?t aw-dispatch-alist)
(delq (assq ?w aw-dispatch-alist) aw-dispatch-alist)))))
(push '(?w hkey-window-link "Hyperbole: Window Link") aw-dispatch-alist)
(push '(?t hkey-throw "Hyperbole: Throw") aw-dispatch-alist)
(push '(?r hkey-replace "Hyperbole: Replace Here") aw-dispatch-alist)
;; Ace-window includes ?m as the swap windows key, so it is not added here.
(push '(?i hkey-drag-item "Hyperbole: Drag Item") aw-dispatch-alist)
(ace-window-display-mode 1))
;;;###autoload
(defun hkey-drag (release-window)
"Emulate Smart Mouse Key drag from the selected window to RELEASE-WINDOW.
When called interactively the RELEASE-WINDOW is chosen via
ace-window. The drag action determines the final selected
window.
Optional prefix arg non-nil means emulate Assist Key rather than the
Action Key.
Works only when running under a window system, not from a dumb terminal."
;; Note: Cannot add free variable start-window as first parameter to this
;; function because it is called like many other functions herein with a
;; single release-window argument by 'hmouse-choose-windows'.
;; Cancel any partial drag that may have been recorded.
(interactive (list (aw-select " Ace - Hyperbole: Drag")))
(condition-case nil
;; This may trigger a No Action error if starting window
;; (window of depress) and release-window are the same; in that
;; case: use the error handler to emulate dragging an item if on
;; one.
(progn (if current-prefix-arg
(setq assist-key-depressed-flag nil)
(setq action-key-depressed-flag nil))
(hkey-operate current-prefix-arg)
(when (window-live-p release-window)
(hypb:select-window-frame release-window))
(hkey-operate current-prefix-arg))
(error (when (eq start-window release-window)
(hmouse-drag-item-to-display)))))
;;;###autoload
(defun hkey-drag-stay (release-window)
"Emulate Smart Mouse Key drag from selected window to RELEASE-WINDOW.
When called interactively the RELEASE-WINDOW is chosen via
ace-window. After the drag, the selected window remains the same
as it was before the drag.
Works only when running under a window system, not from a dumb terminal."
(let ((start-window (selected-window)))
(unwind-protect
(hkey-drag release-window)
;; Leave start-window selected
(when (window-live-p start-window)
(hypb:select-window-frame start-window)))))
;;;###autoload
(defun hkey-drag-item (release-window)
"Emulate Smart Mouse Key drag from item in a selected window to RELEASE-WINDOW.
When called interactively the RELEASE-WINDOW is chosen via
ace-window. RELEASE-WINDOW is left selected unless point is not
on an item, in which case, an error is signalled.
Optional prefix arg non-nil means emulate Assist Key rather than the
Action Key.
Works only when running under a window system, not from a dumb terminal."
(interactive
(list (let ((mode-line-text (concat " Ace - " (nth 2 (assq ?i aw-dispatch-alist)))))
(aw-select mode-line-text))))
(let ((start-window (if (and (boundp 'start-window) (window-live-p start-window))
start-window
(if current-prefix-arg
assist-key-depress-window
action-key-depress-window)))
at-item-flag)
(unless (window-live-p start-window)
(setq start-window (selected-window)))
(cond ((and (setq at-item-flag (hmouse-at-item-p start-window))
(window-live-p release-window))
(hkey-drag release-window)
;; Leave release-window selected
(when (window-live-p release-window)
(hypb:select-window-frame release-window)))
((not at-item-flag)
(error "(hkey-drag-item): No listing item at point"))
(t ;; No item at point or selected release is invalid
(error "(hkey-drag-item): No item at point or invalid final window, %s" release-window)))))
;;;###autoload
(defun hkey-drag-to (release-window)
"Emulate Smart Mouse Key drag from a selected window to RELEASE-WINDOW.
When called interactively the RELEASE-WINDOW is chosen via
ace-window. If an item is dragged to RELEASE-WINDOW, then
RELEASE-WINDOW is selected; otherwise, the drag action determines
the selected window. If no drag has taken place, then the
selected window's buffer is displayed in RELEASE-WINDOW and that
becomes the selected window.
Optional prefix arg non-nil means emulate Assist Key rather than the
Action Key.
Works only when running under a window system, not from a dumb terminal."
(interactive
(list (let ((mode-line-text (concat " Ace - " (nth 2 (assq ?i aw-dispatch-alist)))))
(aw-select mode-line-text))))
(let ((start-window (if (and (boundp 'start-window) (window-live-p start-window))
start-window
(if current-prefix-arg
assist-key-depress-window
action-key-depress-window))))
(unless (window-live-p start-window)
(setq start-window (selected-window)))
(if (and (hmouse-at-item-p start-window) (window-live-p release-window))
(progn (hkey-drag release-window)
;; Leave release-window selected
(when (window-live-p release-window)
(hypb:select-window-frame release-window)))
;; Leave hkey-drag to choose final selected window
(hkey-drag release-window))))
;;;###autoload
(defun hkey-link (release-window)
"Return a list of the selected window (where depressed) and the RELEASE-WINDOW."
(list (selected-window) release-window))
;;;###autoload
(defun hkey-replace (release-window)
"Grab the buffer from RELEASE-WINDOW and place it into the current window.
When called interactively the RELEASE-WINDOW is chosen via
ace-window. The selected window does not change."
(interactive
(list (let ((mode-line-text (concat " Ace - " (nth 2 (assq ?r aw-dispatch-alist)))))
(aw-select mode-line-text))))
(set-window-buffer (selected-window) (window-buffer release-window)))
;;;###autoload
(defun hkey-swap (to-window)
"Swap the buffer from the selected window with that of TO-WINDOW.
When called interactively the TO-WINDOW is chosen via ace-window. Leave
TO-WINDOW as the selected window."
(interactive
(list (let ((mode-line-text (concat " Ace - Hyperbole: " (nth 2 (assq ?m aw-dispatch-alist)))))
(aw-select mode-line-text))))
(hkey-swap-buffers (selected-window) to-window))
;; Once the "display-until.el" library is added to Emacs, hkey-throw can be simplified to the following:
;;
;; (defun hkey-throw (release-window)
;; "Throw either a displayable item at point or the current buffer for display in RELEASE-WINDOW.
;; The selected window does not change."
;; (interactive
;; (list (let ((mode-line-text (concat " Ace - " (nth 2 (assq ?t aw-dispatch-alist)))))
;; (aw-select mode-line-text))))
;; (if (cadr (assq major-mode hmouse-drag-item-mode-forms))
;; ;; Throw the item at point
;; (let ((action-key-depress-window (selected-window))
;; (action-key-release-window release-window)
;; (action-key-depress-args))
;; (hmouse-item-to-window)
;; (select-window action-key-depress-window)
;; (display-window-until release-window))
;; ;; Throw the current buffer
;; (display-window-until release-window (current-buffer))))
;;;###autoload
(defun hkey-throw (release-window &optional throw-region-flag)
"Throw a thing to display in RELEASE-WINDOW.
Throw one of:
- the active (highlighted) region,
- a displayable item at point or
- the current buffer.
With optional prefix arg THROW-REGION-FLAG, throw the current region
even if not active.
The selected window does not change."
(interactive (list (ace-window nil) current-prefix-arg))
(let ((depress-frame (selected-frame))
(display-delay (if (boundp 'temp-display-delay)
temp-display-delay
0.5)))
;; Throw either the region or the item at point and keep selected-window
(let ((action-key-depress-window (selected-window))
(action-key-release-window release-window)
(action-key-depress-args))
(hypb:save-selected-window-and-input-focus
(unless (hkey-insert-region action-key-depress-window release-window throw-region-flag display-delay)
(if (cadr (assq major-mode hmouse-drag-item-mode-forms))
(hmouse-item-to-window)
(set-window-buffer release-window (current-buffer))))
(unless (eq depress-frame (window-frame release-window))
;; Force redisplay or item buffer won't be displayed here.
(redisplay t)
;; Show the frame thrown to before it is covered when
;; input-focus is returned to the depress-frame.
(raise-frame (window-frame release-window))
;; Don't use sit-for here because it can be interrupted early.
(sleep-for display-delay))))))
;;;###autoload
(defun hkey-window-link (release-window)
"Create a but in the selected window, linked to point in RELEASE-WINDOW.
RELEASE-WINDOW is interactively selected via the `ace-window' command.
The selected window does not change.
With no prefix argument, create an unnamed implicit button.
With a single \\`C-u' \\='(4) prefix argument, create an explicit button.
With any other prefix argument, like M-1, create an named implicit button."
(interactive
(list (let ((mode-line-text (concat " Ace - Hyperbole: " (nth 2 (assq ?w aw-dispatch-alist)))))
(aw-select mode-line-text))))
(unless (window-live-p release-window)
(error "(hkey-window-link): Invalid release window: %s" release-window))
(let ((start-window (selected-window)))
(unwind-protect
(progn
(funcall (if (equal current-prefix-arg '(4))
#'hui:ebut-link-directly
#'hui:ibut-link-directly)
start-window release-window)
release-window)
;; Leave start-window selected
(when (window-live-p start-window)
(hypb:select-window-frame start-window)))))
(defun hkey-insert-region (depress-window release-window throw-region-flag display-delay)
"Throw any active (highlighted) region from DEPRESS-WINDOW to RELEASE-WINDOW.
If THROW-REGION-FLAG is non-nil, the region is thrown even if not
active, unless the buffers in DEPRESS-WINDOW and RELEASE-WINDOW are
the same, then the region is not thrown.
Highlight the thrown region for DISPLAY-DELAY seconds.
Return t if thrown, else nil."
(when (or (use-region-p) throw-region-flag)
(cond ((or (not (window-live-p depress-window))
(not (window-live-p release-window)))
(user-error "(hkey-insert-region): Invalid window: depress window: '%s'; release window: '%s'"
depress-window release-window))
((> (region-end) (region-beginning))
;; Non-empty region
(if (and (eq (window-buffer depress-window) (window-buffer release-window))
(<= (region-beginning) (window-point release-window))
(>= (region-end) (window-point release-window)))
(user-error "(hkey-insert-region): Can't throw region to a point within the region")
(let* ((orig-buf (current-buffer))
(orig-start (region-beginning))
(orig-end (region-end))
(len (- orig-end orig-start))
insert-start
insert-end)
(select-window release-window 'mark-for-redisplay)
(setq insert-start (point)
insert-end (+ insert-start len))
(insert-buffer-substring orig-buf orig-start orig-end)
(hmouse-pulse-region insert-start insert-end)
(sit-for display-delay)
t)))
(t (user-error "(hkey-insert-region): Can't throw an empty region")))))
;;;###autoload
(defun hkey-buffer-to (from-window to-window)
"Display buffer from FROM-WINDOW in TO-WINDOW.
When interactive use ace-window to choose FROM-WINDOW and
TO-WINDOW. The selected window does not change."
(interactive
(list (aw-select " Ace - Hyperbole: Buffer to Show")
(aw-select " Ace - Hyperbole: Show in Window")))
(with-selected-window from-window
(set-window-buffer to-window (current-buffer))))
;;;###autoload
(defun hkey-swap-buffers (from-window to-window)
"Swap buffer from FROM-WINDOW with buffer of TO-WINDOW.
When interactive use ace-window to choose FROM-WINDOW and
TO-WINDOW. Leave TO-WINDOW as the selected window."
(interactive
(list (aw-select " Ace - Hyperbole: Swap from Buffer1...")
(aw-select " Ace - Hyperbole: ...to Buffer2")))
(let ((from-buf (window-buffer from-window))
(to-buf (window-buffer to-window)))
(set-window-buffer from-window to-buf)
(set-window-buffer to-window from-buf)
(hypb:select-window-frame to-window)))
;;; ************************************************************************
;;; Hyperbole mouse click window selection functions
;;; ************************************************************************
;;;###autoload
(defun hmouse-click-to-drag ()
"Mouse click on start and end windows for use with `hkey-drag'.
Emulate Smart Mouse Key drag from start window to end window.
The drag action determines the final selected window."
(interactive)
(hmouse-choose-windows #'hkey-drag))
;;;###autoload
(defun hmouse-click-to-drag-stay ()
"Mouse click on start and end windows for use with `hkey-drag-stay'.
Emulate Smart Mouse Key drag from start window to end window.
The selected window does not change."
(interactive)
(hmouse-choose-windows #'hkey-drag-stay))
;;;###autoload
(defun hmouse-click-to-drag-item ()
"Mouse click on start and end windows for use with `hkey-drag-item'.
Emulate {\\`M-o' i} from start window to end window.
After the drag, the end window is the selected window."
(interactive)
(hmouse-choose-windows #'hkey-drag-item))
;;;###autoload
(defun hmouse-click-to-drag-to ()
"Mouse click on start and end windows for use with `hkey-drag-to'.
Emulate Smart Mouse Key drag from start window to end window.
After the drag, the end window is the selected window."
(interactive)
(hmouse-choose-windows #'hkey-drag-to))
;;;###autoload
(defun hmouse-click-to-replace ()
"Mouse click on start and end windows for use with `hkey-replace'.
Replace the buffer in start window with the buffer in end window.
The selected window does not change."
(interactive)
(hmouse-choose-windows #'hkey-replace))
;; Test this next command
;; (global-set-key [C-down-mouse-1] nil)
;; (global-set-key [C-mouse-1] 'hmouse-click-to-swap)
;;;###autoload
(defun hmouse-click-to-swap ()
"Mouse click on start and end windows for use with `hkey-swap'.
Swap the buffer in start window with the buffer in end window.
Leave the end window selected."
(interactive)
(hmouse-choose-windows #'hkey-swap))
;;;###autoload
(defun hmouse-click-to-throw ()
"Mouse click on start and end windows for use with `hkey-throw'.
Throw either a displayable item at start window's point or its current
buffer to the end window. The selected window does not change."
(interactive)
(hmouse-choose-windows #'hkey-throw))
(defun hmouse-choose-link-and-referent-windows ()
"Select and return a list of (link-button-window referent-window)."
(let ((link-but-window (or (and (window-live-p assist-key-depress-window)
assist-key-depress-window)
(selected-window)))
(referent-window (and (window-live-p assist-key-release-window)
assist-key-release-window)))
(unless (and link-but-window referent-window)
(cond ((= (count-windows) 2)
(setq link-but-window (selected-window)
referent-window (next-window nil nil (selected-frame))))
((= (hypb:count-visible-windows) 2)
(setq link-but-window (selected-window)
referent-window (next-window nil nil 'visible)))
((= (hypb:count-visible-windows) 1)
;; Fall through to error below
)
(t
;; Either this frame has more than two windows or other
;; frames exist that together have more than one window;
;; choose which to use as the referent window.
(setq referent-window
(if (fboundp #'aw-select) ;; ace-window selection
(let ((aw-scope 'global))
(aw-select "Select link referent window"))
(message "Select link referent window with the mouse...")
(let (end-event)
(prog1 (cl-loop do (setq end-event (read-event))
until (and (mouse-event-p end-event)
(not (string-match "\\`down-" (symbol-name (car end-event)))))
finally return (posn-window (event-start end-event)))
(message "Done"))))))))
(when (eq link-but-window referent-window)
(error "(hmouse-choose-link-and-referent-windows): No other visible window with a link referent"))
(unless (window-live-p link-but-window)
(error "(hmouse-choose-link-and-referent-windows): Invalid link button window '%s'" link-but-window))
(unless (window-live-p referent-window)
(error "(hmouse-choose-link-and-referent-windows): Invalid link button window '%s'" referent-window))
(list link-but-window referent-window)))
(defun hmouse-choose-windows (func)
"Mouse click on start and end windows which are then applied to FUNC.
With the start window temporarily selected, run FUNC with the end
window as an argument.
Appropriate FUNCs include: hkey-drag, hkey-drag-to, hkey-link,
hkey-replace, hkey-swap and hkey-throw."
(let* (start-event
end-event
start-window
end-window)
(message "Click on the %s start window..." func)
(setq start-window
(cl-loop do (setq start-event (read-event))
until (and (mouse-event-p start-event)
(not (string-match "\\`down-" (symbol-name (car start-event)))))
finally return (posn-window (event-start start-event))))
(message "Now click on the %s end window..." func)
(setq end-window
(cl-loop do (setq end-event (read-event))
until (and (mouse-event-p end-event)
(not (string-match "\\`down-" (symbol-name (car end-event)))))
finally return (posn-window (event-start end-event))))
(message "Done")
(with-selected-window start-window
(funcall func end-window))))
(defun hmouse-keyboard-choose-windows (func)
"Press Return in start and end windows which are then applied to FUNC.
With the start window temporarily selected, run FUNC with the end
window as an argument.
Appropriate FUNCs include: hkey-drag, hkey-drag-to, hkey-link,
hkey-replace, hkey-swap and hkey-throw."
(let* (start-event
end-event
start-window
end-window)
(message "Move to the %s start window and press RETURN..." func)
(setq start-window
(cl-loop do (setq start-event (read-event))
until (eq (event-basic-type start-event) 'return)
finally return (posn-window (event-start start-event))))
(message "Now move to the %s end window and press RETURN..." func)
(setq end-window
(cl-loop do (setq end-event (read-event))
until (eq (event-basic-type end-event) 'return)
finally return (posn-window (event-start end-event))))
(message "Done")
(with-selected-window start-window
(funcall func end-window))))
;;; ************************************************************************
;;; Hyperbole Directional Buffer Movement Commands
;;; ************************************************************************
;;;###autoload
(defun hkey-buffer-move-left ()
"Swap the current buffer with the one on its left, if any; otherwise, do nothing."
(interactive)
(hkey-buffer-move 'left))
;;;###autoload
(defun hkey-buffer-move-right ()
"Swap the current buffer with the one on its right, if any; otherwise do nothing."
(interactive)
(hkey-buffer-move 'right))
;;;###autoload
(defun hkey-buffer-move-down ()
"Swap the current buffer with the one below it, if any; otherwise, do nothing."
(interactive)
(hkey-buffer-move 'down))
;;;###autoload
(defun hkey-buffer-move-up ()
"Swap the current buffer with the one on above it, if any; otherwise, do nothing."
(interactive)
(hkey-buffer-move 'up))
(defun hkey-buffer-move (direction &optional _arg)
"Move the current buffer to the next window in DIRECTION.
DIRECTION is a symbol, one of: up, down, left or right.
When the window-jump package is available and `wj-jump-frames' is
non-nil, the buffer may be moved across non-overlapping frames in
the given direction."
(interactive "SDirection to move buffer (up, down, left or right): \nP")
;; Prefer the window-jump package ...
(if (require 'window-jump nil t)
(let ((w1 (selected-window)))
(window-jump
(pcase direction
('left wj-vec-left)
('right wj-vec-right)
('down wj-vec-down)
('up wj-vec-up)
(_ (error "(hkey-buffer-move): Invalid movement direction, '%s'" direction))))
(hkey-swap-buffers w1 (selected-window)))
;; ... but if not available, use the Emacs builtin windmove package.
(eval-and-compile
(require 'windmove))
(condition-case ()
(windmove-swap-states-in-direction direction)
(error "(hkey-buffer-move): Invalid movement direction, '%s'" direction))))
;;; ************************************************************************
;;; Public support functions
;;; ************************************************************************
;; Next function is redefined from Emacs mouse.el. The standard
;; version allows moving frames by dragging a bottommost modeline with
;; mouse button1 but only if there is no minibuffer window (a rare
;; configuration) This limitation is so that the minibuffer window
;; can be manually resized.
;;
;; Hyperbole's mouse buttons do not support resizing the minibuffer
;; window so instead this function is modified to allow moving frames
;; that have a minibuffer window.
;;
;; The way this function was written does not allow hooking into it,
;; forcing inclusion of a modified version here.
(defun mouse-drag-mode-line (start-event)
"Change the height of a window by dragging on its mode line.
START-EVENT is the starting mouse event of the drag action.
If the drag happens in a mode line on the bottom of a frame and
that frame's `drag-with-mode-line' parameter is non-nil, drag the
frame instead."
(interactive "e")
(let* ((start (event-start start-event))
(window (posn-window start))
(frame (window-frame window)))
(cond
((not (window-live-p window)))
((or (not (window-at-side-p window 'bottom))
;; Allow resizing the minibuffer window if it's on the
;; same frame as and immediately below `window', and it's
;; either active or `resize-mini-windows' is nil.
(let ((minibuffer-window (minibuffer-window frame)))
(and (eq (window-frame minibuffer-window) frame)
(or (not resize-mini-windows)
(eq minibuffer-window
(active-minibuffer-window))))))
(mouse-drag-line start-event 'mode))
((and (frame-parameter frame 'drag-with-mode-line)
(window-at-side-p window 'bottom))
;; Drag frame when the window is on the bottom of its frame.
(if (fboundp 'mouse-drag-frame-move) ;; From Emacs 28
(mouse-drag-frame-move start-event)
(mouse-drag-frame start-event 'move))))))
(defun hkey-debug (pred pred-value hkey-action)
"Display a message with the context and values from Smart Key activation."
(message (concat "(HyDebug) %sContext: %s; %s: %s; Buf: %s; Mode: %s; MinibufDepth: %s\n"
" action-depress: %s; action-release: %s\n"
" assist-depress: %s; assist-release: %s")
(cond ((eq pred-value 'hbut:current)
(format "ButProps: %S\nButType: %s; ButLabel: %s; "
(symbol-plist 'hbut:current)
(hattr:get 'hbut:current 'categ)
(hypb:format-quote (hbut:label 'hbut:current))))
((functionp pred-value)