[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Fri Nov 16 09:28:46 UTC 2007
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 at free.fr)
;;; (c) copyright 2005 by
;;; Aleksandar Bakic (a_bakic at yahoo.com)
+;;; (c) copyright 2007 by
+;;; Troels Henriksen (athas at 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 at 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)))
More information about the Mcclim-cvs
mailing list