source: trunk/source/cocoa-ide/hemlock/src/isearchcoms.lisp @ 14812

Last change on this file since 14812 was 14812, checked in by svspire, 10 years ago

Invert sense of arg in "Exchange Point and Mark" to be more like Fred.
Add "I-Search Yank Selection" plus (commented-out) binding to control-y
to provide Fred-like capability to select a string then control-s control-y
control-s to search for other instances of that string.
Left binding commented out for people who depend on current binding of control-y.

File size: 11.4 KB
Line 
1;;; -*- Mode: Lisp; Package: hemlock -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package :hemlock)
6
7(defmode "I-Search" :precedence :highest
8  ;; Make anything that's not otherwise overridden exit i-search.
9  :default-command "I-Search Exit and Redo")
10
11(add-hook abort-hook 'end-isearch-mode)
12
13(defhvar "Self Insert Command Name"
14  "The name of the command to handle quoted input (i.e. after c-q) in I-Search"
15  :value "I-Search Self Insert"
16  :mode "I-Search")
17
18(defcommand "Incremental Search" (p)
19  "Searches for input string as characters are provided.
20
21  These are the default I-Search command characters:
22     ^Q quotes the next character typed.
23     ^W extends the search string to include the the word after the point.
24     Delete cancels the last key typed.
25     ^G during a successful search aborts and returns point to where it started.
26       During a failing search, ^G backs up to last non-failing point.
27     ^S repeats forward, and ^R repeats backward.
28     ^R or ^S with empty string either changes the direction or yanks the previous search string.
29     Escape exits the search unless the string is empty.
30     Escape with an empty search string calls the non-incremental search command.
31
32  Other control characters cause exit and execution of the appropriate
33  command.
34"
35  "Set up Incremental Search mode"
36  (declare (ignore p))
37  (start-isearch-mode :forward))
38
39(defcommand "Reverse Incremental Search" (p)
40  "Searches for input string as characters are provided.
41
42  These are the default I-Search command characters:
43     ^Q quotes the next character typed.
44     ^W extends the search string to include the the word after the point.
45     Delete cancels the last key typed.
46     ^G during a successful search aborts and returns point to where it started.
47       During a failing search, ^G backs up to last non-failing point.
48     ^S repeats forward, and ^R repeats backward.
49     ^R or ^S with empty string either changes the direction or yanks the previous search string.
50     Escape exits the search unless the string is empty.
51     Escape with an empty search string calls the non-incremental search command.
52
53  Other control characters cause exit and execution of the appropriate
54  command.
55"
56  "Set up Incremental Search mode"
57  (declare (ignore p))
58  (start-isearch-mode :backward))
59
60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61;;
62
63(defstruct (isearch-state (:conc-name "ISS-"))
64  string
65  direction
66  pattern
67  failure
68  wrapped-p
69  history
70  start-region)
71
72(defun current-region-info ()
73  (list (copy-mark (current-point) :temporary)
74        (copy-mark (current-mark) :temporary)
75        (region-active-p)))
76
77(defun set-current-region-info (info)
78  (destructuring-bind (point mark active-p) info
79    (move-mark (current-point) point)
80    (move-mark (current-mark) mark)
81    (if active-p
82      (progn
83        (activate-region)
84        (note-current-selection-set-by-search))
85      (deactivate-region))))
86
87(defun %i-search-save-state (iss)
88  (push (list* (iss-string iss)
89               (iss-direction iss)
90               (iss-failure iss)
91               (iss-wrapped-p iss)
92               (current-region-info))
93        (iss-history iss)))
94
95(defun %i-search-pop-state (iss)
96  (destructuring-bind (string direction failure wrapped-p . region-info)
97                      (pop (iss-history iss))
98    (setf (iss-failure iss) failure)
99    (setf (iss-wrapped-p iss) wrapped-p)
100    (%i-search-set-pattern iss :string string :direction direction)
101    (set-current-region-info region-info)))
102
103(defun %i-search-message (iss)
104  (when t ;(interactive)
105    (message "~:[~;Failing ~]~:[~;Wrapped ~]~:[Reverse I-Search~;I-Search~]: ~A"
106             (iss-failure iss)
107             (iss-wrapped-p iss)
108             (eq (iss-direction iss) :forward)
109             (or (iss-string iss) ""))))
110
111
112;; Minor errors that don't cause isearch mode to be exited, except while
113;; executing keyboard macros.
114(defun %i-search-perhaps-error (message)
115  message
116  (if t ;(interactive)
117      (beep)
118      (abort-current-command message)))
119
120;;;;
121;;
122
123(defun current-isearch-state ()
124  (or (value i-search-state)
125      (error "I-Search command invoked outside I-Search")))
126
127(defun start-isearch-mode (direction)
128  (let* ((buffer (current-buffer))
129         (iss (make-isearch-state :direction direction
130                                  :start-region (current-region-info))))
131    (setf (buffer-minor-mode buffer "I-Search") t)
132    (unless (hemlock-bound-p 'i-search-state :buffer buffer)
133      (defhvar "I-Search State"
134        "Internal variable containing current state of I-Search"
135        :buffer buffer))
136    (unless (region-active-p) ; We need the selection (if there is one) to stay put!
137      (push-new-buffer-mark (current-point)))
138    (setf (value i-search-state) iss)
139    (%i-search-message iss)))
140
141(defun end-isearch-mode ()
142  (setf (buffer-minor-mode (current-buffer) "I-Search") nil))
143
144(defcommand "I-Search Yank Selection" (p)
145   "Pull string from current selection into search string."
146  (declare (ignore p))
147  (let* ((iss (current-isearch-state)))
148    (i-search-extend iss (region-to-string (region (current-mark) (current-point))))))
149
150(defun i-search-backup (iss)
151  (if (iss-history iss)
152    (progn
153      (%i-search-pop-state iss)
154      (%i-search-message iss))
155    (%i-search-perhaps-error "I-Search Backup failed")))
156
157(defun i-search-revert (iss)
158  (loop while (iss-failure iss) do (%i-search-pop-state iss))
159  (%i-search-message iss))
160
161(defun i-search-repeat (iss)
162  (cond ((null (iss-string iss))
163         ;; No search string, so "repeat" really means fetch last successful search string
164         (if (zerop (length *last-search-string*))
165           (%i-search-perhaps-error "No previous search string")
166           (progn
167             (%i-search-save-state iss)
168             (%i-search-set-pattern iss :string *last-search-string*)
169             (%i-search-do-search iss (current-mark)))))
170        ((iss-failure iss)
171         (%i-search-save-state iss)
172         ;; If failed last time, "repeat" really means try again from the top.
173         (setf (iss-wrapped-p iss) t) ;; start saying "Wrapped i-search" to remind 'em.
174         (%i-search-do-search iss (if (eq (iss-direction iss) :forward)
175                                    (buffer-start-mark (current-buffer))
176                                    (buffer-end-mark (current-buffer)))))
177        (t
178         (%i-search-save-state iss)
179         ;; Have a non-empty string and a successful search, just find the next one!
180         (%i-search-do-search iss (current-point))))
181  (%i-search-message iss))
182
183(defun i-search-reverse (iss)
184  (%i-search-save-state iss)
185  (%i-search-set-pattern iss :direction (ecase (iss-direction iss)
186                                          (:forward :backward)
187                                          (:backward :forward)))
188  (let* ((mark (current-mark))
189         (point (current-point)))
190    (with-mark ((temp point))
191      (move-mark point mark)
192      (move-mark mark temp))
193    (when (iss-failure iss)
194      ;; if we were failing before, search immediately, otherwise wait til asked
195      (%i-search-do-search iss mark)))
196  (%i-search-message iss))
197
198(defun i-search-extend (iss extension)
199  (%i-search-save-state iss)
200  (let* ((new-string (concatenate 'simple-string (iss-string iss) extension)))
201    (%i-search-set-pattern iss :string new-string))
202  (unless (iss-failure iss)  ;; Can't succeed now if failed before, so don't try
203    (with-mark ((temp (current-mark)))
204      (when (eq (iss-direction iss) :backward)
205        (or (character-offset temp (length extension))
206            (buffer-end temp)))
207      (%i-search-do-search iss temp)))
208  (%i-search-message iss))
209
210(defun i-search-exit (iss)
211  (let* ((string (iss-string iss)))
212    (when (and string (not (iss-failure iss)))
213      (setf *last-search-string* string)))
214  (end-isearch-mode)
215  (message ""))
216
217(defun %i-search-set-pattern (iss &key (string nil s-p) (direction nil d-p))
218  (when s-p
219    (setf (iss-string iss) (and (not (zerop (length string))) string)))
220  (when d-p
221    (setf (iss-direction iss) direction))
222  (setf (iss-pattern iss)
223        (new-search-pattern (if (value string-search-ignore-case)
224                              :string-insensitive
225                              :string-sensitive)
226                            (iss-direction iss)
227                            (or (iss-string iss) "")
228                            (iss-pattern iss))))
229
230;; Do a search for the current pattern starting at START going to
231;; end/beginning as per ISS-DIRECTION.  Sets ISS-FAILURE depending on
232;; whether found or not.  If successful, moves region to surround the
233;; found string (with point at the end for :forward search and at the
234;; beginning for :backward) and activates the region.  If failed,
235;; leaves region unchanged.  Never modifies START.
236(defun %i-search-do-search (iss start)
237  (let* ((temp (copy-mark start :temporary))
238         (found-offset (find-pattern temp (iss-pattern iss))))
239    (setf (iss-failure iss) (not found-offset))
240    (if (iss-failure iss)
241      (%i-search-perhaps-error "I-Search failed")
242      (let* ((point (current-point))
243             (mark (current-mark)))
244        (move-mark point temp)
245        (if (eq (iss-direction iss) :forward)
246          (character-offset point found-offset)
247          (character-offset temp found-offset))
248        (move-mark mark temp)
249        (activate-region)
250        (note-current-selection-set-by-search)))))
251
252;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
253;;
254
255(defcommand "I-Search Repeat Forward" (p)
256  "Repeat forward incremental search, or reverse direction if currently searching backward"
257  (declare (ignore p))
258  (let* ((iss (current-isearch-state)))
259    (if (eq (iss-direction iss) :forward)
260      (i-search-repeat iss)
261      (i-search-reverse iss))))
262
263(defcommand "I-Search Repeat Backward" (p)
264  "Repeat backward incremental search, or reverse direction if currently searching forward"
265  (declare (ignore p))
266  (let* ((iss (current-isearch-state)))
267    (if (eq (iss-direction iss) :backward)
268      (i-search-repeat iss)
269      (i-search-reverse iss))))
270
271(defcommand "I-Search Backup" (p)
272  "Undo last incremental search command"
273  (declare (ignore p))
274  (let* ((iss (current-isearch-state)))
275    (i-search-backup iss)))
276
277(defcommand "I-Search Yank Word" (p)
278  "Extend the search string to include the the word after the point."
279  (declare (ignore p))
280  (let* ((iss (current-isearch-state))
281        (point (current-point)))
282    (with-mark ((end point))
283      (if (word-offset end 1)
284        (i-search-extend iss (region-to-string (region point end)))
285        (%i-search-perhaps-error "No more words")))))
286
287(defcommand "I-Search Self Insert" (p)
288  "Add character typed to search string"
289  (declare (ignore p))
290  (let* ((iss (current-isearch-state))
291        (char (last-char-typed)))
292    (unless char (editor-error "Can't insert that character."))
293    (i-search-extend iss (string char))))
294
295(defcommand "I-Search Abort" (p)
296  "Abort incremental search mode if search is successful.  Otherwise, revert to last
297successful search and continue searching."
298  (declare (ignore p))
299  (let* ((iss (current-isearch-state)))
300    (if (iss-failure iss)
301      (i-search-revert iss)
302      ;; Else move back to starting point and stop searching
303      (progn
304        (set-current-region-info (iss-start-region iss))
305        (abort-current-command "Search aborted")))))
306
307;; The transparent-p flag takes care of executing the key normally when we're done,
308;; as long as we don't take a non-local exit.
309(defcommand ("I-Search Exit and Redo" :transparent-p t) (p)
310  "Exit Incremental Search and then execute the key normally"
311  (declare (ignore p))
312  (let* ((iss (current-isearch-state)))
313    (i-search-exit iss)))
314
315(defcommand "I-Search Exit or Search" (p)
316  "Exit incremental search.  If the search string is empty, switch to non-incremental search,
317otherwise just quit"
318  (declare (ignore p))
319  (let* ((iss (current-isearch-state))
320         (string (iss-string iss))
321         (direction (iss-direction iss)))
322    (i-search-exit iss)
323    (when (null string)
324      (if (eq direction :forward)
325        (forward-search-command nil)
326        (reverse-search-command nil)))))
327
328
329
Note: See TracBrowser for help on using the repository browser.