/[cmucl]/src/hemlock/undo.lisp
ViewVC logotype

Contents of /src/hemlock/undo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed May 9 13:07:02 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Bill Chiles
12 ;;;
13 ;;; This file contains the implementation of the undo mechanism.
14
15 (in-package 'hemlock)
16
17
18
19 ;;;; -- Constants --
20
21 (defconstant undo-name "Undo")
22
23
24
25 ;;;; -- Variables --
26
27 (defvar *undo-info* nil
28 "Structure containing necessary info to undo last undoable operation.")
29
30
31
32 ;;;; -- Structures --
33
34 (defstruct (undo-info (:print-function %print-undo-info)
35 (:constructor %make-undo-info
36 (name method cleanup method-undo buffer))
37 (:copier nil))
38 name ; string displayed for user to know what's being undone --
39 ; typically a command's name.
40 (hold-name undo-name) ; holds a name for successive invocations of the
41 ; "Undo" command.
42 method ; closure stored by command that undoes the command when invoked.
43 method-undo ; closure stored by command that undoes what method does.
44 cleanup ; closure stored by command that cleans up any data for method,
45 ; such as permanent marks.
46 buffer) ; buffer the command was invoked in.
47
48 (setf (documentation 'undo-info-name 'function)
49 "Return the string indicating what would be undone for given undo info.")
50 (setf (documentation 'undo-info-method 'function)
51 "Return the closure that undoes a command when invoked.")
52 (setf (documentation 'undo-info-cleanup 'function)
53 "Return the closure that cleans up data necessary for an undo method.")
54 (setf (documentation 'undo-info-buffer 'function)
55 "Return the buffer that the last undoable command was invoked in.")
56 (setf (documentation 'undo-info-hold-name 'function)
57 "Return the name being held since the last invocation of \"Undo\"")
58 (setf (documentation 'undo-info-method-undo 'function)
59 "Return the closure that undoes what undo-info-method does.")
60
61
62 (defun %print-undo-info (obj s depth)
63 (declare (ignore depth))
64 (format s "#<Undo Info ~S>" (undo-info-name obj)))
65
66
67
68 ;;;; -- Commands --
69
70 (defcommand "Undo" (p)
71 "Undo last major change, kill, etc.
72 Simple insertions and deletions cannot be undone. If you change the buffer
73 in this way before you undo, you may get slightly wrong results, but this
74 is probably still useful."
75 "This is not intended to be called in Lisp code."
76 (declare (ignore p))
77 (if (not *undo-info*) (editor-error "No currently undoable command."))
78 (let ((buffer (undo-info-buffer *undo-info*))
79 (cleanup (undo-info-cleanup *undo-info*))
80 (method-undo (undo-info-method-undo *undo-info*)))
81 (if (not (eq buffer (current-buffer)))
82 (editor-error "Undo info is for buffer ~S." (buffer-name buffer)))
83 (when (prompt-for-y-or-n :prompt (format nil "Undo the last ~A? "
84 (undo-info-name *undo-info*))
85 :must-exist t)
86 (funcall (undo-info-method *undo-info*))
87 (cond (method-undo
88 (rotatef (undo-info-name *undo-info*)
89 (undo-info-hold-name *undo-info*))
90 (rotatef (undo-info-method *undo-info*)
91 (undo-info-method-undo *undo-info*)))
92 (t (if cleanup (funcall cleanup))
93 (setf *undo-info* nil))))))
94
95
96
97 ;;;; -- Primitives --
98
99 (defun save-for-undo (name method
100 &optional cleanup method-undo (buffer (current-buffer)))
101 "Stashes information for next \"Undo\" command invocation. If there is
102 an undo-info object, it is cleaned up first."
103 (cond (*undo-info*
104 (let ((old-cleanup (undo-info-cleanup *undo-info*)))
105 (if old-cleanup (funcall old-cleanup))
106 (setf (undo-info-name *undo-info*) name)
107 (setf (undo-info-hold-name *undo-info*) undo-name)
108 (setf (undo-info-method *undo-info*) method)
109 (setf (undo-info-method-undo *undo-info*) method-undo)
110 (setf (undo-info-cleanup *undo-info*) cleanup)
111 (setf (undo-info-buffer *undo-info*) buffer)
112 *undo-info*))
113 (t (setf *undo-info*
114 (%make-undo-info name method cleanup method-undo buffer)))))
115
116
117
118 (eval-when (compile eval)
119
120 ;;; MAKE-TWIDDLE-REGION-UNDO sets up an undo method that deletes region1,
121 ;;; saving the deleted region and eventually storing it in region2. After
122 ;;; deleting region1, its start and end are made :right-inserting and
123 ;;; :left-inserting, so it will contain region2 when it is inserted at region1's
124 ;;; end. This results in a method that takes region1 with permanent marks
125 ;;; into some buffer and results with the contents of region2 in region1 (with
126 ;;; permanent marks into a buffer) and the contents of region1 (from the buffer)
127 ;;; in region2 (a region without marks into any buffer).
128 ;;;
129 (defmacro make-twiddle-region-undo (region1 region2)
130 `#'(lambda ()
131 (let* ((tregion (delete-and-save-region ,region1))
132 (mark (region-end ,region1)))
133 (setf (mark-kind (region-start ,region1)) :right-inserting)
134 (setf (mark-kind mark) :left-inserting)
135 (ninsert-region mark ,region2)
136 (setf ,region2 tregion))))
137
138 ;;; MAKE-DELETE-REGION-UNDO sets up an undo method that deletes region with
139 ;;; permanent marks into a buffer, saving the region in region without any
140 ;;; marks into a buffer, deleting one of the permanent marks, and saving one
141 ;;; permanent mark in the variable mark. This is designed to work with
142 ;;; MAKE-INSERT-REGION-UNDO, so mark results in the location in a buffer where
143 ;;; region will be inserted if this method is undone.
144 ;;;
145 (defmacro make-delete-region-undo (region mark)
146 `#'(lambda ()
147 (let ((tregion (delete-and-save-region ,region)))
148 (delete-mark (region-start ,region))
149 (setf ,mark (region-end ,region))
150 (setf ,region tregion))))
151
152 ;;; MAKE-INSERT-REGION-UNDO sets up an undo method that inserts region at mark,
153 ;;; saving in the variable region a region with permanent marks in a buffer.
154 ;;; This is designed to work with MAKE-DELETE-REGION-UNDO, so region can later
155 ;;; be deleted.
156 ;;;
157 (defmacro make-insert-region-undo (region mark)
158 `#'(lambda ()
159 (let ((tregion (region (copy-mark ,mark :right-inserting) ,mark)))
160 (setf (mark-kind ,mark) :left-inserting)
161 (ninsert-region ,mark ,region)
162 (setf ,region tregion))))
163
164 ) ;eval-when
165
166 ;;; MAKE-REGION-UNDO handles three common cases that undo'able commands often
167 ;;; need. This function sets up three closures via SAVE-FOR-UNDO that do
168 ;;; an original undo, undo the original undo, and clean up any permanent marks
169 ;;; the next time SAVE-FOR-UNDO is called. Actually, the original undo and
170 ;;; the undo for the original undo setup here are reversible in that each
171 ;;; invocation of "Undo" switches these, so an undo setup by the function is
172 ;;; undo'able, and the undo of the undo is undo'able, and the ....
173 ;;;
174 ;;; :twiddle
175 ;;; Region has permanent marks into a buffer. Mark-or-region is a region
176 ;;; not connected to any buffer. A first undo deletes region, saving it and
177 ;;; inserting mark-or-region. This also sets region around the inserted
178 ;;; region in the buffer and sets mark-or-region to be the deleted and saved
179 ;;; region. Thus the undo and the undo of the undo are the same action.
180 ;;; :insert
181 ;;; Region is not connected to any buffer. Mark-or-region is a permanent
182 ;;; mark into a buffer where region is to be inserted on a first undo, and
183 ;;; this mark is used to form a region on the first undo that will be
184 ;;; deleted upon a subsequent undo. The cleanup method knows mark-or-region
185 ;;; is a permanent mark into a buffer, but it has to determine if region
186 ;;; has marks into a buffer because if a subsequent undo does occur, region
187 ;;; does point into a buffer.
188 ;;; :delete
189 ;;; Region has permanent marks into a buffer. Mark-or-region should not
190 ;;; have been supplied. A first undo deletes region, saving the deleted
191 ;;; region in region and creating a permanent mark that indicates where to
192 ;;; put region back. The permanent mark is stored in mark-or-region. The
193 ;;; cleanup method has to check that mark-or-region is a mark since it won't
194 ;;; be unless there was a subsequent undo.
195 ;;;
196 (defun make-region-undo (kind name region &optional mark-or-region)
197 (case kind
198 (:twiddle
199 (save-for-undo name
200 (make-twiddle-region-undo region mark-or-region)
201 #'(lambda ()
202 (delete-mark (region-start region))
203 (delete-mark (region-end region)))
204 (make-twiddle-region-undo region mark-or-region)))
205 (:insert
206 (save-for-undo name
207 (make-insert-region-undo region mark-or-region)
208 #'(lambda ()
209 (let ((mark (region-start region)))
210 (delete-mark mark-or-region)
211 (when (line-buffer (mark-line mark))
212 (delete-mark mark)
213 (delete-mark (region-end region)))))
214 (make-delete-region-undo region mark-or-region)))
215 (:delete
216 (save-for-undo name
217 (make-delete-region-undo region mark-or-region)
218 #'(lambda ()
219 (delete-mark (region-start region))
220 (delete-mark (region-end region))
221 (if (markp mark-or-region) (delete-mark mark-or-region)))
222 (make-insert-region-undo region mark-or-region)))))

  ViewVC Help
Powered by ViewVC 1.1.5