[Openmcl-devel] How does Hemlock ...

[Arthur Cater]

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))