blob: 1ef253d19a5913ee08d2e313f900d6096ef1f652 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
;;; ---------------------------------------------------------------------------
;;; License: LGPL-2.1+ (See file 'Copyright' for details).
;;; ---------------------------------------------------------------------------
;;;
;;; (c) Copyright 2001 by Tim Moore <moore@bricoworks.com>
;;; (c) Copyright 2006 by Troels Henriksen <athas@sigkill.dk>
;;; (c) Copyright 2018 by Nisar Ahmad <nisarahmad1324@gmail.com>
;;;
;;; ---------------------------------------------------------------------------
;;;
;;; Finalize input editing code by defining the stuff that actually needs a
;;; working Drei loaded.
(in-package #:clim-internals)
(defclass standard-input-editing-stream (drei:drei-input-editing-mixin
drei:single-line-mixin
standard-input-editing-mixin
input-editing-stream
standard-encapsulating-stream)
((scan-pointer :accessor stream-scan-pointer :initform 0)
(rescan-queued :accessor rescan-queued :initform nil))
(:documentation "The instantiable class that implements CLIM's
standard input editor. This is the class of stream created by
calling `with-input-editing'.
Members of this class are mutable."))
(defmethod interactive-stream-p ((stream standard-input-editing-stream))
t)
(defmethod stream-accept ((stream standard-input-editing-stream) type
&rest args
&key (view (stream-default-view stream))
&allow-other-keys)
(apply #'prompt-for-accept stream type view args)
(apply #'accept-1 stream type args))
;;; Markers for noise strings in the input buffer.
(defclass noise-string-property ()
())
(defclass noise-string-start-property (noise-string-property)
())
(defparameter *noise-string* (make-instance 'noise-string-property))
(defparameter *noise-string-start*
(make-instance 'noise-string-start-property))
(defgeneric activate-stream (stream gesture)
(:documentation "Cause the input editing stream STREAM to be
activated with GESTURE"))
(defmethod activate-stream ((stream standard-input-editing-stream) gesture)
(setf (drei::activation-gesture stream) gesture))
(defmethod finalize ((stream drei:drei-input-editing-mixin) input-sensitizer)
(call-next-method)
(setf (cursor-visibility stream) nil)
(let ((real-stream (encapsulating-stream-stream stream))
(record (drei:drei-instance stream)))
(cond (input-sensitizer
(erase-output-record record real-stream nil)
(funcall input-sensitizer
real-stream
#'(lambda ()
(stream-add-output-record real-stream record)
(when (stream-drawing-p real-stream)
(replay record real-stream)))))
;; We still want to replay it for the cursor visibility change...
((stream-drawing-p real-stream)
(replay record real-stream) ))
;; FIXME this causes a line break even on an empty input. A most notable
;; example is when the command is accepted with :ECHO NIL -- jd 2022-12-09
(setf (stream-cursor-position real-stream)
(values (stream-cursor-initial-position real-stream)
(bounding-rectangle-max-y record)))))
;; XXX: We are supposed to implement input editing for all
;; "interactive streams", but that's not really reasonable. We only
;; care about `clim-stream-pane's, at least for Drei, currently. --
;; internally screams (jd)
(defmethod invoke-with-input-editing ((stream clim-stream-pane)
continuation
input-sensitizer
initial-contents
class)
(let ((editing-stream (make-instance class :stream stream)))
(unwind-protect (with-input-editing (editing-stream
:input-sensitizer input-sensitizer
:initial-contents initial-contents
:class class)
(input-editing-rescan-loop editing-stream continuation))
(finalize editing-stream input-sensitizer))))
(defmethod immediate-rescan ((stream standard-input-editing-stream))
(unless (stream-rescanning-p stream)
(signal 'rescan-condition)))
(defmethod queue-rescan ((stream standard-input-editing-stream))
(setf (rescan-queued stream) t))
(defmethod rescan-if-necessary ((stream standard-input-editing-stream)
&optional inhibit-activation)
;; FIXME:
(declare (ignore inhibit-activation))
(when (rescan-queued stream)
(setf (rescan-queued stream) nil)
(immediate-rescan stream)))
(defmethod input-editing-stream-output-record ((stream standard-input-editing-stream))
(drei:drei-instance stream))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Presentation type history support
;;;
;;; Presentation histories are pretty underspecified, so we have to
;;; rely on internal features and implement input-editor support in
;;; CLIM-INTERNALS.
;;; When yanking history of commands on the stream, Following helper function
;;; ensures the sublists are not evaluated by quoting them. They are
;;; not meant to be evaluated anyway. (See comment on "define-command" in
;;; Core/clim-core/commands.lisp).
(defun %quote-sublists (list)
(let ((result nil))
(loop for item in list
do (if (listp item)
(if (eql (car item) 'quote)
(push item result)
(push `(quote ,item) result))
(push item result)))
(reverse result)))
(defun history-yank-next (stream input-buffer gesture numeric-argument)
(declare (ignore input-buffer gesture numeric-argument))
(let* ((accepting-type *active-history-type*)
(quoted-sublists nil)
(history (and accepting-type
(presentation-type-history accepting-type))))
(when history
(multiple-value-bind (object type)
(presentation-history-next history accepting-type)
(when type
(when (and (equal type 'command-or-form)
(listp object)
(alexandria:starts-with-subseq "COM-" (symbol-name `,(car object))))
(setf quoted-sublists (%quote-sublists object)))
(when (null quoted-sublists)
(setf quoted-sublists object))
(let ((*print-case* :downcase))
(presentation-replace-input stream quoted-sublists type
(stream-default-view stream)
:allow-other-keys t
:accept-result nil)))))))
(defun history-yank-previous (stream input-buffer gesture numeric-argument)
(declare (ignore input-buffer gesture numeric-argument))
(let* ((accepting-type *active-history-type*)
(quoted-sublists nil)
(history (and accepting-type
(presentation-type-history accepting-type))))
(when history
(multiple-value-bind (object type)
(presentation-history-previous history accepting-type)
(when type
(when (and (equal type 'command-or-form)
(listp object)
(alexandria:starts-with-subseq "COM-" (symbol-name `,(car object))))
(setf quoted-sublists (%quote-sublists object)))
(when (null quoted-sublists)
(setf quoted-sublists object))
(let ((*print-case* :downcase))
(presentation-replace-input stream quoted-sublists type
(stream-default-view stream)
:allow-other-keys t
:accept-result nil)))))))
(add-input-editor-command '((#\n :meta)) 'history-yank-next)
(add-input-editor-command '((#\p :meta)) 'history-yank-previous)
|
