source: trunk/source/cocoa-ide/hemlock/src/searchcoms.lisp @ 15880

Last change on this file since 15880 was 15880, checked in by gz, 6 years ago

Make DEFINITIONS-IN-DOCUMENT also return the type of each definition

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.9 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; This file contains searching and replacing commands.
13;;;
14
15(in-package :hemlock)
16
17
18
19;;;; Some global state.
20
21(defvar *last-search-string* () "Last string searched for.")
22(defvar *last-search-pattern*
23  (new-search-pattern :string-insensitive :forward "Foo")
24  "Search pattern we keep around so we don't cons them all the time.")
25(defvar *search-wrapped-p* nil "True if search wrapped")
26
27(defhvar "String Search Ignore Case"
28  "When set, string searching commands use case insensitive."
29  :value t)
30
31(defun get-search-pattern (string direction)
32  (declare (simple-string string))
33  (when (zerop (length string)) (editor-error))
34  (setq *last-search-string* string)
35  (setq *last-search-pattern*
36        (new-search-pattern (if (value string-search-ignore-case)
37                                :string-insensitive
38                                :string-sensitive)
39                            direction string *last-search-pattern*)))
40
41
42(defun note-current-selection-set-by-search ()
43  (hemlock-ext:note-selection-set-by-search (current-buffer)))
44
45;;;; Vanilla searching.
46
47(defcommand "Forward Search" (p &optional string)
48  "Do a forward search for a string.
49  Prompt for the string and leave the point after where it is found."
50  "Searches for the specified String in the current buffer."
51  (declare (ignore p))
52  (if (not string)
53      (setq string (prompt-for-string :prompt "Search: "
54                                      :default *last-search-string*
55                                      :help "String to search for")))
56  (let* ((pattern (get-search-pattern string :forward))
57         (point (current-point))
58         (mark (copy-mark point))
59         ;; find-pattern moves point to start of match, and returns is # chars matched
60         (won (find-pattern point pattern)))
61    (cond (won (move-mark mark point)
62               (character-offset point won)
63               (push-buffer-mark mark t)
64               (note-current-selection-set-by-search))
65          (t (delete-mark mark)
66             (editor-error)))
67    (clear-echo-area)))
68
69(defcommand "Reverse Search" (p &optional string)
70  "Do a backward search for a string.
71   Prompt for the string and leave the point before where it is found."
72  "Searches backwards for the specified String in the current buffer."
73  (declare (ignore p))
74  (if (not string)
75      (setq string (prompt-for-string :prompt "Reverse Search: "
76                                      :default *last-search-string* 
77                                      :help "String to search for")))
78  (let* ((pattern (get-search-pattern string :backward))
79         (point (current-point))
80         (mark (copy-mark point))
81         (won (find-pattern point pattern)))
82    (cond (won (move-mark mark point)
83               (character-offset mark won)
84               (push-buffer-mark mark t)
85               (note-current-selection-set-by-search))
86          (t (delete-mark mark)
87             (editor-error)))
88    (clear-echo-area)))
89
90
91
92;;;; Replacement commands:
93
94(defmode "Query/Replace" :precedence :highest
95  :documentation "Type one of the following single-character commands:"
96  ;; Make anything that's not otherwise overridden exit query/replace
97  :default-command "Query/Replace Exit and Redo")
98
99(add-hook abort-hook 'abort-query/replace-mode)
100
101(defhvar "Case Replace"
102  "If this is true then \"Query Replace\" will try to preserve case when
103  doing replacements."
104  :value t)
105
106(defcommand "Replace String" (p &optional
107                                (target (prompt-for-string
108                                         :prompt "Replace String: "
109                                         :help "Target string"
110                                         :default *last-search-string*))
111                                (replacement (prompt-for-string
112                                              :prompt "With: "
113                                              :help "Replacement string")))
114  "Replaces the specified Target string with the specified Replacement
115   string in the current buffer for all occurrences after the point or within
116   the active region, depending on whether it is active."
117  (let ((qrs (query/replace-init :count p :target target :replacement replacement
118                                 :undo-name "Replace String")))
119    (query/replace-all qrs)
120    (query/replace-finish qrs)))
121
122(defun current-query-replace-state ()
123  (or (value query/replace-state)
124      (error "Query/Replace command invoked outside Query Replace")))
125
126(defcommand "Query Replace" (p &optional
127                               (target (prompt-for-string
128                                        :prompt "Query Replace: "
129                                        :help "Target string"
130                                        :default *last-search-string*))
131                               (replacement (prompt-for-string
132                                             :prompt "With: "
133                                             :help "Replacement string")))
134  "Replaces the Target string with the Replacement string if confirmation
135   from the keyboard is given.  If the region is active, limit queries to
136   occurrences that occur within it, otherwise use point to end of buffer."
137  (let* ((buffer (current-buffer))
138         (qrs (query/replace-init :count p :target target :replacement replacement
139                                  :undo-name "Query Replace")))
140    (setf (buffer-minor-mode (current-buffer) "Query/Replace") t)
141    (unless (hemlock-bound-p 'query/replace-state :buffer buffer)
142      (defhvar "Query/Replace State"
143        "Internal variable containing current state of Query/Replace"
144        :buffer buffer))
145    (setf (value query/replace-state) qrs)
146    (query/replace-find-next qrs)))
147
148(defstruct (replace-undo (:constructor make-replace-undo (mark region)))
149  mark
150  region)
151
152(setf (documentation 'replace-undo-mark 'function)
153      "Return the mark where a replacement was made.")
154(setf (documentation 'replace-undo-region 'function)
155      "Return region deleted due to replacement.")
156
157
158(defstruct (query-replace-state (:conc-name "QRS-"))
159  count
160  target
161  replacement
162  undo-name
163  dumb-p
164  upper
165  cap
166  start-mark
167  last-found
168  stop-mark
169  undo-data)
170
171(defun query/replace-init (&key count target replacement undo-name)
172  (when (and count (minusp count))
173    (editor-error "Replacement count is negative."))
174  (let* ((point (current-point))
175         (region (get-count-region))
176         (start-mark (copy-mark (region-start region) :temporary))
177         (end-mark (copy-mark (region-end region) :left-inserting)))
178    (move-mark point start-mark)
179    (get-search-pattern target :forward)
180    (make-query-replace-state
181     :count (or count -1)
182     :target target
183     :replacement replacement
184     :undo-name undo-name
185     :dumb-p (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
186                                                 (lower-case-p ch)))
187                              (the string replacement))
188                       (value case-replace)))
189     :upper (string-upcase replacement)
190     :cap (string-capitalize replacement)
191     :start-mark start-mark
192     :last-found (copy-mark start-mark :temporary)
193     :stop-mark end-mark
194     :undo-data nil)))
195
196
197(defun query/replace-find-next (qrs &key (interactive t))
198  (let* ((point (current-point))
199         (won (and (not (zerop (qrs-count qrs)))
200                   (find-pattern point *last-search-pattern* (qrs-stop-mark qrs)))))
201    (if won
202      (progn
203        (decf (qrs-count qrs))
204        (move-mark (qrs-last-found qrs) (current-point))
205        (character-offset point (length (qrs-target qrs)))
206        (when interactive
207          (message "Query Replace (type ? for help): "))
208        T)
209      (progn
210        (when interactive
211          (end-query/replace-mode))
212        nil))))
213
214(defun query/replace-replace (qrs)
215  (let* ((replacement (qrs-replacement qrs))
216         (point (current-point))
217         (length (length (qrs-target qrs))))
218    (with-mark ((undo-mark1 point :left-inserting)
219                (undo-mark2 point :left-inserting))
220      (character-offset undo-mark1 (- length))
221      (let ((string (cond ((qrs-dumb-p qrs) replacement)
222                          ((upper-case-p (next-character undo-mark1))
223                           (prog2
224                            (mark-after undo-mark1)
225                            (if (upper-case-p (next-character undo-mark1))
226                              (qrs-upper qrs)
227                              (qrs-cap qrs))
228                            (mark-before undo-mark1)))
229                          (t replacement))))
230        (push (make-replace-undo
231               ;; Save :right-inserting, so the INSERT-STRING at mark below
232               ;; doesn't move the copied mark the past replacement.
233               (copy-mark undo-mark1 :right-inserting)
234               (delete-and-save-region (region undo-mark1 undo-mark2)))
235              (qrs-undo-data qrs))
236        (insert-string point string)))))
237
238(defun query/replace-all (qrs)
239  (loop
240    while (query/replace-find-next qrs :interactive nil)
241    do (query/replace-replace qrs)))
242
243(defun query/replace-finish (qrs &key (report t))
244  (let* ((undo-data (nreverse (qrs-undo-data qrs)))
245         (count (length undo-data))
246         (replacement-len (length (qrs-replacement qrs))))
247    (save-for-undo (qrs-undo-name qrs)
248      #'(lambda ()
249          (dolist (ele undo-data)
250            (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
251          (dolist (ele undo-data)
252            (let ((mark (replace-undo-mark ele)))
253              (delete-characters mark replacement-len)
254              (ninsert-region mark (replace-undo-region ele)))))
255      #'(lambda ()
256          (dolist (ele undo-data)
257            (delete-mark (replace-undo-mark ele)))))
258    (unless (mark= (current-point) (qrs-start-mark qrs))
259      (push-buffer-mark (qrs-start-mark qrs)))
260    (delete-mark (qrs-stop-mark qrs))
261    (when report
262      (message "~D occurrence~:P replaced." count))))
263
264
265(defun abort-query/replace-mode ()
266  (when (buffer-minor-mode (current-buffer) "Query/Replace")
267    (end-query/replace-mode :report nil)))
268
269(defun end-query/replace-mode (&key (report t))
270  (let* ((qrs (current-query-replace-state)))
271    (query/replace-finish qrs :report report)
272    (setf (buffer-minor-mode (current-buffer) "Query/Replace") nil)))
273
274(defcommand "Query/Replace This" (p)
275  "Replace this occurence"
276  (declare (ignore p))
277  (let ((qrs (current-query-replace-state)))
278    (query/replace-replace qrs)
279    (query/replace-find-next qrs)))
280
281(defcommand "Query/Replace Skip" (p)
282  "Don't replace this occurence, but continue"
283  (declare (ignore p))
284  (let ((qrs (current-query-replace-state)))
285    (query/replace-find-next qrs)))
286
287(defcommand "Query/Replace All" (p)
288  "Replace this and all remaining occurences"
289  (declare (ignore p))
290  (let ((qrs (current-query-replace-state)))
291    (query/replace-replace qrs)
292    (query/replace-all qrs))
293  (end-query/replace-mode))
294
295(defcommand "Query/Replace Last" (p)
296  "Replace this occurrence, then exit"
297  (declare (ignore p))
298  (let ((qrs (current-query-replace-state)))
299    (query/replace-replace qrs))
300  (end-query/replace-mode))
301
302(defcommand "Query/Replace Exit" (p)
303  "Exit Query Replace mode"
304  (declare (ignore p))
305  (end-query/replace-mode))
306
307(defcommand "Query/Replace Abort" (p)
308  "Abort Query/Replace mode"
309  (declare (ignore p))
310  (abort-current-command "Query/Replace aborted"))
311
312(defcommand "Query/Replace Help" (p)
313  "Describe Query/Replace commands"
314  (describe-mode-command p "Query/Replace"))
315
316;; The transparent-p flag takes care of executing the key normally when we're done,
317;; as long as we don't take a non-local exit.
318(defcommand ("Query/Replace Exit and Redo" :transparent-p t) (p)
319  "Exit Query Replace and then execute the key normally"
320  (declare (ignore p))
321  (end-query/replace-mode))
322
323;;;; Occurrence searching.
324
325(defcommand "List Matching Lines" (p &optional string)
326  "Prompts for a search string and lists all matching lines after the point or
327   within the current-region, depending on whether it is active or not.
328   With an argument, lists p lines before and after each matching line."
329  "Prompts for a search string and lists all matching lines after the point or
330   within the current-region, depending on whether it is active or not.
331   With an argument, lists p lines before and after each matching line."
332  (unless string
333    (setf string (prompt-for-string :prompt "List Matching: "
334                                    :default *last-search-string*
335                                    :help "String to search for")))
336  (let ((pattern (get-search-pattern string :forward))
337        (matching-lines nil)
338        (region (get-count-region)))
339    (with-mark ((mark (region-start region))
340                (end-mark (region-end region)))
341      (loop
342        (when (or (null (find-pattern mark pattern)) (mark> mark end-mark))
343          (return))
344        (setf matching-lines
345              (nconc matching-lines (list-lines mark (or p 0))))
346        (unless (line-offset mark 1 0)
347          (return))))
348    (with-pop-up-display (s :height (length matching-lines) :title (format nil "Lines matching ~s" string))
349      (dolist (line matching-lines)
350        (write-line line s)))))
351
352;;; LIST-LINES creates a lists of strings containing (num) lines before the
353;;; line that the point is on, the line that the point is on, and (num)
354;;; lines after the line that the point is on. If (num) > 0, a string of
355;;; dashes will be added to make life easier for List Matching Lines.
356;;;
357(defun list-lines (mark num)
358  (if (<= num 0)
359      (list (line-string (mark-line mark)))
360      (with-mark ((mark mark)
361                  (beg-mark mark))
362        (unless (line-offset beg-mark (- num))
363          (buffer-start beg-mark))
364        (unless (line-offset mark num)
365          (buffer-end mark))
366        (let ((lines (list "--------")))
367          (loop
368            (push (line-string (mark-line mark)) lines)
369            (when (same-line-p mark beg-mark)
370              (return lines))
371            (line-offset mark -1))))))
372
373(defcommand "Delete Matching Lines" (p &optional string)
374  "Deletes all lines that match the search pattern using delete-region. If
375   the current region is active, limit the search to it. The argument is
376   ignored."
377  "Deletes all lines that match the search pattern using delete-region. If
378   the current region is active, limit the search to it. The argument is
379   ignored."
380  (declare (ignore p))
381  (unless string
382    (setf string (prompt-for-string :prompt "Delete Matching: "
383                                    :default *last-search-string*
384                                    :help "String to search for")))
385  (let* ((region (get-count-region))
386         (pattern (get-search-pattern string :forward))
387         (start-mark (region-start region))
388         (end-mark (region-end region)))
389    (with-mark ((bol-mark start-mark :left-inserting)
390                (eol-mark start-mark :right-inserting))
391      (loop
392        (unless (and (find-pattern bol-mark pattern) (mark< bol-mark end-mark))
393          (return))
394        (move-mark eol-mark bol-mark)
395        (line-start bol-mark)
396        (unless (line-offset eol-mark 1 0)
397          (buffer-end eol-mark))
398        (delete-region (region bol-mark eol-mark))))))
399
400(defcommand "Delete Non-Matching Lines" (p &optional string)
401  "Deletes all lines that do not match the search pattern using delete-region.
402   If the current-region is active, limit the search to it. The argument is
403   ignored."
404  "Deletes all lines that do not match the search pattern using delete-region.
405   If the current-region is active, limit the search to it. The argument is
406   ignored."
407  (declare (ignore p))
408  (unless string
409    (setf string (prompt-for-string :prompt "Delete Non-Matching:"
410                                    :default *last-search-string*
411                                    :help "String to search for")))
412  (let* ((region (get-count-region))
413         (start-mark (region-start region))
414         (stop-mark (region-end region))
415         (pattern (get-search-pattern string :forward)))
416    (with-mark ((beg-mark start-mark :left-inserting)
417                (end-mark start-mark :right-inserting))
418      (loop
419        (move-mark end-mark beg-mark)
420        (cond ((and (find-pattern end-mark pattern) (mark< end-mark stop-mark))
421               (line-start end-mark)
422               (delete-region (region beg-mark end-mark))
423               (unless (line-offset beg-mark 1 0)
424                 (return)))
425              (t
426               (delete-region (region beg-mark stop-mark))
427               (return)))))))
428
429(defcommand "Count Occurrences" (p &optional string)
430  "Prompts for a search string and counts occurrences of it after the point or
431   within the current-region, depending on whether it is active or not. The
432   argument is ignored."
433  "Prompts for a search string and counts occurrences of it after the point or
434   within the current-region, depending on whether it is active or not. The
435   argument is ignored."
436  (declare (ignore p))
437  (unless string
438    (setf string (prompt-for-string
439                  :prompt "Count Occurrences: "
440                  :default *last-search-string*
441                  :help "String to search for")))
442  (message "~D occurrence~:P"
443           (count-occurrences-region (get-count-region) string)))
444
445(defun count-occurrences-region (region string)
446  (let ((pattern (get-search-pattern string :forward))
447        (end-mark (region-end region)))
448    (let ((occurrences 0))
449      (with-mark ((mark (region-start region)))
450        (loop
451          (let ((won (find-pattern mark pattern)))
452            (when (or (null won) (mark> mark end-mark))
453              (return))
454            (incf occurrences)
455            (character-offset mark won))))
456      occurrences)))
457
458
459;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
460
461(defparameter *def-search-string* (coerce '(#\newline #\() 'string))
462
463(defcommand "List Definitions" (p)
464  "List definitions in the buffer, or in the current region if there is one"
465  (declare (ignore p))
466  (let* ((view (current-view))
467         (region (if (region-active-p)
468                  (current-region)
469                  (buffer-region (current-buffer))))
470         (definitions (collect-definition-lines region)))
471    (flet ((defn-action (defn)
472             (gui::execute-in-gui (lambda ()
473                                    (hemlock-ext:select-view view)
474                                    (hi::handle-hemlock-event view 
475                                      (lambda ()
476                                        ;; TODO: only leave mark if we're far away, or maybe if last command
477                                        ;; was not list-definitions...
478                                        (destructuring-bind (line-text posn) defn
479                                          (or (move-to-definition posn line-text t)
480                                              (loud-message "Could find definition"))))))))
481           (defn-printer (defn stream)
482             (write-string (car defn) stream)))
483      (hemlock-ext:open-sequence-dialog
484       :title (format nil "Definitions in ~s" (buffer-name (current-buffer)))
485       :sequence definitions
486       :action #'defn-action
487       :printer #'defn-printer))))
488
489(defun collect-definition-lines (&optional (region (buffer-region (current-buffer))))
490  (let* ((pattern (new-search-pattern :string-sensitive :forward *def-search-string*))
491         (end (region-end region)))
492    (with-mark ((mark (region-start region)))
493      ;; TODO: doesn't find the definition on very first line.  LTRAB.
494      (loop
495        until (or (null (find-pattern mark pattern)) (mark> mark end))
496        as line = (mark-line (mark-after mark))
497        collect (list (line-string line) (hi::get-line-origin line) (get-definition-type mark))
498        while (let ((next (line-next line)))
499                (when next
500                  (setf (mark-line mark) next)
501                  (setf (mark-charpos mark) 0)))))))
502
503(defun get-definition-type (mark)
504  (let ((buffer (mark-buffer mark)))
505    (mark-after mark)
506    (let ((str (symbol-at-mark buffer mark)))
507      (when str
508        (multiple-value-bind (sym error)
509                             (let* ((*package* (ccl:require-type (or (buffer-package buffer) *package*) 'package)))
510                               (ignore-errors (values (read-from-string str))))
511          (if error
512            (intern (string-upcase str) *package*)
513            sym))))))
514
515(defun move-to-definition (posn line-text &optional (leave-mark t))
516  (flet ((ssearch (mark string direction)
517           (find-pattern mark (new-search-pattern :string-insensitive
518                                                  direction
519                                                  string))))
520    (declare (inline ssearch))
521    (with-mark ((mark (current-point)))
522      (or (move-to-absolute-position mark posn) (buffer-end mark))
523      (when (or (ssearch mark line-text :forward)
524                (ssearch mark line-text :backward))
525        (if leave-mark
526          (move-point-leaving-mark mark)
527          (move-mark (current-point-collapsing-selection) mark))))))
528
529
530;; Interface for getting this functionality outside of the editor.
531;; Returns a list of (string number symbol) where string is the first line of the definition,
532;; number is the absolute position in the buffer of the start of the line, and symbol is the
533;; definition type (eg. DEFUN, DEFVAR, HI:DEFCOMMAND, etc).
534(defun definitions-in-document (ns-doc)
535  (gui::execute-in-buffer (gui::hemlock-buffer ns-doc) #'collect-definition-lines))
Note: See TracBrowser for help on using the repository browser.