-
Notifications
You must be signed in to change notification settings - Fork 22
/
ctrlf.el
1559 lines (1413 loc) · 62.7 KB
/
ctrlf.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
;;; ctrlf.el --- Emacs finally learns how to ctrl+F -*- lexical-binding: t -*-
;; Copyright (C) 2019-2022 Radian LLC and contributors
;; Author: Radian LLC <[email protected]>
;; Created: 23 Dec 2019
;; Homepage: https://github.com/radian-software/ctrlf
;; Keywords: extensions
;; Package-Requires: ((emacs "25.1"))
;; SPDX-License-Identifier: MIT
;; Version: 1.6
;;; Commentary:
;; CTRLF (pronounced "control F") is an intuitive and efficient
;; solution for single-buffer text search in Emacs, replacing packages
;; such as Isearch, Swiper, and helm-swoop. Taking inspiration from
;; the widely-adopted and battle-tested ctrl+F interfaces in programs
;; such as web browsers, but following the flow and keybindings of
;; Isearch, CTRLF improves on existing text search solutions in
;; convenience, robustness, and consistency.
;; Please see https://github.com/radian-software/ctrlf for more
;; information.
;;; Code:
;; To see the outline of this file, run M-x outline-minor-mode and
;; then press C-c @ C-t. To also show the top-level functions and
;; variable declarations in each section, run M-x occur with the
;; following query: ^;;;;* \|^(
;;;; Libraries
(require 'cl-lib)
(require 'hl-line)
(require 'map)
(require 'subr-x)
(require 'thingatpt)
;;;; Backports
;; Not defined before Emacs 27.1
(eval-and-compile
(unless (fboundp 'xor)
(defun xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
return nil."
(declare (pure t) (side-effect-free error-free))
(cond ((not cond1) cond2)
((not cond2) cond1)))))
;;;; User configuration
(defgroup ctrlf nil
"More streamlined replacement for Isearch, Swiper, etc."
:group 'convenience
:prefix "ctrlf-"
:link '(url-link "https://github.com/radian-software/ctrlf"))
;;;;; User options
(defcustom ctrlf-highlight-current-line t
"Non-nil means to highlight the entire line of the current match."
:type 'boolean)
(defcustom ctrlf-auto-recenter nil
"Non-nil means to always keep the current match vertically centered."
:type 'boolean)
(defcustom ctrlf-show-match-count-at-eol t
"Non-nil means to show the match count also directly in the buffer.
Otherwise, the match count is only shown in the minibuffer."
:type 'boolean)
(defcustom ctrlf-go-to-end-of-match t
"Non-nil means to go to the end of the match after the search is finished.
Otherwise, it goes to the beginning of the match."
:type 'boolean)
(defcustom ctrlf-style-alist
'((literal . (:prompt "literal"
:translator regexp-quote
:case-fold ctrlf-no-uppercase-literal-p
:fallback (isearch-forward . isearch-backward)))
(regexp . (:prompt "regexp"
:translator identity
:case-fold ctrlf-no-uppercase-regexp-p
:fallback (isearch-forward-regexp
. isearch-backward-regexp)))
(fuzzy . (:prompt "fuzzy"
:translator ctrlf-translate-fuzzy-literal
:case-fold ctrlf-no-uppercase-literal-p))
(fuzzy-regexp . (:prompt "fuzzy regexp"
:translator ctrlf-translate-fuzzy-regexp
:case-fold ctrlf-no-uppercase-regexp-p))
(symbol . (:prompt "symbol"
:translator ctrlf-translate-symbol
:case-fold ctrlf-no-uppercase-literal-p
:fallback (isearch-forward-symbol)))
(word . (:prompt "word"
:translator ctrlf-translate-word
:case-fold ctrlf-no-uppercase-literal-p)))
"Alist of CTRLF search styles.
Each search style defines a different way to interpret your
query, for example as a literal string or as a regexp. The keys
are unique identifying symbols which can be passed to
`ctrlf-forward' and `ctrlf-backward'. The values are property
lists with the following keys (all mandatory):
- `:prompt': string to be displayed in minibuffer prompt after
\"CTRLF\".
- `:translator': function which takes your query string and
returns a regexp, e.g. `regexp-quote' for a literal search.
- `:case-fold': function which takes your query string and
returns a value for `case-fold-search' to use by default (for
example, non-nil only if the query does not contain any
uppercase letters).
- `:fallback': a cons of of two symbols specifying the fallback
forward and backward search functions that are called when CTRLF
search functions are called in the minibuffer and when not in a
search already."
:type '(alist
:key-type symbol
:value-type (list (const :prompt) string
(const :translator) function
(const :case-fold) function)))
;;;###autoload
(defcustom ctrlf-mode-map
(let ((keymap (make-sparse-keymap)))
(define-key keymap [remap isearch-forward] #'ctrlf-forward-default)
(define-key keymap [remap isearch-backward] #'ctrlf-backward-default)
(define-key keymap [remap isearch-forward-regexp]
#'ctrlf-forward-alternate)
(define-key keymap [remap isearch-backward-regexp]
#'ctrlf-backward-alternate)
(define-key keymap [remap isearch-forward-symbol] #'ctrlf-forward-symbol)
(define-key keymap [remap isearch-forward-symbol-at-point]
#'ctrlf-forward-symbol-at-point)
keymap)
"Keymap used by CTRLF globally."
:type 'sexp)
;;;###autoload
(defcustom ctrlf-mode-bindings
'(([remap isearch-forward] . ctrlf-forward-default)
([remap isearch-backward] . ctrlf-backward-default)
([remap isearch-forward-regexp] . ctrlf-forward-alternate)
([remap isearch-backward-regexp] . ctrlf-backward-alternate)
([remap isearch-forward-symbol] . ctrlf-forward-symbol)
([remap isearch-forward-symbol-at-point] . ctrlf-forward-symbol-at-point))
"This variable is deprecated.
To customize the keybindings, modify `ctrlf-mode-map' directly.
Keybindings enabled in `ctrlf-mode'. This is not a keymap.
Rather it is an alist that is converted into a keymap just before
`ctrlf-mode' is (re-)enabled. The keys are strings or raw key
events and the values are command symbols.
These bindings are available globally in Emacs. See also
`ctrlf-minibuffer-bindings', which defines bindings that are
active in the minibuffer during a search."
:type '(alist
:key-type sexp
:value-type function)
:set (lambda (var val)
(set var val)
(when (bound-and-true-p ctrlf-mode)
(ctrlf-mode +1))))
(make-obsolete-variable 'ctrlf-mode-bindings 'ctrlf-mode-map "2021-09-07")
(defcustom ctrlf-minibuffer-mode-map
(let ((keymap (make-sparse-keymap)))
(set-keymap-parent keymap minibuffer-local-map)
;; This is bound in `minibuffer-local-map' by loading `delsel', so
;; we have to account for it too.
(define-key keymap [remap abort-recursive-edit] #'ctrlf-cancel)
(define-key keymap [remap minibuffer-keyboard-quit] #'ctrlf-cancel)
(define-key keymap [remap abort-minibuffers] #'ctrlf-cancel)
;; Use `minibuffer-beginning-of-buffer' for Emacs >=27 and
;; `beginning-of-buffer' for Emacs <=26.
(define-key keymap [remap minibuffer-beginning-of-buffer]
#'ctrlf-first-match)
(define-key keymap [remap beginning-of-buffer] #'ctrlf-first-match)
(define-key keymap [remap end-of-buffer] #'ctrlf-last-match)
(define-key keymap [remap scroll-up-command] #'ctrlf-next-page)
(define-key keymap [remap scroll-down-command] #'ctrlf-previous-page)
(define-key keymap [remap recenter-top-bottom] #'ctrlf-recenter-top-bottom)
;; Reuse transient binding of `isearch-occur'.
(define-key keymap (kbd "M-s o") #'ctrlf-occur)
;; Reuse transient bindings of `isearch-toggle-case-fold'.
(define-key keymap (kbd "M-c") #'ctrlf-toggle-case-fold-search)
(define-key keymap (kbd "M-s c") #'ctrlf-toggle-case-fold-search)
;; Reuse transient bindings of `isearch-toggle-regexp'.
(define-key keymap (kbd "M-r") #'ctrlf-toggle-regexp)
(define-key keymap (kbd "M-s r") #'ctrlf-toggle-regexp)
;; Reuse transient binding of `isearch-toggle-symbol'.
(define-key keymap (kbd "M-s _") #'ctrlf-toggle-symbol)
;; Add an Isearch like binding for search style selection.
(define-key keymap (kbd "M-s s") #'ctrlf-change-search-style)
;; Previous bindings for backwards compatibility.
(define-key keymap (kbd "C-o c") #'ctrlf-toggle-case-fold-search)
(define-key keymap (kbd "C-o s") #'ctrlf-change-search-style)
keymap)
"Keymap used by CTRLF in minibuffer during search."
:type 'sexp)
(defcustom ctrlf-minibuffer-bindings
'(([remap abort-recursive-edit] . ctrlf-cancel)
([remap minibuffer-keyboard-quit] . ctrlf-cancel)
([remap minibuffer-beginning-of-buffer] . ctrlf-first-match)
([remap beginning-of-buffer] . ctrlf-first-match)
([remap end-of-buffer] . ctrlf-last-match)
([remap scroll-up-command] . ctrlf-next-page)
([remap scroll-down-command] . ctrlf-previous-page)
([remap recenter-top-bottom] . ctrlf-recenter-top-bottom)
("M-s o" . ctrlf-occur)
("M-c" . ctrlf-toggle-case-fold-search)
("M-s c" . ctrlf-toggle-case-fold-search)
("M-r" . ctrlf-toggle-regexp)
("M-s r" . ctrlf-toggle-regexp)
("M-s _" . ctrlf-toggle-symbol)
("M-s s" . ctrlf-change-search-style)
("C-o c" . ctrlf-toggle-case-fold-search)
("C-o s" . ctrlf-change-search-style))
"This variable is deprecated.
To customize the keybindings, modify `ctrlf-minibuffer-mode-map' directly.
Keybindings enabled in minibuffer during search. This is not a keymap.
Rather it is an alist that is converted into a keymap just before
entering the minibuffer. The keys are strings or raw key events
and the values are command symbols. The keymap so constructed
inherits from `minibuffer-local-map'.
See also `ctrlf-mode-bindings', which defines bindings that are
available globally in Emacs when `ctrlf-mode' is active."
:type '(alist
:key-type sexp
:value-type function))
(make-obsolete-variable 'ctrlf-minibuffer-bindings 'ctrlf-minibuffer-mode-map
"2021-09-07")
(defcustom ctrlf-zero-length-match-width 0.2
"Width of vertical bar to display for a zero-length match.
This is relative to the normal width of a character."
:type 'number)
(defcustom ctrlf-default-search-style 'literal
"Default CTRLF search style.
This style is used by `ctrlf-forward-default' and
`ctrlf-backward-default'. Valid values for this option are the
styles defined in `ctrlf-style-alist'"
:type 'symbol)
(defcustom ctrlf-alternate-search-style 'regexp
"Alternative CTRLF search style.
This style is used by `ctrlf-forward-alternate' and
`ctrlf-backward-alternate'. Valid values for this option are the
styles defined in `ctrlf-style-alist'"
:type 'symbol)
;;;;; Functions for use in configuration
;; Stolen (with love) from
;; <https://github.com/radian-software/prescient.el/blob/7fd8c3b8028da4733434940c4aac1209281bef58/prescient.el#L242-L288>.
(defun ctrlf-split-fuzzy (input)
"Split INPUT string into subinputs.
The input is split on spaces, but a sequence of two or more
spaces has one space removed and is treated literally rather than
as a subinput delimiter."
(if (string-match-p "\\` *\\'" input)
;; If string is zero or one spaces, then we match everything.
;; Return an empty sub-input list.
(unless (<= (length input) 1)
;; Otherwise, the number of spaces should be reduced by one.
(list (substring input 1)))
;; Trim off a single space from the beginning and end, if present.
;; Otherwise, they would generate empty splits and cause us to
;; match literal whitespace.
(setq input (replace-regexp-in-string
"\\` ?\\(.*?\\) ?\\'" "\\1" input 'fixedcase))
(let ((splits (split-string input " "))
(subinput "")
(token-found nil)
(subqueries nil))
(dolist (split splits)
;; Check for empty split, meaning two consecutive spaces in
;; the original input.
(if (string-empty-p split)
(progn
;; Consecutive spaces mean literal spaces in the
;; subinput under construction.
(setq subinput (concat subinput " "))
;; If we get a non-empty split, append it to the
;; subinput rather than parsing it as another subinput.
(setq token-found nil))
;; Possibly add the collected string as a new subinput.
(when token-found
(push subinput subqueries)
(setq subinput ""))
;; Either start a new subinput or append to the existing one
;; (in the case of previously seeing an empty split).
(setq subinput (concat subinput split))
;; If another non-empty split is found, it's a separate
;; subinput.
(setq token-found t)))
;; Check if we hit the end of the string while still
;; constructing a subinput, and handle.
(unless (string-empty-p subinput)
(push subinput subqueries))
;; We added the subqueries in reverse order.
(nreverse subqueries))))
(defun ctrlf-translate-fuzzy-literal (input)
"Build a fuzzy-matching regexp from literal INPUT.
See `ctrlf-split-fuzzy' for how INPUT is split into subinputs.
Each subinput is quoted and the results are joined with \".*\"."
(string-join (mapcar #'regexp-quote (ctrlf-split-fuzzy input)) ".*"))
(defun ctrlf-translate-fuzzy-regexp (input)
"Build a fuzzy-matching regexp from regexp INPUT.
See `ctrlf-split-fuzzy' for how INPUT is split into subinputs.
The subinputs are joined with \".*\"."
(string-join (ctrlf-split-fuzzy input) ".*"))
(defun ctrlf-translate-symbol (input)
"Build a symbol-matching regexp from literal INPUT.
The input is treated literally, but quoted as a regexp and
surrounded by symbol boundary constructs \\_< and \\_>."
(concat "\\_<" (regexp-quote input) "\\_>"))
(defun ctrlf-translate-word (input)
"Build a word-matching regexp from literal INPUT.
The input is treated literally, but quoted as a regexp and
surrounded by word boundary constructs \\< and \\>."
(concat "\\<" (regexp-quote input) "\\>"))
(defun ctrlf-no-uppercase-literal-p (input)
"Return non-nil if literal INPUT contains no uppercase letters."
(isearch-no-upper-case-p input nil))
(defun ctrlf-no-uppercase-regexp-p (input)
"Return non-nil if regexp INPUT contains no uppercase letters."
(isearch-no-upper-case-p input t))
;;;;; Faces
(defface ctrlf-highlight-active
'((t :inherit isearch))
"Face used to highlight current match.")
(defface ctrlf-highlight-passive
'((t :inherit lazy-highlight))
"Face used to highlight other matches in the buffer.")
(defface ctrlf-highlight-line
'((t :inherit hl-line))
"Face used to highlight current line.")
(defface ctrlf-message-face
'((t :inherit minibuffer-prompt))
"Base face used for message display. Other CTRLF faces inherit from this.")
(defface ctrlf-minibuffer-message-face
'((t :inherit ctrlf-message-face))
"Face used to display CTRLF messages in the minibuffer.")
(defface ctrlf-in-buffer-message-face
'((t :inherit ctrlf-message-face))
"Face used to display CTRLF messages in buffers other than the minibuffer.")
;;;;; Variables
(defvar ctrlf-search-history nil
"History of searches that were not canceled.")
;;;; Session variables
;;;;; Invariant session variables
(defvar ctrlf--active-p nil
"Non-nil means we're currently performing a search.
This is dynamically bound by CTRLF commands.")
(defvar ctrlf--starting-point nil
"Value of point from when search was started.")
(defvar ctrlf--minibuffer nil
"The minibuffer being used for search.")
;;;;; Non-invariant session variables
(defvar ctrlf--style nil
"Current search style.")
(defvar ctrlf--backward-p nil
"Non-nil means we are currently searching backward.
Nil means we are currently searching forward.")
(defvar ctrlf--case-fold-search :auto
"Whether `case-fold-search' is enabled in the current CTRLF session.
Value `:auto' means to guess based on the current search query.")
(defvar ctrlf--current-starting-point nil
"Value of point from which to search.")
(defvar ctrlf--match-bounds nil
"Cons cell of current match beginning and end, or nil if no match.")
;;;; Overlay shenanigans
(defvar ctrlf--overlays nil
"List of all overlays used by CTRLF.
They all have a non-nil `ctrlf' property so that we can identify
them when reading directly from the buffer. Most of our overlays
have an `after-string' property. Some have a `ctrlf--transient'
property which indicates that they should be removed after the
next command. Also, some sub-sections of the string in
`after-string' can have a non-nil `ctrlf--transient' property
which indicates that those sub-sections should be removed after
the next command. (This supports the condensation of persistent
and transient overlays together; see
`ctrlf--condense-overlays'.)")
(defun ctrlf--condense-overlays ()
"Combine multiple overlays with `after-string' properties into one.
Look at `ctrlf--overlays' to identify groups of overlays that are
at the same buffer position, and merge those.
This function should not be necessary, but there are several
reasons why multiple `after-string' overlays at the same point do
not behave well. One is that in some cases overlay priorities are
not considered correctly when Emacs decides which string to show
first. Another is that multiple `after-string' overlays with
`cursor' properties on their strings will cause the cursor to
render between them rather than at the position indicated by the
highest-priority overlay.
Note that this function is a horrifying hack which cannot
possibly be expected to do the right thing in general, only in
certain special cases within CTRLF and frankly I wouldn't even
trust it in that context."
(dolist (ols (map-values
(seq-group-by
(lambda (ol)
(cons
(overlay-buffer ol)
(overlay-end ol)))
ctrlf--overlays)))
(setq ols
(cl-delete-if-not
(lambda (ol)
(overlay-get ol 'after-string))
ols))
(when ols
(setq ols
(cl-sort
ols #'>
:key (lambda (ol)
(let ((priority (overlay-get ol 'priority)))
(if (numberp priority)
priority
0)))))
(let ((str
(mapconcat
(lambda (ol)
(let ((str (overlay-get ol 'after-string)))
(when (overlay-get ol 'ctrlf--transient)
(put-text-property
0 (length str) 'ctrlf--transient t str))
str))
ols
"")))
(remove-text-properties 0 (length str) 'cursor str)
(put-text-property 0 1 'cursor t str)
(overlay-put (car ols) 'after-string str)
(overlay-put (car ols) 'ctrlf--transient nil)
(mapc #'delete-overlay (cdr ols)))))
(setq ctrlf--overlays
(cl-delete-if-not #'overlay-buffer ctrlf--overlays)))
(defun ctrlf--delete-all-overlays ()
"Delete all overlays in `ctrlf--overlays'."
(mapc #'delete-overlay ctrlf--overlays)
(setq ctrlf--overlays nil))
(defun ctrlf--delete-transient-overlays (&optional negate)
"Delete overlays marked as transient in `ctrlf--overlays'.
If only part of an overlay is marked as transient (due to
condensation; see `ctrlf--condense-overlays'), only delete that
part. NEGATE non-nil means delete overlays *not* marked as
transient."
(dolist (ol ctrlf--overlays)
(if (xor (overlay-get ol 'ctrlf--transient) negate)
(delete-overlay ol)
(if-let ((str (overlay-get ol 'after-string)))
(let ((idx 0))
(while (< idx (length str))
(let ((cur (get-text-property idx 'ctrlf--transient str))
(next-idx
(or (next-property-change idx str)
(length str))))
(if (xor cur negate)
(setq str (concat
(substring str 0 idx)
(substring str next-idx)))
(setq idx next-idx))))
(if (string-empty-p str)
(delete-overlay ol)
(remove-text-properties 0 (length str) 'cursor str)
(put-text-property 0 1 'cursor t str)
(overlay-put ol 'after-string str))))))
(setq ctrlf--overlays
(cl-delete-if-not #'overlay-buffer ctrlf--overlays)))
(defun ctrlf--delete-persistent-overlays (&optional negate)
"Delete overlays *not* marked as transient in `ctrlf--overlays'.
If only part of an overlay is not marked as transient (due to
condensation; see `ctrlf--condense-overlays'), only delete that
part. NEGATE non-nil means delete overlays that *are* marked as
transient."
(ctrlf--delete-transient-overlays (not negate)))
(defun ctrlf--minibuffer-message-condense (func &rest args)
"Apply `ctrlf--condense-overlays' after `minibuffer-message'.
This is an `:around' advice for `minibuffer-message'. FUNC and
ARGS the original function and its arguments, as usual."
(cl-letf* ((make-overlay (symbol-function #'make-overlay))
((symbol-function #'make-overlay)
(lambda (&rest args)
(let ((ol (apply make-overlay args)))
(prog1 ol
;; Assume ownership of this overlay so we can mess
;; with it :D
(overlay-put ol 'ctrlf t)
(overlay-put ol 'ctrlf--transient t)
(push ol ctrlf--overlays)))))
(sit-for (symbol-function #'sit-for))
((symbol-function #'sit-for)
(lambda (&rest args)
;; Have to stick this inside of `sit-for' because
;; `minibuffer-message' uses `sit-for' instead of
;; returning.
(ctrlf--condense-overlays)
(apply sit-for args))))
(apply func args)))
(defvar ctrlf--message-persist-p nil
"Whether `ctrlf--message' will show persistent messages.
If non-nil, then messages will persist until the next
recomputation of CTRLF's overlays. Otherwise, they will only last
until the next interactive command. Persistent messages will be
shown to the left of transient messages.")
(defvar ctrlf--message-in-buffer-p nil
"Whether `ctrlf--message' will also display its message in the buffer.
By default messages are shown only in the minibuffer.")
(defun ctrlf--message (format &rest args)
"Display a transient message in the minibuffer.
FORMAT and ARGS are as in `message'. This function behaves
exactly the same as `message' in Emacs 27 and later, and it acts
as a backport for Emacs 26 and earlier where signaling a message
while the minibuffer is active causes an absolutely horrendous
mess."
;; Some of this is borrowed from `minibuffer-message'.
(if (not ctrlf--minibuffer)
(minibuffer-message format args)
(let ((string (apply #'format (concat " [" format "]") args)))
(put-text-property
0 (length string)
'face
(if ctrlf--message-in-buffer-p
'ctrlf-in-buffer-message-face
'ctrlf-minibuffer-message-face)
string)
(with-current-buffer ctrlf--minibuffer
;; Setting REAR-ADVANCE:
;; <https://github.com/radian-software/ctrlf/issues/4>
(let ((ol (make-overlay
(point-max) (point-max) nil nil 'rear-advance)))
(push ol ctrlf--overlays)
(overlay-put ol 'ctrlf t)
(unless ctrlf--message-persist-p
(overlay-put ol 'ctrlf--transient t))
(overlay-put
ol 'priority
;; Prioritize our messages over ones generated by Emacs, and
;; persistent messages over transient ones.
(if ctrlf--message-persist-p 2 1))
(overlay-put ol 'after-string string))
(when ctrlf--message-in-buffer-p
(with-current-buffer (window-buffer
(minibuffer-selected-window))
(let* ((loc (point-at-eol))
(ol (make-overlay loc loc)))
(push ol ctrlf--overlays)
(overlay-put ol 'ctrlf t)
(unless ctrlf--message-persist-p
(overlay-put ol 'ctrlf--transient t))
(overlay-put ol 'priority 1)
(overlay-put ol 'after-string string))))))
(ctrlf--condense-overlays)))
;;;; Search primitive
(cl-defun ctrlf--search
(query &key
(style :unset) (backward :unset) (forward :unset)
bound)
"Single-buffer text search primitive. Search for QUERY.
STYLE controls the search style. If it's unset, use the value of
`ctrlf--style'. BACKWARD controls whether to do a forward
search (nil) or a backward search (non-nil), else check
`ctrlf--backward-p'. FORWARD does the same but the meaning of its
argument is inverted. BOUND, if non-nil, is a limit for the
search as in `search-forward' and friends. BOUND can also be the
symbol `wraparound', meaning keep searching at the beginning (or
end, respectively) of the buffer, rather than stopping. If the
search succeeds, move point to the end (for forward searches) or
beginning (for backward searches) of the match. If the search
fails, return nil, but still move point. Otherwise, return
non-nil."
(let* ((style (cond
((not (eq style :unset))
style)
(t
ctrlf--style)))
(backward (cond
((not (eq backward :unset))
backward)
((not (eq forward :unset))
(not forward))
(t
ctrlf--backward-p)))
(func (if backward
#'re-search-backward
#'re-search-forward))
(query (funcall
(plist-get (alist-get style ctrlf-style-alist) :translator)
query))
(wraparound (eq bound 'wraparound))
(bound (and (integer-or-marker-p bound) bound)))
(or (funcall func query bound 'noerror)
(when wraparound
(goto-char
(if backward
(point-max)
(point-min)))
(funcall func query nil 'noerror)))))
;;;; Integration with other packages
;;;;; Evil integration
(defun ctrlf--evil-set-jump ()
"Integration with evil's jump list.
Adds an entry to evil's jump list for the current position."
(when (fboundp 'evil-set-jump)
;; Jump must be set in the buffer we are searching, not in the
;; minibuffer which is current during a ctrlf session
(with-selected-window (or (minibuffer-selected-window) (selected-window))
(evil-set-jump))))
(defun ctrlf--evil-remember-search-string (str)
"Integration with evil's search history.
Will add search pattern STR to evil's search history ring."
(when (bound-and-true-p evil-mode)
;; Evil-mode integration is only implicit, so we ignore the warnings about
;; unknown variables.
(with-no-warnings
(cl-case evil-search-module
(isearch
(setq isearch-string str))
(evil-search
(add-to-history 'evil-ex-search-history str)
(let* ((style-plist (alist-get ctrlf--style ctrlf-style-alist))
(translator (plist-get style-plist :translator))
(translated-str (funcall translator str)))
(setq evil-ex-search-direction 'forward
evil-ex-search-pattern (list translated-str nil t))
(when evil-ex-search-persistent-highlight
(evil-ex-search-activate-highlight evil-ex-search-pattern)))))))
str)
;;;; Main loop
(defun ctrlf--minibuffer-before-change-function (&rest _)
"Prepare for user input."
;; Clear overlays pre-emptively. See
;; <https://github.com/radian-software/ctrlf/issues/1>.
(ctrlf--delete-transient-overlays))
;;;;; Bookkeeping variables
(defvar ctrlf--last-input nil
"Previous user input, or nil if none yet.")
(defvar ctrlf--case-fold-search-toggled nil
"Whether `case-fold-search' has been toggled, so a message should be shown.")
(defvar ctrlf--case-fold-search-last-guessed nil
"Last guessed value of `case-fold-search'.")
(defvar ctrlf--opened-overlays nil
"List of overlays that were temporarily made visible to show matches.")
;;;;; Utility functions
(defun ctrlf--copy-properties (s1 s2)
"Return a copy of S1 with properties from S2 added.
Assume that S2 has the same properties throughout."
(apply #'propertize s1 (text-properties-at 0 s2)))
(defun ctrlf--prompt ()
"Return the prompt to use in the minibuffer."
(concat
"CTRLF "
(if ctrlf--backward-p "↑" "↓")
" "
(plist-get (alist-get ctrlf--style ctrlf-style-alist) :prompt)
": "))
;;;;;; Invisible overlay management
(defun ctrlf--restore-all-invisible-overlays ()
"Restore any overlays that were previously disabled."
(while ctrlf--opened-overlays
(let ((ol (pop ctrlf--opened-overlays)))
(if-let ((func (overlay-get ol 'isearch-open-invisible-temporary)))
(funcall func ol t)
(overlay-put ol 'invisible (overlay-get ol 'ctrlf-orig-invisible))
;; I don't see a function for removing an overlay property, and
;; Isearch does it by setting the property to nil, so I assume
;; it's fine.
(overlay-put ol 'ctrlf-orig-invisible nil)))))
(defun ctrlf--disable-invisible-overlays-at-point (&optional permanently)
"Disable any overlays that are currently hiding point.
PERMANENTLY non-nil means the overlays will not be restored
later (this should be used at the end of the search)."
(when ctrlf--match-bounds
(dolist (ol (overlays-in (car ctrlf--match-bounds)
(cdr ctrlf--match-bounds)))
(when (and (invisible-p (overlay-get ol 'invisible))
;; If this function is missing, then we can't open
;; the overlay permanently because we don't know how
;; to do it properly. Hey, don't ask me, I'm just
;; following Isearch.
(overlay-get ol 'isearch-open-invisible))
(if permanently
(funcall (overlay-get ol 'isearch-open-invisible) ol)
(push ol ctrlf--opened-overlays)
(if-let ((func (overlay-get ol 'isearch-open-invisible-temporary)))
(funcall func ol nil)
(overlay-put ol 'ctrlf-orig-invisible (overlay-get ol 'invisible))
(overlay-put ol 'invisible nil)))))))
;;;;; Post-command hook
(defun ctrlf--minibuffer-post-command-hook ()
"Deal with updated user input."
(save-excursion
(let* ((old-prompt (field-string (point-min)))
(new-prompt (ctrlf--copy-properties (ctrlf--prompt) old-prompt))
(inhibit-read-only t)
;; Prevent this getting set to t by the editing below.
(deactivate-mark nil))
(goto-char (point-min))
(delete-region (point) (field-end (point)))
(insert new-prompt)))
(when (< (point) (field-end (point-min)))
(goto-char (field-end (point-min))))
(ctrlf--delete-transient-overlays)
(cl-block nil
(let* ((input (field-string (point-max)))
(translator (plist-get
(alist-get ctrlf--style ctrlf-style-alist)
:translator))
(case-fold-search
(if (eq ctrlf--case-fold-search :auto)
(setq ctrlf--case-fold-search-last-guessed
(funcall (plist-get
(alist-get
ctrlf--style ctrlf-style-alist)
:case-fold)
input))
ctrlf--case-fold-search))
(regexp nil)
(skip-search nil))
(condition-case e
(setq regexp (funcall translator input))
(error
(ctrlf--message "Invalid input: %s" (cadr e))
(setq skip-search t)))
(unless skip-search
(condition-case e
;; Simple hack for the sake of performance, because taking a
;; regexp that always matches and matching it against the
;; entire buffer takes a long time, and we should avoid
;; doing this every time CTRLF is launched.
(when (string-match-p regexp "")
(setq skip-search t))
(invalid-regexp
(ctrlf--message "Invalid regexp: %s" (cadr e))
(setq skip-search t))))
(unless (equal input ctrlf--last-input)
(setq ctrlf--last-input input)
(with-current-buffer (window-buffer (minibuffer-selected-window))
;; Jump to the next match.
(let ((prev-point (point)))
(goto-char ctrlf--current-starting-point)
(if (and (not skip-search)
(ctrlf--search input :bound 'wraparound))
(progn
(goto-char (if ctrlf-go-to-end-of-match
(match-end 0)
(match-beginning 0)))
(setq ctrlf--match-bounds
(cons (match-beginning 0)
(match-end 0))))
(goto-char prev-point)
(setq ctrlf--match-bounds nil)))
(set-window-point (minibuffer-selected-window) (point))
(when (and ctrlf-auto-recenter ctrlf--match-bounds)
(with-selected-window
(minibuffer-selected-window)
(recenter)))
(ctrlf--delete-persistent-overlays)
;; You might think we could do this before clearing
;; persistent overlays, because the message overlay in this
;; case will be transient. Unfortunately this does not work,
;; because overlay condensing may combine the transient
;; overlay into a persistent one, which will then get
;; deleted before the user can see it.
(when ctrlf--case-fold-search-toggled
(ctrlf--message
"Case-sensitivity %s"
(if case-fold-search
"disabled"
"enabled"))
(setq ctrlf--case-fold-search-toggled nil))
(when ctrlf--match-bounds
;; Make sure the match is visible. See:
;; <https://github.com/radian-software/ctrlf/issues/23>
;; <https://github.com/abo-abo/swiper/blob/64f05f4735bba8b708bc12cfc2cbfb7fb7706787/swiper.el#L878-L885>
(ctrlf--restore-all-invisible-overlays)
(ctrlf--disable-invisible-overlays-at-point)
;; If there was a match, find all the other matches in the
;; buffer. Count them and highlight the ones that appear
;; in the window. Display that info in the minibuffer.
;;
;; You might think we'd want to use `window-start' and
;; `window-end' to determine which matches to passively
;; highlight. And you'd be right... if those functions
;; actually returned correct values. Unfortunately, they
;; return the values that *were* correct at the time of
;; the last redisplay, which means since we moved point we
;; would need to force a redisplay to get the right
;; values. Doing that leads to
;; <https://github.com/radian-software/ctrlf/issues/18>,
;; so I came up with the workaround of just being
;; conservative and highlighting a little more than we
;; need, to be sure that we get everything necessary,
;; without having to highlight the whole buffer which
;; would be very slow.
(let* ((window-height (window-body-height
(minibuffer-selected-window)))
(start (save-excursion
(forward-line (- window-height))
(point)))
(end (save-excursion
(forward-line window-height)
(point)))
(cur-point (point))
(num-matches 0)
(cur-index nil)
(abort nil))
(save-excursion
(goto-char (point-min))
(while (and (not abort)
(prog1 (ctrlf--search input :forward t)
(when (= (match-beginning 0) (match-end 0))
(condition-case _
(forward-char)
(end-of-buffer (setq abort t))))))
(when (and (>= (match-end 0) start)
(<= (match-beginning 0) end)
(or (<= (match-end 0)
(car ctrlf--match-bounds))
(>= (match-beginning 0)
(cdr ctrlf--match-bounds)))
;; You might think we could get away
;; without this, since overlaying the
;; active face below would just
;; overwrite the assignment here. But
;; that doesn't work for zero-length
;; matches.
(/= (match-beginning 0)
(car ctrlf--match-bounds)))
(let ((ol (make-overlay
(match-beginning 0) (match-end 0))))
(push ol ctrlf--overlays)
(overlay-put ol 'ctrlf t)
(overlay-put ol 'priority 2)
(if (/= (match-beginning 0) (match-end 0))
(overlay-put ol 'face 'ctrlf-highlight-passive)
(overlay-put
ol 'after-string
(propertize
" "
'display
`(space :width ,ctrlf-zero-length-match-width)
'face 'ctrlf-highlight-passive)))))
(cl-incf num-matches)
(when (and (null cur-index)
(>= (point) cur-point))
(setq cur-index num-matches))))
(with-current-buffer ctrlf--minibuffer
(when cur-index
(let ((ctrlf--message-persist-p t)
(ctrlf--message-in-buffer-p
ctrlf-show-match-count-at-eol))
(ctrlf--message
"%d/%d" cur-index num-matches)))))
;; Highlight the active match specially, and optionally also
;; the line on which it appears.
(when ctrlf--match-bounds
(let ((ol (make-overlay
(car ctrlf--match-bounds) (cdr ctrlf--match-bounds))))
(push ol ctrlf--overlays)
(overlay-put ol 'ctrlf t)
(overlay-put ol 'priority 2)
(if (/= (car ctrlf--match-bounds) (cdr ctrlf--match-bounds))
(overlay-put ol 'face 'ctrlf-highlight-active)
(overlay-put ol 'ctrlf-skip-highlighting t)
(overlay-put
ol 'after-string
(propertize
" "
'display
`(space :width ,ctrlf-zero-length-match-width)
'face 'ctrlf-highlight-active))))
(when ctrlf-highlight-current-line
(let* ((start (save-excursion
(goto-char (car ctrlf--match-bounds))
(line-beginning-position)))
(end (save-excursion
(goto-char (cdr ctrlf--match-bounds))
(line-beginning-position 2)))
(ol (make-overlay start end)))
(push ol ctrlf--overlays)
(overlay-put ol 'ctrlf t)
(overlay-put ol 'face 'ctrlf-highlight-line)
(dolist (ol (overlays-in start end))
(when (and (overlay-get ol 'ctrlf)
(not (overlay-get ol 'ctrlf-skip-highlighting)))
(when-let ((string (overlay-get ol 'after-string)))
;; No need to worry about removing the face
;; later, as the overlay will get destroyed
;; anyway by the time that this becomes
;; relevant.
(add-face-text-property
0 (length string)
'ctrlf-highlight-line nil string)))))))))))))
;;;; Teardown
(defvar ctrlf--final-window-start nil
"Original buffer's `window-start' just before exiting minibuffer.
For some reason this gets trashed when exiting the minibuffer, so
we restore it to keep the scroll position consistent.
I have literally no idea why this is needed.")
(defun ctrlf--finalize ()
"Perform cleanup that has to happen after the minibuffer is exited.
And self-destruct this hook."
(remove-hook 'post-command-hook #'ctrlf--finalize)
(unless (= (point) ctrlf--starting-point)
(if ctrlf-auto-recenter
(set-window-start (get-buffer-window) ctrlf--final-window-start)
(push-mark ctrlf--starting-point))))
(defun ctrlf--minibuffer-exit-hook ()
"Clean up CTRLF from minibuffer and self-destruct this hook."
(setq ctrlf--minibuffer nil)
(setq ctrlf--final-window-start (window-start (minibuffer-selected-window)))
(ctrlf--delete-all-overlays)
(with-current-buffer (window-buffer (minibuffer-selected-window))
(ctrlf--restore-all-invisible-overlays)
(ctrlf--disable-invisible-overlays-at-point 'permanently))
(remove-hook
'post-command-hook #'ctrlf--minibuffer-post-command-hook 'local)
(remove-hook
'before-change-functions #'ctrlf--minibuffer-before-change-function 'local)
(remove-hook 'minibuffer-exit-hook #'ctrlf--minibuffer-exit-hook 'local)