/[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.9 - (hide annotations)
Wed Jan 30 21:21:43 2008 UTC (6 years, 2 months ago) by thenriksen
Branch: MAIN
Changes since 1.8: +15 -10 lines
WITH-INPUT-EDITING now works really well with Drei.
1 thenriksen 1.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     (defclass empty-input-mixin ()
29     ()
30     (:documentation "A mixin class used for detecting empty input"))
31    
32     (defclass standard-input-editing-stream (drei:drei-input-editing-mixin
33     empty-input-mixin
34     input-editing-stream
35     standard-encapsulating-stream)
36     ((scan-pointer :accessor stream-scan-pointer :initform 0)
37 thenriksen 1.6 (rescan-queued :accessor rescan-queued :initform nil))
38     (:documentation "The instantiable class that implements CLIM's
39     standard input editor. This is the class of stream created by
40     calling `with-input-editing'.
41    
42     Members of this class are mutable."))
43 thenriksen 1.1
44 thenriksen 1.7 (defmethod interactive-stream-p ((stream standard-input-editing-stream))
45     t)
46    
47 thenriksen 1.1 (defmethod stream-accept ((stream standard-input-editing-stream) type
48     &rest args
49     &key (view (stream-default-view stream))
50     &allow-other-keys)
51     (apply #'prompt-for-accept stream type view args)
52     (apply #'accept-1 stream type args))
53    
54     ;;; Markers for noise strings in the input buffer.
55    
56     (defclass noise-string-property ()
57     ())
58    
59     (defclass noise-string-start-property (noise-string-property)
60     ())
61    
62     (defparameter *noise-string* (make-instance 'noise-string-property))
63    
64     (defparameter *noise-string-start*
65     (make-instance 'noise-string-start-property))
66    
67     (defgeneric activate-stream (stream gesture)
68     (:documentation "Cause the input editing stream STREAM to be
69     activated with GESTURE"))
70    
71     (defmethod activate-stream ((stream standard-input-editing-stream) gesture)
72     (setf (drei::activation-gesture stream) gesture))
73    
74     ;;; These helper functions take the arguments of ACCEPT so that they
75     ;;; can be used directly by ACCEPT.
76    
77     (defun make-activation-gestures
78     (&key (activation-gestures nil activation-gestures-p)
79     (additional-activation-gestures nil additional-activations-p)
80     (existing-activation-gestures *activation-gestures*)
81     &allow-other-keys)
82     (cond (additional-activations-p
83     (append additional-activation-gestures existing-activation-gestures))
84     (activation-gestures-p
85     activation-gestures)
86     (t (or existing-activation-gestures
87     *standard-activation-gestures*))))
88    
89     (defun make-delimiter-gestures
90     (&key (delimiter-gestures nil delimiter-gestures-p)
91     (additional-delimiter-gestures nil additional-delimiters-p)
92     (existing-delimiter-gestures *delimiter-gestures*)
93     &allow-other-keys)
94     (cond (additional-delimiters-p
95     (append additional-delimiter-gestures existing-delimiter-gestures))
96     (delimiter-gestures-p
97     delimiter-gestures)
98     (t existing-delimiter-gestures)))
99    
100     (define-condition rescan-condition (condition)
101     ())
102    
103     (defgeneric finalize (editing-stream input-sensitizer)
104     (:documentation "Do any cleanup on an editing stream, like turning off the
105     cursor, etc."))
106    
107     (defmethod finalize ((stream drei:drei-input-editing-mixin)
108     input-sensitizer)
109     (setf (cursor-visibility stream) nil)
110     (let ((real-stream (encapsulating-stream-stream stream))
111     (record (drei:drei-instance stream)))
112 thenriksen 1.8 (cond (input-sensitizer
113     (erase-output-record record real-stream)
114     (funcall input-sensitizer
115     real-stream
116     #'(lambda ()
117     (stream-add-output-record real-stream record)
118     (when (stream-drawing-p real-stream)
119     (replay record real-stream)))))
120     ;; We still want to replay it for the cursor visibility
121     ;; change...
122     ((stream-drawing-p real-stream)
123     (replay record real-stream) ))
124 thenriksen 1.5 (setf (stream-cursor-position real-stream)
125     (values 0 (nth-value 3 (input-editing-stream-bounding-rectangle stream))))))
126 thenriksen 1.1
127     (defgeneric invoke-with-input-editing
128     (stream continuation input-sensitizer initial-contents class))
129    
130     (defmethod invoke-with-input-editing :around ((stream extended-output-stream)
131     continuation
132     input-sensitizer
133     initial-contents
134     class)
135     (declare (ignore continuation input-sensitizer initial-contents class))
136     (letf (((cursor-visibility (stream-text-cursor stream)) nil))
137     (call-next-method)))
138    
139     (defmethod invoke-with-input-editing :around (stream
140     continuation
141     input-sensitizer
142     initial-contents
143     class)
144     (declare (ignore continuation input-sensitizer initial-contents class))
145     (with-activation-gestures (*standard-activation-gestures*)
146     (call-next-method)))
147    
148     ;; XXX: We are supposed to implement input editing for all
149     ;; "interactive streams", but that's not really reasonable. We only
150     ;; care about `clim-stream-pane's, at least for Drei, currently.
151     (defmethod invoke-with-input-editing ((stream clim-stream-pane)
152     continuation
153     input-sensitizer
154     initial-contents
155     class)
156     (let ((editing-stream (make-instance class
157 thenriksen 1.9 :stream stream)))
158     (if (stringp initial-contents)
159     (replace-input editing-stream initial-contents)
160     (presentation-replace-input editing-stream
161     (first initial-contents)
162     (second initial-contents)
163     (stream-default-view editing-stream)))
164 thenriksen 1.1 (unwind-protect
165     (loop
166 thenriksen 1.9 (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 thenriksen 1.1 (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 thenriksen 1.5 (bounding-rectangle* (view (drei:drei-instance stream))))
193 thenriksen 1.2
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-next (stream input-buffer gesture numeric-argument)
203 thenriksen 1.3 (declare (ignore input-buffer gesture numeric-argument))
204 thenriksen 1.2 (let* ((accepting-type *active-history-type*)
205     (history (and accepting-type
206     (presentation-type-history accepting-type))))
207     (when history
208     (multiple-value-bind (object type)
209     (presentation-history-next history accepting-type)
210     (when type
211 thenriksen 1.4 (presentation-replace-input stream object type (stream-default-view stream)
212     :allow-other-keys t
213     :accept-result nil))))))
214 thenriksen 1.2
215     (defun history-yank-previous (stream input-buffer gesture numeric-argument)
216 thenriksen 1.3 (declare (ignore input-buffer gesture numeric-argument))
217 thenriksen 1.2 (let* ((accepting-type *active-history-type*)
218     (history (and accepting-type
219     (presentation-type-history accepting-type))))
220     (when history
221     (multiple-value-bind (object type)
222     (presentation-history-previous history accepting-type)
223     (when type
224 thenriksen 1.4 (presentation-replace-input stream object type (stream-default-view stream)
225     :allow-other-keys t
226     :accept-result nil))))))
227 thenriksen 1.2
228 thenriksen 1.3 (add-input-editor-command '((#\n :meta)) 'history-yank-next)
229 thenriksen 1.2
230 thenriksen 1.3 (add-input-editor-command '((#\p :meta)) 'history-yank-previous)

  ViewVC Help
Powered by ViewVC 1.1.5