source: trunk/cocoa-ide-contrib/cater/clickable.lisp @ 15208

Last change on this file since 15208 was 15208, checked in by rme, 9 years ago

New contribution from Arthur Cater.

Briefly, it lets you make a customised Hemlock view, in which a
new format directive ~v,v@:/clickable/ will work which offers
highlighting and click-responsiveness of text elements.

File size: 18.8 KB
1(in-package hemlock)
3; --------------------------------------------------------------------------------
4; Permission is granted to all to use, to distribute and to modify this code.
5;                 February 2012
6;                       No warranty is expressed or implied.
8" This file provides for creating a custom Hemlock window and output stream, with
9; which FORMAT directive /CLICKABLE/ can be used. The contents of the window are
10; not syntax-colorised and parenthesis highlighting is disabled, other Hemlock
11; windows continue to enjoy those features as usual.
13; The CLICKABLE directive allows for printed strings to be underlined and shown
14; in color - red, or blue if the @ modifier is used. A function can be supplied
15; as a first prefix argument, if not supplied it defaults to INSPECT. A lisp datum
16; can be supplied as a second prefix argument, if not supplied it defaults to the
17; object printed. The colon modifier causes the object printed to be printed as
18; if by ~s, without the colon modifier it is printed as if by ~a.
20; If you mouse-click on the printed representation, the supplied function is
21; called with the datum - second prefix argument, defaulting to object printed.
23; There are severe limitations: don't expect it to work inside text-justification
24; directives for instance.
26; The API consists of :-
28;      In CL-USER package.
29;      Returns three values: a stream, a hemlock-view, and a ns-window
31;    CLICKABLE                                                  (format directive)
32;       In CL-USER package.
33;       Usages:"
34;       (format s "...~/CLICKABLE/..." arg)
35"       The arg is printed as if by ~a in red and underlined.
36;       Clicking on it causes INSPECT to be called on it.
37;       The '@' modifier causes it to be printed in blue and underlined.
38;       The ':' modifier causes it to be printed as if by ~s.
40;       (format s "...~V/CLICKABLE/..." #'yourfn arg)
41"       The arg is printed as above, clicking it causes YOURFN to be called on it
43;       (format s "...~,V/CLICKABLE/..." yourobj arg)
44"       The arg is printed as above, clicking it causes INSPECT of YOUROBJ
46;       (format s "...~V,V/CLICKABLE/..." #'yourfn #'yourobj arg)
47"       The arg is printed as above, clicking it calls YOURFN on YOUROBJ  "
48; --------------------------------------------------------------------------------
49" Some existing methods of Clozure's Hemlock are redefined:
54; --------------------------------------------------------------------------------
56(defmacro do-objc-array ((itemvar arrayexpr) &body body)
57"Perform BODY with ITEMVAR bound to successive elements of the ObjC array which
58is value of ARRAYEXPR, while allowing for the possibility it is a null pointer."
59  (let ((arrayvar (gensym)) (countvar (gensym)) (indexvar (gensym)))
60    `(let ((,arrayvar ,arrayexpr))
61       (unless (ccl::%null-ptr-p ,arrayvar)
62         (let ((,countvar (#/count ,arrayvar)))
63           (dotimes (,indexvar ,countvar)
64             (let ((,itemvar (#/objectAtIndex: ,arrayvar ,indexvar))) ,@body)))))))
66(defparameter *main-click-color* nil "Gets set to a hue of red, used for formatting
67~/CLICKABLE/ objects when atsign modifier was not specified.")
69(defparameter *alternate-click-color* nil "Gets set to a hue of blue, used for formatting
70~/CLICKABLE/ objects when atsign modifier was specified.")
72(defparameter *underlinedicts* nil "Gets set to a list of two ns-mutable-dictionary(s)")
74(defun underlinedicts nil "Makes or reuses a list of two NS-MUTABLE-DICTIONARYs,
75probably needs work if to be used before and after saving an application. I didn't try."
76  (or *underlinedicts*
77      (prog1
78       (setf *underlinedicts*
79             (list
80              (make-instance 'ns:ns-mutable-dictionary :with-capacity 2)
81              (make-instance 'ns:ns-mutable-dictionary :with-capacity 2)))
82       (setf *main-click-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 1.0 0.2 0.2 1.0))
83       (setf *alternate-click-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 1.0 1.0))
84       (#/setObject:forKey: (first *underlinedicts*) (#/numberWithInt: ns:ns-number 1)
85                            #&NSUnderlineStyleAttributeName)
86       (#/setObject:forKey: (second *underlinedicts*) (#/numberWithInt: ns:ns-number 1)
87                            #&NSUnderlineStyleAttributeName)
88       (#/setObject:forKey: (first *underlinedicts*) *main-click-color*
89                            #&NSForegroundColorAttributeName)
90       (#/setObject:forKey: (second *underlinedicts*) *alternate-click-color*
91                            #&NSForegroundColorAttributeName))))
93; --------------------------------------------------------------------------------
94" MAKE-CLICKABLE-STREAM makes a view specialised for CLICKABLE formatting, and
95; returns three values:
96; (1) a stream for writing to it
97; (2) the view (an instance of hemlock-view)
98; (3) the ns-window in which it is presented
99; Keyword arguments FONT, FRAME and CUSTOM-P may be supplied.
100; FONT       should be a ns-font object, or unspecified.
101; FRAME      should be a ns-rect onject, or unspecified.
102; ENCODING   should be an encoding keyword such as :UTF-8, or unspecified.
103;            If unspecified, the existing default encoding is used.
104; CUSTOM-P   defaults to T. If specified as NIL, the view is not specialised for
105;            CLICKABLE formatting. It behaves as an ordinary Hemlock view, with
106;            syntax coloring and parenthesis highlighting."
107; --------------------------------------------------------------------------------
109(defun cl-user::make-clickable-stream (&key (custom-p t) (font gui::*editor-font*) frame encoding)
110  (gui::execute-in-gui
111   (lambda nil
112     (let ((ccl::*default-file-character-encoding* (or encoding ccl::*default-file-character-encoding*))
113           (oldfont (shiftf gui::*editor-font* font))
114           stream view window)
115       (unwind-protect
116           (let* ((hview (gui::find-or-make-hemlock-view nil))
117                  (buffer (hemlock-view-buffer hview)))
118             (setf window (#/window (hi::hemlock-view-pane hview)))
119             (when frame
120               (#/setFrame:display: window frame t))
121             (when custom-p
122               (underlinedicts)
123               (setf (getf (buffer-plist buffer) :specialises-mousedown) 'clickable-mousedown-function)
124               (setf (getf (buffer-plist buffer) :preserve-attributes) t))
125             (setf stream (hi:make-hemlock-output-stream (buffer-end-mark buffer) :none))
126             ; All possible values {:none, :line, :full} apparently have the same effect
127             (setf view hview))
128         (setf gui::*editor-font* oldfont))
129       (values stream view window)))))
131; --------------------------------------------------------------------------------
132; This redefinition of the primary method COMPUTE-TEMPORARY-ATTRIBUTES uses the
133; buffer-plist key :preserve-attributes in order to allow syntax styling and paren
134; balancing in ordinary Hemlock windows, and red-and-underlined text in customised
135; ones.
136; With the original defn, the redness is eliminated yet the underlining survives.
137; --------------------------------------------------------------------------------
139(defmethod gui::compute-temporary-attributes ((self gui::hemlock-textstorage-text-view))
140  #-cocotron
141  (let* ((container (#/textContainer self))
142         ;; If there's a containing scroll view, use its contentview         
143         ;; Otherwise, just use the current view.
144         (scrollview (#/enclosingScrollView self))
145         (contentview (if (ccl::%null-ptr-p scrollview) self (#/contentView scrollview)))
146         (rect (#/bounds contentview))
147         (layout (#/layoutManager container))
148         (glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
149                       layout rect container))
150         (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
151                      layout glyph-range ccl::+null-ptr+))
152         (start (ns:ns-range-location char-range))
153         (length (ns:ns-range-length char-range))
154         (ts (#/textStorage self))
155         (cache (gui::hemlock-buffer-string-cache (slot-value ts 'gui::hemlock-string)))
156         (hi::*current-buffer* (gui::buffer-cache-buffer cache))
157         (preserve-attributes (getf (hi::buffer-plist hi::*current-buffer*) :preserve-attributes)))
158    (when (and (> length 0) (null preserve-attributes))
159      ;; Remove all temporary attributes from the character range
160      (#/removeTemporaryAttribute:forCharacterRange:
161       layout #&NSForegroundColorAttributeName char-range)
162      (#/removeTemporaryAttribute:forCharacterRange:
163       layout #&NSBackgroundColorAttributeName char-range)
164      (multiple-value-bind (start-line start-offset)
165                           (gui::update-line-cache-for-index cache start)
166        (let* ((end-line (gui::update-line-cache-for-index cache (+ start length))))
167          (gui::set-temporary-character-attributes
168           layout
169           (- start start-offset)
170           start-line
171           (hi::line-next end-line)))))
172    (when (and (eql #$YES (gui::text-view-paren-highlight-enabled self))
173               (null preserve-attributes))
174      (let* ((background #&NSBackgroundColorAttributeName)
175             (paren-highlight-left (gui::text-view-paren-highlight-left-pos self))
176             (paren-highlight-right (gui::text-view-paren-highlight-right-pos self))
177             (paren-highlight-color (gui::text-view-paren-highlight-color self))
178             (attrs (#/dictionaryWithObject:forKey: ns:ns-dictionary
179                                                    paren-highlight-color
180                                                    background)))
181        (ns:with-ns-range (left-range paren-highlight-left 1)
182          (ns:with-ns-range (right-range paren-highlight-right 1)
183            #-cocotron
184            (let ((layout (#/layoutManager (#/textContainer self))))
185              (#/addTemporaryAttributes:forCharacterRange: layout attrs left-range)
186              (#/addTemporaryAttributes:forCharacterRange: layout attrs right-range))
187            #+cocotron
188            (let ((ts (#/textStorage self)))
189              (#/beginEditing ts)
190              (#/addAttributes:range: ts attrs left-range)
191              (#/addAttributes:range: ts attrs right-range)
192              (#/endEditing ts))))))))
194; --------------------------------------------------------------------------------
195; As Glen Foy suggests, define AROUND methods for Handle-Hemlock-Event and
196; Compute-Temporary-Attributes in order to customise handling mouse clicks
197; --------------------------------------------------------------------------------
199(defConstant *left-mouse-down* 65535)
201;;; Redefinition of a Hemlock method in cocoa-editor.lisp
202(defMethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
203 (ccl::with-autorelease-pool
204     (call-next-method))
205 (let ((keysym (when (typep event 'hi::key-event) (hi::key-event-keysym event))))
206   (when (and (numberp keysym)
207              (= keysym *left-mouse-down*)
208              (getf (buffer-plist (hemlock-view-buffer view)) :specialises-mousedown))
209     (setf (getf (buffer-plist (hemlock-view-buffer view)) :mousedown-pressed) t))))
211(defmethod gui::compute-temporary-attributes :around ((self gui::hemlock-textstorage-text-view))
212  (call-next-method)
213  (let* ((view (gui::hemlock-view self))
214         (hi::*current-buffer* (hi::hemlock-view-buffer view))
215         (plist (buffer-plist hi::*current-buffer*)))
216    (when (and (getf plist :mousedown-pressed) (getf plist :specialises-mousedown))
217      (funcall (getf plist :specialises-mousedown) hi::*current-buffer* view)
218      (setf (getf plist :mousedown-pressed) nil))))
220; --------------------------------------------------------------------------------
221; Clickable-Mousedown-Function may be the value of the :specialises-mousedown
222; property on a buffer's plist, so gui::compute-temporary-attributes will call it
223; after a mousedown-mouseup sequence.
224; --------------------------------------------------------------------------------
226(defun clickable-mousedown-function (hi::*current-buffer* hi::*current-view*)
227  (gui::assume-cocoa-thread)
228  (let* ((point (current-point))
229         (line (mark-line point))
230         (pos (mark-charpos point))
231         (pchange (find pos (slot-value line 'hi::charprops-changes)
232                        :from-end t :test #'>= :key #'hi::charprops-change-index))
233         (props (when pchange (hi::charprops-change-plist pchange))))
234    (when (and props (<= pos (+ (getf props :length) (hi::charprops-change-index pchange))))
235      (funcall (getf props :clickfunction) (getf props :argument)))))
237(defun open-hemlock-output-stream-p (stream)
238  (and (typep stream 'hemlock::hemlock-output-stream)
239       (not (null (hi::hemlock-output-stream-mark stream)))))
241; --------------------------------------------------------------------------------
242; Redefine methods given in ccl:cocoa-ide;hemlock;src;streams.lisp
243; to ensure that hemlock buffer modification is done in the proper thread
244; --------------------------------------------------------------------------------
246(defmethod hi::stream-write-char ((stream hi::hemlock-output-stream) char)
247  (gui::execute-in-gui
248   (lambda nil
249     (gui::assume-cocoa-thread)
250     (funcall (hi::old-lisp-stream-out stream) stream char))))
252(defmethod hi::stream-write-string ((stream hi::hemlock-output-stream) string
253                                &optional
254                                (start 0)
255                                (end (length string)))
256  (gui::execute-in-gui
257   (lambda nil
258     (gui::assume-cocoa-thread)
259     (funcall (hi::old-lisp-stream-sout stream) stream string start end))))
261; --------------------------------------------------------------------------------
262" The ~V,V/CLICKABLE/ format directive
263; Consumes one two or three arguments from the format args list
264; The principal argument is something to be output to the stream.
265; By default it is printed as if by PRINC (~A), but the colon modifier causes it
266; to be printed as if by PRIN1 (~S).
267; The first prefix argument (corresponding to first V) should be a function of one
268; argument or a symbol naming one. If omitted, then INSPECT will used.
269; The second prefix argument specifies the argument for that function. If omitted,
270; the principal argument will be used.
271; - If the stream is a hemlock-output-stream that has not been closed, then the
272;   text produced for the principal argument will be mouse-sensitive. Clicking on
273;   it will cause the function to be invoked with the argument that was printed.
274; - On other streams, the prefix arguments will be consumed but ignored."
275; --------------------------------------------------------------------------------
277(defun cl-user::clickable (stream arg colon atsign &optional prefix (dataobject arg datagiven-p))
278  (declare (ignorable atsign))
279  (cond
280   ((open-hemlock-output-stream-p stream)
281    (unless prefix (setf prefix #'inspect))
282    (let* ((mark (hi:copy-mark (slot-value stream 'hi::mark) :temporary))
283           (markabsolute (hi::mark-absolute-position mark))
284           (line (slot-value mark 'hi::line))
285           (color (if atsign *alternate-click-color* *main-click-color*))
286           (charprops `(:font-underline :single :font-color ,color
287                        :clickfunction ,prefix  :argument ,dataobject))
288           (start (slot-value mark 'hi::charpos))
289           (dict (if atsign (second *underlinedicts*) (first *underlinedicts*))))
290      (if colon (prin1 arg stream) (princ arg stream))
291      (let* ((length (- (hi::mark-absolute-position (slot-value stream 'hi::mark)) markabsolute))
292             (doc (hi::buffer-document (line-buffer line)))
293             (store (when doc (slot-value doc 'gui::textstorage)))
294             (end (slot-value (slot-value stream 'hi::mark) 'hi::charpos)))
295        (hi::set-line-charprops line (list* :length length charprops) :start start :end end)
296        (when doc
297          (do-objc-array (layout (#/layoutManagers store))
298             (ns:with-ns-range (range markabsolute length)
299               (#/addTemporaryAttributes:forCharacterRange: layout dict range))))
300        (gui::perform-edit-change-notification
301         store
302         (objc:\@selector #/noteHemlockAttrChangeAtPosition:length:fontNum:)
303         markabsolute length 0))))
304   (t (if colon (prin1 arg stream) (princ arg stream)))))
306; --------------------------------------------------------------------------------
307" Example.
308; The UPWARD LEFT and RIGHT cases do what is intended, ie they move the window.
309; Oddly, they also sometimes cause text selection, I think this is because the
310; mouse-up event first provokes the movement and only then is examined to see if
311; the mouse was dragged, and the window's movement makes it look as if it was.
312; This is an unusual case and I am not going even to try to 'fix it' because just
313; maybe it is useful to be able to down-drag-up and have text selected as usual.
314; The INSPECT case also does what is intended.
315; The MORE case is horribly contorted. I couldn't get it to work any simple way.
316; What's different about it is that clicking causes extra text to be added to the
317; view. Different ways I tried resulted in complaints about 'NIL is not a line',
318; complaints about incorrect process, and a cascade of numbers followed by crash.
319; There must be a simple way to get the effect I want, but I can't find it."
320; --------------------------------------------------------------------------------
322(defun clickable-demo nil
323  (let ((left 400) (bottom 200) (more 0))
324    (multiple-value-bind (s v w)
325                         (cl-user::make-clickable-stream
326                          :font (#/fontWithName:size: ns:ns-font #@"Monaco" 24.0)
327                          :frame (ns:make-ns-rect left bottom 400 400))
328      (flet ((reposition (&optional (x w))
329               (#/setFrame:display: x (ns:make-ns-rect left bottom 400 400) t)))
330        (format s "~%       ~v,v/clickable/~%"
331                (lambda (win) (incf bottom 100) (reposition win))
332                w
333                "Upward")
334        (format s "~v/clickable/~%"
335                (lambda (string) (assert (equalp string "Left")) (decf left 100) (reposition))
336                "Left")
337        (format s "Ordinary boring text.~%")
338        (format s "       ~@/clickable/~%"
339                "Inspect me")
340        (format s "              ~v,v:/clickable/~%"
341                (lambda (win) (incf left 100) (reposition win))
342                w
343                "Right")
344        (format s "       ~v/clickable/~%"
345                (lambda (text)
346                  (hi::handle-hemlock-event v 
347                    (lambda nil
348                      (ccl::process-run-function
349                       (gensym)
350                       (lambda nil (format s "~a ~a~%" (incf more) text))))))
351                "more")))))
353#| Move me -> |#
Note: See TracBrowser for help on using the repository browser.