Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31402/Drei
Modified Files: search-commands.lisp packages.lisp drei.lisp Added Files: targets.lisp Log Message: Added Drei "target" concept, facilitating search/replace-commands that act over multiple buffers (or "targets").
--- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2007/11/16 09:28:44 1.2 @@ -8,6 +8,8 @@ ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) +;;; (c) copyright 2007 by +;;; Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -28,6 +30,29 @@
(in-package :drei-commands)
+(defun simple-search (drei-instance search-function + targets more-targets-predicate more-targets-fn) + (let ((old-buffer (buffer drei-instance)) + (old-offset (offset (point drei-instance)))) + (activate-target-specification targets) + (or (loop until (funcall search-function (point drei-instance)) + if (funcall more-targets-predicate targets) + do (funcall more-targets-fn targets) + else return nil + finally (return t)) + (setf (buffer drei-instance) old-buffer + (offset (point drei-instance)) old-offset)))) + +(defun simple-search-forward (drei-instance search-function &optional + (targets (funcall *default-target-creator* drei-instance))) + (simple-search drei-instance search-function targets + #'subsequent-targets-p #'next-target)) + +(defun simple-search-backward (drei-instance search-function &optional + (targets (funcall *default-target-creator* drei-instance))) + (simple-search drei-instance search-function targets + #'preceding-targets-p #'previous-target)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; String search @@ -36,13 +61,19 @@ ((string 'string :prompt "String Search")) "Prompt for a string and search forward for it. If found, leaves point after string. If not, leaves point where it is." - (search-forward *current-point* string :test (case-relevant-test string))) + (simple-search-forward *current-window* + #'(lambda (mark) + (search-forward mark string + :test (case-relevant-test string)))))
(define-command (com-reverse-string-search :name t :command-table search-table) ((string 'string :prompt "Reverse String Search")) "Prompt for a string and search backward for it. If found, leaves point before string. If not, leaves point where it is." - (search-backward *current-point* string :test (case-relevant-test string))) + (simple-search-backward *current-window* + #'(lambda (mark) + (search-backward mark string + :test (case-relevant-test string)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -52,13 +83,17 @@ ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search forward for it. If found, leaves point after the word. If not, leaves point where it is." - (search-word-forward *current-point* word)) + (simple-search-forward *current-window* + #'(lambda (mark) + (search-word-forward mark word))))
(define-command (com-reverse-word-search :name t :command-table search-table) ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search backward for it. If found, leaves point before the word. If not, leaves point where it is." - (search-word-backward *current-point* word)) + (simple-search-backward *current-window* + #'(lambda (mark) + (search-backward mark word))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -66,51 +101,75 @@
(make-command-table 'isearch-drei-table :errorp nil)
-(defun isearch-command-loop (pane forwardp) - (let* ((point (point pane)) - (orig-offset (offset point))) - (unless (endp (isearch-states pane)) - (setf (isearch-previous-string pane) - (search-string (first (isearch-states pane))))) - (setf (isearch-mode pane) t) - (setf (isearch-states pane) +(defun isearch-command-loop (drei-instance forwardp) + (let* ((point (point drei-instance)) + (orig-offset (offset point)) + (orig-buffer (buffer drei-instance))) + (unless (endp (isearch-states drei-instance)) + (setf (isearch-previous-string drei-instance) + (search-string (first (isearch-states drei-instance))))) + (setf (isearch-mode drei-instance) t) + (setf (isearch-states drei-instance) (list (make-instance 'isearch-state :search-string "" :search-mark (clone-mark point) + :search-buffer orig-buffer :search-forward-p forwardp - :search-success-p t))) + :search-success-p t + :targets (funcall *default-target-creator* drei-instance)))) + (activate-target-specification (targets (first (isearch-states drei-instance)))) (simple-command-loop 'isearch-drei-table - (isearch-mode pane) + (isearch-mode drei-instance) ((display-message "Mark saved where search started") - (setf (offset (mark pane)) orig-offset) - (setf (isearch-mode pane) nil)) + (setf (offset (mark drei-instance)) orig-offset) + (setf (isearch-mode drei-instance) nil)) ((display-message "Returned point to original location") - (setf (offset (point pane)) orig-offset) - (setf (isearch-mode pane) nil) + (setf (buffer drei-instance) orig-buffer) + (setf (offset (point drei-instance)) orig-offset) + (setf (isearch-mode drei-instance) nil) (signal 'abort-gesture :event *current-gesture*)))))
-(defun isearch-from-mark (pane mark string forwardp) - (let* ((point (point pane)) +(defun isearch-from-mark (drei-instance mark string forwardp) + (let* ((point (point drei-instance)) (mark2 (clone-mark mark)) (success (funcall (if forwardp #'search-forward #'search-backward) mark2 string - :test (case-relevant-test string)))) - (when success - (setf (offset point) (offset mark2) - (offset mark) (if forwardp - (- (offset mark2) (length string)) - (+ (offset mark2) (length string))))) + :test (case-relevant-test string))) + (state (first (isearch-states drei-instance)))) + (if success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length string)))) + (when (funcall (if forwardp + #'subsequent-targets-p + #'preceding-targets-p) + (targets state)) + (funcall (if forwardp #'next-target #'previous-target) + (targets state)) + (if (isearch-from-mark drei-instance (clone-mark (point drei-instance)) + string forwardp) + (return-from isearch-from-mark t) + (progn (pop (isearch-states drei-instance)) + (funcall (if forwardp #'previous-target #'next-target) + (targets state)) + (setf (offset (point drei-instance)) + (offset (search-mark state))) + nil)))) (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" success forwardp (display-string string)) (push (make-instance 'isearch-state - :search-string string - :search-mark mark - :search-forward-p forwardp - :search-success-p success) - (isearch-states pane)) + :search-string string + :search-mark mark + :search-buffer (buffer drei-instance) + :search-forward-p forwardp + :search-success-p success + :targets (targets state)) + (isearch-states drei-instance)) (unless success - (beep)))) + (beep)) + success))
(define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") @@ -280,15 +339,20 @@
(defun query-replace-find-next-match (state) (with-accessors ((string string1) - (buffers buffers) - (mark mark)) state - (let ((offset-before (offset mark))) + (targets targets)) state + (let* ((mark (point (drei-instance (targets state)))) + (offset-before (offset mark))) (search-forward mark string :test (case-relevant-test string)) - (/= (offset mark) offset-before)))) + (if (= (offset mark) offset-before) + (when (subsequent-targets-p targets) + (next-target targets) + (beginning-of-buffer (point (buffer (drei-instance targets)))) + (query-replace-find-next-match state)) + t))))
(define-command (com-query-replace :name t :command-table search-table) () - (let* ((pane *current-window*) - (old-state (query-replace-state pane)) + (let* ((drei *current-window*) + (old-state (query-replace-state drei)) (old-string1 (when old-state (string1 old-state))) (old-string2 (when old-state (string2 old-state))) (string1 (handler-case @@ -313,21 +377,25 @@ (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil)))))) - (setf (query-replace-state pane) (make-instance 'query-replace-state + (setf (query-replace-state drei) (make-instance 'query-replace-state :string1 string1 :string2 string2 - :mark *current-point*)) - (when (query-replace-find-next-match (query-replace-state pane)) - (setf (query-replace-mode pane) t) - (display-message "Replace ~A with ~A:" - string1 string2) - (simple-command-loop 'query-replace-drei-table - (query-replace-mode pane) - ((setf (query-replace-mode pane) nil) - (display-message "Replaced ~A occurence~:P" - (occurrences (query-replace-state pane)))) - ((setf (query-replace-mode pane) nil) - (signal 'abort-gesture :event *current-gesture*)))))) + :targets (funcall *default-target-creator* drei))) + (activate-target-specification (targets (query-replace-state drei))) + (if (query-replace-find-next-match (query-replace-state drei)) + (progn + (setf (query-replace-mode drei) t) + (display-message "Replace ~A with ~A:" + string1 string2) + (simple-command-loop 'query-replace-drei-table + (query-replace-mode drei) + ((setf (query-replace-mode drei) nil) + (deactivate-target-specification (targets (query-replace-state drei))) + (display-message "Replaced ~A occurence~:P" + (occurrences (query-replace-state drei)))) + ((setf (query-replace-mode drei) nil) + (signal 'abort-gesture :event *current-gesture*)))) + (display-message "Replaced 0 occurences"))))
(set-key 'com-query-replace 'search-table @@ -338,15 +406,17 @@ (state (query-replace-state pane))) (with-accessors ((string1 string1) (string2 string2) - (occurrences occurrences)) state - (let ((string1-length (length string1))) - (backward-object (mark state) string1-length) - (replace-one-string (mark state) + (occurrences occurrences) + (targets targets)) state + (let ((string1-length (length string1)) + (mark (point (drei-instance targets)))) + (backward-object mark string1-length) + (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) - (if (query-replace-find-next-match (query-replace-state pane)) + (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))))) @@ -359,10 +429,12 @@ (state (query-replace-state pane))) (with-accessors ((string1 string1) (string2 string2) - (occurrences occurrences)) state - (let ((string1-length (length string1))) - (backward-object (mark state) string1-length) - (replace-one-string (mark state) + (occurrences occurrences) + (targets targets)) state + (let ((string1-length (length string1)) + (mark (point (drei-instance targets)))) + (backward-object mark string1-length) + (replace-one-string mark string1-length string2 (no-upper-p string1)) @@ -377,15 +449,17 @@ (state (query-replace-state pane))) (with-accessors ((string1 string1) (string2 string2) - (occurrences occurrences)) state - (let ((string1-length (length string1))) - (loop do (backward-object (mark state) string1-length) - (replace-one-string (mark state) + (occurrences occurrences) + (targets targets)) state + (let ((string1-length (length string1)) + (mark (point (drei-instance targets)))) + (loop do (backward-object mark string1-length) + (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) - while (query-replace-find-next-match (query-replace-state pane)) + while (query-replace-find-next-match state) finally (setf (query-replace-mode pane) nil))))))
(define-command (com-query-replace-skip :name t :command-table query-replace-drei-table) () @@ -435,14 +509,18 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (re-search-forward *current-point* (normalise-minibuffer-regex string)))) + (simple-search-forward *current-window* + #'(lambda (mark) + (re-search-forward mark (normalise-minibuffer-regex string))))))
(define-command (com-regex-search-backward :name t :command-table search-table) () (let ((string (accept 'string :prompt "RE search backward" :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (re-search-backward *current-point* (normalise-minibuffer-regex string)))) + (simple-search-backward *current-window* + #'(lambda (mark) + (re-search-backward mark (normalise-minibuffer-regex string))))))
(define-command (com-how-many :name t :command-table search-table) ((regex 'string :prompt "How many matches for")) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/08/13 21:58:44 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/11/16 09:28:44 1.16 @@ -186,9 +186,9 @@ #:offset-to-screen-position #:page-down #:page-up #:indent-tabs-mode - #:isearch-state #:search-string #:search-mark + #:isearch-state #:search-string #:search-mark #:search-buffer #:search-forward-p #:search-success-p - #:query-replace-state #:string1 #:string2 #:buffers #:mark #:occurrences + #:query-replace-state #:string1 #:string2 #:targets #:occurrences
;; Undo. #:undo-mixin #:undo-tree #:undo-accumulate #:performing-undo @@ -433,7 +433,17 @@
#:start-mark #:end-mark - #:make-buffer-stream) + #:make-buffer-stream + + #:target-specification + #:activate-target-specification + #:deactivate-target-specification + #:subsequent-targets-p #:preceding-targets-p + #:next-target #:previous-target + #:previous-target + #:no-more-targets + #:*default-target-creator* + #:buffer-list-target-specification) (:documentation "Implementation of much syntax-aware, yet no syntax-specific, core functionality of Drei."))
--- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 20:03:00 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/11/16 09:28:44 1.16 @@ -325,8 +325,10 @@ (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) (search-mark :initarg :search-mark :accessor search-mark) + (search-buffer :initarg :search-buffer :accessor search-buffer) (search-forward-p :initarg :search-forward-p :accessor search-forward-p) - (search-success-p :initarg :search-success-p :accessor search-success-p))) + (search-success-p :initarg :search-success-p :accessor search-success-p) + (targets :initarg :targets :accessor targets )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -335,7 +337,7 @@ (defclass query-replace-state () ((string1 :initarg :string1 :accessor string1) (string2 :initarg :string2 :accessor string2) - (mark :initarg :mark :accessor mark) + (targets :initarg :targets :accessor targets) (occurences :initform 0 :accessor occurrences)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -675,7 +677,11 @@ :active active) cursors)))
-(defmethod (setf buffer) :after (buffer (object drei)) +(defmethod (setf buffer) :before ((buffer drei-buffer) (object drei)) + (with-slots (buffer point) object + (setf (point buffer) point))) + +(defmethod (setf buffer) :after ((buffer drei-buffer) (object drei)) (with-slots (point mark top bot) object (setf point (clone-mark (point buffer)) mark (clone-mark (low-mark buffer) :right)
--- /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2007/11/16 09:28:46 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2007/11/16 09:28:46 1.1 ;;; -*- Mode: Lisp; Package: DREI-CORE -*-
;;; (c) copyright 2007 by ;;; Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
;;; Facilities and protocols for iterating through buffer objects, the ;;; point being that the buffer may be magically exchanged for some ;;; other buffer, permitting easy iteration through multiple buffers ;;; as a single sequence. This is meant to support Climacs' ;;; Group-facility, I'm not sure what else it could be used for.
(in-package :drei-core)
(defclass target-specification () ((%drei :reader drei-instance :initarg :drei-instance :initform (error "A Drei instance must be provided for a target specification"))) (:documentation "The base class for target specifications, objects that permit browsing through targets for various operations. `Target-specification' instances start off deactivated."))
(defgeneric activate-target-specification (target-specification) (:documentation "Cause the Drei instance associated with `target-specification' to switch to the "current" target of `target-specification', whatever that is. It is illegal to call any other target function on a `target-specification' object until it has been activated by this function, and it is illegal to call this function on an already activated `target-specification' instance."))
(defgeneric deactivate-target-specification (target-specification) (:documentation "Deactivate the `target-specification' instance, restoring whatever state the call to `activate-target-specification' modified. It is illegal to call `deactivate-target-specification' on a deactivated `target-specification' instance."))
(defgeneric subsequent-targets-p (target-specification) (:documentation "Return true if there are more targets to act on, that is, if the `next-target' function would not signal an error."))
(defgeneric preceding-targets-p (target-specification) (:documentation "Return true if there are targets to act on in sequence before the current target, that is, if the `previous-target' function would not signal an error."))
(defgeneric next-target (target-specification) (:documentation "Change to the next target specified by the target specification. Signals an error of type `no-more-targets' if `subsequent-targets-p' is false."))
(defgeneric previous-target (target-specification) (:documentation "Change to the previous target specified by the target specification. Signals an error of type `no-more-targets' if `preceding-targets-p' is false."))
(define-condition no-more-targets (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No more targets available for iteration"))) (:documentation "Signal that there are no more targets available for iteration, either forward or backwards in the sequence of targets."))
(defclass current-buffer-target (target-specification) ((%buffer :accessor buffer)) (:documentation "A target specification class specifying just one buffer, the current buffer of the Drei instance at the time of object creation. This is mostly used as a dummy target specification to make target-aware commands behave "normally" when no particular targets are specified."))
(defmethod initialize-instance :after ((obj current-buffer-target) &rest initargs) (declare (ignore initargs)) (setf (buffer obj) (buffer (drei-instance obj))))
(defmethod activate-target-specification ((spec current-buffer-target)) ;; Noop. )
(defmethod deactivate-target-specification ((spec current-buffer-target)) ;; Noop. )
(defmethod subsequent-targets-p ((spec current-buffer-target)) nil)
(defmethod preceding-targets-p ((spec current-buffer-target)) nil)
(defmethod next-target ((spec current-buffer-target)) (error 'no-more-targets))
(defmethod previous-target ((spec current-buffer-target)) (error 'no-more-targets))
(defvar *default-target-creator* #'(lambda (drei) (make-instance 'current-buffer-target :drei-instance drei)) "A function of a single argument, the Drei instance, that creates a target specification object (or subtype thereof) that should be used for aquiring targets.")
(defclass buffer-list-target-specification (target-specification) ((%buffers :initarg :buffers :initform '() :accessor buffers) (%buffer-count :accessor buffer-count) (%current-buffer-index :initform 0 :accessor current-buffer-index)) (:documentation "A target specification that has a provided list of existing buffers as its target."))
(defmethod initialize-instance :after ((obj buffer-list-target-specification) &rest initargs) (declare (ignore initargs)) (setf (buffer-count obj) (length (buffers obj))) ;; If the current buffer is in the list of buffers, we move it to ;; the head of the list, since it makes sense to make it the ;; starting point. (when (/= (length (setf (buffers obj) (remove (buffer (drei-instance obj)) (buffers obj)))) (buffer-count obj)) (push (buffer (drei-instance obj)) (buffers obj))))
(defmethod activate-target-specification ((spec buffer-list-target-specification)) (unless (or (null (buffers spec)) (eq (buffer (drei-instance spec)) (first (buffers spec)))) (setf (buffer (drei-instance spec)) (first (buffers spec))) (beginning-of-buffer (point (drei-instance spec)))))
(defmethod deactivate-target-specification ((spec buffer-list-target-specification)))
(defmethod subsequent-targets-p ((spec buffer-list-target-specification)) (/= (1+ (current-buffer-index spec)) (buffer-count spec)))
(defmethod preceding-targets-p ((spec buffer-list-target-specification)) (plusp (current-buffer-index spec)))
(defmethod next-target ((spec buffer-list-target-specification)) (if (subsequent-targets-p spec) (progn (setf (buffer (drei-instance spec)) (elt (buffers spec) (incf (current-buffer-index spec)))) (beginning-of-buffer (point (drei-instance spec)))) (error 'no-more-targets)))
(defmethod previous-target ((spec buffer-list-target-specification)) (if (preceding-targets-p spec) (progn (setf (buffer (drei-instance spec)) (elt (buffers spec) (decf (current-buffer-index spec)))) (end-of-buffer (point (drei-instance spec)))) (error 'no-more-targets)))
-
thenriksen