Changeset 7922

Timestamp:

Dec 19, 2007, 7:36:01 AM (17 years ago)

Author:

gz

Message:

Reimplement Query Replace as a minor mode

Location:

branches/event-ide/ccl/cocoa-ide/hemlock/src

Files:

• bindings.lisp (modified) (2 diffs)
• echo.lisp (modified) (1 diff)
• search1.lisp (modified) (2 diffs)
• searchcoms.lisp (modified) (4 diffs)

branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

@@ -959 +959 @@
 
 
+;;;; Query/Replace mode.
+;;;;
+;;;; Anything that's not explicitly bound here will exit i-search.
+
+(bind-key "Query/Replace This" #k"y" :mode "Query/Replace")
+(bind-key "Query/Replace This" #k"space" :mode "Query/Replace")
+(bind-key "Query/Replace Skip" #k"n" :mode "Query/Replace")
+(bind-key "Query/Replace Skip" #k"backspace" :mode "Query/Replace")
+(bind-key "Query/Replace Skip" #k"delete" :mode "Query/Replace")
+(bind-key "Query/Replace All" #k"!" :mode "Query/Replace")
+(bind-key "Query/Replace Last" #k"." :mode "Query/Replace")
+(bind-key "Query/Replace Exit" #k"q" :mode "Query/Replace")
+(bind-key "Query/Replace Exit" #k"escape" :mode "Query/Replace")
+(bind-key "Query/Replace Abort" #k"control-g" :mode "Query/Replace")
+(bind-key "Query/Replace Abort" #k"control-G" :mode "Query/Replace")
+(bind-key "Query/Replace Help" #k"h" :mode "Query/Replace")
+(bind-key "Query/Replace Help" #k"?" :mode "Query/Replace")
+(bind-key "Query/Replace Help" #k"home" :mode "Query/Replace")
+(bind-key "Query/Replace Help" #k"control-_" :mode "Query/Replace")
+
 ;;;; Logical characters.
  
@@ -967 +987 @@
 (setf (logical-key-event-p #k"backspace" :no) t)
 (setf (logical-key-event-p #k"delete" :no) t)
-(setf (logical-key-event-p #k"!" :do-all) t)
-(setf (logical-key-event-p #k"." :do-once) t)
 (setf (logical-key-event-p #k"home" :help) t)
 (setf (logical-key-event-p #k"h" :help) t)

branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

@@ -542 +542 @@
                                   (help "Type any key"))
   "Prompts for a key-event."
-  (prompt-for-something
+  (parse-for-something
    :verification-function #'(lambda (eps key-event)
                               (declare (ignore eps))

branches/event-ide/ccl/cocoa-ide/hemlock/src/search1.lisp

@@ -629 +629 @@
 
 
-(defun find-pattern (mark search-pattern)
+(defun find-pattern (mark search-pattern &optional stop-mark)
   "Find a match of Search-Pattern starting at Mark.  Mark is moved to
   point before the match and the number of characters matched is returned.
   If there is no match for the pattern then Mark is not modified and NIL
-  is returned."
+  is returned.
+  If stop-mark is specified, NIL is returned and mark is not moved if
+  the point before the match is after stop-mark"
   (close-line)
   (multiple-value-bind (line start matched)
@@ -639 +641 @@
                                 search-pattern (mark-line mark)
                                 (mark-charpos mark))
-    (when matched
+    (when (and matched
+               (or (null stop-mark)
+                   (< (line-number line) (line-number (mark-line stop-mark)))
+                   (and (= (line-number line) (line-number (mark-line stop-mark)))
+                        (<= start (mark-charpos stop-mark)))))
       (move-to-position mark start line)
       matched)))

branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

@@ -95 +95 @@
 ;;;; Replacement commands:
 
+(defmode "Query/Replace" :precedence :highest
+  :documentation "Type one of the following single-character commands:"
+  ;; Make anything that's not otherwise overridden exit query/replace
+  :default-command "Query/Replace Exit and Redo")
+
+(add-hook abort-hook 'abort-query/replace-mode)
+
+(defhvar "Query/Replace State"
+  "Internal variable containing current state of Query/Replace"
+  :mode "Query/Replace")
+
+(defun current-query-replace-state ()
+  (or (value query/replace-state)
+      (error "Query/Replace command invoked outside Query Replace")))
+
+(defhvar "Case Replace"
+  "If this is true then \"Query Replace\" will try to preserve case when
+  doing replacements."
+  :value t)
+
 (defcommand "Replace String" (p &optional
                                 (target (prompt-for-string
@@ -106 +126 @@
    string in the current buffer for all occurrences after the point or within
    the active region, depending on whether it is active."
-  "Replaces the specified Target string with the specified Replacement
-   string in the current buffer for all occurrences after the point or within
-   the active region, depending on whether it is active.  The prefix argument
-   may limit the number of replacements."
-  (multiple-value-bind (ignore count)
-                       (query-replace-function p target replacement
-                                               "Replace String" t)
-    (declare (ignore ignore))
-    (message "~D Occurrences replaced." count)))
+  (let ((qrs (query/replace-init :count p :target target :replacement replacement
+                                 :undo-name "Replace String")))
+    (query/replace-all qrs)
+    (query/replace-finish qrs)))
 
 (defcommand "Query Replace" (p &optional
@@ -127 +142 @@
    from the keyboard is given.  If the region is active, limit queries to
    occurrences that occur within it, otherwise use point to end of buffer."
-  "Replaces the Target string with the Replacement string if confirmation
-   from the keyboard is given.  If the region is active, limit queries to
-   occurrences that occur within it, otherwise use point to end of buffer.
-   A prefix argument may limit the number of queries."
-  (let ((mark (copy-mark (current-point))))
-    (multiple-value-bind (ignore count)
-                         (query-replace-function p target replacement
-                                                 "Query Replace")
-      (declare (ignore ignore))
-      (message "~D Occurrences replaced." count))
-    (push-buffer-mark mark)))
-
-
-(defhvar "Case Replace"
-  "If this is true then \"Query Replace\" will try to preserve case when
-  doing replacements."
-  :value t)
+  (let ((qrs (query/replace-init :count p :target target :replacement replacement
+                                 :undo-name "Query Replace")))
+    (setf (buffer-minor-mode (current-buffer) "Query/Replace") t)
+    (setf (value query/replace-state) qrs)
+    (query/replace-find-next qrs)))
 
 (defstruct (replace-undo (:constructor make-replace-undo (mark region)))
@@ -154 +157 @@
       "Return region deleted due to replacement.")
 
-(defvar *query-replace-undo-data* nil)
-
-;;; REPLACE-THAT-CASE replaces a string case-sensitively.  Lower, Cap and Upper
-;;; are the original, capitalized and uppercase replacement strings.  Mark is a
-;;; :left-inserting mark after the text to be replaced.  Length is the length
-;;; of the target string.  If dumb, then do a simple replace.  This pushes
-;;; an undo information structure into *query-replace-undo-data* which
-;;; QUERY-REPLACE-FUNCTION uses.
-;;;
-(defun replace-that-case (lower cap upper mark length dumb)
-  (character-offset mark (- length))
-  (let ((insert (cond (dumb lower)
-                      ((upper-case-p (next-character mark))
-                       (mark-after mark)
-                       (prog1 (if (upper-case-p (next-character mark)) upper cap)
-                              (mark-before mark)))
-                      (t lower))))
-    (with-mark ((undo-mark1 mark :left-inserting)
-                (undo-mark2 mark :left-inserting))
-      (character-offset undo-mark2 length)
-      (push (make-replace-undo
-             ;; Save :right-inserting, so the INSERT-STRING at mark below
-             ;; doesn't move the copied mark the past replacement.
-             (copy-mark mark :right-inserting)
-             (delete-and-save-region (region undo-mark1 undo-mark2)))
-            *query-replace-undo-data*))
-    (insert-string mark insert)))
-
-;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands:
-;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace".
-;;; Name is the name of the command for undoing purposes.  If doing-all? is
-;;; true, this replaces all ocurrences for the non-querying commands.  This
-;;; returns t if it completes successfully, and nil if it is aborted.  As a
-;;; second value, it returns the number of replacements.
-;;;
-;;; The undo method, before undo'ing anything, makes all marks :left-inserting.
-;;; There's a problem when two replacements are immediately adjacent, such as
-;;;    foofoo
-;;; replacing "foo" with "bar".  If the marks were still :right-inserting as
-;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would
-;;; bring the two marks together due to the DELETE-CHARACTERS.  Then inserting
-;;; the region would move the second replacement's mark to be before the first
-;;; replacement.
-;;;
-(defun query-replace-function (count target replacement name
-                               &optional (doing-all? nil))
-  (declare (simple-string replacement))
-  (let ((replacement-len (length replacement))
-        (*query-replace-undo-data* nil))
-    (when (and count (minusp count))
-      (editor-error "Replacement count is negative."))
+
+(defstruct (query-replace-state (:conc-name "QRS-"))
+  count
+  target
+  replacement
+  undo-name
+  dumb-p
+  upper
+  cap
+  start-mark
+  last-found
+  stop-mark
+  undo-data)
+
+(defun query/replace-init (&key count target replacement undo-name)
+  (when (and count (minusp count))
+    (editor-error "Replacement count is negative."))
+  (let* ((point (current-point))
+         (region (get-count-region))
+         (start-mark (copy-mark (region-start region) :temporary))
+         (end-mark (copy-mark (region-end region) :left-inserting)))
+    (move-mark point start-mark)
     (get-search-pattern target :forward)
-    (unwind-protect
-        (query-replace-loop (get-count-region) (or count -1) target replacement
-                            replacement-len (current-point) doing-all?)
-      (let ((undo-data (nreverse *query-replace-undo-data*)))
-        (save-for-undo name
-          #'(lambda ()
-              (dolist (ele undo-data)
-                (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
-              (dolist (ele undo-data)
-                (let ((mark (replace-undo-mark ele)))
-                  (delete-characters mark replacement-len)
-                  (ninsert-region mark (replace-undo-region ele)))))
-          #'(lambda ()
-              (dolist (ele undo-data)
-                (delete-mark (replace-undo-mark ele)))))))))
-
-;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION.  The first
-;;; value is whether we completed all replacements, nil if we aborted.  The
-;;; second value is how many replacements occurred.
-;;;
-(defun query-replace-loop (region count target replacement replacement-len
-                           point doing-all?)
-  (with-mark ((last-found point)
-              ;; Copy REGION-END before moving point to REGION-START in case
-              ;; the end is point.  Also, make it permanent in case we make
-              ;; replacements on the last line containing the end.
-              (stop-mark (region-end region) :left-inserting))
-    (move-mark point (region-start region))
-    (let ((length (length target))
-          (cap (string-capitalize replacement))
-          (upper (string-upcase replacement))
-          (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
-                                                    (lower-case-p ch)))
-                                 (the string replacement))
-                          (value case-replace)))))
-      (values
-       (loop
-         (let ((won (find-pattern point *last-search-pattern*)))
-           (when (or (null won) (zerop count) (mark> point stop-mark))
-             (character-offset (move-mark point last-found) replacement-len)
-             (return t))
-           (decf count)
-           (move-mark last-found point)
-           (character-offset point length)
-           (if doing-all?
-               (replace-that-case replacement cap upper point length dumb)
-               (command-case
-                   (:prompt
-                    "Query replace: "
-                    :help "Type one of the following single-character commands:"
-                    #| :change-window nil |#
-                    :bind key-event)
-                 (:yes "Replace this occurrence."
-                       (replace-that-case replacement cap upper point length
-                                          dumb))
-                 (:no "Don't replace this occurrence, but continue.")
-                 (:do-all "Replace this and all remaining occurrences."
-                          (replace-that-case replacement cap upper point length
-                                             dumb)
-                          (setq doing-all? t))
-                 (:do-once "Replace this occurrence, then exit."
-                           (replace-that-case replacement cap upper point length
-                                              dumb)
-                           (return nil))
-                 (:exit "Exit immediately."
-                        (return nil))
-                 (t (unget-key-event key-event hi::*editor-input*)
-                    (return nil))))))
-       (length (the list *query-replace-undo-data*))))))
-
-
-
+    (make-query-replace-state
+     :count (or count -1)
+     :target target
+     :replacement replacement
+     :undo-name undo-name
+     :dumb-p (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
+                                                 (lower-case-p ch)))
+                              (the string replacement))
+                       (value case-replace)))
+     :upper (string-upcase replacement)
+     :cap (string-capitalize replacement)
+     :start-mark start-mark
+     :last-found (copy-mark start-mark :temporary)
+     :stop-mark end-mark
+     :undo-data nil)))
+
+
+(defun query/replace-find-next (qrs &key (interactive t))
+  (let* ((point (current-point))
+         (won (and (not (zerop (qrs-count qrs)))
+                   (find-pattern point *last-search-pattern* (qrs-stop-mark qrs)))))
+    (if won
+      (progn
+        (decf (qrs-count qrs))
+        (move-mark (qrs-last-found qrs) (current-point))
+        (character-offset point (length (qrs-target qrs)))
+        (when interactive
+          (message "Query Replace (type ? for help): "))
+        T)
+      (progn
+        (when interactive
+          (end-query/replace-mode))
+        nil))))
+
+(defun query/replace-replace (qrs)
+  (let* ((replacement (qrs-replacement qrs))
+         (point (current-point))
+         (length (length (qrs-target qrs))))
+    (with-mark ((undo-mark1 point :left-inserting)
+                (undo-mark2 point :left-inserting))
+      (character-offset undo-mark1 (- length))
+      (let ((string (cond ((qrs-dumb-p qrs) replacement)
+                          ((upper-case-p (next-character undo-mark1))
+                           (prog2
+                            (mark-after undo-mark1)
+                            (if (upper-case-p (next-character undo-mark1))
+                              (qrs-upper qrs)
+                              (qrs-cap qrs))
+                            (mark-before undo-mark1)))
+                          (t replacement))))
+        (push (make-replace-undo
+               ;; Save :right-inserting, so the INSERT-STRING at mark below
+               ;; doesn't move the copied mark the past replacement.
+               (copy-mark undo-mark1 :right-inserting)
+               (delete-and-save-region (region undo-mark1 undo-mark2)))
+              (qrs-undo-data qrs))
+        (insert-string point string)))))
+
+(defun query/replace-all (qrs)
+  (loop
+    while (query/replace-find-next qrs :interactive nil)
+    do (query/replace-replace qrs)))
+
+(defun query/replace-finish (qrs &key (report t))
+  (let* ((undo-data (nreverse (qrs-undo-data qrs)))
+         (count (length undo-data))
+         (replacement-len (length (qrs-replacement qrs))))
+    (save-for-undo (qrs-undo-name qrs)
+      #'(lambda ()
+          (dolist (ele undo-data)
+            (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
+          (dolist (ele undo-data)
+            (let ((mark (replace-undo-mark ele)))
+              (delete-characters mark replacement-len)
+              (ninsert-region mark (replace-undo-region ele)))))
+      #'(lambda ()
+          (dolist (ele undo-data)
+            (delete-mark (replace-undo-mark ele)))))
+    (unless (mark= (current-point) (qrs-start-mark qrs))
+      (push-buffer-mark (qrs-start-mark qrs)))
+    (delete-mark (qrs-stop-mark qrs))
+    (when report
+      (message "~D Occurrence~:[s~] replaced." count (eql count 1)))))
+
+
+(defun abort-query/replace-mode ()
+  (when (buffer-minor-mode (current-buffer) "Query/Replace")
+    (end-query/replace-mode :report nil)))
+
+(defun end-query/replace-mode (&key (report t))
+  (let* ((qrs (current-query-replace-state)))
+    (query/replace-finish qrs :report report)
+    (setf (buffer-minor-mode (current-buffer) "Query/Replace") nil)))
+
+(defcommand "Query/Replace This" (p)
+  "Replace this occurence"
+  (declare (ignore p))
+  (let ((qrs (current-query-replace-state)))
+    (query/replace-replace qrs)
+    (query/replace-find-next qrs)))
+
+(defcommand "Query/Replace Skip" (p)
+  "Don't replace this occurence, but continue"
+  (declare (ignore p))
+  (let ((qrs (current-query-replace-state)))
+    (query/replace-find-next qrs)))
+
+(defcommand "Query/Replace All" (p)
+  "Replace this and all remaining occurences"
+  (declare (ignore p))
+  (let ((qrs (current-query-replace-state)))
+    (query/replace-replace qrs)
+    (query/replace-all qrs))
+  (end-query/replace-mode))
+
+(defcommand "Query/Replace Last" (p)
+  "Replace this occurrence, then exit"
+  (declare (ignore p))
+  (let ((qrs (current-query-replace-state)))
+    (query/replace-replace qrs))
+  (end-query/replace-mode))
+
+(defcommand "Query/Replace Exit" (p)
+  "Exit Query Replace mode"
+  (declare (ignore p))
+  (end-query/replace-mode))
+
+(defcommand "Query/Replace Abort" (p)
+  "Abort Query/Replace mode"
+  (declare (ignore p))
+  (abort-current-command "Query/Replace aborted"))
+
+(defcommand "Query/Replace Help" (p)
+  "Describe Query/Replace commands"
+  (describe-mode-command p "Query/Replace"))
+
+;; The transparent-p flag takes care of executing the key normally when we're done,
+;; as long as we don't take a non-local exit.
+(defcommand ("Query/Replace Exit and Redo" :transparent-p t) (p)
+  "Exit Query Replace and then execute the key normally"
+  (declare (ignore p))
+  (end-query/replace-mode))
 
 ;;;; Occurrence searching.