/[mcclim]/mcclim/input-editing-drei.lisp
ViewVC logotype

Contents of /mcclim/input-editing-drei.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Nov 20 09:00:56 2006 UTC (7 years, 4 months ago) by thenriksen
Branch: MAIN
Changes since 1.1: +43 -0 lines
Added support for navigating presentation histories in Drei. Use M-p
and M-n to browse previous input for a specific presentation type.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2001 by
4 ;;; Tim Moore (moore@bricoworks.com)
5 ;;; (c) copyright 2006 by
6 ;; Troels Henriksen (athas@sigkill.dk)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; Finalize input editing code by defining the stuff that actually
24 ;;; needs a working Drei loaded.
25
26 (in-package :clim-internals)
27
28 (with-system-redefinition-allowed
29 (when (and (fboundp 'interactive-stream-p)
30 (not (typep (fdefinition 'interactive-stream-p)
31 'generic-function)))
32 (fmakunbound 'interactive-stream-p))
33 (defgeneric interactive-stream-p (stream)
34 (:method (stream)
35 (cl:interactive-stream-p stream))))
36
37 (defclass empty-input-mixin ()
38 ()
39 (:documentation "A mixin class used for detecting empty input"))
40
41 (defclass standard-input-editing-stream (drei:drei-input-editing-mixin
42 empty-input-mixin
43 input-editing-stream
44 standard-encapsulating-stream)
45 ((scan-pointer :accessor stream-scan-pointer :initform 0)
46 (rescan-queued :accessor rescan-queued :initform nil)))
47
48 (defmethod stream-accept ((stream standard-input-editing-stream) type
49 &rest args
50 &key (view (stream-default-view stream))
51 &allow-other-keys)
52 (apply #'prompt-for-accept stream type view args)
53 (apply #'accept-1 stream type args))
54
55 ;;; Markers for noise strings in the input buffer.
56
57 (defclass noise-string-property ()
58 ())
59
60 (defclass noise-string-start-property (noise-string-property)
61 ())
62
63 (defparameter *noise-string* (make-instance 'noise-string-property))
64
65 (defparameter *noise-string-start*
66 (make-instance 'noise-string-start-property))
67
68 (defgeneric activate-stream (stream gesture)
69 (:documentation "Cause the input editing stream STREAM to be
70 activated with GESTURE"))
71
72 (defmethod activate-stream ((stream standard-input-editing-stream) gesture)
73 (setf (drei::activation-gesture stream) gesture))
74
75 ;;; These helper functions take the arguments of ACCEPT so that they
76 ;;; can be used directly by ACCEPT.
77
78 (defun make-activation-gestures
79 (&key (activation-gestures nil activation-gestures-p)
80 (additional-activation-gestures nil additional-activations-p)
81 (existing-activation-gestures *activation-gestures*)
82 &allow-other-keys)
83 (cond (additional-activations-p
84 (append additional-activation-gestures existing-activation-gestures))
85 (activation-gestures-p
86 activation-gestures)
87 (t (or existing-activation-gestures
88 *standard-activation-gestures*))))
89
90 (defun make-delimiter-gestures
91 (&key (delimiter-gestures nil delimiter-gestures-p)
92 (additional-delimiter-gestures nil additional-delimiters-p)
93 (existing-delimiter-gestures *delimiter-gestures*)
94 &allow-other-keys)
95 (cond (additional-delimiters-p
96 (append additional-delimiter-gestures existing-delimiter-gestures))
97 (delimiter-gestures-p
98 delimiter-gestures)
99 (t existing-delimiter-gestures)))
100
101 (define-condition rescan-condition (condition)
102 ())
103
104 (defun reposition-stream-cursor (stream)
105 "Moves the cursor somewhere clear of the editing area."
106 (let ((max-y 0))
107 (map-over-output-records #'(lambda (r)
108 (setf max-y (max max-y (bounding-rectangle-max-y r))))
109 (stream-output-history stream))
110 (setf (stream-cursor-position stream)
111 (values 0 max-y))))
112
113 (defgeneric finalize (editing-stream input-sensitizer)
114 (:documentation "Do any cleanup on an editing stream, like turning off the
115 cursor, etc."))
116
117 (defmethod finalize ((stream drei:drei-input-editing-mixin)
118 input-sensitizer)
119 (setf (cursor-visibility stream) nil)
120 (let ((real-stream (encapsulating-stream-stream stream))
121 (record (drei:drei-instance stream)))
122 (when input-sensitizer
123 (erase-output-record record real-stream)
124 (funcall input-sensitizer
125 real-stream
126 #'(lambda ()
127 (stream-add-output-record real-stream record)
128 (when (stream-drawing-p real-stream)
129 (replay record real-stream)))))
130 (reposition-stream-cursor real-stream)))
131
132 (defgeneric invoke-with-input-editing
133 (stream continuation input-sensitizer initial-contents class))
134
135 (defmethod invoke-with-input-editing :around ((stream extended-output-stream)
136 continuation
137 input-sensitizer
138 initial-contents
139 class)
140 (declare (ignore continuation input-sensitizer initial-contents class))
141 (letf (((cursor-visibility (stream-text-cursor stream)) nil))
142 (call-next-method)))
143
144 (defmethod invoke-with-input-editing :around (stream
145 continuation
146 input-sensitizer
147 initial-contents
148 class)
149 (declare (ignore continuation input-sensitizer initial-contents class))
150 (with-activation-gestures (*standard-activation-gestures*)
151 (call-next-method)))
152
153 ;; XXX: We are supposed to implement input editing for all
154 ;; "interactive streams", but that's not really reasonable. We only
155 ;; care about `clim-stream-pane's, at least for Drei, currently.
156 (defmethod invoke-with-input-editing ((stream clim-stream-pane)
157 continuation
158 input-sensitizer
159 initial-contents
160 class)
161 (let ((editing-stream (make-instance class
162 :stream stream
163 :initial-contents initial-contents)))
164 (unwind-protect
165 (loop
166 (block rescan
167 (handler-bind ((rescan-condition
168 #'(lambda (c)
169 (declare (ignore c))
170 (reset-scan-pointer editing-stream)
171 (return-from rescan nil))))
172 (return-from invoke-with-input-editing
173 (funcall continuation editing-stream)))))
174 (finalize editing-stream input-sensitizer))))
175
176 (defmethod immediate-rescan ((stream standard-input-editing-stream))
177 (unless (stream-rescanning-p stream)
178 (signal 'rescan-condition)))
179
180 (defmethod queue-rescan ((stream standard-input-editing-stream))
181 (setf (rescan-queued stream) t))
182
183 (defmethod rescan-if-necessary ((stream standard-input-editing-stream)
184 &optional inhibit-activation)
185 ;; FIXME:
186 (declare (ignore inhibit-activation))
187 (when (rescan-queued stream)
188 (setf (rescan-queued stream) nil)
189 (immediate-rescan stream)))
190
191 (defmethod input-editing-stream-bounding-rectangle ((stream standard-input-editing-stream))
192 (bounding-rectangle* (drei:drei-instance stream)))
193
194 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
195 ;;;
196 ;;; Presentation type history support
197 ;;;
198 ;;; Presentation histories are pretty underspecified, so we have to
199 ;;; rely on internal features and implement input-editor support in
200 ;;; CLIM-INTERNALS (Goatee does the same trick).
201
202 (defun history-yank (stream input-buffer gesture numeric-argument)
203 (let* ((accepting-type *active-history-type*)
204 (history (and accepting-type
205 (presentation-type-history accepting-type))))
206 (when history
207 (multiple-value-bind (object type)
208 (presentation-history-head history accepting-type)
209 (presentation-replace-input stream object type (stream-default-view stream))))))
210
211 (defun history-yank-next (stream input-buffer gesture numeric-argument)
212 (let* ((accepting-type *active-history-type*)
213 (history (and accepting-type
214 (presentation-type-history accepting-type))))
215 (when history
216 (multiple-value-bind (object type)
217 (presentation-history-next history accepting-type)
218 (when type
219 (presentation-replace-input stream object type (stream-default-view stream)))))))
220
221 (defun history-yank-previous (stream input-buffer gesture numeric-argument)
222 (let* ((accepting-type *active-history-type*)
223 (history (and accepting-type
224 (presentation-type-history accepting-type))))
225 (when history
226 (multiple-value-bind (object type)
227 (presentation-history-previous history accepting-type)
228 (when type
229 (presentation-replace-input stream object type (stream-default-view stream)))))))
230
231 (add-input-editor-command '((#\y :control :meta)) 'history-yank)
232
233 (add-input-editor-command '((#\p :meta)) 'history-yank-next)
234
235 (add-input-editor-command '((#\n :meta)) 'history-yank-previous)

  ViewVC Help
Powered by ViewVC 1.1.5