Changeset 7911


Ignore:
Timestamp:
Dec 15, 2007, 12:03:45 AM (13 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:
14 edited

Legend:

Unmodified
Added
Removed
  • branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

    r7898 r7911  
    725725      )))
    726726
    727 #|
    728 TODO: the absolute-bla bla stuff is likely not used anymore, right?
    729 
    730 ;; TODO: If selection scrolled out of view, anything that modifies the buffer should
    731 ;; bring the selection back into view so the user can see what happened.
    732 ;; Hemlock should ensure that.
    733 (defmethod ensure-selection-visible ((view hi:hemlock-view))
    734   (let ((tv ???))
    735   (assume-not-editing tv)
    736   (#/scrollRangeToVisible: tv (#/selectedRange tv))
    737   ))
    738 |#
    739 
    740727(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
    741728                                                attributes
     
    864851        (let ((hemlock-key (nsevent-to-key-event event quote-p)))
    865852          (when hemlock-key
    866             #+GZ (log-debug "Handle key ~s" hemlock-key)
    867853            (hi::handle-hemlock-event view hemlock-key)))))))
    868854
     
    908894(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
    909895  ;; If no modifier keys are pressed, send hemlock a no-op.
     896  ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect)
    910897  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
    911898    (let* ((view (hemlock-view self)))
     
    10491036                                 nil)
    10501037    (assume-not-editing self)
    1051     (#/scrollRangeToVisible: self range)
    10521038    (when (> length 0)
    10531039      (let* ((ts (#/textStorage self)))
     
    17891775
    17901776(defun nsstring-for-lisp-condition (cond)
    1791   (%make-nsstring (double-%-in (princ-to-string cond))))
    1792 
    1793 (objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) info)
    1794   (let* ((message (#/objectAtIndex: info 0))
    1795          (signal (#/objectAtIndex: info 1)))
    1796     #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
    1797     (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
    1798                          (if (logbitp 0 (random 2))
    1799                            #@"Not OK, but what can you do?"
    1800                            #@"The sky is falling. FRED never did this!")
    1801                          +null-ptr+
    1802                          +null-ptr+
    1803                          self
    1804                          self
    1805                          (@selector #/sheetDidEnd:returnCode:contextInfo:)
    1806                          (@selector #/sheetDidDismiss:returnCode:contextInfo:)
    1807                          signal
    1808                          message)))
    1809 
    1810 (objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame))
    1811  (declare (ignore sheet code info))
    1812   #+debug
    1813   (#_NSLog #@"Sheet did end"))
    1814 
    1815 (objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void)
    1816     ((self hemlock-frame) sheet code info)
    1817   (declare (ignore sheet code))
    1818   #+debug (#_NSLog #@"dismiss sheet: semaphore = %lx" :unsigned-doubleword (#/unsignedLongValue info))
    1819   (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info))))
    1820  
     1777  (%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
     1778                                   "#<error printing error message>"))))
     1779
     1780(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message)
     1781  #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
     1782  (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
     1783                       (if (logbitp 0 (random 2))
     1784                         #@"Not OK, but what can you do?"
     1785                         #@"The sky is falling. FRED never did this!")
     1786                       +null-ptr+
     1787                       +null-ptr+
     1788                       self
     1789                       self
     1790                       +null-ptr+
     1791                       +null-ptr+
     1792                       +null-ptr+
     1793                       message))
     1794
    18211795(defun report-condition-in-hemlock-frame (condition frame)
    1822   (let* ((semaphore (make-semaphore))
    1823          (message (nsstring-for-lisp-condition condition))
    1824          (sem-value (make-instance 'ns:ns-number
    1825                                    :with-unsigned-long (%ptr-to-int (ccl::semaphore.value semaphore)))))
    1826     #+debug
    1827     (#_NSLog #@"created semaphore with value %lx" :address (semaphore.value semaphore))
    1828     (rlet ((paramptrs (:array :id 2)))
    1829       (setf (paref paramptrs (:array :id) 0) message
    1830             (paref paramptrs (:array :id) 1) sem-value)
    1831       (let* ((params (make-instance 'ns:ns-array
    1832                                     :with-objects paramptrs
    1833                                     :count 2))
    1834              #|(*debug-io* *typeout-stream*)|#)
    1835         (#/performSelectorOnMainThread:withObject:waitUntilDone:
    1836          frame (@selector #/runErrorSheet:) params t)
    1837         (unless (eq *current-process* ccl::*initial-process*)
    1838           (wait-on-semaphore semaphore))))))
     1796  (assume-cocoa-thread)
     1797  (let ((message (nsstring-for-lisp-condition condition)))
     1798    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1799     frame
     1800     (@selector #/runErrorSheet:)
     1801     message
     1802     t)))
    18391803
    18401804(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition)
     1805  (maybe-log-callback-error condition)
    18411806  (let ((pane (hi::hemlock-view-pane view)))
    18421807    (when (and pane (not (%null-ptr-p pane)))
     
    23022267         (point (hi::buffer-point buffer))
    23032268         (pointpos (hi:mark-absolute-position point)))
    2304     (#/beginEditing textstorage)
    2305     (#/edited:range:changeInLength:
    2306      textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
    2307     (nsstring-to-buffer nsstring buffer)
    2308     (let* ((newlen (hemlock-buffer-length buffer)))
    2309       (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
    2310       (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
    2311       (let* ((ts-string (#/hemlockString textstorage))
    2312              (display (hemlock-buffer-string-cache ts-string)))
    2313         (reset-buffer-cache display)
    2314         (update-line-cache-for-index display 0)
    2315         (move-hemlock-mark-to-absolute-position point
    2316                                                 display
    2317                                                 (min newlen pointpos))))
    2318     (#/updateMirror textstorage)
    2319     (#/endEditing textstorage)
    2320     (update-hemlock-selection textstorage)
    2321     (setf (hi::buffer-modified buffer) nil)
    2322     (hi::note-modeline-change buffer)
     2269    (invoke-modifying-buffer-storage
     2270     buffer
     2271     #'(lambda ()
     2272         (#/edited:range:changeInLength:
     2273          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
     2274         (nsstring-to-buffer nsstring buffer)
     2275         (let* ((newlen (hemlock-buffer-length buffer)))
     2276           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
     2277           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
     2278           (let* ((ts-string (#/hemlockString textstorage))
     2279                  (display (hemlock-buffer-string-cache ts-string)))
     2280             (reset-buffer-cache display)
     2281             (update-line-cache-for-index display 0)
     2282             (move-hemlock-mark-to-absolute-position point
     2283                                                     display
     2284                                                     (min newlen pointpos))))
     2285         (#/updateMirror textstorage)
     2286         (setf (hi::buffer-modified buffer) nil)
     2287         (hi::note-modeline-change buffer)))
    23232288    t))
    23242289
     2290
     2291(defvar *last-document-created* nil)
    23252292
    23262293(objc:defmethod #/init ((self hemlock-editor-document))
     
    23322299                                (#/displayName doc))
    23332300                               :modes '("Lisp" "Editor")))))
     2301    (setq *last-document-created* doc)
    23342302    doc))
    23352303
     
    23462314    ((self hemlock-editor-document) url type (perror (:* :id)))
    23472315  (declare (ignorable type))
    2348   (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
    2349     (let* ((pathname
    2350             (lisp-string-from-nsstring
    2351              (if (#/isFileURL url)
    2352                (#/path url)
    2353                (#/absoluteString url))))
    2354            (buffer (or (hemlock-document-buffer self)
    2355                        (make-buffer-for-document self pathname)))
    2356            (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
    2357            (string
     2316  (with-callback-context "readFromURL"
     2317    (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
     2318      (let* ((pathname
     2319              (lisp-string-from-nsstring
     2320               (if (#/isFileURL url)
     2321                 (#/path url)
     2322                 (#/absoluteString url))))
     2323             (buffer (or (hemlock-document-buffer self)
     2324                         (make-buffer-for-document self pathname)))
     2325             (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
     2326             (string
     2327              (if (zerop selected-encoding)
     2328                (#/stringWithContentsOfURL:usedEncoding:error:
     2329                 ns:ns-string
     2330                 url
     2331                 pused-encoding
     2332                 perror)
     2333                +null-ptr+)))
     2334       
     2335        (if (%null-ptr-p string)
     2336          (progn
    23582337            (if (zerop selected-encoding)
    2359               (#/stringWithContentsOfURL:usedEncoding:error:
    2360                ns:ns-string
    2361                url
    2362                pused-encoding
    2363                perror)
    2364               +null-ptr+)))
    2365 
    2366       (if (%null-ptr-p string)
    2367         (progn
    2368           (if (zerop selected-encoding)
    2369             (setq selected-encoding (get-default-encoding)))
    2370           (setq string (#/stringWithContentsOfURL:encoding:error:
    2371                         ns:ns-string
    2372                         url
    2373                         selected-encoding
    2374                         perror)))
    2375         (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
    2376       (unless (%null-ptr-p string)
    2377         (with-slots (encoding) self (setq encoding selected-encoding))
    2378         (let* ((textstorage (slot-value self 'textstorage))
    2379                (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
    2380 
    2381           (#/beginEditing textstorage)
    2382 
    2383           (nsstring-to-buffer string buffer)
    2384 
    2385           (reset-buffer-cache display)
    2386 
    2387           (#/updateMirror textstorage)
    2388 
    2389           (update-line-cache-for-index display 0)
    2390 
    2391           (textstorage-note-insertion-at-position
    2392            textstorage
    2393            0
    2394            (hemlock-buffer-length buffer))
    2395 
    2396           (hi::note-modeline-change buffer)
    2397 
    2398           (#/endEditing textstorage))
    2399 
    2400         (setf (hi::buffer-modified buffer) nil)
    2401         (hi::process-file-options buffer pathname)
    2402         t))))
     2338              (setq selected-encoding (get-default-encoding)))
     2339            (setq string (#/stringWithContentsOfURL:encoding:error:
     2340                          ns:ns-string
     2341                          url
     2342                          selected-encoding
     2343                          perror)))
     2344          (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
     2345        (unless (%null-ptr-p string)
     2346          (with-slots (encoding) self (setq encoding selected-encoding))
     2347
     2348          ;; ** TODO: Argh.  How about we just let hemlock insert it.
     2349          (let* ((textstorage (slot-value self 'textstorage))
     2350                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
     2351                 (hi::*current-buffer* buffer))
     2352           
     2353            (invoke-modifying-buffer-storage
     2354             buffer
     2355             #'(lambda ()
     2356                 (nsstring-to-buffer string buffer)
     2357                 (reset-buffer-cache display)
     2358                 (#/updateMirror textstorage)
     2359                 (update-line-cache-for-index display 0)
     2360                 (textstorage-note-insertion-at-position
     2361                  textstorage
     2362                  0
     2363                  (hemlock-buffer-length buffer))
     2364                 (hi::note-modeline-change buffer)
     2365                 (setf (hi::buffer-modified buffer) nil))))
     2366          t)))))
     2367
    24032368
    24042369
     
    25502515  #+debug
    25512516  (#_NSLog #@"Make window controllers")
    2552   (let* ((textstorage  (slot-value self 'textstorage))
    2553          (window (%hemlock-frame-for-textstorage
    2554                   hemlock-frame
    2555                   textstorage
    2556                   *editor-columns*
    2557                   *editor-rows*
    2558                   nil
    2559                   (textview-background-color self)
    2560                   (user-input-style self)))
    2561          (controller (make-instance
    2562                       'hemlock-editor-window-controller
    2563                       :with-window window)))
    2564     (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
    2565     (#/addWindowController: self controller)
    2566     (#/release controller)
    2567     (ns:with-ns-point  (current-point
    2568                         (or *next-editor-x-pos*
    2569                             (x-pos-for-window window *initial-editor-x-pos*))
    2570                         (or *next-editor-y-pos*
    2571                             (y-pos-for-window window *initial-editor-y-pos*)))
    2572       (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
    2573         (setq *next-editor-x-pos* (ns:ns-point-x new-point)
    2574               *next-editor-y-pos* (ns:ns-point-y new-point))))))
     2517  (with-callback-context "makeWindowControllers"
     2518    (let* ((textstorage  (slot-value self 'textstorage))
     2519           (window (%hemlock-frame-for-textstorage
     2520                    hemlock-frame
     2521                    textstorage
     2522                    *editor-columns*
     2523                    *editor-rows*
     2524                    nil
     2525                    (textview-background-color self)
     2526                    (user-input-style self)))
     2527           (controller (make-instance
     2528                           'hemlock-editor-window-controller
     2529                         :with-window window)))
     2530      (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
     2531      (#/addWindowController: self controller)
     2532      (#/release controller)
     2533      (ns:with-ns-point  (current-point
     2534                          (or *next-editor-x-pos*
     2535                              (x-pos-for-window window *initial-editor-x-pos*))
     2536                          (or *next-editor-y-pos*
     2537                              (y-pos-for-window window *initial-editor-y-pos*)))
     2538        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
     2539          (setq *next-editor-x-pos* (ns:ns-point-x new-point)
     2540                *next-editor-y-pos* (ns:ns-point-y new-point))))
     2541      (let ((view (hemlock-view window)))
     2542        (hi::handle-hemlock-event view #'(lambda ()
     2543                                           (hi::process-file-options)))))))
    25752544
    25762545
     
    27612730  (make-editor-style-map))
    27622731
    2763 ;;; This needs to run on the main thread.
     2732;;; This needs to run on the main thread.  Sets the cocoa selection from the
     2733;;; hemlock selection.
    27642734(defmethod update-hemlock-selection ((self hemlock-text-storage))
    27652735  (assume-cocoa-thread)
    2766   (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString self))))
    2767          (hi::*current-buffer* buffer)
    2768          (point (hi::buffer-point buffer))
    2769          (pointpos (hi:mark-absolute-position point))
    2770          (location pointpos)
    2771          (len 0))
    2772     (when (hemlock::%buffer-region-active-p buffer)
    2773       (let* ((mark (hi::buffer-%mark buffer)))
    2774         (when mark
    2775           (let* ((markpos (hi:mark-absolute-position mark)))
    2776             (if (< markpos pointpos)
    2777               (setq location markpos len (- pointpos markpos))
    2778               (if (< pointpos markpos)
    2779                 (setq location pointpos len (- markpos pointpos))))))))
    2780     #+debug
    2781     (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
    2782              :int (hi::mark-charpos point) :int pointpos)
    2783     (for-each-textview-using-storage
    2784      self
    2785      #'(lambda (tv)
    2786          (#/updateSelection:length:affinity: tv location len (if (eql location 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream))))))
    2787 
    2788 
    2789 (defun hi::allocate-temporary-object-pool ()
    2790   (create-autorelease-pool))
    2791 
    2792 (defun hi::free-temporary-objects (pool)
    2793   (release-autorelease-pool pool))
    2794 
     2736  (let ((buffer (hemlock-buffer self)))
     2737    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
     2738      #+debug
     2739      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
     2740               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
     2741      (for-each-textview-using-storage
     2742       self
     2743       #'(lambda (tv)
     2744           (#/updateSelection:length:affinity: tv
     2745                                               start
     2746                                               (- end start)
     2747                                               (if (eql start 0)
     2748                                                 #$NSSelectionAffinityUpstream
     2749                                                 #$NSSelectionAffinityDownstream)))))))
     2750
     2751;; This should be invoked by any command that modifies the buffer, so it can show the
     2752;; user what happened...  This ensures the Cocoa selection is made visible, so it
     2753;; assumes the Cocoa selection has already been synchronized with the hemlock one.
     2754(defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view))
     2755  (let ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
     2756    (#/scrollRangeToVisible: tv (#/selectedRange tv))))
    27952757
    27962758(defloadvar *general-pasteboard* nil)
     
    28562818
    28572819
    2858 (defun cocoa-edit-definition (name info)
     2820;; This is called by stuff that makes a window programmatically, e.g. m-. or grep.
     2821;; But the Open and New menus invoke the cocoa fns below directly. So just changing
     2822;; things here will not change how the menus create views.  Instead,f make changes to
     2823;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers.
     2824(defun find-or-make-hemlock-view (&optional pathname)
     2825  (assume-cocoa-thread)
     2826  (rlet ((perror :id +null-ptr+))
     2827    (let* ((doc (if pathname
     2828                  (#/openDocumentWithContentsOfURL:display:error:
     2829                   (#/sharedDocumentController ns:ns-document-controller)
     2830                   (pathname-to-url pathname)
     2831                   #$YES
     2832                   perror)
     2833                  (let ((*last-document-created* nil))
     2834                    (#/newDocument:
     2835                     (#/sharedDocumentController hemlock-document-controller)
     2836                     +null-ptr+)
     2837                    *last-document-created*))))
     2838      #+gz (log-debug "created ~s" doc)
     2839      (when (%null-ptr-p doc)
     2840        (error "Couldn't open ~s: ~a" pathname
     2841               (let ((error (pref perror :id)))
     2842                 (if (%null-ptr-p error)
     2843                   "unknown error encountered"
     2844                   (lisp-string-from-nsstring (#/localizedDescription error))))))
     2845      (front-view-for-buffer (hemlock-buffer doc)))))
     2846
     2847(defun cocoa-edit-single-definition (name info)
    28592848  (assume-cocoa-thread)
    28602849  (destructuring-bind (indicator . pathname) info
    2861     (invoke-in-file-buffer pathname #'(lambda ()
    2862                                         (hemlock::find-definition-in-buffer name indicator)))))
    2863 
    2864 (defun invoke-in-file-buffer (pathname thunk)
    2865   "Find file PATHNAME, and invoke thunk in it, typically to set initial selection"
    2866   (assume-cocoa-thread)
    2867   (let* ((namestring (native-translated-namestring pathname))
    2868          (url (#/initFileURLWithPath:
    2869                (#/alloc ns:ns-url)
    2870                (%make-nsstring namestring)))
    2871          (document (#/openDocumentWithContentsOfURL:display:error:
    2872                     (#/sharedDocumentController ns:ns-document-controller)
    2873                     url
    2874                     nil
    2875                     +null-ptr+)))
    2876     (when (%null-ptr-p document)
    2877       ;; TODO: get the system error message above!
    2878       (error "Couldn't open ~s" pathname))
    2879     #+GZ (log-debug "~&Opened Document ~s, buffer ~s, view ~s"
    2880                     document (hemlock-buffer document) (front-view-for-buffer (hemlock-buffer document)))
    2881     (when (= (#/count (#/windowControllers document)) 0)
    2882       (#/makeWindowControllers document))
    2883     (let* ((buffer (hemlock-buffer document))
    2884            (hi::*current-buffer* buffer))
    2885       (funcall thunk))
    2886     (update-hemlock-selection (slot-value document 'textstorage))
    2887     (#/showWindows document)))
     2850    (let ((view (find-or-make-hemlock-view pathname)))
     2851      (hi::handle-hemlock-event view
     2852                                #'(lambda ()
     2853                                    (hemlock::find-definition-in-buffer name indicator))))))
    28882854
    28892855(defun hemlock-ext:edit-single-definition (name info)
    2890   (execute-in-cocoa-thread #'(lambda () (cocoa-edit-definition name info))))
     2856  (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info))))
    28912857
    28922858(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
     
    29342900   t))
    29352901
    2936 (defmethod hemlock-edit-from-filename (file)
    2937   (assume-cocoa-thread)
    2938   (check-type file (or string pathname))
    2939   (let* ((document-controller (#/sharedDocumentController hemlock-document-controller)))
    2940     (let* ((url (pathname-to-url file))
    2941            ;; The default implementation of this method checks to see if the document is
    2942            ;; already open according to documentForURL:, and if it is not open determines
    2943            ;; the type of the document, invokes makeDocumentWithContentsOfURL:ofType:error:
    2944            ;; to instantiate it, then invokes addDocument: to record its opening, and sends
    2945            ;; the document makeWindowControllers and showWindows messages.  If the document
    2946            ;; is already open, it is just sent a showWindows message.
    2947            ;; If not successful, the method returns nil after setting outError to point to
    2948            ;; an NSError object that encapsulates the reason why the document could not be opened.
    2949            (doc (#/openDocumentWithContentsOfURL:display:error:
    2950                  document-controller
    2951                  url
    2952                  #$YES
    2953                  +null-ptr+)))
    2954       (when (%null-ptr-p doc)
    2955         ;; TODO: should pass in a place to put error and show here.
    2956         (error "Failed to open ~s" file)))))
    2957  
    29582902;;; Enable CL:ED
    29592903(defun cocoa-edit (&optional arg)
    2960   (let* ((document-controller (#/sharedDocumentController hemlock-document-controller)))
    2961     (cond ((null arg)
    2962            (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2963             document-controller
    2964             (@selector #/newDocument:)
    2965             +null-ptr+
    2966             t))
    2967           ((or (typep arg 'string)
    2968                (typep arg 'pathname))
    2969            #+no (unless (probe-file arg)
    2970                   (ccl::touch arg))
    2971            (execute-in-cocoa-thread #'(lambda () (hemlock-edit-from-filename arg))))
    2972           ((ccl::valid-function-name-p arg)
    2973            (hemlock::edit-definition arg))
    2974           (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p)))))
    2975     t))
     2904  (cond ((or (null arg)
     2905             (typep arg 'string)
     2906             (typep arg 'pathname))
     2907         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
     2908        ((ccl::valid-function-name-p arg)
     2909         (hemlock::edit-definition arg)
     2910         arg)
     2911        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
    29762912
    29772913(setq ccl::*resident-editor-hook* 'cocoa-edit)
  • branches/event-ide/ccl/cocoa-ide/cocoa-grep.lisp

    r7898 r7911  
    99(defun cocoa-edit-grep-line (file line-num)
    1010  (assume-cocoa-thread)
    11   (invoke-in-file-buffer file #'(lambda ()
    12                                   (edit-grep-line-in-buffer line-num))))
     11  (let ((view (find-or-make-hemlock-view file)))
     12    (hi::handle-hemlock-event view #'(lambda ()
     13                                       (edit-grep-line-in-buffer line-num)))))
    1314
    1415(defun edit-grep-line-in-buffer (line-num)
     
    3132  (multiple-value-bind (file line-num) (parse-grep-line line)
    3233    (when file
    33       (execute-in-cocoa-thread #'(lambda ()
    34                                    (cocoa-edit-grep-line file line-num))))))
     34      (execute-in-gui #'(lambda ()
     35                          (cocoa-edit-grep-line file line-num))))))
    3536
    3637(defun grep-comment-line-p (line)
  • branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp

    r7898 r7911  
    203203            (setq nextra n)
    204204            (let ((view (hemlock-view self)))
    205               (queue-for-cocoa-thread #'(lambda () (append-output view string))))
     205              (queue-for-gui #'(lambda () (append-output view string))))
    206206            (#/readInBackgroundAndNotify fh)))))))
    207207             
  • branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp

    r7844 r7911  
    119119;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    120120;;
     121
     122(defvar *log-callback-errors* :backtrace)
     123
     124(defun maybe-log-callback-error (condition)
     125  (when *log-callback-errors*
     126    ;; Put these in separate ignore-errors, so at least some of it can get thru
     127    (let ((emsg (ignore-errors (princ-to-string condition))))
     128      (ignore-errors (clear-output *debug-io*))
     129      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
     130      (when (eq *log-callback-errors* :backtrace)
     131        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
     132          (when err
     133            (ignore-errors (format *debug-io* "~&Error printing call history - "))
     134            (ignore-errors (print err *debug-io*))
     135            (ignore-errors (princ err *debug-io*))
     136            (ignore-errors (force-output *debug-io*))))))))
     137
     138(defmacro with-callback-context (description &body body)
     139  (let ((saved-debug-io (gensym)))
     140    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
     141       (let ((,saved-debug-io *debug-io*))
     142         (handler-bind ((error #'(lambda (condition)
     143                                   (let ((*debug-io* ,saved-debug-io))
     144                                     (maybe-log-callback-error condition)
     145                                     (abort)))))
     146           ,@body)))))
     147
     148;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     149;;
    121150;; utilities for executing in the cocoa event thread
    122151
    123152(defstatic *cocoa-thread-arg-id-map* (make-id-map))
    124153
    125 ;; This is for debugging, it's preserved across queue-for-cocoa-thread and bound
     154;; This is for debugging, it's preserved across queue-for-gui and bound
    126155;; so it can be seen in backtraces.
    127156(defvar *invoking-event-context* "unknown")
     
    142171    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
    143172
    144 ;; This immediately executes the thunk in the cocoa thread, via performSelectorOnMainThread.
    145 ;; It should only be used for relatively quick and safe stuff.
    146 (defun execute-in-cocoa-thread (thunk &key result-handler context)
    147   "Execute thunk in the main cocoa thread, waiting for it to return."
    148   (if (eq *current-process* ccl::*initial-process*)
    149     (handle-invoking-lisp-function thunk result-handler context)
     173(defun execute-in-gui (thunk &key context)
     174  "Execute thunk in the main cocoa thread, return whatever values it returns"
     175  (if (typep *current-process* 'appkit-process)
     176    (handle-invoking-lisp-function thunk nil context)
    150177    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
    151178      (error "cocoa thread not available")
    152       (let ((arg (make-instance 'ns:ns-number
    153                    :with-long (register-cocoa-thread-function thunk result-handler context))))
     179      (let* ((return-values nil)
     180             (result-handler #'(lambda (&rest values) (setq return-values values)))
     181             (arg (make-instance 'ns:ns-number
     182                    :with-long (register-cocoa-thread-function thunk result-handler context))))
    154183        (#/performSelectorOnMainThread:withObject:waitUntilDone:
    155184         *nsapp*
    156185         (@selector #/invokeLispFunction:)
    157186         arg
    158          t)))))
     187         t)
     188        (apply #'values return-values)))))
     189
    159190
    160191(defconstant $lisp-function-event-subtype 17)
     
    172203    (call-next-method e)))
    173204
    174 ;; This queues an event rather than just doing performSelectorOnMainThread.
    175 (defun queue-for-cocoa-thread (thunk &key result-handler context at-start)
     205;; This queues an event rather than just doing performSelectorOnMainThread, so that the
     206;; action is deferred until the event thread is idle.
     207(defun queue-for-gui (thunk &key result-handler context at-start)
    176208  "Queue thunk for execution in main cocoa thread and return immediately."
    177   (execute-in-cocoa-thread
     209  (execute-in-gui
    178210   #'(lambda ()
    179211       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
     
    215247
    216248(defun assume-cocoa-thread ()
    217   #+debug (assert (eq *current-process* ccl::*initial-process*)))
     249  (assert (eq *current-process* ccl::*initial-process*)))
    218250
    219251(defmethod assume-not-editing ((whatever t)))
  • branches/event-ide/ccl/cocoa-ide/cocoa-window.lisp

    r7833 r7911  
    6262    (apply function args)
    6363    (if (and *NSApp* (#/isRunning *NSApp*))
    64       (queue-for-cocoa-thread #'(lambda () (apply function args))
    65                               :at-start t)
     64      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
    6665      (call-next-method))))
    6766
     
    7675                (ccl::ns-lisp-exception-condition condition)
    7776                condition)))
    78       (unless (member c *event-process-reported-conditions*)
     77      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
    7978        (push c *event-process-reported-conditions*)
    8079        (catch 'need-a-catch-frame-for-backtrace
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7898 r7911  
    4242  ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
    4343  ;; want to address that.
    44   (let ((message (apply #'format nil string args)))
    45     (modifying-echo-buffer
    46      (delete-region (buffer-region *current-buffer*))
    47      (insert-string (buffer-point *current-buffer*) message)
    48      (setq *last-message-time* (get-internal-real-time))
    49      )))
     44    (if *current-view*
     45      (let ((message (apply #'format nil string args)))
     46        (modifying-echo-buffer
     47         (delete-region (buffer-region *current-buffer*))
     48         (insert-string (buffer-point *current-buffer*) message)
     49         (setq *last-message-time* (get-internal-real-time))
     50         ))
     51      ;; For some reason this crashes.  Perhaps something is too aggressive about
     52      ;; catching conditions in events??
     53      #+not-yet(apply #'warn string args)
     54      #-not-yet (apply #'format t string args)))
    5055
    5156;;; LOUD-MESSAGE -- Public.
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp

    r7898 r7911  
    8989(defun get-def-info-and-go-to-it (string package)
    9090  (multiple-value-bind (fun-name error)
    91       (let* ((*package* package))
     91      (let* ((*package* (ccl:require-type package 'package)))
    9292        (ignore-errors (values (read-from-string string))))
    9393    (if error
    94       (editor-error)
     94      (editor-error "unreadable name: ~s" string)
    9595      (edit-definition fun-name))))
    9696
     
    282282
    283283(defun match-definition-context (mark name indicator package)
    284   (declare (ignorable name indicator))
    285284  (pre-command-parse-check mark)
    286285  (when (valid-spot mark t)
     
    295294                        (values (read-from-string (region-to-string (region start end)))))))
    296295           (match-context-for-indicator start end package indicator)))))
    297    
     296
    298297(defun find-definition-in-buffer (name indicator)
    299298  (let ((buffer (current-buffer)))
     
    302301      (let* ((string (string name))
    303302             (len (length string))
    304              (pattern (get-search-pattern (string name) :forward))
     303             (pattern (get-search-pattern string :forward))
    305304             (mark (copy-mark (buffer-start-mark buffer)))
    306305             (package (or
     
    319318             (unless (character-offset mark len)
    320319               (return))))
    321          (beep))))))
     320         (editor-error "Couldn't find definition for ~s" name))))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

    r7844 r7911  
    4141;;; This kicks in if we find no colon on the file options line.
    4242;;;
    43 (defun process-file-options (buffer &optional
    44                                     (pathname (buffer-pathname buffer)))
     43(defun process-file-options (&optional (buffer (current-buffer))
     44                                       (pathname (buffer-pathname buffer)))
    4545  "Checks for file options and invokes handlers if there are any.  If no
    4646   \"Mode\" mode option is specified, then this tries to invoke the appropriate
     
    211211  "Reprocess this buffer's file options."
    212212  (declare (ignore p))
    213   (process-file-options (current-buffer)))
     213  (process-file-options))
    214214
    215215(defcommand "Ensure File Options Line" (p)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

    r7898 r7911  
    448448      (move-mark mark m))))
    449449
     450(defun buffer-selection-range (buffer)
     451  "Absolute start and end positions of the current selection"
     452  (let* ((point (buffer-point buffer))
     453         (pos-1 (mark-absolute-position point))
     454         (mark (and (hemlock::%buffer-region-active-p buffer) (buffer-%mark buffer)))
     455         (pos-2 (if mark (mark-absolute-position mark) pos-1)))
     456    (values (min pos-1 pos-2) (max pos-1 pos-2))))
     457
    450458(defun mark-column (mark)
    451459  (let ((column 0)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp

    r7899 r7911  
    19961996         :action #'edit-definition)))))
    19971997
    1998 ;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed. from anywhere,
    1999 ;; or it might be called from a sequence dialog, etc.
     1998;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed,
     1999;; from any thread, or it might be called from a sequence dialog, etc.
    20002000(defun edit-definition (name)
    2001   (let* ((info (ccl::get-source-files-with-types&classes name)))
    2002     (when (null info)
    2003       (let* ((seen (list name))
    2004              (found ())
    2005              (pname (symbol-name name)))
    2006         (dolist (pkg (list-all-packages))
    2007           (let ((sym (find-symbol pname pkg)))
    2008             (when (and sym (not (member sym seen)))
    2009               (let ((new (ccl::get-source-files-with-types&classes sym)))
    2010                 (when new
    2011                   (setq info (append new info))
    2012                   (push sym found)))
    2013               (push sym seen))))
    2014         (when found
    2015           ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
    2016           (loud-message "No definitions for ~s, using ~s instead"
    2017                         name (if (cdr found) found (car found))))))
    2018     (if info
    2019       (if (cdr info)
    2020         (hemlock-ext:open-sequence-dialog
    2021          :title (format nil "Definitions of ~s" name)
    2022          :sequence info
    2023          :action #'(lambda (item) (hemlock-ext:edit-single-definition name item))
    2024          :printer #'(lambda (item stream) (prin1 (car item) stream)))
    2025         (hemlock-ext:edit-single-definition name (car info)))
    2026       (editor-error "No known definitions for ~s" name))))
     2001  (flet ((get-source-alist (name)
     2002           (mapcar #'(lambda (item) (cons name item))
     2003                   (ccl::get-source-files-with-types&classes name))))
     2004    (let* ((info (get-source-alist name)))
     2005      (when (null info)
     2006        (let* ((seen (list name))
     2007               (found ())
     2008               (pname (symbol-name name)))
     2009          (dolist (pkg (list-all-packages))
     2010            (let ((sym (find-symbol pname pkg)))
     2011              (when (and sym (not (member sym seen)))
     2012                (let ((new (get-source-alist sym)))
     2013                  (when new
     2014                    (setq info (nconc new info))
     2015                    (push sym found)))
     2016                (push sym seen))))
     2017          (when found
     2018            ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
     2019            (loud-message "No definitions for ~s, using ~s instead"
     2020                          name (if (cdr found) found (car found))))))
     2021      (if info
     2022        (if (cdr info)
     2023          (hemlock-ext:open-sequence-dialog
     2024           :title (format nil "Definitions of ~s" name)
     2025           :sequence info
     2026           :action #'(lambda (item) (hemlock-ext:edit-single-definition (car item) (cdr item)))
     2027           :printer #'(lambda (item stream) (prin1 (cadr item) stream)))
     2028          (hemlock-ext:edit-single-definition (caar info) (cdar info)))
     2029        (editor-error "No known definitions for ~s" name)))))
    20272030
    20282031#||
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

    r7844 r7911  
    9292;; This is kinda Cocoa-specific, but we'll pretend it's not. It gets wrapped around
    9393;; possible multiple modifications of the buffer's text, so that the OS can defer
    94 ;; layout and redisplay until the end.
    95 ;; Buffer can be NIL to temporarily turn off the grouping.
     94;; layout and redisplay until the end.  It takes care of showing the spin cursor
     95;; if the command takes too long, and it ensures that the cocoa selection matches
     96;; hemlock's idea of selection.
     97;; As a special hack, buffer can be NIL to temporarily turn off the grouping.
    9698
    9799(defmacro modifying-buffer-storage ((buffer) &body body)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

    r7898 r7911  
    355355   #:scroll-mark-to-top
    356356   #:scroll-view
     357   #:ensure-selection-visible
    357358   #:report-hemlock-error
    358359   #:top-listener-output-stream
     
    367368   ))
    368369
    369 (defpackage :hemlock-internals
     370(defpackage :hi
    370371  (:use :common-lisp :hemlock-interface)
    371   (:nicknames :hi)
     372  (:nicknames :hemlock-internals)
    372373  (:shadow #:char-code-limit)
    373374  (:import-from
     
    508509   #:line-length #:line-buffer #:line-string #:line-character #:mark #:mark-kind
    509510   #:copy-mark #:delete-mark #:move-to-position #:mark-absolute-position
    510    #:move-to-absolute-position #:region #:make-empty-region
     511   #:move-to-absolute-position #:buffer-selection-range #:region #:make-empty-region
    511512   #:start-line-p #:end-line-p #:empty-line-p #:blank-line-p #:blank-before-p
    512513   #:blank-after-p #:same-line-p #:mark< #:mark<= #:mark> #:mark>= #:mark= #:mark/=
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp

    r7833 r7911  
    398398         (ss (or (buffer-shadow-syntax buffer)
    399399                 (setf (buffer-shadow-syntax buffer) (make-shadow-syntax)))))
     400    #+GZ (setq mode (ccl:require-type mode 'mode-object))
    400401    (loop for (desc .  vals) in (mode-object-character-attributes mode)
    401402      do (%init-one-shadow-attribute ss desc vals))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

    r7862 r7911  
    7777
    7878
    79 (defvar *log-event-errors* :backtrace)
    80 
    8179;; This handles errors in event handling.  It assumes it's called in a normal
    8280;; event handling context for some view.
     
    8482  (with-standard-standard-output
    8583    (handler-case
    86         (let ((emsg (ignore-errors (princ-to-string condition))))
    87           (when *log-event-errors*
    88             ;; Put these in separate ignore-errors, so at least some of it can get thru
    89             (ignore-errors (clear-output *debug-io*))
    90             (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
    91             (when (eq *log-event-errors* :backtrace)
    92               (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
    93                 (when err
    94                   (ignore-errors (format *debug-io* "~&Error printing call history - "))
    95                   (ignore-errors (print err *debug-io*))
    96                   (ignore-errors (princ err *debug-io*))
    97                   (ignore-errors (force-output *debug-io*))))))
    98           (hemlock-ext:report-hemlock-error *current-view* condition)
    99           (abort-to-toplevel emsg))
     84        (progn
     85          (hemlock-ext:report-hemlock-error *current-view* condition)
     86          (let ((emsg (ignore-errors (princ-to-string condition))))
     87            (abort-to-toplevel (or emsg "Error"))))
    10088      (error (cc)
    10189             (ignore-errors (format t "~&Event error handling failed"))
     
    228216(defmethod handle-hemlock-event ((view hemlock-view) key)
    229217  ;; Key can also be a function, in which case it will get executed in the view event context
    230   (ccl::with-standard-abort-handling "Abort editor event handling"
    231     (let* ((*current-view* view)
    232            (*current-buffer* (hemlock-view-current-buffer view)))
    233       (with-buffer-bindings (*current-buffer*)
    234         (modifying-buffer-storage (*current-buffer*)
    235           (restart-case
    236               (handler-bind ((error #'lisp-error-error-handler))
    237                 (execute-hemlock-key view key))
    238             (exit-event-handler () :report "Exit from hemlock event handler")))
    239         (update-echo-area-after-command view)))))
     218  #+GZ (log-debug "handle-hemlock-event ~s~:[~; (recursive)~]"
     219                  key
     220                  (and (eq view *current-view*)
     221                       (eq (hemlock-view-current-buffer view) *current-buffer*)))
     222  (if (and (eq view *current-view*)
     223           (eq (hemlock-view-current-buffer view) *current-buffer*))
     224    ;; KLUDGE: This might happen with stuff that normally switches buffers (e.g. meta-.)
     225    ;; but happens not to.  Because of the stupid buffer binding/unbinding, it's currently
     226    ;; problematic to just recurse here, so don't.
     227    (progn
     228      ;; TODO: should this catch exit-event or let outer one do it?  Check callers.
     229      (execute-hemlock-key view key)
     230      )
     231    (ccl::with-standard-abort-handling "Abort editor event handling"
     232      (let* ((*current-view* view)
     233             (*current-buffer* (hemlock-view-current-buffer view))
     234             (start-sig (buffer-signature *current-buffer*))
     235             (sel (multiple-value-list (buffer-selection-range *current-buffer*))))
     236        (with-buffer-bindings (*current-buffer*)
     237          (modifying-buffer-storage (*current-buffer*)
     238            (restart-case
     239                (handler-bind ((error #'lisp-error-error-handler))
     240                  (execute-hemlock-key view key))
     241              (exit-event-handler () :report "Exit from hemlock event handler")))
     242          (unless (and (eql start-sig (buffer-signature *current-buffer*))
     243                       (multiple-value-bind (s e) (buffer-selection-range *current-buffer*)
     244                         (and (eql s (car sel)) (eql e (cadr sel)))))
     245            ;; Modified buffer, make sure user sees what happened
     246            (hemlock-ext:ensure-selection-visible view))
     247          (update-echo-area-after-command view)
     248          )))))
Note: See TracChangeset for help on using the changeset viewer.