[Openmcl-devel] Fwd: How does Hemlock ...

Sat Jan 28 08:57:50 PST 2012

Begin forwarded message:

> From: Arthur Cater <arthur.cater at ucd.ie>
> Date: 28 January 2012 12:23:56 GMT
> To: Glen Foy <lisp at clairvaux.org>
> Subject: Re: [Openmcl-devel] How does Hemlock ...
> 
> Thank you Glen for that help. I've adapted it for my use by using the
> buffer-plist instead of parameter *process-down-mouse-p* and instead of
> rebinding the #k"LeftDown". It works now for the single-line case but not
> for the multi-line case. I think my claim that the invocation happens after
> mouse-up was wrong, the result of my code switching attention to another
> buffer - the listener's - in order to be seen to do something.
> 
> So my problems a,b,c seem fixed, but not d.
> 
> I still don't understand how the buffer-point gets to be set in the first place,
> nor why what I was doing previously caused it to be set only belatedly.
> And I like to understand.
> 
> Arthur
> 
> 
> On 27 Jan 2012, at 01:19, Glen Foy wrote:
> 
>> 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
>> 
> 

-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20120128/7ac74a09/attachment.htm>