Changeset 7911

Timestamp:

Dec 14, 2007, 4:03:45 PM (17 years ago)

Author:

gz

Message:

make cl:ed return the view created
fixes for edit-definition breakage
fixes for clicking/recentering breakage
fixes for process-file-options breakage
swap name/nickname for hi/hemlock-internals, for less verbose output.
more massaging of callback context, error handling.

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (12 diffs)
• cocoa-grep.lisp (modified) (2 diffs)
• cocoa-listener.lisp (modified) (1 diff)
• cocoa-utils.lisp (modified) (4 diffs)
• cocoa-window.lisp (modified) (2 diffs)
• hemlock/src/echo.lisp (modified) (1 diff)
• hemlock/src/edit-defs.lisp (modified) (5 diffs)
• hemlock/src/filecoms.lisp (modified) (2 diffs)
• hemlock/src/htext1.lisp (modified) (1 diff)
• hemlock/src/lispmode.lisp (modified) (1 diff)
• hemlock/src/macros.lisp (modified) (1 diff)
• hemlock/src/package.lisp (modified) (3 diffs)
• hemlock/src/syntax.lisp (modified) (1 diff)
• hemlock/src/views.lisp (modified) (3 diffs)

branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

@@ -725 +725 @@
       )))
 
-#|
-TODO: the absolute-bla bla stuff is likely not used anymore, right?
-
-;; TODO: If selection scrolled out of view, anything that modifies the buffer should
-;; bring the selection back into view so the user can see what happened.
-;; Hemlock should ensure that.
-(defmethod ensure-selection-visible ((view hi:hemlock-view))
-  (let ((tv ???))
-  (assume-not-editing tv)
-  (#/scrollRangeToVisible: tv (#/selectedRange tv))
-  ))
-|#
-
 (objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
                                                 attributes
@@ -864 +851 @@
         (let ((hemlock-key (nsevent-to-key-event event quote-p)))
           (when hemlock-key
-            #+GZ (log-debug "Handle key ~s" hemlock-key)
             (hi::handle-hemlock-event view hemlock-key)))))))
 
