[Openmcl-devel] How does Hemlock ...

Glen Foy lisp at clairvaux.org
Fri Jan 27 01:19:18 UTC 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