[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
Matthieu Villeneuve
mvilleneuve at common-lisp.net
Wed Jan 26 22:49:50 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv23005
Modified Files:
gui.lisp packages.lisp pane.lisp
Log Message:
Added basic query-replace support. First humble try at command loop factoring
Date: Wed Jan 26 14:49:47 2005
Author: mvilleneuve
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.99 climacs/gui.lisp:1.100
--- climacs/gui.lisp:1.99 Wed Jan 26 08:10:40 2005
+++ climacs/gui.lisp Wed Jan 26 14:49:46 2005
@@ -280,6 +280,32 @@
(setf (executingp *application-frame*) nil)
(redisplay-frame-panes frame))))))
+(defmacro simple-command-loop (command-table loop-condition end-clauses)
+ (let ((gesture (gensym))
+ (item (gensym))
+ (command (gensym))
+ (condition (gensym)))
+ `(progn
+ (redisplay-frame-panes *application-frame*)
+ (loop while ,loop-condition
+ as ,gesture = (climacs-read-gesture)
+ as ,item = (find-gestures (list ,gesture) ,command-table)
+ do (cond ((and ,item (eq (command-menu-item-type ,item) :command))
+ (setf *current-gesture* ,gesture)
+ (let ((,command (command-menu-item-value ,item)))
+ (unless (consp ,command)
+ (setf ,command (list ,command)))
+ (handler-case
+ (execute-frame-command *application-frame*
+ ,command)
+ (error (,condition)
+ (beep)
+ (format *error-output* "~a~%" ,condition)))))
+ (t
+ (unread-gesture ,gesture)
+ , at end-clauses))
+ (redisplay-frame-panes *application-frame*)))))
+
(defun region-limits (pane)
(if (mark< (mark pane) (point pane))
(values (mark pane) (point pane))
@@ -1006,24 +1032,9 @@
:search-string ""
:search-mark (clone-mark point)
:search-forward-p forwardp)))
- (redisplay-frame-panes *application-frame*)
- (loop while (isearch-mode pane)
- as gesture = (climacs-read-gesture)
- as item = (find-gestures (list gesture) 'isearch-climacs-table)
- do (cond ((and item (eq (command-menu-item-type item) :command))
- (setf *current-gesture* gesture)
- (let ((command (command-menu-item-value item)))
- (unless (consp command)
- (setf command (list command)))
- (handler-case
- (execute-frame-command *application-frame* command)
- (error (condition)
- (beep)
- (format *error-output* "~a~%" condition)))))
- (t
- (unread-gesture gesture)
- (setf (isearch-mode pane) nil)))
- (redisplay-frame-panes *application-frame*))))
+ (simple-command-loop 'isearch-climacs-table
+ (isearch-mode pane)
+ ((setf (isearch-mode pane) nil)))))
(defun isearch-from-mark (pane mark string forwardp)
(flet ((object-equal (x y)
@@ -1104,6 +1115,56 @@
(define-named-command com-isearch-exit ()
(setf (isearch-mode (current-window)) nil))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Query replace
+
+(defun query-replace-find-next-match (mark string)
+ (let ((offset-before (offset mark)))
+ (search-forward mark string)
+ (/= (offset mark) offset-before)))
+
+(define-named-command com-query-replace ()
+ (let* ((string1 (accept 'string :prompt "Query replace"))
+ (string2 (accept 'string
+ :prompt (format nil "Query replace ~A with"
+ string1)))
+ (pane (current-window))
+ (point (point pane)))
+ (when (query-replace-find-next-match point string1)
+ (setf (query-replace-state pane) (make-instance 'query-replace-state
+ :string1 string1
+ :string2 string2)
+ (query-replace-mode pane) t)
+ (simple-command-loop 'query-replace-climacs-table
+ (query-replace-mode pane)
+ ((setf (query-replace-mode pane) nil))))))
+
+(define-named-command com-query-replace-replace ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (state (query-replace-state pane))
+ (string1-length (length (string1 state))))
+ (backward-object point string1-length)
+ (delete-range point string1-length)
+ (insert-sequence point (string2 state))
+ (unless (query-replace-find-next-match point (string1 state))
+ (setf (query-replace-mode pane) nil))))
+
+(define-named-command com-query-replace-skip ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (state (query-replace-state pane)))
+ (unless (query-replace-find-next-match point (string1 state))
+ (setf (query-replace-mode pane) nil))))
+
+(define-named-command com-query-replace-exit ()
+ (setf (query-replace-mode (current-window)) nil))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Undo/redo
+
(define-named-command com-undo ()
(undo (undo-tree (buffer (current-window)))))
@@ -1230,6 +1291,7 @@
(global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
(global-set-key '(#\s :control) 'com-isearch-mode-forward)
(global-set-key '(#\r :control) 'com-isearch-mode-backward)
+(global-set-key '(#\% :shift :meta) 'com-query-replace)
(global-set-key '(:up) 'com-previous-line)
(global-set-key '(:down) 'com-next-line)
@@ -1457,3 +1519,21 @@
(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
(isearch-set-key '(#\s :control) 'com-isearch-forward)
(isearch-set-key '(#\r :control) 'com-isearch-backward)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Query replace command table
+
+(make-command-table 'query-replace-climacs-table :errorp nil)
+
+(defun query-replace-set-key (gesture command)
+ (add-command-to-command-table command 'query-replace-climacs-table
+ :keystroke gesture :errorp nil))
+
+(query-replace-set-key '(#\Newline) 'com-query-replace-exit)
+(query-replace-set-key '(#\Space) 'com-query-replace-replace)
+(query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
+(query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
+(query-replace-set-key '(#\q) 'com-query-replace-exit)
+(query-replace-set-key '(#\y) 'com-query-replace-replace)
+(query-replace-set-key '(#\n) 'com-query-replace-skip)
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.41 climacs/packages.lisp:1.42
--- climacs/packages.lisp:1.41 Wed Jan 26 08:10:40 2005
+++ climacs/packages.lisp Wed Jan 26 14:49:47 2005
@@ -110,6 +110,8 @@
#:auto-fill-mode #:auto-fill-column
#:isearch-state #:search-string #:search-mark #:search-forward-p
#:isearch-mode #:isearch-states #:isearch-previous-string
+ #:query-replace-state #:string1 #:string2
+ #:query-replace-mode
#:with-undo
#:url))
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.14 climacs/pane.lisp:1.15
--- climacs/pane.lisp:1.14 Wed Jan 26 08:10:41 2005
+++ climacs/pane.lisp Wed Jan 26 14:49:47 2005
@@ -146,6 +146,14 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
+;;; Query replace
+
+(defclass query-replace-state ()
+ ((string1 :initarg :string1 :accessor string1)
+ (string2 :initarg :string2 :accessor string2)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
;;; View
(defclass climacs-textual-view (textual-view tabify-mixin)
@@ -180,6 +188,8 @@
(isearch-mode :initform nil :accessor isearch-mode)
(isearch-states :initform '() :accessor isearch-states)
(isearch-previous-string :initform nil :accessor isearch-previous-string)
+ (query-replace-mode :initform nil :accessor query-replace-mode)
+ (query-replace-state :initform nil :accessor query-replace-state)
(full-redisplay-p :initform nil :accessor full-redisplay-p)
(cache :initform (let ((cache (make-instance 'standard-flexichain)))
(insert* cache 0 nil)
More information about the Climacs-cvs
mailing list