@@ -908 +894 @@
 (objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
   ;; If no modifier keys are pressed, send hemlock a no-op.
+  ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect)
   (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
     (let* ((view (hemlock-view self)))
@@ -1049 +1036 @@
                                  nil)
     (assume-not-editing self)
-    (#/scrollRangeToVisible: self range)
     (when (> length 0)
       (let* ((ts (#/textStorage self)))
@@ -1789 +1775 @@
 
 (defun nsstring-for-lisp-condition (cond)
-  (%make-nsstring (double-%-in (princ-to-string cond))))
-
-(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) info)
-  (let* ((message (#/objectAtIndex: info 0))
-         (signal (#/objectAtIndex: info 1)))
-    #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
-    (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
-                         (if (logbitp 0 (random 2))
-                           #@"Not OK, but what can you do?"
-                           #@"The sky is falling. FRED never did this!")
-                         +null-ptr+
-                         +null-ptr+
-                         self
-                         self
-                         (@selector #/sheetDidEnd:returnCode:contextInfo:)
-                         (@selector #/sheetDidDismiss:returnCode:contextInfo:)
-                         signal
-                         message)))
-
-(objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame))
- (declare (ignore sheet code info))
-  #+debug
-  (#_NSLog #@"Sheet did end"))
-
-(objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void)
-    ((self hemlock-frame) sheet code info)
-  (declare (ignore sheet code))
-  #+debug (#_NSLog #@"dismiss sheet: semaphore = %lx" :unsigned-doubleword (#/unsignedLongValue info))
-  (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info))))
-  
+  (%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
+                                   "#<error printing error message>"))))
+
+(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message)
+  #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
+  (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
+                       (if (logbitp 0 (random 2))
+                         #@"Not OK, but what can you do?"
+                         #@"The sky is falling. FRED never did this!")
+                       +null-ptr+
+                       +null-ptr+
+                       self
+                       self
+                       +null-ptr+
+                       +null-ptr+
+                       +null-ptr+
+                       message))
+
 (defun report-condition-in-hemlock-frame (condition frame)
-  (let* ((semaphore (make-semaphore))
-         (message (nsstring-for-lisp-condition condition))
-         (sem-value (make-instance 'ns:ns-number
-                                   :with-unsigned-long (%ptr-to-int (ccl::semaphore.value semaphore)))))
-    #+debug
-    (#_NSLog #@"created semaphore with value %lx" :address (semaphore.value semaphore))
-    (rlet ((paramptrs (:array :id 2)))
-      (setf (paref paramptrs (:array :id) 0) message
-            (paref paramptrs (:array :id) 1) sem-value)
-      (let* ((params (make-instance 'ns:ns-array
-                                    :with-objects paramptrs
-                                    :count 2))
-             #|(*debug-io* *typeout-stream*)|#)
-        (#/performSelectorOnMainThread:withObject:waitUntilDone:
-         frame (@selector #/runErrorSheet:) params t)
-        (unless (eq *current-process* ccl::*initial-process*)
-          (wait-on-semaphore semaphore))))))
+  (assume-cocoa-thread)
+  (let ((message (nsstring-for-lisp-condition condition)))
+    (#/performSelectorOnMainThread:withObject:waitUntilDone:
+     frame
+     (@selector #/runErrorSheet:)
+     message
+     t)))
 
 (defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition)
+  (maybe-log-callback-error condition)
   (let ((pane (hi::hemlock-view-pane view)))
     (when (and pane (not (%null-ptr-p pane)))
@@ -2302 +2267 @@
          (point (hi::buffer-point buffer))
          (pointpos (hi:mark-absolute-position point)))
-    (#/beginEditing textstorage)
-    (#/edited:range:changeInLength:
-     textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
-    (nsstring-to-buffer nsstring buffer)
-    (let* ((newlen (hemlock-buffer-length buffer)))
-      (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
-      (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
-      (let* ((ts-string (#/hemlockString textstorage))
-             (display (hemlock-buffer-string-cache ts-string)))
-        (reset-buffer-cache display) 
-        (update-line-cache-for-index display 0)
-        (move-hemlock-mark-to-absolute-position point
-                                                display
-                                                (min newlen pointpos))))
-    (#/updateMirror textstorage)
-    (#/endEditing textstorage)
-    (update-hemlock-selection textstorage)
-    (setf (hi::buffer-modified buffer) nil)
-    (hi::note-modeline-change buffer)
+    (invoke-modifying-buffer-storage
+     buffer
+     #'(lambda ()
+         (#/edited:range:changeInLength:
+          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
+         (nsstring-to-buffer nsstring buffer)
+         (let* ((newlen (hemlock-buffer-length buffer)))
+           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
+           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
+           (let* ((ts-string (#/hemlockString textstorage))
+                  (display (hemlock-buffer-string-cache ts-string)))
+             (reset-buffer-cache display) 
+             (update-line-cache-for-index display 0)
+             (move-hemlock-mark-to-absolute-position point
+                                                     display
+                                                     (min newlen pointpos))))
+         (#/updateMirror textstorage)
+         (setf (hi::buffer-modified buffer) nil)
+         (hi::note-modeline-change buffer)))
     t))
 
+
+(defvar *last-document-created* nil)
 
 (objc:defmethod #/init ((self hemlock-editor-document))
@@ -2332 +2299 @@
                                 (#/displayName doc))
                                :modes '("Lisp" "Editor")))))
+    (setq *last-document-created* doc)
     doc))
 
@@ -2346 +2314 @@
     ((self hemlock-editor-document) url type (perror (:* :id)))
   (declare (ignorable type))
-  (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
-    (let* ((pathname
-            (lisp-string-from-nsstring
-             (if (#/isFileURL url)
-               (#/path url)
-               (#/absoluteString url))))
-           (buffer (or (hemlock-document-buffer self)
-                       (make-buffer-for-document self pathname)))
-           (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
-           (string
+  (with-callback-context "readFromURL"
+    (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
+      (let* ((pathname
+              (lisp-string-from-nsstring
+               (if (#/isFileURL url)
+                 (#/path url)
+                 (#/absoluteString url))))
+             (buffer (or (hemlock-document-buffer self)
+                         (make-buffer-for-document self pathname)))
+             (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
+             (string
+              (if (zerop selected-encoding)
+                (#/stringWithContentsOfURL:usedEncoding:error:
+                 ns:ns-string
+                 url
+                 pused-encoding
+                 perror)
+                +null-ptr+)))
+        
+        (if (%null-ptr-p string)
+          (progn
             (if (zerop selected-encoding)
-              (#/stringWithContentsOfURL:usedEncoding:error:
-               ns:ns-string
-               url
-               pused-encoding
-               perror)
-              +null-ptr+)))
-
-      (if (%null-ptr-p string)
-        (progn
-          (if (zerop selected-encoding)
-            (setq selected-encoding (get-default-encoding)))
-          (setq string (#/stringWithContentsOfURL:encoding:error:
-                        ns:ns-string
-                        url
-                        selected-encoding
-                        perror)))
-        (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
-      (unless (%null-ptr-p string)
-        (with-slots (encoding) self (setq encoding selected-encoding))
-        (let* ((textstorage (slot-value self 'textstorage))
-               (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
-
-          (#/beginEditing textstorage)
-
-          (nsstring-to-buffer string buffer)
-
-          (reset-buffer-cache display) 
-
-          (#/updateMirror textstorage)
-
-          (update-line-cache-for-index display 0)
-
-          (textstorage-note-insertion-at-position
-           textstorage
-           0
-           (hemlock-buffer-length buffer))
-
-          (hi::note-modeline-change buffer)
-
-          (#/endEditing textstorage))
-
-        (setf (hi::buffer-modified buffer) nil)
-        (hi::process-file-options buffer pathname)
-        t))))
+              (setq selected-encoding (get-default-encoding)))
+            (setq string (#/stringWithContentsOfURL:encoding:error:
+                          ns:ns-string
+                          url
+                          selected-encoding
+                          perror)))
+          (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
+        (unless (%null-ptr-p string)
+          (with-slots (encoding) self (setq encoding selected-encoding))
+
+          ;; ** TODO: Argh.  How about we just let hemlock insert it.
+          (let* ((textstorage (slot-value self 'textstorage))
+                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
+                 (hi::*current-buffer* buffer))
+            
+            (invoke-modifying-buffer-storage
+             buffer
+             #'(lambda ()
+                 (nsstring-to-buffer string buffer)
+                 (reset-buffer-cache display) 
+                 (#/updateMirror textstorage)
+                 (update-line-cache-for-index display 0)
+                 (textstorage-note-insertion-at-position
+                  textstorage
+                  0
+                  (hemlock-buffer-length buffer))
+                 (hi::note-modeline-change buffer)
+                 (setf (hi::buffer-modified buffer) nil))))
+          t)))))
+
 
 
@@ -2550 +2515 @@
   #+debug
   (#_NSLog #@"Make window controllers")
-  (let* ((textstorage  (slot-value self 'textstorage))
-         (window (%hemlock-frame-for-textstorage
-                  hemlock-frame
-                  textstorage
-                  *editor-columns*
-                  *editor-rows*
-                  nil
-                  (textview-background-color self)
-                  (user-input-style self)))
-         (controller (make-instance
-                      'hemlock-editor-window-controller
-                      :with-window window)))
-    (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
-    (#/addWindowController: self controller)
-    (#/release controller)
-    (ns:with-ns-point  (current-point
-                        (or *next-editor-x-pos*
-                            (x-pos-for-window window *initial-editor-x-pos*))
-                        (or *next-editor-y-pos*
-                            (y-pos-for-window window *initial-editor-y-pos*)))
-      (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
-        (setq *next-editor-x-pos* (ns:ns-point-x new-point)
-              *next-editor-y-pos* (ns:ns-point-y new-point))))))
+  (with-callback-context "makeWindowControllers"
+    (let* ((textstorage  (slot-value self 'textstorage))
+           (window (%hemlock-frame-for-textstorage
+                    hemlock-frame
+                    textstorage
+                    *editor-columns*
+                    *editor-rows*
+                    nil
+                    (textview-background-color self)
+                    (user-input-style self)))
+           (controller (make-instance
+                           'hemlock-editor-window-controller
+                         :with-window window)))
+      (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
+      (#/addWindowController: self controller)
+      (#/release controller)
+      (ns:with-ns-point  (current-point
+                          (or *next-editor-x-pos*
+                              (x-pos-for-window window *initial-editor-x-pos*))
+                          (or *next-editor-y-pos*
+                              (y-pos-for-window window *initial-editor-y-pos*)))
+        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
+          (setq *next-editor-x-pos* (ns:ns-point-x new-point)
+                *next-editor-y-pos* (ns:ns-point-y new-point))))
+      (let ((view (hemlock-view window)))
+        (hi::handle-hemlock-event view #'(lambda ()
+                                           (hi::process-file-options)))))))
 
 
@@ -2761 +2730 @@
   (make-editor-style-map))
 
-;;; This needs to run on the main thread.
+;;; This needs to run on the main thread.  Sets the cocoa selection from the
+;;; hemlock selection.
 (defmethod update-hemlock-selection ((self hemlock-text-storage))
   (assume-cocoa-thread)
-  (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString self))))
-         (hi::*current-buffer* buffer)
-         (point (hi::buffer-point buffer))
-         (pointpos (hi:mark-absolute-position point))
-         (location pointpos)
-         (len 0))
-    (when (hemlock::%buffer-region-active-p buffer)
-      (let* ((mark (hi::buffer-%mark buffer)))
-        (when mark
-          (let* ((markpos (hi:mark-absolute-position mark)))
-            (if (< markpos pointpos)
-              (setq location markpos len (- pointpos markpos))
-              (if (< pointpos markpos)
-                (setq location pointpos len (- markpos pointpos))))))))
-    #+debug
-    (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
-             :int (hi::mark-charpos point) :int pointpos)
-    (for-each-textview-using-storage
-     self
-     #'(lambda (tv)
-         (#/updateSelection:length:affinity: tv location len (if (eql location 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream))))))
-
-
-(defun hi::allocate-temporary-object-pool ()
-  (create-autorelease-pool))
-
-(defun hi::free-temporary-objects (pool)
-  (release-autorelease-pool pool))
-
+  (let ((buffer (hemlock-buffer self)))
+    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
+      #+debug
+      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
+               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
+      (for-each-textview-using-storage
+       self
+       #'(lambda (tv)
+           (#/updateSelection:length:affinity: tv
+                                               start
+                                               (- end start)
+                                               (if (eql start 0)
+                                                 #$NSSelectionAffinityUpstream
+                                                 #$NSSelectionAffinityDownstream)))))))
+
+;; This should be invoked by any command that modifies the buffer, so it can show the
+;; user what happened...  This ensures the Cocoa selection is made visible, so it
+;; assumes the Cocoa selection has already been synchronized with the hemlock one.
+(defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view))
+  (let ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
+    (#/scrollRangeToVisible: tv (#/selectedRange tv))))
 
 (defloadvar *general-pasteboard* nil)
@@ -2856 +2818 @@
 
 
-(defun cocoa-edit-definition (name info)
+;; This is called by stuff that makes a window programmatically, e.g. m-. or grep.
+;; But the Open and New menus invoke the cocoa fns below directly. So just changing
+;; things here will not change how the menus create views.  Instead,f make changes to
+;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers.
+(defun find-or-make-hemlock-view (&optional pathname)
+  (assume-cocoa-thread)
+  (rlet ((perror :id +null-ptr+))
+    (let* ((doc (if pathname
+                  (#/openDocumentWithContentsOfURL:display:error:
+                   (#/sharedDocumentController ns:ns-document-controller)
+                   (pathname-to-url pathname)
+                   #$YES
+                   perror)
+                  (let ((*last-document-created* nil))
+                    (#/newDocument: 
+                     (#/sharedDocumentController hemlock-document-controller)
+                     +null-ptr+)
+                    *last-document-created*))))
+      #+gz (log-debug "created ~s" doc)
+      (when (%null-ptr-p doc)
+        (error "Couldn't open ~s: ~a" pathname
+               (let ((error (pref perror :id)))
+                 (if (%null-ptr-p error)
+                   "unknown error encountered"
+                   (lisp-string-from-nsstring (#/localizedDescription error))))))
+      (front-view-for-buffer (hemlock-buffer doc)))))
+
+(defun cocoa-edit-single-definition (name info)
   (assume-cocoa-thread)
   (destructuring-bind (indicator . pathname) info
-    (invoke-in-file-buffer pathname #'(lambda ()
-                                        (hemlock::find-definition-in-buffer name indicator)))))
-
-(defun invoke-in-file-buffer (pathname thunk)
-  "Find file PATHNAME, and invoke thunk in it, typically to set initial selection"
-  (assume-cocoa-thread)
-  (let* ((namestring (native-translated-namestring pathname))
-         (url (#/initFileURLWithPath:
-               (#/alloc ns:ns-url)
-               (%make-nsstring namestring)))
-         (document (#/openDocumentWithContentsOfURL:display:error:
-                    (#/sharedDocumentController ns:ns-document-controller)
-                    url
-                    nil
-                    +null-ptr+)))
-    (when (%null-ptr-p document)
-      ;; TODO: get the system error message above!
-      (error "Couldn't open ~s" pathname))
-    #+GZ (log-debug "~&Opened Document ~s, buffer ~s, view ~s"
-                    document (hemlock-buffer document) (front-view-for-buffer (hemlock-buffer document)))
-    (when (= (#/count (#/windowControllers document)) 0)
-      (#/makeWindowControllers document))
-    (let* ((buffer (hemlock-buffer document))
-           (hi::*current-buffer* buffer))
-      (funcall thunk))
-    (update-hemlock-selection (slot-value document 'textstorage))
-    (#/showWindows document)))
+    (let ((view (find-or-make-hemlock-view pathname)))
+      (hi::handle-hemlock-event view
+                                #'(lambda ()
+                                    (hemlock::find-definition-in-buffer name indicator))))))
 
 (defun hemlock-ext:edit-single-definition (name info)
-  (execute-in-cocoa-thread #'(lambda () (cocoa-edit-definition name info))))
+  (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info))))
 
 (defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
@@ -2934 +2900 @@
    t))
 
-(defmethod hemlock-edit-from-filename (file)
-  (assume-cocoa-thread)
-  (check-type file (or string pathname))
-  (let* ((document-controller (#/sharedDocumentController hemlock-document-controller)))
-    (let* ((url (pathname-to-url file))
-           ;; The default implementation of this method checks to see if the document is
-           ;; already open according to documentForURL:, and if it is not open determines
-           ;; the type of the document, invokes makeDocumentWithContentsOfURL:ofType:error:
-           ;; to instantiate it, then invokes addDocument: to record its opening, and sends
-           ;; the document makeWindowControllers and showWindows messages.  If the document
-           ;; is already open, it is just sent a showWindows message.
-           ;; If not successful, the method returns nil after setting outError to point to
-           ;; an NSError object that encapsulates the reason why the document could not be opened.
-           (doc (#/openDocumentWithContentsOfURL:display:error:
-                 document-controller
-                 url
-                 #$YES
-                 +null-ptr+)))
-      (when (%null-ptr-p doc)
-        ;; TODO: should pass in a place to put error and show here.
-        (error "Failed to open ~s" file)))))
-  
 ;;; Enable CL:ED
 (defun cocoa-edit (&optional arg)
-  (let* ((document-controller (#/sharedDocumentController hemlock-document-controller)))
-    (cond ((null arg)
-           (#/performSelectorOnMainThread:withObject:waitUntilDone:
-            document-controller
-            (@selector #/newDocument:)
-            +null-ptr+
-            t))
-          ((or (typep arg 'string)
-               (typep arg 'pathname))
-           #+no (unless (probe-file arg)
-                  (ccl::touch arg))
-           (execute-in-cocoa-thread #'(lambda () (hemlock-edit-from-filename arg))))
-          ((ccl::valid-function-name-p arg)
-           (hemlock::edit-definition arg))
-          (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p)))))
-    t))
+  (cond ((or (null arg)
+             (typep arg 'string)
+             (typep arg 'pathname))
+         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
+        ((ccl::valid-function-name-p arg)
+         (hemlock::edit-definition arg)
+         arg)
+        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
 
 (setq ccl::*resident-editor-hook* 'cocoa-edit)

branches/event-ide/ccl/cocoa-ide/cocoa-grep.lisp

@@ -9 +9 @@
 (defun cocoa-edit-grep-line (file line-num)
   (assume-cocoa-thread)
-  (invoke-in-file-buffer file #'(lambda () 
-                                  (edit-grep-line-in-buffer line-num))))
+  (let ((view (find-or-make-hemlock-view file)))
+    (hi::handle-hemlock-event view #'(lambda ()
+                                       (edit-grep-line-in-buffer line-num)))))
 
 (defun edit-grep-line-in-buffer (line-num)
@@ -31 +32 @@
   (multiple-value-bind (file line-num) (parse-grep-line line)
     (when file
-      (execute-in-cocoa-thread #'(lambda ()
-                                   (cocoa-edit-grep-line file line-num))))))
+      (execute-in-gui #'(lambda ()
+                          (cocoa-edit-grep-line file line-num))))))
 
 (defun grep-comment-line-p (line)

branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp

@@ -203 +203 @@
             (setq nextra n)
             (let ((view (hemlock-view self)))
-              (queue-for-cocoa-thread #'(lambda () (append-output view string))))
+              (queue-for-gui #'(lambda () (append-output view string))))
             (#/readInBackgroundAndNotify fh)))))))
              

branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp

@@ -119 +119 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
+
+(defvar *log-callback-errors* :backtrace)
+
+(defun maybe-log-callback-error (condition)
+  (when *log-callback-errors*
+    ;; Put these in separate ignore-errors, so at least some of it can get thru
+    (let ((emsg (ignore-errors (princ-to-string condition))))
+      (ignore-errors (clear-output *debug-io*))
+      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
+      (when (eq *log-callback-errors* :backtrace)
+        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
+          (when err
+            (ignore-errors (format *debug-io* "~&Error printing call history - "))
+            (ignore-errors (print err *debug-io*))
+            (ignore-errors (princ err *debug-io*))
+            (ignore-errors (force-output *debug-io*))))))))
+
+(defmacro with-callback-context (description &body body)
+  (let ((saved-debug-io (gensym)))
+    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
+       (let ((,saved-debug-io *debug-io*))
+         (handler-bind ((error #'(lambda (condition)
+                                   (let ((*debug-io* ,saved-debug-io))
+                                     (maybe-log-callback-error condition)
+                                     (abort)))))
+           ,@body)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
 ;; utilities for executing in the cocoa event thread
 
 (defstatic *cocoa-thread-arg-id-map* (make-id-map))
 
-;; This is for debugging, it's preserved across queue-for-cocoa-thread and bound
+;; This is for debugging, it's preserved across queue-for-gui and bound
 ;; so it can be seen in backtraces.
 (defvar *invoking-event-context* "unknown")
@@ -142 +171 @@
     (handle-invoking-lisp-function thunk result-handler context invoking-process)))
 
-;; This immediately executes the thunk in the cocoa thread, via performSelectorOnMainThread.
-;; It should only be used for relatively quick and safe stuff.
-(defun execute-in-cocoa-thread (thunk &key result-handler context)
-  "Execute thunk in the main cocoa thread, waiting for it to return."
-  (if (eq *current-process* ccl::*initial-process*)
-    (handle-invoking-lisp-function thunk result-handler context)
+(defun execute-in-gui (thunk &key context)
+  "Execute thunk in the main cocoa thread, return whatever values it returns"
+  (if (typep *current-process* 'appkit-process)
+    (handle-invoking-lisp-function thunk nil context)
     (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
       (error "cocoa thread not available")
-      (let ((arg (make-instance 'ns:ns-number
-                   :with-long (register-cocoa-thread-function thunk result-handler context))))
+      (let* ((return-values nil)
+             (result-handler #'(lambda (&rest values) (setq return-values values)))
+             (arg (make-instance 'ns:ns-number
+                    :with-long (register-cocoa-thread-function thunk result-handler context))))
         (#/performSelectorOnMainThread:withObject:waitUntilDone:
          *nsapp*
          (@selector #/invokeLispFunction:)
          arg
-         t)))))
+         t)
+        (apply #'values return-values)))))
+
 
 (defconstant $lisp-function-event-subtype 17)
@@ -172 +203 @@
     (call-next-method e)))
 
-;; This queues an event rather than just doing performSelectorOnMainThread.
-(defun queue-for-cocoa-thread (thunk &key result-handler context at-start)
+;; This queues an event rather than just doing performSelectorOnMainThread, so that the
+;; action is deferred until the event thread is idle.
+(defun queue-for-gui (thunk &key result-handler context at-start)
   "Queue thunk for execution in main cocoa thread and return immediately."
-  (execute-in-cocoa-thread
+  (execute-in-gui
    #'(lambda () 
        (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
@@ -215 +247 @@
 
 (defun assume-cocoa-thread ()
-  #+debug (assert (eq *current-process* ccl::*initial-process*)))
+  (assert (eq *current-process* ccl::*initial-process*)))
 
 (defmethod assume-not-editing ((whatever t)))

branches/event-ide/ccl/cocoa-ide/cocoa-window.lisp

@@ -62 +62 @@
     (apply function args)
     (if (and *NSApp* (#/isRunning *NSApp*))
-      (queue-for-cocoa-thread #'(lambda () (apply function args))
-                              :at-start t)
+      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
       (call-next-method))))
 
@@ -76 +75 @@
                 (ccl::ns-lisp-exception-condition condition)
                 condition)))
-      (unless (member c *event-process-reported-conditions*)
+      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
         (push c *event-process-reported-conditions*)
         (catch 'need-a-catch-frame-for-backtrace

branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

@@ -42 +42 @@
   ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
   ;; want to address that.
-  (let ((message (apply #'format nil string args)))
-    (modifying-echo-buffer
-     (delete-region (buffer-region *current-buffer*))
-     (insert-string (buffer-point *current-buffer*) message)
-     (setq *last-message-time* (get-internal-real-time))
-     )))
+    (if *current-view*
+      (let ((message (apply #'format nil string args)))
+        (modifying-echo-buffer
+         (delete-region (buffer-region *current-buffer*))
+         (insert-string (buffer-point *current-buffer*) message)
+         (setq *last-message-time* (get-internal-real-time))
+         ))
+      ;; For some reason this crashes.  Perhaps something is too aggressive about
+      ;; catching conditions in events??
+      #+not-yet(apply #'warn string args)
+      #-not-yet (apply #'format t string args)))
 
 ;;; LOUD-MESSAGE -- Public.

branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp

@@ -89 +89 @@
 (defun get-def-info-and-go-to-it (string package)
   (multiple-value-bind (fun-name error)
-      (let* ((*package* package))
+      (let* ((*package* (ccl:require-type package 'package)))
         (ignore-errors (values (read-from-string string))))
     (if error
-      (editor-error)
+      (editor-error "unreadable name: ~s" string)
       (edit-definition fun-name))))
 
@@ -282 +282 @@
 
 (defun match-definition-context (mark name indicator package)
-  (declare (ignorable name indicator))
   (pre-command-parse-check mark)
   (when (valid-spot mark t)
@@ -295 +294 @@
                         (values (read-from-string (region-to-string (region start end)))))))
            (match-context-for-indicator start end package indicator)))))
-    
+
 (defun find-definition-in-buffer (name indicator)
   (let ((buffer (current-buffer)))
@@ -302 +301 @@
       (let* ((string (string name))
              (len (length string))
-             (pattern (get-search-pattern (string name) :forward))
+             (pattern (get-search-pattern string :forward))
              (mark (copy-mark (buffer-start-mark buffer)))
              (package (or
@@ -319 +318 @@
              (unless (character-offset mark len)
                (return))))
-         (beep))))))
+         (editor-error "Couldn't find definition for ~s" name))))))

branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

@@ -41 +41 @@
 ;;; This kicks in if we find no colon on the file options line.
 ;;;
-(defun process-file-options (buffer &optional
-                                    (pathname (buffer-pathname buffer)))
+(defun process-file-options (&optional (buffer (current-buffer))
+                                       (pathname (buffer-pathname buffer)))
   "Checks for file options and invokes handlers if there are any.  If no
    \"Mode\" mode option is specified, then this tries to invoke the appropriate
@@ -211 +211 @@
   "Reprocess this buffer's file options."
   (declare (ignore p))
-  (process-file-options (current-buffer)))
+  (process-file-options))
 
 (defcommand "Ensure File Options Line" (p)

branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

@@ -448 +448 @@
       (move-mark mark m))))
 
+(defun buffer-selection-range (buffer)
+  "Absolute start and end positions of the current selection"
+  (let* ((point (buffer-point buffer))
+         (pos-1 (mark-absolute-position point))
+         (mark (and (hemlock::%buffer-region-active-p buffer) (buffer-%mark buffer)))
+         (pos-2 (if mark (mark-absolute-position mark) pos-1)))
+    (values (min pos-1 pos-2) (max pos-1 pos-2))))
+
 (defun mark-column (mark)
   (let ((column 0)

branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp

@@ -1996 +1996 @@
          :action #'edit-definition)))))
 
-;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed. from anywhere,
-;; or it might be called from a sequence dialog, etc.
+;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed,
+;; from any thread, or it might be called from a sequence dialog, etc.
 (defun edit-definition (name)
-  (let* ((info (ccl::get-source-files-with-types&classes name)))
-    (when (null info)
-      (let* ((seen (list name))
-             (found ())
-             (pname (symbol-name name)))
-        (dolist (pkg (list-all-packages))
-          (let ((sym (find-symbol pname pkg)))
-            (when (and sym (not (member sym seen)))
-              (let ((new (ccl::get-source-files-with-types&classes sym)))
-                (when new
-                  (setq info (append new info))
-                  (push sym found)))
-              (push sym seen))))
-        (when found
-          ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
-          (loud-message "No definitions for ~s, using ~s instead"
-                        name (if (cdr found) found (car found))))))
-    (if info
-      (if (cdr info)
-        (hemlock-ext:open-sequence-dialog
-         :title (format nil "Definitions of ~s" name)
-         :sequence info
-         :action #'(lambda (item) (hemlock-ext:edit-single-definition name item))
-         :printer #'(lambda (item stream) (prin1 (car item) stream)))
-        (hemlock-ext:edit-single-definition name (car info)))
-      (editor-error "No known definitions for ~s" name))))
+  (flet ((get-source-alist (name)
+           (mapcar #'(lambda (item) (cons name item))
+                   (ccl::get-source-files-with-types&classes name))))
+    (let* ((info (get-source-alist name)))
+      (when (null info)
+        (let* ((seen (list name))
+               (found ())
+               (pname (symbol-name name)))
+          (dolist (pkg (list-all-packages))
+            (let ((sym (find-symbol pname pkg)))
+              (when (and sym (not (member sym seen)))
+                (let ((new (get-source-alist sym)))
+                  (when new
+                    (setq info (nconc new info))
+                    (push sym found)))
+                (push sym seen))))
+          (when found
+            ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
+            (loud-message "No definitions for ~s, using ~s instead"
+                          name (if (cdr found) found (car found))))))
+      (if info
+        (if (cdr info)
+          (hemlock-ext:open-sequence-dialog
+           :title (format nil "Definitions of ~s" name)
+           :sequence info
+           :action #'(lambda (item) (hemlock-ext:edit-single-definition (car item) (cdr item)))
+           :printer #'(lambda (item stream) (prin1 (cadr item) stream)))
+          (hemlock-ext:edit-single-definition (caar info) (cdar info)))
+        (editor-error "No known definitions for ~s" name)))))
 
 #||

branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

@@ -92 +92 @@
 ;; This is kinda Cocoa-specific, but we'll pretend it's not. It gets wrapped around
 ;; possible multiple modifications of the buffer's text, so that the OS can defer
-;; layout and redisplay until the end.
-;; Buffer can be NIL to temporarily turn off the grouping.
+;; layout and redisplay until the end.  It takes care of showing the spin cursor
+;; if the command takes too long, and it ensures that the cocoa selection matches
+;; hemlock's idea of selection.
+;; As a special hack, buffer can be NIL to temporarily turn off the grouping.
 
 (defmacro modifying-buffer-storage ((buffer) &body body)

branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

@@ -355 +355 @@
    #:scroll-mark-to-top
    #:scroll-view
+   #:ensure-selection-visible
    #:report-hemlock-error
    #:top-listener-output-stream
@@ -367 +368 @@
    ))
 
-(defpackage :hemlock-internals
+(defpackage :hi
   (:use :common-lisp :hemlock-interface)
-  (:nicknames :hi)
+  (:nicknames :hemlock-internals)
   (:shadow #:char-code-limit)
   (:import-from
@@ -508 +509 @@
    #:line-length #:line-buffer #:line-string #:line-character #:mark #:mark-kind
    #:copy-mark #:delete-mark #:move-to-position #:mark-absolute-position
-   #:move-to-absolute-position #:region #:make-empty-region
+   #:move-to-absolute-position #:buffer-selection-range #:region #:make-empty-region
    #:start-line-p #:end-line-p #:empty-line-p #:blank-line-p #:blank-before-p
    #:blank-after-p #:same-line-p #:mark< #:mark<= #:mark> #:mark>= #:mark= #:mark/=

branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp

@@ -398 +398 @@
          (ss (or (buffer-shadow-syntax buffer)
                  (setf (buffer-shadow-syntax buffer) (make-shadow-syntax)))))
+    #+GZ (setq mode (ccl:require-type mode 'mode-object))
     (loop for (desc .  vals) in (mode-object-character-attributes mode)
       do (%init-one-shadow-attribute ss desc vals))))

branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

@@ -77 +77 @@
 
 
-(defvar *log-event-errors* :backtrace)
-
 ;; This handles errors in event handling.  It assumes it's called in a normal
 ;; event handling context for some view.
@@ -84 +82 @@
   (with-standard-standard-output
     (handler-case
-        (let ((emsg (ignore-errors (princ-to-string condition))))
-          (when *log-event-errors*
-            ;; Put these in separate ignore-errors, so at least some of it can get thru
-            (ignore-errors (clear-output *debug-io*))
-            (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
-            (when (eq *log-event-errors* :backtrace)
-              (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
-                (when err
-                  (ignore-errors (format *debug-io* "~&Error printing call history - "))
-                  (ignore-errors (print err *debug-io*))
-                  (ignore-errors (princ err *debug-io*))
-                  (ignore-errors (force-output *debug-io*))))))
-          (hemlock-ext:report-hemlock-error *current-view* condition)
-          (abort-to-toplevel emsg))
+        (progn
+          (hemlock-ext:report-hemlock-error *current-view* condition)
+          (let ((emsg (ignore-errors (princ-to-string condition))))
+            (abort-to-toplevel (or emsg "Error"))))
       (error (cc)
              (ignore-errors (format t "~&Event error handling failed"))
@@ -228 +216 @@
 (defmethod handle-hemlock-event ((view hemlock-view) key)
   ;; Key can also be a function, in which case it will get executed in the view event context
-  (ccl::with-standard-abort-handling "Abort editor event handling"
-    (let* ((*current-view* view)
-           (*current-buffer* (hemlock-view-current-buffer view)))
-      (with-buffer-bindings (*current-buffer*)
-        (modifying-buffer-storage (*current-buffer*)
-          (restart-case
-              (handler-bind ((error #'lisp-error-error-handler))
-                (execute-hemlock-key view key))
-            (exit-event-handler () :report "Exit from hemlock event handler")))
-        (update-echo-area-after-command view)))))
+  #+GZ (log-debug "handle-hemlock-event ~s~:[~; (recursive)~]"
+                  key
+                  (and (eq view *current-view*)
+                       (eq (hemlock-view-current-buffer view) *current-buffer*)))
+  (if (and (eq view *current-view*)
+           (eq (hemlock-view-current-buffer view) *current-buffer*))
+    ;; KLUDGE: This might happen with stuff that normally switches buffers (e.g. meta-.)
+    ;; but happens not to.  Because of the stupid buffer binding/unbinding, it's currently
+    ;; problematic to just recurse here, so don't.
+    (progn
+      ;; TODO: should this catch exit-event or let outer one do it?  Check callers.
+      (execute-hemlock-key view key)
+      )
+    (ccl::with-standard-abort-handling "Abort editor event handling"
+      (let* ((*current-view* view)
+             (*current-buffer* (hemlock-view-current-buffer view))
+             (start-sig (buffer-signature *current-buffer*))
+             (sel (multiple-value-list (buffer-selection-range *current-buffer*))))
+        (with-buffer-bindings (*current-buffer*)
+          (modifying-buffer-storage (*current-buffer*)
+            (restart-case
+                (handler-bind ((error #'lisp-error-error-handler))
+                  (execute-hemlock-key view key))
+              (exit-event-handler () :report "Exit from hemlock event handler")))
+          (unless (and (eql start-sig (buffer-signature *current-buffer*))
+                       (multiple-value-bind (s e) (buffer-selection-range *current-buffer*)
+                         (and (eql s (car sel)) (eql e (cadr sel)))))
+            ;; Modified buffer, make sure user sees what happened
+            (hemlock-ext:ensure-selection-visible view))
+          (update-echo-area-after-command view)
+          )))))