[Openmcl-devel] How does Hemlock ...
Glen Foy
lisp at clairvaux.org
Thu Jan 26 17:19:18 PST 2012
Arthur,
This is ugly as sin, but it will respond to left-down-mouse, and it will read point after it has been set to the new click position. There may be a cleaner way to do this (surely there is), but I couldn't find it:
-- Glen
(defConstant *left-mouse-down* 65535)
(defParameter *process-down-mouse-p* nil)
;;; Redefintion of a Hemlock method in cocoa-editor.lisp
(defMethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
(ccl::with-autorelease-pool
(call-next-method))
(let ((keysym (when (typep event 'hi::key-event) (hi::key-event-keysym event))))
(when (and (numberp keysym) (= keysym *left-mouse-down*))
(setf *process-down-mouse-p* t))))
(defmethod gui::compute-temporary-attributes :around ((self gui::hemlock-textstorage-text-view))
(call-next-method)
(when *process-down-mouse-p*
(let* ((view (gui::hemlock-view self))
(hi::*current-buffer* (hi::hemlock-view-buffer view))
(point (hi::current-point))
(line (when point (hi::mark-line point)))
(pos (when point (hi::mark-charpos point))))
(format t "~%~%line: ~S" line)
(format t "~%pos: ~S" pos))
(setq *process-down-mouse-p* nil)))
On Jan 26, 2012, at 5:52 AM, Arthur Cater wrote:
> I'm looking for some help because I'm floundering in trying to program Hemlock.
> I'm using a MacBook Pro, OS 10.6.8, ClozureCL Version 1.7-r15184M (DarwinX8664)
>
> What I'm trying to do is write a format directive that gives a behaviour rather like
> hyperlinks when used on a customised Hemlock view: text should be highlighted
> (underlined and printed in red) and clicking on it should invoke the function of choice.
>
> I can get the red and underlining, and get a function invoked. But
>
> a) the invocation of the function happens on mouse-up rather than mouse-down
>
> b) the invocation does happen on mouse-downwhen in the minibuffer
>
> c) when there is just one line of text with no terminating newline, the current-point
> of the buffer seems to correspond to the previous mouse-down-up sequence
> rather than the current one
>
> d) when there are many lines of text with a terminating newline, the current-point
> stubbornly stays at buffer end.
>
>
> I have searched the Hemlock sources for various things, but I do not understand
> how a mouse-click gets to move the buffer's buffer-point. Please can somebody
> explain to me how that is done, or tell me where to look more carefully?
>
>
> Below, if anyone cares to look, is the code I have. It will create a hemlock view,
> if in the listener you type (hemlock::two) you will see a line of text with two words
> in red and underlined. Clicking on them - or elsewhere - causes informative messages
> to be written to the listener. If you close the window, make a new one with
> (hemlock::my) and (hemlock::twentytwo) you see many lines of text each with one
> word red and underlined. I must be doing something wrong :( and would gratefully
> receive advice.
>
> (I am aware of difficulties ahead, eg interaction with justification directives. I'm
> not too concerned with those at the moment because I'm trying to build a tool to
> help with examining datastructures in an application I'm building.)
>
> Thanks in advance for any help I get!
> Arthur
>
>
>
> (in-package hemlock)
>
> (defmacro do-objc-array ((itemvar arrayexpr) &body body)
> "Perform BODY with ITEMVAR bound to successive elements of the ObjC array which
> is value of ARRAYEXPR, while allowing for the possibility it is a null pointer."
> (let ((arrayvar (gensym)) (countvar (gensym)) (indexvar (gensym)))
> `(let ((,arrayvar ,arrayexpr))
> (unless (ccl::%null-ptr-p ,arrayvar)
> (let ((,countvar (#/count ,arrayvar)))
> (dotimes (,indexvar ,countvar)
> (let ((,itemvar (#/objectAtIndex: ,arrayvar ,indexvar))) , at body)))))))
>
> (defmacro write-listener (msg &rest args)
> (let ((p (gensym)))
> `(let ((,p (find 'gui::cocoa-listener-process (ccl:all-processes) :key #'type-of)))
> (if ,p
> (format (gui::cocoa-listener-process-output-stream ,p) ,msg , at args)))))
>
>
> (defmethod gui::compute-temporary-attributes ((self gui::hemlock-textstorage-text-view))
> nil)
>
> (defparameter *my* nil "Gets set to a hemlock-view")
>
> (defparameter *mystream* nil "Gets set to an output stream for the hemlock-view in *MY*")
>
> (defparameter *click-color* nil)
>
> (defparameter *underlinedict* nil "Gets set to a ns-mutable-dictionary")
>
> (defparameter *info* nil "Accumulates some debug info")
>
> (defun underlinedict nil "Makes or reuses a ns-mutable-dictionary"
> (or *underlinedict*
> (prog1
> (setf *underlinedict*
> (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
> (setf *click-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 1.0 0.2 0.2 1.0))
> (#/setObject:forKey: *underlinedict* (#/numberWithInt: ns:ns-number 1)
> #&NSUnderlineStyleAttributeName)
> (#/setObject:forKey: *underlinedict* *click-color*
> #&NSForegroundColorAttributeName))))
>
> (defcommand "Invoke Click Response" (p) "Responds to 'CLICKABLE' text by invoking its associated function."
> (declare (ignore p))
> ;(write-listener "Invoking...~%")
> (gui::execute-in-gui
> (lambda nil
> (gui::assume-cocoa-thread)
> (let* ((point (current-point))
> (line (mark-line point))
> (pos (mark-charpos point))
> (pchange (find pos (slot-value line 'hi::charprops-changes) :from-end t :test #'>= :key #'hi::charprops-change-index))
> (props (when pchange (hi::charprops-change-plist pchange))))
> (write-listener "point=~s~%line=~s~%pos=~s~%LastKeyEvent=~s~%" point line pos (last-key-event-typed))
> (when (and props (<= pos (+ (getf props :length) (hi::charprops-change-index pchange))))
> (write-listener "props are ~s, fn is ~s, arg is ~s~%"
> props (getf props :clickfunction) (getf props :argument)))))))
>
> (defun my ()
> (gui::execute-in-gui ; Makes the view
> #'(lambda nil
> (setf hemlock::*my* (gui::find-or-make-hemlock-view nil))
> (let ((buffer (hemlock-view-buffer hemlock::*my*)))
> (underlinedict)
> (bind-key "Invoke Click Response" #k"LeftDown" :buffer buffer)
> (setf *mystream* (hi:make-hemlock-output-stream (buffer-start-mark buffer) :none)) ))))
>
> (my)
>
> (defun open-hemlock-output-stream-p (stream)
> (and (typep stream 'hemlock::hemlock-output-stream)
> (slot-value stream 'hi::mark)
> t))
>
> ; --------------------------------------------------------------------------------
> ; Redefine methods given in ccl:cocoa-ide;hemlock;src;streams.lisp
> ; to ensure that hemlock buffer modification is done in the proper thread
> ; --------------------------------------------------------------------------------
>
> (defmethod hi::stream-write-char ((stream hi::hemlock-output-stream) char)
> (gui::execute-in-gui
> (lambda nil
> (gui::assume-cocoa-thread)
> (funcall (hi::old-lisp-stream-out stream) stream char))))
>
> (defmethod hi::stream-write-string ((stream hi::hemlock-output-stream) string
> &optional
> (start 0)
> (end (length string)))
> (gui::execute-in-gui
> (lambda nil
> (gui::assume-cocoa-thread)
> (funcall (hi::old-lisp-stream-sout stream) stream string start end))))
>
> ; --------------------------------------------------------------------------------
> ; The ~V/CLICKABLE/ format directive
> ; Consumes one or two arguments from the format args list
> ; The principal argument is something to be output to the stream.
> ; By default it is printed as if by PRINC (~A), but the colon modifier causes it
> ; to be printed as if by PRIN1 (~S).
> ; The prefix argument (corresponding to V) should be a function of one argument
> ; or a symbol naming one.
> ; - If the stream is a hemlock-output-stream that has not been closed, then the
> ; text produced for the principal argument will be mouse-sensitive. Clicking on
> ; it will cause the function to be invoked with the argument that was printed.
> ; - On other streams, the prefix argument will be consumed but ignored.
> ; - If the V prefix is omitted, then no function will be invoked by clicking.
> ; --------------------------------------------------------------------------------
>
> (defun clickable (stream arg colon atsign &optional prefix)
> (declare (ignorable atsign))
> (cond
> ((open-hemlock-output-stream-p stream)
> (let* ((mark (hi:copy-mark (slot-value stream 'hi::mark) :temporary))
> (markabsolute (hi::mark-absolute-position mark))
> (line (slot-value mark 'hi::line))
> (charprops (when prefix `(:font-underline :single :font-color ,*click-color*
> :clickfunction ,prefix :argument ,arg)))
> (start (when charprops (slot-value mark 'hi::charpos)))
> end)
> (if colon (prin1 arg stream) (princ arg stream))
> (when charprops
> (let* ((length (- (hi::mark-absolute-position (slot-value stream 'hi::mark)) markabsolute))
> (doc (hi::buffer-document (line-buffer line)))
> (store (when doc (slot-value doc 'gui::textstorage))))
> (setf end (slot-value (slot-value stream 'hi::mark) 'hi::charpos))
> (setf *info* `(:start ,start :end ,end))
> (hi::set-line-charprops line (list* :length length charprops) :start start :end end)
> (when doc
> (do-objc-array (layout (#/layoutManagers store))
> (ns:with-ns-range (range markabsolute length)
> (#/addTemporaryAttributes:forCharacterRange: layout (underlinedict) range))))
> (gui::perform-edit-change-notification
> store
> (objc:\@selector #/noteHemlockAttrChangeAtPosition:length:)
> markabsolute length 0)
> (setf *info* `(:changes ,(hi::line-charprops-changes line) ,@*info*))))))
> (t (if colon (prin1 arg stream) (princ arg stream)))))
>
> (defun twentytwo nil
> (dotimes (k 22)
> (format *mystream*
> "Try ~v/hemlock::clickable/ out.~%" :that (format nil "~5,'xD" k))))
>
> (defun two nil
> (format *mystream*
> "Try ~v/hemlock::clickable/ or ~v/hemlock::clickable/ now."
> :first :one :second :two))
>
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel
More information about the Openmcl-devel
mailing list