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

Last change on this file since 8428 was 8428, checked in by gz, 13 years ago

Merge of the 'event-ide' branch. Hemlock's thread model has been changed
so that Hemlock commands now run in the Cocoa event thread -- see the
Hemlock file view.lisp for an overview.

IDE compilation has also been reorganized. Hemlock is now more fully
integrated into the IDE and cannot be compiled separately, sorry.

The hemlock-ext package has been repurposed to contain all interfaces
to window-system specific functionality.

There are also many many assorted other changes, cleanups and fixes.

The Hemlock documentation (Hemlock Command Implementor's Manual) in
http://trac.clozure.com/openmcl/wiki now correctly reflects the
implementation, although it doesn't (yet) describe the integration
with Cocoa or the threading model.

File size: 11.1 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    (push-new-buffer-mark (current-point))
137    (setf (value i-search-state) iss)
138    (%i-search-message iss)))
139
140(defun end-isearch-mode ()
141  (setf (buffer-minor-mode (current-buffer) "I-Search") nil))
142
143(defun i-search-backup (iss)
144  (if (iss-history iss)
145    (progn
146      (%i-search-pop-state iss)
147      (%i-search-message iss))
148    (%i-search-perhaps-error "I-Search Backup failed")))
149
150(defun i-search-revert (iss)
151  (loop while (iss-failure iss) do (%i-search-pop-state iss))
152  (%i-search-message iss))
153
154(defun i-search-repeat (iss)
155  (cond ((null (iss-string iss))
156         ;; No search string, so "repeat" really means fetch last successful search string
157         (if (zerop (length *last-search-string*))
158           (%i-search-perhaps-error "No previous search string")
159           (progn
160             (%i-search-save-state iss)
161             (%i-search-set-pattern iss :string *last-search-string*)
162             (%i-search-do-search iss (current-mark)))))
163        ((iss-failure iss)
164         (%i-search-save-state iss)
165         ;; If failed last time, "repeat" really means try again from the top.
166         (setf (iss-wrapped-p iss) t) ;; start saying "Wrapped i-search" to remind 'em.
167         (%i-search-do-search iss (if (eq (iss-direction iss) :forward)
168                                    (buffer-start-mark (current-buffer))
169                                    (buffer-end-mark (current-buffer)))))
170        (t
171         (%i-search-save-state iss)
172         ;; Have a non-empty string and a successful search, just find the next one!
173         (%i-search-do-search iss (current-point))))
174  (%i-search-message iss))
175
176(defun i-search-reverse (iss)
177  (%i-search-save-state iss)
178  (%i-search-set-pattern iss :direction (ecase (iss-direction iss)
179                                          (:forward :backward)
180                                          (:backward :forward)))
181  (let* ((mark (current-mark))
182         (point (current-point)))
183    (with-mark ((temp point))
184      (move-mark point mark)
185      (move-mark mark temp))
186    (when (iss-failure iss)
187      ;; if we were failing before, search immediately, otherwise wait til asked
188      (%i-search-do-search iss mark)))
189  (%i-search-message iss))
190
191(defun i-search-extend (iss extension)
192  (%i-search-save-state iss)
193  (let* ((new-string (concatenate 'simple-string (iss-string iss) extension)))
194    (%i-search-set-pattern iss :string new-string))
195  (unless (iss-failure iss)  ;; Can't succeed now if failed before, so don't try
196    (with-mark ((temp (current-mark)))
197      (when (eq (iss-direction iss) :backward)
198        (or (character-offset temp (length extension))
199            (buffer-end temp)))
200      (%i-search-do-search iss temp)))
201  (%i-search-message iss))
202
203(defun i-search-exit (iss)
204  (let* ((string (iss-string iss)))
205    (when (and string (not (iss-failure iss)))
206      (setf *last-search-string* string)))
207  (end-isearch-mode)
208  (message ""))
209
210(defun %i-search-set-pattern (iss &key (string nil s-p) (direction nil d-p))
211  (when s-p
212    (setf (iss-string iss) (and (not (zerop (length string))) string)))
213  (when d-p
214    (setf (iss-direction iss) direction))
215  (setf (iss-pattern iss)
216        (new-search-pattern (if (value string-search-ignore-case)
217                              :string-insensitive
218                              :string-sensitive)
219                            (iss-direction iss)
220                            (or (iss-string iss) "")
221                            (iss-pattern iss))))
222
223;; Do a search for the current pattern starting at START going to
224;; end/beginning as per ISS-DIRECTION.  Sets ISS-FAILURE depending on
225;; whether found or not.  If successful, moves region to surround the
226;; found string (with point at the end for :forward search and at the
227;; beginning for :backward) and activates the region.  If failed,
228;; leaves region unchanged.  Never modifies START.
229(defun %i-search-do-search (iss start)
230  (let* ((temp (copy-mark start :temporary))
231         (found-offset (find-pattern temp (iss-pattern iss))))
232    (setf (iss-failure iss) (not found-offset))
233    (if (iss-failure iss)
234      (%i-search-perhaps-error "I-Search failed")
235      (let* ((point (current-point))
236             (mark (current-mark)))
237        (move-mark point temp)
238        (if (eq (iss-direction iss) :forward)
239          (character-offset point found-offset)
240          (character-offset temp found-offset))
241        (move-mark mark temp)
242        (activate-region)
243        (note-current-selection-set-by-search)))))
244
245;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246;;
247
248(defcommand "I-Search Repeat Forward" (p)
249  "Repeat forward incremental search, or reverse direction if currently searching backward"
250  (declare (ignore p))
251  (let* ((iss (current-isearch-state)))
252    (if (eq (iss-direction iss) :forward)
253      (i-search-repeat iss)
254      (i-search-reverse iss))))
255
256(defcommand "I-Search Repeat Backward" (p)
257  "Repeat backward incremental search, or reverse direction if currently searching forward"
258  (declare (ignore p))
259  (let* ((iss (current-isearch-state)))
260    (if (eq (iss-direction iss) :backward)
261      (i-search-repeat iss)
262      (i-search-reverse iss))))
263
264(defcommand "I-Search Backup" (p)
265  "Undo last incremental search command"
266  (declare (ignore p))
267  (let* ((iss (current-isearch-state)))
268    (i-search-backup iss)))
269
270(defcommand "I-Search Yank Word" (p)
271  "Extend the search string to include the the word after the point."
272  (declare (ignore p))
273  (let* ((iss (current-isearch-state))
274        (point (current-point)))
275    (with-mark ((end point))
276      (if (word-offset end 1)
277        (i-search-extend iss (region-to-string (region point end)))
278        (%i-search-perhaps-error "No more words")))))
279
280(defcommand "I-Search Self Insert" (p)
281  "Add character typed to search string"
282  (declare (ignore p))
283  (let* ((iss (current-isearch-state))
284        (char (last-char-typed)))
285    (unless char (editor-error "Can't insert that character."))
286    (i-search-extend iss (string char))))
287
288(defcommand "I-Search Abort" (p)
289  "Abort incremental search mode if search is successful.  Otherwise, revert to last
290successful search and continue searching."
291  (declare (ignore p))
292  (let* ((iss (current-isearch-state)))
293    (if (iss-failure iss)
294      (i-search-revert iss)
295      ;; Else move back to starting point and stop searching
296      (progn
297        (set-current-region-info (iss-start-region iss))
298        (abort-current-command "Search aborted")))))
299
300;; The transparent-p flag takes care of executing the key normally when we're done,
301;; as long as we don't take a non-local exit.
302(defcommand ("I-Search Exit and Redo" :transparent-p t) (p)
303  "Exit Incremental Search and then execute the key normally"
304  (declare (ignore p))
305  (let* ((iss (current-isearch-state)))
306    (i-search-exit iss)))
307
308(defcommand "I-Search Exit or Search" (p)
309  "Exit incremental search.  If the search string is empty, switch to non-incremental search,
310otherwise just quit"
311  (declare (ignore p))
312  (let* ((iss (current-isearch-state))
313         (string (iss-string iss))
314         (direction (iss-direction iss)))
315    (i-search-exit iss)
316    (when (null string)
317      (if (eq direction :forward)
318        (forward-search-command nil)
319        (reverse-search-command nil)))))
320
321
322
Note: See TracBrowser for help on using the repository browser.