Changeset 7922


Ignore:
Timestamp:
Dec 19, 2007, 3:36:01 PM (12 years ago)
Author:
gz
Message:

Reimplement Query Replace as a minor mode

Location:
branches/event-ide/ccl/cocoa-ide/hemlock/src
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

    r7919 r7922  
    959959
    960960
     961;;;; Query/Replace mode.
     962;;;;
     963;;;; Anything that's not explicitly bound here will exit i-search.
     964
     965(bind-key "Query/Replace This" #k"y" :mode "Query/Replace")
     966(bind-key "Query/Replace This" #k"space" :mode "Query/Replace")
     967(bind-key "Query/Replace Skip" #k"n" :mode "Query/Replace")
     968(bind-key "Query/Replace Skip" #k"backspace" :mode "Query/Replace")
     969(bind-key "Query/Replace Skip" #k"delete" :mode "Query/Replace")
     970(bind-key "Query/Replace All" #k"!" :mode "Query/Replace")
     971(bind-key "Query/Replace Last" #k"." :mode "Query/Replace")
     972(bind-key "Query/Replace Exit" #k"q" :mode "Query/Replace")
     973(bind-key "Query/Replace Exit" #k"escape" :mode "Query/Replace")
     974(bind-key "Query/Replace Abort" #k"control-g" :mode "Query/Replace")
     975(bind-key "Query/Replace Abort" #k"control-G" :mode "Query/Replace")
     976(bind-key "Query/Replace Help" #k"h" :mode "Query/Replace")
     977(bind-key "Query/Replace Help" #k"?" :mode "Query/Replace")
     978(bind-key "Query/Replace Help" #k"home" :mode "Query/Replace")
     979(bind-key "Query/Replace Help" #k"control-_" :mode "Query/Replace")
     980
    961981;;;; Logical characters.
    962982 
     
    967987(setf (logical-key-event-p #k"backspace" :no) t)
    968988(setf (logical-key-event-p #k"delete" :no) t)
    969 (setf (logical-key-event-p #k"!" :do-all) t)
    970 (setf (logical-key-event-p #k"." :do-once) t)
    971989(setf (logical-key-event-p #k"home" :help) t)
    972990(setf (logical-key-event-p #k"h" :help) t)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7919 r7922  
    542542                                  (help "Type any key"))
    543543  "Prompts for a key-event."
    544   (prompt-for-something
     544  (parse-for-something
    545545   :verification-function #'(lambda (eps key-event)
    546546                              (declare (ignore eps))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/search1.lisp

    r6582 r7922  
    629629
    630630
    631 (defun find-pattern (mark search-pattern)
     631(defun find-pattern (mark search-pattern &optional stop-mark)
    632632  "Find a match of Search-Pattern starting at Mark.  Mark is moved to
    633633  point before the match and the number of characters matched is returned.
    634634  If there is no match for the pattern then Mark is not modified and NIL
    635   is returned."
     635  is returned.
     636  If stop-mark is specified, NIL is returned and mark is not moved if
     637  the point before the match is after stop-mark"
    636638  (close-line)
    637639  (multiple-value-bind (line start matched)
     
    639641                                search-pattern (mark-line mark)
    640642                                (mark-charpos mark))
    641     (when matched
     643    (when (and matched
     644               (or (null stop-mark)
     645                   (< (line-number line) (line-number (mark-line stop-mark)))
     646                   (and (= (line-number line) (line-number (mark-line stop-mark)))
     647                        (<= start (mark-charpos stop-mark)))))
    642648      (move-to-position mark start line)
    643649      matched)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

    r7919 r7922  
    9595;;;; Replacement commands:
    9696
     97(defmode "Query/Replace" :precedence :highest
     98  :documentation "Type one of the following single-character commands:"
     99  ;; Make anything that's not otherwise overridden exit query/replace
     100  :default-command "Query/Replace Exit and Redo")
     101
     102(add-hook abort-hook 'abort-query/replace-mode)
     103
     104(defhvar "Query/Replace State"
     105  "Internal variable containing current state of Query/Replace"
     106  :mode "Query/Replace")
     107
     108(defun current-query-replace-state ()
     109  (or (value query/replace-state)
     110      (error "Query/Replace command invoked outside Query Replace")))
     111
     112(defhvar "Case Replace"
     113  "If this is true then \"Query Replace\" will try to preserve case when
     114  doing replacements."
     115  :value t)
     116
    97117(defcommand "Replace String" (p &optional
    98118                                (target (prompt-for-string
     
    106126   string in the current buffer for all occurrences after the point or within
    107127   the active region, depending on whether it is active."
    108   "Replaces the specified Target string with the specified Replacement
    109    string in the current buffer for all occurrences after the point or within
    110    the active region, depending on whether it is active.  The prefix argument
    111    may limit the number of replacements."
    112   (multiple-value-bind (ignore count)
    113                        (query-replace-function p target replacement
    114                                                "Replace String" t)
    115     (declare (ignore ignore))
    116     (message "~D Occurrences replaced." count)))
     128  (let ((qrs (query/replace-init :count p :target target :replacement replacement
     129                                 :undo-name "Replace String")))
     130    (query/replace-all qrs)
     131    (query/replace-finish qrs)))
    117132
    118133(defcommand "Query Replace" (p &optional
     
    127142   from the keyboard is given.  If the region is active, limit queries to
    128143   occurrences that occur within it, otherwise use point to end of buffer."
    129   "Replaces the Target string with the Replacement string if confirmation
    130    from the keyboard is given.  If the region is active, limit queries to
    131    occurrences that occur within it, otherwise use point to end of buffer.
    132    A prefix argument may limit the number of queries."
    133   (let ((mark (copy-mark (current-point))))
    134     (multiple-value-bind (ignore count)
    135                          (query-replace-function p target replacement
    136                                                  "Query Replace")
    137       (declare (ignore ignore))
    138       (message "~D Occurrences replaced." count))
    139     (push-buffer-mark mark)))
    140 
    141 
    142 (defhvar "Case Replace"
    143   "If this is true then \"Query Replace\" will try to preserve case when
    144   doing replacements."
    145   :value t)
     144  (let ((qrs (query/replace-init :count p :target target :replacement replacement
     145                                 :undo-name "Query Replace")))
     146    (setf (buffer-minor-mode (current-buffer) "Query/Replace") t)
     147    (setf (value query/replace-state) qrs)
     148    (query/replace-find-next qrs)))
    146149
    147150(defstruct (replace-undo (:constructor make-replace-undo (mark region)))
     
    154157      "Return region deleted due to replacement.")
    155158
    156 (defvar *query-replace-undo-data* nil)
    157 
    158 ;;; REPLACE-THAT-CASE replaces a string case-sensitively.  Lower, Cap and Upper
    159 ;;; are the original, capitalized and uppercase replacement strings.  Mark is a
    160 ;;; :left-inserting mark after the text to be replaced.  Length is the length
    161 ;;; of the target string.  If dumb, then do a simple replace.  This pushes
    162 ;;; an undo information structure into *query-replace-undo-data* which
    163 ;;; QUERY-REPLACE-FUNCTION uses.
    164 ;;;
    165 (defun replace-that-case (lower cap upper mark length dumb)
    166   (character-offset mark (- length))
    167   (let ((insert (cond (dumb lower)
    168                       ((upper-case-p (next-character mark))
    169                        (mark-after mark)
    170                        (prog1 (if (upper-case-p (next-character mark)) upper cap)
    171                               (mark-before mark)))
    172                       (t lower))))
    173     (with-mark ((undo-mark1 mark :left-inserting)
    174                 (undo-mark2 mark :left-inserting))
    175       (character-offset undo-mark2 length)
    176       (push (make-replace-undo
    177              ;; Save :right-inserting, so the INSERT-STRING at mark below
    178              ;; doesn't move the copied mark the past replacement.
    179              (copy-mark mark :right-inserting)
    180              (delete-and-save-region (region undo-mark1 undo-mark2)))
    181             *query-replace-undo-data*))
    182     (insert-string mark insert)))
    183 
    184 ;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands:
    185 ;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace".
    186 ;;; Name is the name of the command for undoing purposes.  If doing-all? is
    187 ;;; true, this replaces all ocurrences for the non-querying commands.  This
    188 ;;; returns t if it completes successfully, and nil if it is aborted.  As a
    189 ;;; second value, it returns the number of replacements.
    190 ;;;
    191 ;;; The undo method, before undo'ing anything, makes all marks :left-inserting.
    192 ;;; There's a problem when two replacements are immediately adjacent, such as
    193 ;;;    foofoo
    194 ;;; replacing "foo" with "bar".  If the marks were still :right-inserting as
    195 ;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would
    196 ;;; bring the two marks together due to the DELETE-CHARACTERS.  Then inserting
    197 ;;; the region would move the second replacement's mark to be before the first
    198 ;;; replacement.
    199 ;;;
    200 (defun query-replace-function (count target replacement name
    201                                &optional (doing-all? nil))
    202   (declare (simple-string replacement))
    203   (let ((replacement-len (length replacement))
    204         (*query-replace-undo-data* nil))
    205     (when (and count (minusp count))
    206       (editor-error "Replacement count is negative."))
     159
     160(defstruct (query-replace-state (:conc-name "QRS-"))
     161  count
     162  target
     163  replacement
     164  undo-name
     165  dumb-p
     166  upper
     167  cap
     168  start-mark
     169  last-found
     170  stop-mark
     171  undo-data)
     172
     173(defun query/replace-init (&key count target replacement undo-name)
     174  (when (and count (minusp count))
     175    (editor-error "Replacement count is negative."))
     176  (let* ((point (current-point))
     177         (region (get-count-region))
     178         (start-mark (copy-mark (region-start region) :temporary))
     179         (end-mark (copy-mark (region-end region) :left-inserting)))
     180    (move-mark point start-mark)
    207181    (get-search-pattern target :forward)
    208     (unwind-protect
    209         (query-replace-loop (get-count-region) (or count -1) target replacement
    210                             replacement-len (current-point) doing-all?)
    211       (let ((undo-data (nreverse *query-replace-undo-data*)))
    212         (save-for-undo name
    213           #'(lambda ()
    214               (dolist (ele undo-data)
    215                 (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
    216               (dolist (ele undo-data)
    217                 (let ((mark (replace-undo-mark ele)))
    218                   (delete-characters mark replacement-len)
    219                   (ninsert-region mark (replace-undo-region ele)))))
    220           #'(lambda ()
    221               (dolist (ele undo-data)
    222                 (delete-mark (replace-undo-mark ele)))))))))
    223 
    224 ;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION.  The first
    225 ;;; value is whether we completed all replacements, nil if we aborted.  The
    226 ;;; second value is how many replacements occurred.
    227 ;;;
    228 (defun query-replace-loop (region count target replacement replacement-len
    229                            point doing-all?)
    230   (with-mark ((last-found point)
    231               ;; Copy REGION-END before moving point to REGION-START in case
    232               ;; the end is point.  Also, make it permanent in case we make
    233               ;; replacements on the last line containing the end.
    234               (stop-mark (region-end region) :left-inserting))
    235     (move-mark point (region-start region))
    236     (let ((length (length target))
    237           (cap (string-capitalize replacement))
    238           (upper (string-upcase replacement))
    239           (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
    240                                                     (lower-case-p ch)))
    241                                  (the string replacement))
    242                           (value case-replace)))))
    243       (values
    244        (loop
    245          (let ((won (find-pattern point *last-search-pattern*)))
    246            (when (or (null won) (zerop count) (mark> point stop-mark))
    247              (character-offset (move-mark point last-found) replacement-len)
    248              (return t))
    249            (decf count)
    250            (move-mark last-found point)
    251            (character-offset point length)
    252            (if doing-all?
    253                (replace-that-case replacement cap upper point length dumb)
    254                (command-case
    255                    (:prompt
    256                     "Query replace: "
    257                     :help "Type one of the following single-character commands:"
    258                     #| :change-window nil |#
    259                     :bind key-event)
    260                  (:yes "Replace this occurrence."
    261                        (replace-that-case replacement cap upper point length
    262                                           dumb))
    263                  (:no "Don't replace this occurrence, but continue.")
    264                  (:do-all "Replace this and all remaining occurrences."
    265                           (replace-that-case replacement cap upper point length
    266                                              dumb)
    267                           (setq doing-all? t))
    268                  (:do-once "Replace this occurrence, then exit."
    269                            (replace-that-case replacement cap upper point length
    270                                               dumb)
    271                            (return nil))
    272                  (:exit "Exit immediately."
    273                         (return nil))
    274                  (t (unget-key-event key-event hi::*editor-input*)
    275                     (return nil))))))
    276        (length (the list *query-replace-undo-data*))))))
    277 
    278 
    279 
     182    (make-query-replace-state
     183     :count (or count -1)
     184     :target target
     185     :replacement replacement
     186     :undo-name undo-name
     187     :dumb-p (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
     188                                                 (lower-case-p ch)))
     189                              (the string replacement))
     190                       (value case-replace)))
     191     :upper (string-upcase replacement)
     192     :cap (string-capitalize replacement)
     193     :start-mark start-mark
     194     :last-found (copy-mark start-mark :temporary)
     195     :stop-mark end-mark
     196     :undo-data nil)))
     197
     198
     199(defun query/replace-find-next (qrs &key (interactive t))
     200  (let* ((point (current-point))
     201         (won (and (not (zerop (qrs-count qrs)))
     202                   (find-pattern point *last-search-pattern* (qrs-stop-mark qrs)))))
     203    (if won
     204      (progn
     205        (decf (qrs-count qrs))
     206        (move-mark (qrs-last-found qrs) (current-point))
     207        (character-offset point (length (qrs-target qrs)))
     208        (when interactive
     209          (message "Query Replace (type ? for help): "))
     210        T)
     211      (progn
     212        (when interactive
     213          (end-query/replace-mode))
     214        nil))))
     215
     216(defun query/replace-replace (qrs)
     217  (let* ((replacement (qrs-replacement qrs))
     218         (point (current-point))
     219         (length (length (qrs-target qrs))))
     220    (with-mark ((undo-mark1 point :left-inserting)
     221                (undo-mark2 point :left-inserting))
     222      (character-offset undo-mark1 (- length))
     223      (let ((string (cond ((qrs-dumb-p qrs) replacement)
     224                          ((upper-case-p (next-character undo-mark1))
     225                           (prog2
     226                            (mark-after undo-mark1)
     227                            (if (upper-case-p (next-character undo-mark1))
     228                              (qrs-upper qrs)
     229                              (qrs-cap qrs))
     230                            (mark-before undo-mark1)))
     231                          (t replacement))))
     232        (push (make-replace-undo
     233               ;; Save :right-inserting, so the INSERT-STRING at mark below
     234               ;; doesn't move the copied mark the past replacement.
     235               (copy-mark undo-mark1 :right-inserting)
     236               (delete-and-save-region (region undo-mark1 undo-mark2)))
     237              (qrs-undo-data qrs))
     238        (insert-string point string)))))
     239
     240(defun query/replace-all (qrs)
     241  (loop
     242    while (query/replace-find-next qrs :interactive nil)
     243    do (query/replace-replace qrs)))
     244
     245(defun query/replace-finish (qrs &key (report t))
     246  (let* ((undo-data (nreverse (qrs-undo-data qrs)))
     247         (count (length undo-data))
     248         (replacement-len (length (qrs-replacement qrs))))
     249    (save-for-undo (qrs-undo-name qrs)
     250      #'(lambda ()
     251          (dolist (ele undo-data)
     252            (setf (mark-kind (replace-undo-mark ele)) :left-inserting))
     253          (dolist (ele undo-data)
     254            (let ((mark (replace-undo-mark ele)))
     255              (delete-characters mark replacement-len)
     256              (ninsert-region mark (replace-undo-region ele)))))
     257      #'(lambda ()
     258          (dolist (ele undo-data)
     259            (delete-mark (replace-undo-mark ele)))))
     260    (unless (mark= (current-point) (qrs-start-mark qrs))
     261      (push-buffer-mark (qrs-start-mark qrs)))
     262    (delete-mark (qrs-stop-mark qrs))
     263    (when report
     264      (message "~D Occurrence~:[s~] replaced." count (eql count 1)))))
     265
     266
     267(defun abort-query/replace-mode ()
     268  (when (buffer-minor-mode (current-buffer) "Query/Replace")
     269    (end-query/replace-mode :report nil)))
     270
     271(defun end-query/replace-mode (&key (report t))
     272  (let* ((qrs (current-query-replace-state)))
     273    (query/replace-finish qrs :report report)
     274    (setf (buffer-minor-mode (current-buffer) "Query/Replace") nil)))
     275
     276(defcommand "Query/Replace This" (p)
     277  "Replace this occurence"
     278  (declare (ignore p))
     279  (let ((qrs (current-query-replace-state)))
     280    (query/replace-replace qrs)
     281    (query/replace-find-next qrs)))
     282
     283(defcommand "Query/Replace Skip" (p)
     284  "Don't replace this occurence, but continue"
     285  (declare (ignore p))
     286  (let ((qrs (current-query-replace-state)))
     287    (query/replace-find-next qrs)))
     288
     289(defcommand "Query/Replace All" (p)
     290  "Replace this and all remaining occurences"
     291  (declare (ignore p))
     292  (let ((qrs (current-query-replace-state)))
     293    (query/replace-replace qrs)
     294    (query/replace-all qrs))
     295  (end-query/replace-mode))
     296
     297(defcommand "Query/Replace Last" (p)
     298  "Replace this occurrence, then exit"
     299  (declare (ignore p))
     300  (let ((qrs (current-query-replace-state)))
     301    (query/replace-replace qrs))
     302  (end-query/replace-mode))
     303
     304(defcommand "Query/Replace Exit" (p)
     305  "Exit Query Replace mode"
     306  (declare (ignore p))
     307  (end-query/replace-mode))
     308
     309(defcommand "Query/Replace Abort" (p)
     310  "Abort Query/Replace mode"
     311  (declare (ignore p))
     312  (abort-current-command "Query/Replace aborted"))
     313
     314(defcommand "Query/Replace Help" (p)
     315  "Describe Query/Replace commands"
     316  (describe-mode-command p "Query/Replace"))
     317
     318;; The transparent-p flag takes care of executing the key normally when we're done,
     319;; as long as we don't take a non-local exit.
     320(defcommand ("Query/Replace Exit and Redo" :transparent-p t) (p)
     321  "Exit Query Replace and then execute the key normally"
     322  (declare (ignore p))
     323  (end-query/replace-mode))
    280324
    281325;;;; Occurrence searching.
Note: See TracChangeset for help on using the changeset viewer.