source: trunk/source/cocoa-ide/cocoa-editor.lisp

Last change on this file was 16686, checked in by rme, 4 years ago

Update copyright/license headers in cocoa-ide directory.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 157.4 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;; Copyright 2007 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(in-package "GUI")
18
19;;; In the double-float case, this is probably way too small.
20;;; Traditionally, it's (approximately) the point at which
21;;; a single-float stops being able to accurately represent
22;;; integral values.
23(eval-when (:compile-toplevel :load-toplevel :execute)
24  (defconstant large-number-for-text (cgfloat 1.0f7)))
25
26;;; Compensates for the fact that Cocotron uses Mac font metrics and assumes
27;;; the default Macintosh DPI (72) vs. that of Windows (96).
28(defun font-size-kludge (size)
29  #-cocotron size
30  #+cocotron (* size (/ 96.0 72.0)))
31   
32(def-cocoa-default *editor-font* :font #'(lambda ()
33                                           (#/fontWithName:size:
34                                            ns:ns-font
35                                            #+darwin-target
36                                            #@"Monaco"
37                                            #-darwin-target
38                                            #@"Courier New"
39                                            (font-size-kludge 10.0)))
40                   "Default font for editor windows")
41
42(def-cocoa-default *editor-rows* :int 24 "Initial height of editor windows, in characters")
43(def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters")
44
45(def-cocoa-default *editor-background-color* :color '(1.0 1.0 1.0 1.0) "Editor background color")
46(def-cocoa-default *wrap-lines-to-window* :bool nil
47                   "Soft wrap lines to window width")
48
49(def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available")
50
51(def-cocoa-default *option-is-meta* :bool t "Use option key as meta?")
52
53(defgeneric hemlock-view (ns-object))
54
55(defmethod hemlock-view ((unknown t))
56  nil)
57
58(defgeneric hemlock-buffer (ns-object))
59
60(defmethod hemlock-buffer ((unknown t))
61  (let ((view (hemlock-view unknown)))
62    (when view (hi::hemlock-view-buffer view))))
63
64(defmacro with-hemlock-context ((ns-object) &body body)
65  (let ((ns-obj (gensym)) (view (gensym)) (buffer (gensym)) (pane (gensym)))
66    `(let* ((,ns-obj ,ns-object)
67            (,view (hemlock-view ,ns-obj))
68            (,buffer (hemlock-buffer ,ns-obj))
69            (,pane (cond ((eq ,buffer (hi::hemlock-view-buffer ,view)) :text)
70                         ((eq ,buffer (hi::hemlock-echo-area-buffer ,view)) :echo)
71                         (t (error "invalid buffer ~s for view ~s" ,view ,buffer)))))
72       (hemlock:with-display-context (,view ,pane)
73         ,@body))))
74
75
76(defmacro nsstring-encoding-to-nsinteger (n)
77  (ccl::target-word-size-case
78   (32 `(ccl::u32->s32 ,n))
79   (64 n)))
80
81(defmacro nsinteger-to-nsstring-encoding (n)
82  (ccl::target-word-size-case
83   (32 `(ccl::s32->u32 ,n))
84   (64 n)))
85
86;;; Create a paragraph style, mostly so that we can set tabs reasonably.
87(defun rme-create-paragraph-style (font line-break-mode)
88  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
89         (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
90    (#/setLineBreakMode: p
91                         (ecase line-break-mode
92                           (:char #$NSLineBreakByCharWrapping)
93                           (:word #$NSLineBreakByWordWrapping)
94                           ;; This doesn't seem to work too well.
95                           ((nil) #$NSLineBreakByClipping)))
96    ;; Clear existing tab stops.
97    (#/setTabStops: p (#/array ns:ns-array))
98    ;; And set the "default tab interval".
99    (#/setDefaultTabInterval: p (* *tab-width* charwidth))
100    p))
101
102(defun rme-create-text-attributes (&key (font *editor-font*)
103                                   (line-break-mode *default-line-break-mode*)
104                                   (color nil)
105                                   (obliqueness nil)
106                                   (stroke-width nil))
107  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
108    (#/setObject:forKey: dict (rme-create-paragraph-style font line-break-mode)
109                         #&NSParagraphStyleAttributeName)
110    (#/setObject:forKey: dict font #&NSFontAttributeName)
111    (when color
112      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
113    (when stroke-width
114      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
115                           #&NSStrokeWidthAttributeName))
116    (when obliqueness
117      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
118                           #&NSObliquenessAttributeName))
119    dict))
120
121(defun rme-make-editor-style-map ()
122  (let* ((font *editor-font*)
123         (fm (#/sharedFontManager ns:ns-font-manager))
124         (bold-font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask))
125         (oblique-font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask))
126         (bold-oblique-font (#/convertFont:toHaveTrait:
127                             fm font (logior #$NSItalicFontMask
128                                             #$NSBoldFontMask)))
129         (colors (vector (#/blackColor ns:ns-color)))
130         (fonts (vector font bold-font oblique-font bold-oblique-font))
131         (styles (make-instance 'ns:ns-mutable-array)))
132    (dotimes (c (length colors))
133      (dotimes (i 4)
134        (let* ((mask (logand i 3))
135               (f (svref fonts mask)))
136          (#/addObject: styles 
137                        (rme-create-text-attributes :font f
138                                                    :color (svref colors c)
139                                                    :obliqueness
140                                                    (if (logbitp 1 i)
141                                                      (when (eql f font)
142                                                        0.15f0))
143                                                    :stroke-width
144                                                    (if (logbitp 0 i)
145                                                      (when (eql f font)
146                                                        -10.0f0)))))))
147    styles))
148
149(defun make-editor-style-map ()
150  (rme-make-editor-style-map))
151
152#+nil
153(defun make-editor-style-map ()
154  (let* ((font-name *default-font-name*)
155         (font-size *default-font-size*)
156         (font (default-font :name font-name :size font-size))
157         (bold-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold))))
158                      (unless (eql f font) f)))
159         (oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:italic))))
160                      (unless (eql f font) f)))
161         (bold-oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold :italic))))
162                      (unless (eql f font) f)))
163         (color-class (find-class 'ns:ns-color))
164         (colors (vector (#/blackColor color-class)))
165         (styles (make-instance 'ns:ns-mutable-array
166                                :with-capacity (the fixnum (* 4 (length colors)))))
167         (bold-stroke-width -10.0f0)
168         (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font)))
169         (real-fonts (vector font bold-font oblique-font bold-oblique-font))
170         (s 0))
171    (declare (dynamic-extent fonts real-fonts colors))
172    (dotimes (c (length colors))
173      (dotimes (i 4)
174        (let* ((mask (logand i 3)))
175          (#/addObject: styles
176                        (create-text-attributes :font (svref fonts mask)
177                                                :color (svref colors c)
178                                                :obliqueness
179                                                (if (logbitp 1 i)
180                                                  (unless (svref real-fonts mask)
181                                                    0.15f0))
182                                                :stroke-width
183                                                (if (logbitp 0 i)
184                                                  (unless (svref real-fonts mask)
185                                                    bold-stroke-width)))))
186        (incf s)))
187    (#/retain styles)))
188
189(defun make-hemlock-buffer (&rest args)
190  (let* ((buf (apply #'hi::make-buffer args)))
191    (assert buf)
192    buf))
193
194;;; Define some key event modifiers and keysym codes
195
196(hi:define-modifier-bit #$NSShiftKeyMask "Shift")
197(hi:define-modifier-bit #$NSControlKeyMask "Control")
198(hi:define-modifier-bit #$NSAlternateKeyMask "Meta")
199(hi:define-modifier-bit #$NSAlphaShiftKeyMask "Lock")
200
201(hi:define-keysym-code :F1 #$NSF1FunctionKey)
202(hi:define-keysym-code :F2 #$NSF2FunctionKey)
203(hi:define-keysym-code :F3 #$NSF3FunctionKey)
204(hi:define-keysym-code :F4 #$NSF4FunctionKey)
205(hi:define-keysym-code :F5 #$NSF5FunctionKey)
206(hi:define-keysym-code :F6 #$NSF6FunctionKey)
207(hi:define-keysym-code :F7 #$NSF7FunctionKey)
208(hi:define-keysym-code :F8 #$NSF8FunctionKey)
209(hi:define-keysym-code :F9 #$NSF9FunctionKey)
210(hi:define-keysym-code :F10 #$NSF10FunctionKey)
211(hi:define-keysym-code :F11 #$NSF11FunctionKey)
212(hi:define-keysym-code :F12 #$NSF12FunctionKey)
213(hi:define-keysym-code :F13 #$NSF13FunctionKey)
214(hi:define-keysym-code :F14 #$NSF14FunctionKey)
215(hi:define-keysym-code :F15 #$NSF15FunctionKey)
216(hi:define-keysym-code :F16 #$NSF16FunctionKey)
217(hi:define-keysym-code :F17 #$NSF17FunctionKey)
218(hi:define-keysym-code :F18 #$NSF18FunctionKey)
219(hi:define-keysym-code :F19 #$NSF19FunctionKey)
220(hi:define-keysym-code :F20 #$NSF20FunctionKey)
221(hi:define-keysym-code :F21 #$NSF21FunctionKey)
222(hi:define-keysym-code :F22 #$NSF22FunctionKey)
223(hi:define-keysym-code :F23 #$NSF23FunctionKey)
224(hi:define-keysym-code :F24 #$NSF24FunctionKey)
225(hi:define-keysym-code :F25 #$NSF25FunctionKey)
226(hi:define-keysym-code :F26 #$NSF26FunctionKey)
227(hi:define-keysym-code :F27 #$NSF27FunctionKey)
228(hi:define-keysym-code :F28 #$NSF28FunctionKey)
229(hi:define-keysym-code :F29 #$NSF29FunctionKey)
230(hi:define-keysym-code :F30 #$NSF30FunctionKey)
231(hi:define-keysym-code :F31 #$NSF31FunctionKey)
232(hi:define-keysym-code :F32 #$NSF32FunctionKey)
233(hi:define-keysym-code :F33 #$NSF33FunctionKey)
234(hi:define-keysym-code :F34 #$NSF34FunctionKey)
235(hi:define-keysym-code :F35 #$NSF35FunctionKey)
236
237;;; Upper right key bank.
238;;;
239(hi:define-keysym-code :Printscreen #$NSPrintScreenFunctionKey)
240;; Couldn't type scroll lock.
241(hi:define-keysym-code :Pause #$NSPauseFunctionKey)
242
243;;; Middle right key bank.
244;;;
245(hi:define-keysym-code :Insert #$NSInsertFunctionKey)
246(hi:define-keysym-code :Del #$NSDeleteFunctionKey)
247(hi:define-keysym-code :Home #$NSHomeFunctionKey)
248(hi:define-keysym-code :Pageup #$NSPageUpFunctionKey)
249(hi:define-keysym-code :End #$NSEndFunctionKey)
250(hi:define-keysym-code :Pagedown #$NSPageDownFunctionKey)
251
252;;; Arrows.
253;;;
254(hi:define-keysym-code :Leftarrow #$NSLeftArrowFunctionKey)
255(hi:define-keysym-code :Uparrow #$NSUpArrowFunctionKey)
256(hi:define-keysym-code :Downarrow #$NSDownArrowFunctionKey)
257(hi:define-keysym-code :Rightarrow #$NSRightArrowFunctionKey)
258
259;;;
260
261;(hi:define-keysym-code :linefeed 65290)
262
263
264
265
266
267;;; We want to display a Hemlock buffer in a "pane" (an on-screen
268;;; view) which in turn is presented in a "frame" (a Cocoa window).  A
269;;; 1:1 mapping between frames and panes seems to fit best into
270;;; Cocoa's document architecture, but we should try to keep the
271;;; concepts separate (in case we come up with better UI paradigms.)
272;;; Each pane has a modeline (which describes attributes of the
273;;; underlying document); each frame has an echo area (which serves
274;;; to display some commands' output and to provide multi-character
275;;; input.)
276
277
278;;; I'd pretty much concluded that it wouldn't be possible to get the
279;;; Cocoa text system (whose storage model is based on NSString
280;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with
281;;; Hemlock, and (since the whole point of using Hemlock was to be
282;;; able to treat an editor buffer as a rich lisp data structure) it
283;;; seemed like it'd be necessary to toss the higher-level Cocoa text
284;;; system and implement our own scrolling, redisplay, selection
285;;; ... code.
286;;;
287;;; Mikel Evins pointed out that NSString and friends were
288;;; abstract classes and that there was therefore no reason (in
289;;; theory) not to implement a thin wrapper around a Hemlock buffer
290;;; that made it act like an NSString.  As long as the text system can
291;;; ask a few questions about the NSString (its length and the
292;;; character and attributes at a given location), it's willing to
293;;; display the string in a scrolling, mouse-selectable NSTextView;
294;;; as long as Hemlock tells the text system when and how the contents
295;;; of the abstract string changes, Cocoa will handle the redisplay
296;;; details.
297;;;
298
299
300;;; Hemlock-buffer-string objects:
301
302(defclass hemlock-buffer-string (ns:ns-string)
303    ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache))
304  (:metaclass ns:+ns-object))
305
306
307 
308(defmethod hemlock-buffer ((self hemlock-buffer-string))
309  (let ((cache (hemlock-buffer-string-cache self)))
310    (when cache
311      (hemlock-buffer cache))))
312
313;;; Cocoa wants to treat the buffer as a linear array of characters;
314;;; Hemlock wants to treat it as a doubly-linked list of lines, so
315;;; we often have to map between an absolute position in the buffer
316;;; and a relative position on a line.  We can certainly do that
317;;; by counting the characters in preceding lines every time that we're
318;;; asked, but we're often asked to map a sequence of nearby positions
319;;; and wind up repeating a lot of work.  Caching the results of that
320;;; work seems to speed things up a bit in many cases; this data structure
321;;; is used in that process.  (It's also the only way to get to the
322;;; actual underlying Lisp buffer from inside the network of text-system
323;;; objects.)
324
325(defstruct buffer-cache 
326  buffer                                ; the hemlock buffer
327  buflen                                ; length of buffer, if known
328  workline                              ; cache for character-at-index
329  workline-offset                       ; cached offset of workline
330  workline-length                       ; length of cached workline
331  workline-start-font-index             ; current font index at start of workline
332  )
333
334(objc:defmethod (#/dealloc :void) ((self hemlock-buffer-string))
335  (let* ((cache (hemlock-buffer-string-cache self))
336         (buffer (if cache (buffer-cache-buffer cache))))
337    (when buffer
338      (setf (buffer-cache-buffer cache) nil
339            (slot-value self 'cache) nil
340            (hi::buffer-document buffer) nil)
341      (when (eq buffer hi::*current-buffer*)
342        (setf hi::*current-buffer* nil))
343      (hi::delete-buffer buffer)))
344  (objc:remove-lisp-slots self)
345  (call-next-method))
346
347(defmethod hemlock-buffer ((self buffer-cache))
348  (buffer-cache-buffer self))
349
350;;; Initialize (or reinitialize) a buffer cache, so that it points
351;;; to the buffer's first line (which is the only line whose
352;;; absolute position will never change).  Code which modifies the
353;;; buffer generally has to call this, since any cached information
354;;; might be invalidated by the modification.
355
356(defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d)
357                                                buffer-p))
358  (when buffer-p (setf (buffer-cache-buffer d) buffer))
359  (let* ((hi::*current-buffer* buffer)
360         (workline (hi::mark-line
361                    (hi::buffer-start-mark buffer))))
362    (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer)
363          (buffer-cache-workline-offset d) 0
364          (buffer-cache-workline d) workline
365          (buffer-cache-workline-length d) (hi::line-length workline)
366          (buffer-cache-workline-start-font-index d) 0)
367    d))
368
369
370(defun adjust-buffer-cache-for-insertion (display pos n)
371  (if (buffer-cache-workline display)
372    (let* ((hi::*current-buffer* (buffer-cache-buffer display)))
373      (if (> (buffer-cache-workline-offset display) pos)
374        (incf (buffer-cache-workline-offset display) n)
375        (when (>= (+ (buffer-cache-workline-offset display)
376                     (buffer-cache-workline-length display))
377                  pos)
378          (setf (buffer-cache-workline-length display)
379                (hi::line-length (buffer-cache-workline display)))))
380      (incf (buffer-cache-buflen display) n))
381    (reset-buffer-cache display)))
382
383         
384           
385
386;;; Update the cache so that it's describing the current absolute
387;;; position.
388
389(defun update-line-cache-for-index (cache index)
390  (let* ((buffer (buffer-cache-buffer cache))
391         (hi::*current-buffer* buffer)
392         (line (or
393                (buffer-cache-workline cache)
394                (progn
395                  (reset-buffer-cache cache)
396                  (buffer-cache-workline cache))))
397         (pos (buffer-cache-workline-offset cache))
398         (len (buffer-cache-workline-length cache))
399         (moved nil))
400    (loop
401      (when (and (>= index pos)
402                   (< index (1+ (+ pos len))))
403          (let* ((idx (- index pos)))
404            (when moved
405              (setf (buffer-cache-workline cache) line
406                    (buffer-cache-workline-offset cache) pos
407                    (buffer-cache-workline-length cache) len))
408            (return (values line idx))))
409      (setq moved t)
410      (if (< index pos)
411        (setq line (hi::line-previous line)
412              len (hi::line-length line)
413              pos (1- (- pos len)))
414        (setq line (hi::line-next line)
415              pos (1+ (+ pos len))
416              len (hi::line-length line))))))
417
418;;; Ask Hemlock to count the characters in the buffer.
419(defun hemlock-buffer-length (buffer)
420  (let* ((hi::*current-buffer* buffer))
421    (hemlock::count-characters (hemlock::buffer-region buffer))))
422
423;;; Find the line containing (or immediately preceding) index, which is
424;;; assumed to be less than the buffer's length.  Return the character
425;;; in that line or the trailing #\newline, as appropriate.
426(defun hemlock-char-at-index (cache index)
427  (let* ((hi::*current-buffer* (buffer-cache-buffer cache)))
428    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
429      (let* ((len (hemlock::line-length line)))
430        (if (< idx len)
431          (hemlock::line-character line idx)
432          #\newline)))))
433
434;;; Given an absolute position, move the specified mark to the appropriate
435;;; offset on the appropriate line.
436(defun move-hemlock-mark-to-absolute-position (mark cache abspos)
437  ;; TODO: figure out if updating the cache matters, and if not, use hi:move-to-absolute-position.
438  (let* ((hi::*current-buffer* (buffer-cache-buffer cache)))
439    (hi::move-to-absolute-position mark abspos)
440    #+old
441    (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos)
442      #+debug
443      (#_NSLog #@"Moving point from current pos %d to absolute position %d"
444               :int (hi:mark-absolute-position mark)
445               :int abspos)
446      (hemlock::move-to-position mark idx line)
447      #+debug
448      (#_NSLog #@"Moved mark to %d" :int (hi:mark-absolute-position mark)))))
449
450;;; Return the length of the abstract string, i.e., the number of
451;;; characters in the buffer (including implicit newlines.)
452(objc:defmethod (#/length :<NSUI>nteger) ((self hemlock-buffer-string))
453  (let* ((cache (hemlock-buffer-string-cache self)))
454    (or (buffer-cache-buflen cache)
455        (setf (buffer-cache-buflen cache)
456              (let* ((buffer (buffer-cache-buffer cache)))
457                (hemlock-buffer-length buffer))))))
458
459
460
461;;; Return the character at the specified index (as a :unichar.)
462
463(objc:defmethod (#/characterAtIndex: :unichar)
464    ((self hemlock-buffer-string) (index :<NSUI>nteger))
465  #+debug
466  (#_NSLog #@"Character at index: %d" :<NSUI>nteger index)
467  (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index)))
468
469(objc:defmethod (#/getCharacters:range: :void)
470    ((self hemlock-buffer-string)
471     (buffer (:* :unichar))
472     (r :<NSR>ange))
473  (let* ((cache (hemlock-buffer-string-cache self))
474         (index (ns:ns-range-location r))
475         (length (ns:ns-range-length r))
476         (hi::*current-buffer* (buffer-cache-buffer cache)))
477    #+debug
478    (#_NSLog #@"get characters: %d/%d"
479             :<NSUI>nteger index
480             :<NSUI>nteger length)
481    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
482      (let* ((len (hemlock::line-length line)))
483        (do* ((i 0 (1+ i)))
484             ((= i length))
485          (cond ((< idx len)
486                 (setf (paref buffer (:* :unichar) i)
487                       (char-code (hemlock::line-character line idx)))
488                 (incf idx))
489                (t
490                 (setf (paref buffer (:* :unichar) i)
491                       (char-code #\Newline)
492                       line (hi::line-next line)
493                       len (if line (hi::line-length line) 0)
494                       idx 0))))))))
495
496
497(objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void)
498    ((self hemlock-buffer-string)
499     (startptr (:* :<NSUI>nteger))
500     (endptr (:* :<NSUI>nteger))
501     (contents-endptr (:* :<NSUI>nteger))
502     (r :<NSR>ange))
503  (let* ((cache (hemlock-buffer-string-cache self))
504         (index (pref r :<NSR>ange.location))
505         (length (pref r :<NSR>ange.length))
506         (hi::*current-buffer* (buffer-cache-buffer cache)))
507    #+debug
508    (#_NSLog #@"get line start: %d/%d"
509             :unsigned index
510             :unsigned length)
511    (update-line-cache-for-index cache index)
512    (unless (%null-ptr-p startptr)
513      ;; Index of the first character in the line which contains
514      ;; the start of the range.
515      (setf (pref startptr :<NSUI>nteger)
516            (buffer-cache-workline-offset cache)))
517    (unless (%null-ptr-p endptr)
518      ;; Index of the newline which terminates the line which
519      ;; contains the start of the range.
520      (setf (pref endptr :<NSUI>nteger)
521            (+ (buffer-cache-workline-offset cache)
522               (buffer-cache-workline-length cache))))
523    (unless (%null-ptr-p contents-endptr)
524      ;; Index of the newline which terminates the line which
525      ;; contains the start of the range.
526      (unless (zerop length)
527        (update-line-cache-for-index cache (+ index length)))
528      (setf (pref contents-endptr :<NSUI>nteger)
529            (1+ (+ (buffer-cache-workline-offset cache)
530                   (buffer-cache-workline-length cache)))))))
531
532;;; For debugging, mostly: make the printed representation of the string
533;;; reference the named Hemlock buffer.
534(objc:defmethod #/description ((self hemlock-buffer-string))
535  (let* ((cache (hemlock-buffer-string-cache self))
536         (b (buffer-cache-buffer cache)))
537    (with-cstrs ((s (format nil "~a" b)))
538      (#/stringWithFormat: ns:ns-string #@"<%s for %s>" (#_object_getClassName self) s))))
539
540
541
542;;; hemlock-text-storage objects
543(defclass hemlock-text-storage (ns:ns-text-storage)
544    ((string :foreign-type :id)
545     (hemlock-string :foreign-type :id)
546     (edit-count :foreign-type :int)
547     (mirror :foreign-type :id)
548     (styles :foreign-type :id)
549     (selection-set-by-search :foreign-type :<BOOL>))
550  (:metaclass ns:+ns-object))
551(declaim (special hemlock-text-storage))
552
553(defmethod hemlock-buffer ((self hemlock-text-storage))
554  (let ((string (slot-value self 'hemlock-string)))
555    (unless (%null-ptr-p string)
556      (hemlock-buffer string))))
557
558;;; This is only here so that calls to it can be logged for debugging.
559#+debug
560(objc:defmethod (#/lineBreakBeforeIndex:withinRange: :<NSUI>nteger)
561    ((self hemlock-text-storage)
562     (index :<NSUI>nteger)
563     (r :<NSR>ange))
564  (#_NSLog #@"Line break before index: %d within range: %@"
565           :unsigned index
566           :id (#_NSStringFromRange r))
567  (call-next-method index r))
568
569
570
571
572;;; Return true iff we're inside a "beginEditing/endEditing" pair
573(objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
574  ;; This is meaningless outside the event thread, since you can't tell what
575  ;; other edit-count changes have already been queued up for execution on
576  ;; the event thread before it gets to whatever you might queue up next.
577  (assume-cocoa-thread)
578  (> (slot-value self 'edit-count) 0))
579
580(defmethod assume-not-editing ((ts hemlock-text-storage))
581  #+debug NIL (assert (eql (slot-value ts 'edit-count) 0)))
582
583(defun textstorage-note-insertion-at-position (self pos n)
584  (ns:with-ns-range (r pos 0)
585    (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r n)
586    (setf (ns:ns-range-length r) n)
587    (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes r 0)))
588
589
590
591;;; This runs on the main thread; it synchronizes the "real" NSMutableAttributedString
592;;; with the hemlock string and informs the textstorage of the insertion.
593(objc:defmethod (#/noteHemlockInsertionAtPosition:length:extra: :void) ((self hemlock-text-storage)
594                                                                  (pos :<NSI>nteger)
595                                                                  (n :<NSI>nteger)
596                                                                  (extra :<NSI>nteger))
597  (declare (ignorable extra))
598  (assume-cocoa-thread)
599  (let* ((mirror (#/mirror self))
600         (hemlock-string (#/hemlockString self))
601         (display (hemlock-buffer-string-cache hemlock-string))
602         (buffer (buffer-cache-buffer display))
603         (hi::*current-buffer* buffer)
604         (attributes (buffer-active-font-attributes buffer))
605         (document (#/document self))
606         (undo-mgr (and document (#/undoManager document))))
607    #+debug 
608    (#_NSLog #@"insert: pos = %ld, n = %ld" :long pos :long n)
609    ;; We need to update the hemlock string mirror here so that #/substringWithRange:
610    ;; will work on the hemlock buffer string.
611    (adjust-buffer-cache-for-insertion display pos n)
612    (update-line-cache-for-index display pos)
613    (let* ((replacestring (#/substringWithRange: hemlock-string (ns:make-ns-range pos n))))
614      (ns:with-ns-range (replacerange pos 0)
615        (#/replaceCharactersInRange:withString:
616         mirror replacerange replacestring))
617      #+cocotron
618      (#/updateChangeCount: document #$NSChangeDone)
619      (when (and undo-mgr (not (#/isUndoing undo-mgr)))
620        (#/replaceCharactersAtPosition:length:withString:
621         (#/prepareWithInvocationTarget: undo-mgr self)
622         pos n #@"")))
623    (#/setAttributes:range: mirror attributes (ns:make-ns-range pos n))
624    (textstorage-note-insertion-at-position self pos n)))
625
626(objc:defmethod (#/noteHemlockDeletionAtPosition:length:extra: :void) ((self hemlock-text-storage)
627                                                                       (pos :<NSI>nteger)
628                                                                       (n :<NSI>nteger)
629                                                                       (extra :<NSI>nteger))
630  (declare (ignorable extra))
631  #+debug
632  (#_NSLog #@"delete: pos = %ld, n = %ld" :long pos :long n)
633  (ns:with-ns-range (range pos n)
634    (let* ((mirror (#/mirror self))
635           (deleted-string (#/substringWithRange: (#/string mirror) range))
636           (document (#/document self))
637           (undo-mgr (and document (#/undoManager document)))
638           (display (hemlock-buffer-string-cache (#/hemlockString self))))
639      ;; It seems to be necessary to call #/edited:range:changeInLength: before
640      ;; deleting from the mirror attributed string.  It's not clear whether this
641      ;; is also true of insertions and modifications.
642      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
643                                                   #$NSTextStorageEditedAttributes)
644                                      range (- n))
645      (#/deleteCharactersInRange: mirror range)
646      #+cocotron
647      (#/updateChangeCount: document #$NSChangeDone)     
648      (when (and undo-mgr (not (#/isUndoing undo-mgr)))
649        (#/replaceCharactersAtPosition:length:withString:
650         (#/prepareWithInvocationTarget: undo-mgr self)
651         pos 0 deleted-string))
652      (reset-buffer-cache display)
653      (update-line-cache-for-index display pos))))
654
655(objc:defmethod (#/noteHemlockModificationAtPosition:length:extra: :void) ((self hemlock-text-storage)
656                                                                           (pos :<NSI>nteger)
657                                                                           (n :<NSI>nteger)
658                                                                           (extra :<NSI>nteger))
659  (declare (ignorable extra))
660  #+debug
661  (#_NSLog #@"modify: pos = %ld, n = %ld" :long pos :long n)
662  (ns:with-ns-range (range pos n)
663    (let* ((hemlock-string (#/hemlockString self))
664           (mirror (#/mirror self))
665           (deleted-string (#/substringWithRange: (#/string mirror) range))
666           (document (#/document self))
667           (undo-mgr (and document (#/undoManager document))))
668      (#/replaceCharactersInRange:withString:
669       mirror range (#/substringWithRange: hemlock-string range))
670      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
671                                                   #$NSTextStorageEditedAttributes) range 0)
672      #+cocotron
673      (#/updateChangeCount: document #$NSChangeDone)     
674      (when (and undo-mgr (not (#/isUndoing undo-mgr)))
675        (#/replaceCharactersAtPosition:length:withString:
676         (#/prepareWithInvocationTarget: undo-mgr self)
677         pos n deleted-string)))))
678
679(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length:fontNum: :void) ((self hemlock-text-storage)
680                                                                           (pos :<NSI>nteger)
681                                                                           (n :<NSI>nteger)
682                                                                           (fontnum :<NSI>nteger))
683  (ns:with-ns-range (range pos n)
684    (#/setAttributes:range: (#/mirror self) (#/objectAtIndex: (#/styles self) fontnum) range)
685    (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0)))
686
687
688(defloadvar *buffer-change-invocation*
689    (with-autorelease-pool
690        (#/retain
691                   (#/invocationWithMethodSignature: ns:ns-invocation
692                                                     (#/instanceMethodSignatureForSelector:
693                                                      hemlock-text-storage
694                                            (@selector #/noteHemlockInsertionAtPosition:length:extra:))))))
695
696(defstatic *buffer-change-invocation-lock* (make-lock))
697
698         
699         
700(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage))
701  (assume-cocoa-thread)
702  (with-slots (edit-count) self
703    #+debug
704    (#_NSLog #@"begin-editing")
705    (incf edit-count)
706    #+debug
707    (#_NSLog #@"after beginEditing on %@ edit-count now = %d" :id self :int edit-count)
708    (call-next-method)))
709
710(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage))
711  (assume-cocoa-thread)
712  (with-slots (edit-count) self
713    #+debug
714    (#_NSLog #@"end-editing")
715    (call-next-method)
716    (assert (> edit-count 0))
717    (decf edit-count)
718    #+debug
719    (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int edit-count)))
720
721
722
723 
724
725;;; Access the string.  It'd be nice if this was a generic function;
726;;; we could have just made a reader method in the class definition.
727
728
729
730(objc:defmethod #/string ((self hemlock-text-storage))
731  (slot-value self 'string))
732
733(objc:defmethod #/mirror ((self hemlock-text-storage))
734  (slot-value self 'mirror))
735
736(objc:defmethod #/hemlockString ((self hemlock-text-storage))
737  (slot-value self 'hemlock-string))
738
739(objc:defmethod #/styles ((self hemlock-text-storage))
740  (slot-value self 'styles))
741
742(objc:defmethod #/document ((self hemlock-text-storage))
743  (or
744   (let* ((string (#/hemlockString self)))
745     (unless (%null-ptr-p string)
746       (let* ((cache (hemlock-buffer-string-cache string)))
747         (when cache
748           (let* ((buffer (buffer-cache-buffer cache)))
749             (when buffer
750               (hi::buffer-document buffer)))))))
751   +null-ptr+))
752
753
754#-cocotron
755(objc:defmethod #/initWithString: ((self hemlock-text-storage) s)
756  (setq s (%inc-ptr s 0))
757  (let* ((newself (#/init self))
758         (styles (make-editor-style-map))
759         (mirror (make-instance ns:ns-mutable-attributed-string
760                                   :with-string s
761                                   :attributes (#/objectAtIndex: styles 0))))
762    (declare (type hemlock-text-storage newself))
763    (setf (slot-value newself 'styles) styles)
764    (setf (slot-value newself 'hemlock-string) s)
765    (setf (slot-value newself 'mirror) mirror)
766    (setf (slot-value newself 'string) (#/retain (#/string mirror)))
767    newself))
768
769#+cocotron
770(objc:defmethod #/initWithString: ((self hemlock-text-storage) s)
771  (setq s (%inc-ptr s 0))
772  (let* ((styles (make-editor-style-map))
773         (mirror (make-instance ns:ns-mutable-attributed-string
774                                   :with-string s
775                                   :attributes (#/objectAtIndex: styles 0)))
776         (string (#/retain (#/string mirror)))
777         (newself (call-next-method string)))
778    (declare (type hemlock-text-storage newself))
779    (setf (slot-value newself 'styles) styles)
780    (setf (slot-value newself 'hemlock-string) s)
781    (setf (slot-value newself 'mirror) mirror)
782    (setf (slot-value newself 'string) string)
783    newself))
784
785;;; Should generally only be called after open/revert.
786(objc:defmethod (#/updateMirror :void) ((self hemlock-text-storage))
787  (with-slots (hemlock-string mirror styles) self
788    (#/replaceCharactersInRange:withString: mirror (ns:make-ns-range 0 (#/length mirror)) hemlock-string)
789    (#/setAttributes:range: mirror (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length mirror)))))
790
791;;; This is the only thing that's actually called to create a
792;;; hemlock-text-storage object.  (It also creates the underlying
793;;; hemlock-buffer-string.)
794(defun make-textstorage-for-hemlock-buffer (buffer)
795  (make-instance 'hemlock-text-storage
796                 :with-string
797                 (make-instance
798                  'hemlock-buffer-string
799                  :cache
800                  (reset-buffer-cache
801                   (make-buffer-cache)
802                   buffer))))
803
804(objc:defmethod #/attributesAtIndex:effectiveRange:
805    ((self hemlock-text-storage) (index :<NSUI>nteger) (rangeptr (* :<NSR>ange)))
806  #+debug
807  (#_NSLog #@"Attributes at index: %lu storage %@" :<NSUI>nteger index :id self)
808  (with-slots (mirror styles) self
809    (when (>= index (#/length mirror))
810      (#_NSLog #@"Bounds error - Attributes at index: %lu  edit-count: %d mirror: %@ layout: %@" :<NSUI>nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0))
811      (ccl::dbg))
812    (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr)))
813      (when (eql 0 (#/count attrs))
814        (#_NSLog #@"No attributes ?")
815        (ns:with-ns-range (r)
816          (#/attributesAtIndex:longestEffectiveRange:inRange:
817           mirror index r (ns:make-ns-range 0 (#/length mirror)))
818          (setq attrs (#/objectAtIndex: styles 0))
819          (#/setAttributes:range: mirror attrs r)))
820      attrs)))
821
822(objc:defmethod (#/replaceCharactersAtPosition:length:withString: :void)
823    ((self hemlock-text-storage) (pos <NSUI>nteger) (len <NSUI>nteger) string)
824  (let* ((document (#/document self))
825         (undo-mgr (and document (#/undoManager document))))
826    (when (and undo-mgr (not (#/isRedoing undo-mgr)))
827      (let ((replaced-string (#/substringWithRange: (#/hemlockString self) (ns:make-ns-range pos len))))
828        (#/replaceCharactersAtPosition:length:withString:
829         (#/prepareWithInvocationTarget: undo-mgr self)
830         pos (#/length string) replaced-string)))
831    (ns:with-ns-range (r pos len)
832      (#/beginEditing self)
833      (unwind-protect
834           (#/replaceCharactersInRange:withString: self r string)
835        (#/endEditing self)))
836    (for-each-textview-using-storage self #'update-paren-highlight)))
837
838(defun front-view-for-buffer (buffer)
839  (loop
840     with win-arr =  (#/orderedWindows *NSApp*)
841     for i from 0 below (#/count win-arr) as w = (#/objectAtIndex: win-arr i)
842     thereis (and (eq (hemlock-buffer w) buffer) (hemlock-view w))))
843
844
845;;; Modify the hemlock buffer; don't change attributes.
846(objc:defmethod (#/replaceCharactersInRange:withString: :void)
847    ((self hemlock-text-storage) (r :<NSR>ange) string)
848  (let* ((buffer (hemlock-buffer self))
849         (hi::*current-buffer* buffer)
850         (position (pref r :<NSR>ange.location))
851        (length (pref r :<NSR>ange.length))
852        (lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string)))
853         (edit-count (slot-value self 'edit-count)))
854    ;; #!#@#@* find panel neglects to call #/beginEditing / #/endEditing.
855    (when (eql 0 edit-count)
856      (#/beginEditing self))
857    (unwind-protect
858         (hi::with-mark ((m (hi::buffer-point buffer)))
859           (hi::move-to-absolute-position m position)
860           (when (> length 0)
861             (hi::delete-characters m length))
862           (when lisp-string
863             (hi::insert-string m lisp-string)))
864      (when (eql 0 edit-count)
865        (#/endEditing self)))
866    (let ((view (front-view-for-buffer buffer)))
867      (when view
868        (setf (hi::hemlock-view-quote-next-p view) nil)))))
869
870(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
871                                                attributes
872                                                (r :<NSR>ange))
873  #+debug
874  (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :<NSR>ange.location) :int (pref r :<NSR>ange.length))
875  (with-slots (mirror) self
876    (#/setAttributes:range: mirror attributes r)
877      #+debug
878      (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: mirror (pref r :<NSR>ange.location) +null-ptr+))))
879
880(defun for-each-textview-using-storage (textstorage f)
881  (let* ((layouts (#/layoutManagers textstorage)))
882    (unless (%null-ptr-p layouts)
883      (dotimes (i (#/count layouts))
884        (let* ((layout (#/objectAtIndex: layouts i))
885               (containers (#/textContainers layout)))
886          (unless (%null-ptr-p containers)
887            (dotimes (j (#/count containers))
888              (let* ((container (#/objectAtIndex: containers j))
889                     (tv (#/textView container)))
890                (funcall f tv)))))))))
891
892;;; Again, it's helpful to see the buffer name when debugging.
893(objc:defmethod #/description ((self hemlock-text-storage))
894  (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'hemlock-string)))
895
896(defun close-hemlock-textstorage (ts)
897  (declare (type hemlock-text-storage ts))
898  (when (slot-exists-p ts 'styles)
899    (with-slots (styles) ts
900      (#/release styles)
901      (setq styles +null-ptr+)))
902  (let* ((hemlock-string (slot-value ts 'hemlock-string)))
903    (setf (slot-value ts 'hemlock-string) +null-ptr+)
904    (unless (%null-ptr-p hemlock-string)
905      (#/release hemlock-string))))
906
907
908;;; Mostly experimental, so that we can see what happens when a
909;;; real typesetter is used.
910#-cocotron
911(progn
912(defclass hemlock-ats-typesetter (ns:ns-ats-typesetter)
913    ()
914  (:metaclass ns:+ns-object))
915
916(objc:defmethod (#/layoutGlyphsInLayoutManager:startingAtGlyphIndex:maxNumberOfLineFragments:nextGlyphIndex: :void)
917    ((self hemlock-ats-typesetter)
918     layout-manager
919     (start-index :<NSUI>nteger)
920     (max-lines :<NSUI>nteger)
921     (next-index (:* :<NSUI>nteger)))
922  (#_NSLog #@"layoutGlyphs: start = %d, maxlines = %d" :int start-index :int max-lines)
923  (call-next-method layout-manager start-index max-lines next-index))
924)
925
926;;; An abstract superclass of the main and echo-area text views.
927(defclass hemlock-textstorage-text-view (ns::ns-text-view)
928    ((paren-highlight-enabled :foreign-type #>BOOL :accessor text-view-paren-highlight-enabled)
929     (peer :foreign-type :id)
930     (paren-highlighting :initform nil :accessor text-view-paren-highlighting)
931     (hemlock-view :initform nil))
932  (:metaclass ns:+ns-object))
933(declaim (special hemlock-textstorage-text-view))
934
935(defmethod hemlock-buffer ((tv hemlock-textstorage-text-view))
936  ;; Could be the main buffer or the echo area.
937  (hemlock-buffer (#/textStorage tv)))
938
939#| causes more problems than it solves.
940   removed until a better implementation manifests itself --me
941(objc:defmethod (#/performDragOperation: #>BOOL)
942    ((self hemlock-textstorage-text-view)
943     (sender :id))
944  (let* ((pboard (#/draggingPasteboard sender))
945         (pbTypes (#/arrayWithObjects: ns:ns-array #&NSFilenamesPboardType
946                                       +null-ptr+))
947         (available-type (#/availableTypeFromArray: pboard pbTypes)))
948    (if (%null-ptr-p available-type)
949        (progn (log-debug "No data available of type NSFilenamesPboardType")
950               (call-next-method sender))
951        (let* ((plist (#/propertyListForType: pboard #&NSFilenamesPboardType)))
952          (cond
953            ;; we found NSFilenamesPboardType and it's an array of pathnames
954            ((#/isKindOfClass: plist ns:ns-array)
955             (with-autorelease-pool
956               (let* ((strings-for-dropped-objects
957                       (mapcar (lambda (d)
958                                 (if (#/isKindOfClass: d ns:ns-string)
959                                     (ccl::lisp-string-from-nsstring d)
960                                     (#/description d)))
961                               (list-from-ns-array plist)))
962                      (canonical-dropped-paths
963                       (mapcar (lambda (s)
964                                 (if (and (probe-file s)
965                                          (directoryp s))
966                                     (ccl::ensure-directory-pathname s)
967                                     s))
968                               strings-for-dropped-objects))
969                      (dropstr (if (= (length canonical-dropped-paths) 1)
970                                   (with-output-to-string (out)
971                                     (format out "~S~%" (first canonical-dropped-paths)))
972                                   nil)))
973                 ;; TODO: insert them in the window
974                 (if dropstr
975                     (let* ((hview (hemlock-view self))
976                            (buf (hi:hemlock-view-buffer hview))
977                            (point (hi::buffer-point buf))
978                            (hi::*current-buffer* buf))
979                       (hi::insert-string point dropstr)
980                       #$YES)
981                     #$NO))))
982            ;; we found NSFilenamesPboardType, but didn't get an array of pathnames; huh???
983            (t (log-debug "hemlock-textstorage-text-view received an unrecognized data type in a drag operation: '~S'"
984                          (#/description plist))
985               (call-next-method sender)))))))
986|#
987
988(defmethod hemlock-view ((self hemlock-textstorage-text-view))
989  (slot-value self 'hemlock-view))
990
991
992(defmethod activate-hemlock-view ((self hemlock-textstorage-text-view))
993  (assume-cocoa-thread)
994  (let* ((the-hemlock-frame (#/window self)))
995    #+debug (log-debug "Activating ~s" self)
996    (with-slots ((echo peer)) self
997      (deactivate-hemlock-view echo))
998    (#/setEditable: self t)
999    (#/makeFirstResponder: the-hemlock-frame self)))
1000
1001(defmethod deactivate-hemlock-view ((self hemlock-textstorage-text-view))
1002  (assume-cocoa-thread)
1003  #+debug (log-debug "deactivating ~s" self)
1004  (assume-not-editing self)
1005  (#/setSelectable: self nil)
1006  (disable-paren-highlight self))
1007
1008
1009
1010     
1011
1012(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view))
1013  ;; Return true if cmd-. is in the queue.  Not sure what to do about c-g:
1014  ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe
1015  ;; c-g will need to be synchronous meaning just end current command,
1016  ;; while cmd-. is the real abort.
1017  #|
1018   (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0)))
1019    (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue:
1020                         target (logior #$whatever) now #&NSDefaultRunLoopMode t)))
1021            (when (%null-ptr-p event) (return)))))
1022  "target" can either be an NSWindow or the global shared application object;
1023  |#
1024  nil)
1025
1026(defvar *buffer-being-edited* nil)
1027
1028#-darwin-target
1029(objc:defmethod (#/hasMarkedText #>BOOL) ((self hemlock-textstorage-text-view))
1030  nil)
1031
1032(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event)
1033  #+debug (#_NSLog #@"Key down event in %@  = %@" :id self :address event)
1034  (let* ((view (hemlock-view self))
1035         ;; quote-p means handle characters natively
1036         (quote-p (and view (hi::hemlock-view-quote-next-p view))))
1037    #+debug (log-debug "~&quote-p ~s event ~s" quote-p event)
1038    (cond ((or (null view) (#/hasMarkedText self) (eq quote-p :native))
1039           (when (and quote-p (not (eq quote-p :native)))       ;; see ticket:461
1040             (setf (hi::hemlock-view-quote-next-p view) nil))
1041           (call-next-method event))
1042          ((not (eventqueue-abort-pending-p self))
1043           (let ((hemlock-key (nsevent-to-key-event event quote-p)))
1044             (if (and hemlock-key
1045                      (not (hi:native-key-event-p hemlock-key)))
1046               (progn
1047                 (#/setHiddenUntilMouseMoves: ns:ns-cursor t)
1048                 (hi::handle-hemlock-event view hemlock-key))
1049               (call-next-method event)))))))
1050
1051(defmacro with-string-under-cursor ((text-view selection-name &optional bufname) &body body)
1052  "Intelligently grab the string under the cursor in the given text-view.
1053   If something is selected, just grab that. Otherwise call hemlock::symbol-at-point at cursor position.
1054   selection-name is the name of a variable to which the selection will be assigned.
1055   bufname (if given) is the name of a variable to which the current buffer will be assigned."
1056  (let ((bufsym (or bufname (gensym))))
1057    `(with-hemlock-context (,text-view)
1058       (let* ((,bufsym (hi:current-buffer))
1059              (,selection-name (hemlock::symbol-at-point ,bufsym)))
1060         ,@body))))
1061
1062(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
1063  (declare (ignore event))
1064  (with-autorelease-pool
1065      (call-next-method)))
1066
1067(defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift"))
1068
1069;;; Translate a keyDown NSEvent to a Hemlock key-event.
1070(defun nsevent-to-key-event (event quote-p)
1071  (let* ((modifiers (#/modifierFlags event)))
1072    (unless (logtest #$NSCommandKeyMask modifiers)
1073      (let* ((native-chars (#/characters event))
1074             (native-len (if (%null-ptr-p native-chars)
1075                           0
1076                           (#/length native-chars)))
1077             (native-c (and (eql 1 native-len)
1078                            (#/characterAtIndex: native-chars 0)))
1079             (option-p (logtest #$NSAlternateKeyMask modifiers)))
1080        ;; If a standalone dead key (e.g. ^'` on a French keyboard,) was pressed,
1081        ;; reverse the meaning of quote-p, i.e. use the system meaning if NOT quoted.
1082        ;; (I have no idea what makes standalone dead keys somehow different from
1083        ;; non-standalone dead keys).
1084        (when (and (not option-p) (eql 0 native-len))
1085          (setq quote-p (not quote-p)))
1086        (let ((c (if (or quote-p
1087                         (and option-p
1088                              (or (not *option-is-meta*)
1089                                  #-cocotron
1090                                  (and native-c
1091                                       (ccl::valid-char-code-p native-c)
1092                                       (standard-char-p (code-char (the ccl::valid-char-code native-c)))))
1093                              (setq quote-p t)))
1094                   native-c
1095                   (let ((chars (#/charactersIgnoringModifiers event)))
1096                     (and (not (%null-ptr-p chars))
1097                          (eql 1 (#/length chars))
1098                          (#/characterAtIndex: chars 0))))))
1099          (when c
1100            (let ((bits 0)
1101                  (useful-modifiers (logandc2 modifiers
1102                                              (logior
1103                                               ;;#$NSShiftKeyMask
1104                                               #$NSAlphaShiftKeyMask))))
1105              (unless quote-p
1106                (dolist (map hi:*modifier-translations*)
1107                  (when (logtest useful-modifiers (car map))
1108                    (setq bits (logior bits
1109                                       (hi:key-event-modifier-mask (cdr map)))))))
1110              (let* ((char (code-char c)))
1111                (when (and char (alpha-char-p char))
1112                  (setq bits (logandc2 bits +shift-event-mask+)))
1113                (when (logtest #$NSAlphaShiftKeyMask modifiers)
1114                  (setf c (char-code (char-upcase char)))))
1115              (hi:make-key-event c bits))))))))
1116
1117;; For now, this is only used to abort i-search.  All actual mouse handling is done
1118;; by Cocoa.   In the future might want to allow users to extend via hemlock, e.g.
1119;; to implement mouse-copy.
1120;; Also -- shouldn't this happen on mouse up?
1121(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
1122  ;; If no modifier keys are pressed, send hemlock a no-op.
1123  ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect)
1124  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
1125    (let* ((view (hemlock-view self))
1126           (hi::*delay-display-update-p* t))
1127      (when view
1128        (unless (eventqueue-abort-pending-p self)
1129          (hi::handle-hemlock-event view #k"leftdown")))))
1130  (call-next-method event))
1131
1132(defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
1133  (assume-not-editing (#/textStorage tv)))
1134
1135(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view)
1136                                        sender)
1137  (declare (ignorable sender))
1138  #+debug (#_NSLog #@"Change color to = %@" :id (#/color sender)))
1139
1140(def-cocoa-default *layout-text-in-background* :bool t "When true, do text layout when idle.")
1141
1142(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void)
1143    ((self hemlock-textstorage-text-view) layout cont (flag :<BOOL>))
1144  (declare (ignorable cont flag))
1145  #+debug (#_NSLog #@"layout complete: container = %@, atend = %d" :id cont :int (if flag 1 0))
1146  (unless *layout-text-in-background*
1147    (#/setDelegate: layout +null-ptr+)
1148    #-cocotron
1149    (#/setBackgroundLayoutEnabled: layout nil)))
1150
1151(defun ns-attribute (attribute)
1152  (ecase attribute
1153    (:foreground #&NSForegroundColorAttributeName)
1154    (:background #&NSBackgroundColorAttributeName)))
1155
1156(defmethod remove-paren-highlight ((self hemlock-textstorage-text-view))
1157  (ns:with-ns-range (range)
1158    #-cocotron
1159    (let* ((layout (#/layoutManager self)))
1160      (setf (ns:ns-range-length range) 1)
1161      (loop
1162        for (pos attrib . nil) in (text-view-paren-highlighting self)
1163        do (setf (ns:ns-range-location range) pos)
1164        do  (#/removeTemporaryAttribute:forCharacterRange: layout (ns-attribute attrib) range)))
1165    ;;; This assumes that NSBackgroundColorAttributeName can only be
1166    ;;; present if it's (possibly stale) paren highlighting info.
1167    ;;; We can't be sure of the locations (because of insertions/deletions),
1168    ;;; so remove the attribute from the entire textstorage.
1169    #+cocotron
1170    (let* ((textstorage (#/textStorage self))
1171           (len (#/length textstorage)))
1172      (#/beginEditing textstorage)
1173      (setf (ns:ns-range-location range) 0)
1174      (setf (ns:ns-range-length range) len)
1175      (#/removeAttribute:range: textstorage #&NSBackgroundColorAttributeName range)
1176      (#/endEditing textstorage))))
1177
1178(defmethod disable-paren-highlight ((self hemlock-textstorage-text-view))
1179  (when (eql (text-view-paren-highlight-enabled self) #$YES)
1180    (setf (text-view-paren-highlight-enabled self) #$NO)
1181    (remove-paren-highlight self)))
1182
1183(defun hemlock-ext:lookup-color (color-spec)
1184  (etypecase color-spec
1185    (cons (apply #'color-values-to-nscolor color-spec))
1186    ((vector t) (apply #'color-values-to-nscolor (coerce color-spec 'list)))
1187    ((or string symbol)
1188     (let ((name (string color-spec)))
1189       ;; Please rewrite me...
1190       (cond ((string-equal name "black") (#/blackColor ns:ns-color))
1191             ((string-equal name "blue") (#/blueColor ns:ns-color))
1192             ((string-equal name "brown") (#/brownColor ns:ns-color))
1193             ((string-equal name "cyan") (#/cyanColor ns:ns-color))
1194             ((string-equal name "gray") (#/grayColor ns:ns-color))
1195             ((string-equal name "lightgray") (#/lightGrayColor ns:ns-color))
1196             ((string-equal name "darkgray") (#/darkGrayColor ns:ns-color))       
1197             ((string-equal name "green") (#/greenColor ns:ns-color))
1198             ((string-equal name "magenta") (#/magentaColor ns:ns-color))
1199             ((string-equal name "orange") (#/orangeColor ns:ns-color))
1200             ((string-equal name "purple") (#/purpleColor ns:ns-color))
1201             ((string-equal name "red") (#/redColor ns:ns-color))
1202             ((string-equal name "white") (#/whiteColor ns:ns-color))
1203             ((string-equal name "yellow") (#/yellowColor ns:ns-color))
1204             (t (error "I don't know color ~s" name)))))))
1205
1206(defmethod compute-temporary-attributes ((self hemlock-textstorage-text-view))
1207  #-cocotron
1208  (let* ((container (#/textContainer self))
1209         ;; If there's a containing scroll view, use its contentview         
1210         ;; Otherwise, just use the current view.
1211         (scrollview (#/enclosingScrollView self))
1212         (contentview (if (%null-ptr-p scrollview) self (#/contentView scrollview)))
1213         (rect (#/bounds contentview))
1214         (layout (#/layoutManager container))
1215         (glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
1216                       layout rect container))
1217         (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
1218                      layout glyph-range +null-ptr+))
1219         (start (ns:ns-range-location char-range))
1220         (length (ns:ns-range-length char-range))
1221         (end (+ start length)))
1222    (with-hemlock-context (self)
1223      (ns:with-ns-range (range)
1224        (when (> length 0)
1225          ;; Remove all temporary attributes from the character range
1226          (#/removeTemporaryAttribute:forCharacterRange: layout #&NSForegroundColorAttributeName char-range)
1227          (#/removeTemporaryAttribute:forCharacterRange: layout #&NSBackgroundColorAttributeName char-range)
1228          (loop
1229            for (pos len attrib . color) in (hemlock:compute-syntax-coloring start length) as endpos = (+ pos len)
1230            while (< pos end)
1231            do (when (and color (< start endpos))
1232                 (setf (ns:ns-range-location range) pos
1233                       (ns:ns-range-length range) len)
1234                 (#/addTemporaryAttribute:value:forCharacterRange: layout (ns-attribute attrib) color range))))
1235        (when (eql #$YES (text-view-paren-highlight-enabled self))
1236          (setf (ns:ns-range-length range) 1)
1237          (loop
1238             for (pos attrib . color) in (text-view-paren-highlighting self)
1239             do (when (and (<= start pos) (< pos end))
1240                  (setf (ns:ns-range-location range) pos)
1241                  (#/addTemporaryAttribute:value:forCharacterRange: layout (ns-attribute attrib) color range)))))))
1242  #+cocotron
1243  (when (eql #$YES (text-view-paren-highlight-enabled self))
1244    (let* ((ts (#/textStorage self)))
1245      (ns:with-ns-range (range)
1246        (#/beginEditing ts)
1247        (setf (ns:ns-range-length range) 1)
1248        (loop
1249          for (pos attrib . color) in (text-view-paren-highlighting self)
1250          do (setf (ns:ns-range-location range) pos)
1251          do (#/addAttribute:value:range: ts (ns-attribute attrib) color range))
1252        (#/endEditing ts)))))
1253
1254(defmethod update-paren-highlight ((self hemlock-textstorage-text-view))
1255  (disable-paren-highlight self)
1256  (with-hemlock-context (self)
1257    (let ((buffer (hi:current-buffer)))
1258      (when (string= (hi:buffer-major-mode buffer) "Lisp")
1259        #+debug (#_NSLog #@"Syntax check for paren-highlighting")
1260        (update-buffer-package (hi::buffer-document buffer))
1261        (setf (text-view-paren-highlighting self) (hemlock:compute-paren-highlighting))
1262        (setf (text-view-paren-highlight-enabled self) #$YES))
1263      (compute-temporary-attributes self))))
1264
1265
1266
1267;;; Set and display the selection at pos, whose length is len and whose
1268;;; affinity is affinity.  This should never be called from any Cocoa
1269;;; event handler; it should not call anything that'll try to set the
1270;;; underlying buffer's point and/or mark
1271
1272(objc:defmethod (#/updateSelection:length:affinity: :void)
1273    ((self hemlock-textstorage-text-view)
1274     (pos :int)
1275     (length :int)
1276     (affinity :<NSS>election<A>ffinity))
1277  (assume-cocoa-thread)
1278  (when (eql length 0)
1279    (update-paren-highlight self))
1280  (with-hemlock-context (self)
1281    (setf (hi::buffer-selection-set-by-command (hi:current-buffer)) (> length 0))
1282    (rlet ((range :ns-range :location pos :length length))
1283      (ccl::%call-next-objc-method self
1284                                   hemlock-textstorage-text-view
1285                                   (@selector #/setSelectedRange:affinity:stillSelecting:)
1286                                   '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
1287                                   range
1288                                   affinity
1289                                   nil)
1290      (assume-not-editing self)
1291      (when (> length 0)
1292        (let* ((ts (#/textStorage self)))
1293          (with-slots (selection-set-by-search) ts
1294            (when (prog1 (eql #$YES selection-set-by-search)
1295                    (setq selection-set-by-search #$NO))
1296              (highlight-search-selection self pos length))))))))
1297
1298(defloadvar *can-use-show-find-indicator-for-range*
1299    (#/instancesRespondToSelector: ns:ns-text-view (@selector "showFindIndicatorForRange:")))
1300
1301;;; Add transient highlighting to a selection established via a search
1302;;; primitive, if the OS supports it.
1303(defun highlight-search-selection (tv pos length)
1304  (when *can-use-show-find-indicator-for-range*
1305    (ns:with-ns-range (r pos length)
1306      (objc-message-send tv "showFindIndicatorForRange:" :<NSR>ange r :void))))
1307 
1308;;; A specialized NSTextView. The NSTextView is part of the "pane"
1309;;; object that displays buffers.
1310(defclass hemlock-text-view (hemlock-textstorage-text-view)
1311    ((pane :foreign-type :id :accessor text-view-pane)
1312     (char-width :foreign-type :<CGF>loat :accessor text-view-char-width)
1313     (line-height :foreign-type :<CGF>loat :accessor text-view-line-height))
1314  (:metaclass ns:+ns-object))
1315(declaim (special hemlock-text-view))
1316
1317(objc:defmethod (#/duplicate: :void) ((self hemlock-text-view) sender)
1318  (#/duplicate: (#/window self) sender))
1319
1320(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender)
1321  (declare (ignore sender))
1322  (let* ((view (hemlock-view self)))
1323    (when view
1324      (hi::handle-hemlock-event view #'(lambda ()
1325                                         (hemlock::editor-execute-expression-command nil))))))
1326
1327(defun ui-buffer-env (obj)
1328  (let* ((buffer (hemlock-buffer obj))
1329         (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
1330         (pathname (hi::buffer-pathname buffer)))
1331    (list package-name pathname)))
1332
1333(objc:defmethod (#/evalAll: :void) ((self hemlock-text-view) sender)
1334  (declare (ignore sender))
1335  (let* ((s (lisp-string-from-nsstring (#/string self))))
1336    (ui-object-eval-selection *NSApp* `(,@(ui-buffer-env self) ,s))))
1337
1338(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender)
1339  (declare (ignore sender))
1340  (ui-object-load-buffer *NSApp* (ui-buffer-env self)))
1341
1342(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender)
1343  (declare (ignore sender))
1344  (ui-object-compile-buffer *NSApp* (ui-buffer-env self)))
1345
1346(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender)
1347  (declare (ignore sender))
1348  (ui-object-compile-and-load-buffer *NSApp* (ui-buffer-env self)))
1349
1350(defloadvar *text-view-context-menu* ())
1351
1352(defun text-view-context-menu ()
1353  (or *text-view-context-menu*
1354      (setq *text-view-context-menu*
1355            (#/retain
1356             (let* ((menu (make-instance 'ns:ns-menu :with-title #@"Menu")))
1357               (#/addItemWithTitle:action:keyEquivalent:
1358                menu #@"Cut" (@selector #/cut:) #@"")
1359               (#/addItemWithTitle:action:keyEquivalent:
1360                menu #@"Copy" (@selector #/copy:) #@"")
1361               (#/addItemWithTitle:action:keyEquivalent:
1362                menu #@"Paste" (@selector #/paste:) #@"")
1363               ;; Separator
1364               (#/addItem: menu (#/separatorItem ns:ns-menu-item))
1365               (#/addItemWithTitle:action:keyEquivalent:
1366                menu #@"Background Color ..." (@selector #/changeBackgroundColor:) #@"")
1367               (#/addItemWithTitle:action:keyEquivalent:
1368                menu #@"Text Color ..." (@selector #/changeTextColor:) #@"")
1369               ;; Separator
1370               (#/addItem: menu (#/separatorItem ns:ns-menu-item))
1371               (#/addItemWithTitle:action:keyEquivalent:
1372                menu #@"Duplicate this window" (@selector #/duplicate:) #@"")
1373               menu)))))
1374
1375
1376
1377
1378
1379(objc:defmethod (#/changeBackgroundColor: :void)
1380    ((self hemlock-text-view) sender)
1381  (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel))
1382         (color (#/backgroundColor self)))
1383    (#/close colorpanel)
1384    (#/setAction: colorpanel (@selector #/updateBackgroundColor:))
1385    (#/setColor: colorpanel color)
1386    (#/setTarget: colorpanel self)
1387    (#/setContinuous: colorpanel nil)
1388    (#/orderFrontColorPanel: *NSApp* sender)))
1389
1390
1391
1392(objc:defmethod (#/updateBackgroundColor: :void)
1393    ((self hemlock-text-view) sender)
1394  (when (#/isVisible sender)
1395    (let* ((color (#/color sender)))
1396      (unless (typep self 'echo-area-view)
1397        (let* ((window (#/window self))
1398               (echo-view (unless (%null-ptr-p window)
1399                            (slot-value window 'echo-area-view))))
1400          (when echo-view (#/setBackgroundColor: echo-view color))))
1401      #+debug (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender)
1402      (#/setBackgroundColor: self color))))
1403
1404(objc:defmethod (#/changeTextColor: :void)
1405    ((self hemlock-text-view) sender)
1406  (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel))
1407         (textstorage (#/textStorage self))
1408         (color (#/objectForKey:
1409                 (#/objectAtIndex: (slot-value textstorage 'styles) 0)
1410                 #&NSForegroundColorAttributeName)))
1411    (#/close colorpanel)
1412    (#/setAction: colorpanel (@selector #/updateTextColor:))
1413    (#/setColor: colorpanel color)
1414    (#/setTarget: colorpanel self)
1415    (#/setContinuous: colorpanel nil)
1416    (#/orderFrontColorPanel: *NSApp* sender)))
1417
1418
1419
1420
1421
1422
1423   
1424(objc:defmethod (#/updateTextColor: :void)
1425    ((self hemlock-textstorage-text-view) sender)
1426  (unwind-protect
1427      (progn
1428        (#/setUsesFontPanel: self t)
1429        (ccl::%call-next-objc-method
1430         self
1431         hemlock-textstorage-text-view
1432         (@selector #/changeColor:)
1433         '(:void :id)
1434         sender))
1435    (#/setUsesFontPanel: self nil))
1436  (#/setNeedsDisplay: self t))
1437   
1438(objc:defmethod (#/updateTextColor: :void)
1439    ((self hemlock-text-view) sender)
1440  (let* ((textstorage (#/textStorage self))
1441         (styles (slot-value textstorage 'styles))
1442         (newcolor (#/color sender)))
1443    (dotimes (i (#/count styles))
1444      (let* ((dict (#/objectAtIndex: styles i)))
1445        (#/setValue:forKey: dict newcolor #&NSForegroundColorAttributeName)))
1446    (call-next-method sender)))
1447
1448
1449
1450(defmethod text-view-string-cache ((self hemlock-textstorage-text-view))
1451  (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
1452
1453
1454(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range)
1455    ((self hemlock-textstorage-text-view)
1456     (proposed :ns-range)
1457     (g :<NSS>election<G>ranularity))
1458  #+debug
1459  (#_NSLog #@"Granularity = %d" :int g)
1460  (objc:returning-foreign-struct (r)
1461    (block HANDLED
1462      (let* ((index (ns:ns-range-location proposed))
1463             (length (ns:ns-range-length proposed))
1464             (textstorage (#/textStorage self))
1465             (event (#/currentEvent (#/window self)))
1466             (event-type (#/type event)))
1467        ;; Workaround for bug #150
1468        (when (and (eql g #$NSSelectByCharacter)
1469                   (eql index (#/length textstorage))
1470                   (or (eql event-type #$NSLeftMouseDown) (eql event-type #$NSLeftMouseUp)))
1471          (setq g (case (#/clickCount event)
1472                    ((0 1) #$NSSelectByCharacter)
1473                    (2 #$NSSelectByWord)
1474                    (t #$NSSelectByParagraph))))
1475        (unless (eql g #$NSSelectByCharacter)
1476          (with-hemlock-context (self)
1477            (let* ((point (hi:current-point))
1478                   (atom-mode (eql g #$NSSelectByParagraph)))
1479              (hi:with-mark ((mark point))
1480                (when (or (= length 0) (hi:move-to-absolute-position mark index))
1481                  (let* ((region (hemlock:selection-for-click mark atom-mode))
1482                         (other-region (and (< 0 length)
1483                                            (hi:character-offset mark length)
1484                                            (hemlock:selection-for-click mark atom-mode))))
1485                    (when (null region) (setq region other-region other-region nil))
1486                    (when region
1487                      (let ((start-pos (min (hi:mark-absolute-position (hi:region-start region))
1488                                            (if other-region
1489                                              (hi:mark-absolute-position (hi:region-start other-region))
1490                                              index)))
1491                            (end-pos (max (hi:mark-absolute-position (hi:region-end region))
1492                                          (if other-region
1493                                            (hi:mark-absolute-position (hi:region-end other-region))
1494                                            (+ index length)))))
1495                        (assert (<= start-pos end-pos))
1496                        ;; Act as if we started the selection at the other end, so the heuristic
1497                        ;; in #/setSelectedRange does the right thing.  ref bug #565.
1498                        ;; However, only do so at the end, so don't keep toggling during selection, ref bug #851.
1499                        (when (and (eql event-type #$NSLeftMouseUp) (< start-pos end-pos))
1500                          (let ((point-pos (hi:mark-absolute-position point)))
1501                            (cond ((eql point-pos start-pos)
1502                                   (hi:move-to-absolute-position point end-pos))
1503                                  ((eql point-pos end-pos)
1504                                   (hi:move-to-absolute-position point start-pos)))))
1505                        (ns:init-ns-range r start-pos (- end-pos start-pos))
1506                        #+debug
1507                        (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
1508                                 :address (#_NSStringFromRange r)
1509                                 :address (#_NSStringFromRange proposed)
1510                                 :<NSS>election<G>ranularity g)
1511                        (return-from HANDLED r)))))))))
1512        (prog1
1513            (call-next-method proposed g)
1514          #+debug
1515          (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
1516                   :address (#_NSStringFromRange r)
1517                   :address (#_NSStringFromRange proposed)
1518                   :<NSS>election<G>ranularity g))))))
1519
1520(defun append-output (view string)
1521  (assume-cocoa-thread)
1522  ;; Arrange to do the append in command context
1523  (when view
1524    (hi::handle-hemlock-event view #'(lambda ()
1525                                       (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string)))))
1526
1527
1528;;; Update the underlying buffer's point (and "active region", if appropriate.
1529;;; This is called in response to a mouse click or other event; it shouldn't
1530;;; be called from the Hemlock side of things.
1531
1532(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void)
1533    ((self hemlock-text-view)
1534     (r :<NSR>ange)
1535     (affinity :<NSS>election<A>ffinity)
1536     (still-selecting :<BOOL>))
1537  #+debug
1538  (#_NSLog #@"Set selected range called: range = %@, affinity = %d, still-selecting = %d"
1539           :address (#_NSStringFromRange r)
1540           :<NSS>election<A>ffinity affinity
1541           :<BOOL> (if still-selecting #$YES #$NO))
1542  #+debug
1543  (#_NSLog #@"text view string = %@, textstorage string = %@"
1544           :id (#/string self)
1545           :id (#/string (#/textStorage self)))
1546  (unless (#/editingInProgress (#/textStorage self))
1547    (with-hemlock-context (self)
1548      (let* ((buffer (hi:current-buffer))
1549             (d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
1550             (location (pref r :<NSR>ange.location))
1551             (len (pref r :<NSR>ange.length)))
1552        (setf (hi::buffer-selection-set-by-command buffer) nil)
1553        (cond ((eql len 0)
1554               #+debug
1555               (#_NSLog #@"Moving point to absolute position %d" :int location)
1556               ;; Do this even if still-selecting, in order to enable the heuristic below.
1557               (hemlock:move-point-for-click buffer location)
1558               (update-paren-highlight self))
1559              (t
1560               ;; We don't get much information about which end of the
1561               ;; selection the mark's at and which end point is at, so
1562               ;; we have to sort of guess.  In every case I've ever seen,
1563               ;; selection via the mouse generates a sequence of calls to
1564               ;; this method whose parameters look like:
1565               ;; a: range: {n0,0} still-selecting: false  [ rarely repeats ] (this doesn't actually happen)
1566               ;; b: range: {n0,0) still-selecting: true   [ rarely repeats ]
1567               ;; c: range: {n1,m} still-selecting: true   [ often repeats ]
1568               ;; d: range: {n1,m} still-selecting: false  [ rarely repeats ] (mouse up)
1569               ;;
1570               ;; (Sadly, "affinity" doesn't tell us anything interesting.)
1571               ;; We've handled a and b in the clause above; after handling
1572               ;; b, point references buffer position n0 and the
1573               ;; region is inactive.
1574               ;; Let's ignore c, and wait until the selection's stabilized.
1575               ;; Make a new mark, a copy of point (position n0).
1576               ;; At step d (here), we should have either
1577               ;; d1) n1=n0.  Mark stays at n0, point moves to n0+m.
1578               ;; d2) n1+m=n0.  Mark stays at n0, point moves to n0-m.
1579               ;; If neither d1 nor d2 apply, arbitrarily assume forward
1580               ;; selection: mark at n1, point at n1+m.
1581               ;; In all cases, activate Hemlock selection.
1582               (unless still-selecting
1583                 (let* ((point (hi::buffer-point buffer))
1584                        (pointpos (hi:mark-absolute-position point))
1585                        (selection-end (+ location len))
1586                        (mark (hi::copy-mark point :right-inserting)))
1587                   (cond ((eql pointpos location)
1588                          (move-hemlock-mark-to-absolute-position point
1589                                                                  d
1590                                                                  selection-end))
1591                         ((eql pointpos selection-end)
1592                          (move-hemlock-mark-to-absolute-position point
1593                                                                  d
1594                                                                  location))
1595                         (t
1596                          (move-hemlock-mark-to-absolute-position mark
1597                                                                  d
1598                                                                  location)
1599                          (move-hemlock-mark-to-absolute-position point
1600                                                                  d
1601                                                                  selection-end)))
1602                   (hemlock::%buffer-push-buffer-mark buffer mark t))))))))
1603  (call-next-method r affinity still-selecting))
1604
1605
1606
1607;;; Modeline-view
1608
1609(defclass modeline-view (ns:ns-view)
1610    ((pane :foreign-type :id :accessor modeline-view-pane)
1611     (text-attributes :foreign-type :id :accessor modeline-text-attributes))
1612  (:metaclass ns:+ns-object))
1613
1614(objc:defmethod #/initWithFrame: ((self modeline-view) (frame :<NSR>ect))
1615  (call-next-method frame)
1616  (let* ((size (#/smallSystemFontSize ns:ns-font))
1617         (font (#/systemFontOfSize: ns:ns-font size))
1618         (dict (#/dictionaryWithObject:forKey: ns:ns-dictionary font #&NSFontAttributeName)))
1619    (setf (modeline-text-attributes self) (#/retain dict)))
1620  self)
1621
1622;;; Find the underlying buffer.
1623(defun buffer-for-modeline-view (mv)
1624  (let* ((pane (modeline-view-pane mv)))
1625    (unless (%null-ptr-p pane)
1626      (let* ((tv (text-pane-text-view pane)))
1627        (unless (%null-ptr-p tv)
1628          (hemlock-buffer tv))))))
1629
1630;;; Draw a string in the modeline view.  The font and other attributes
1631;;; are initialized lazily; apparently, calling the Font Manager too
1632;;; early in the loading sequence confuses some Carbon libraries that're
1633;;; used in the event dispatch mechanism,
1634(defun draw-modeline-string (the-modeline-view)
1635  (with-slots (text-attributes) the-modeline-view
1636    (let* ((buffer (buffer-for-modeline-view the-modeline-view)))
1637      (when buffer
1638        (let* ((string
1639                (apply #'concatenate 'string
1640                       (mapcar
1641                        #'(lambda (field)
1642                            (or (ignore-errors 
1643                                  (funcall (hi::modeline-field-function field) buffer))
1644                                ""))
1645                        (hi::buffer-modeline-fields buffer)))))
1646          (#/drawAtPoint:withAttributes: (#/autorelease (%make-nsstring string))
1647                                         (ns:make-ns-point 5 1)
1648                                         text-attributes))))))
1649
1650(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :<NSR>ect))
1651  (declare (ignorable rect))
1652  (let* ((bounds (#/bounds self))
1653         (context (#/currentContext ns:ns-graphics-context)))
1654    (#/saveGraphicsState context)
1655    (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.9 1.0))
1656    (#_NSRectFill bounds)
1657    (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.3333 1.0))
1658    ;; Draw borders on top and bottom.
1659    (ns:with-ns-rect (r 0 0.5 (ns:ns-rect-width bounds) 0.5)
1660      (#_NSRectFill r))
1661    (ns:with-ns-rect (r 0 (- (ns:ns-rect-height bounds) 0.5)
1662                        (ns:ns-rect-width bounds) (- (ns:ns-rect-height bounds) 0.5))
1663      (#_NSRectFill r))
1664    (draw-modeline-string self)
1665    (#/restoreGraphicsState context)))
1666
1667;;; Hook things up so that the modeline is updated whenever certain buffer
1668;;; attributes change.
1669(hi::%init-mode-redisplay)
1670
1671
1672;;; A clip view subclass, which exists mostly so that we can track origin changes.
1673(defclass text-pane-clip-view (ns:ns-clip-view)
1674  ()
1675  (:metaclass ns:+ns-object))
1676
1677(objc:defmethod (#/scrollToPoint: :void) ((self text-pane-clip-view)
1678                                           (origin #>NSPoint))
1679  (unless (#/inLiveResize self)
1680    (call-next-method origin)
1681    (compute-temporary-attributes (#/documentView self))))
1682
1683;;; Text-pane
1684
1685;;; The text pane is just an NSBox that (a) provides a draggable border
1686;;; around (b) encapsulates the text view and the mode line.
1687
1688(defclass text-pane (ns:ns-box)
1689    ((hemlock-view :initform nil :reader text-pane-hemlock-view)
1690     (text-view :foreign-type :id :accessor text-pane-text-view)
1691     (mode-line :foreign-type :id :accessor text-pane-mode-line)
1692     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
1693  (:metaclass ns:+ns-object))
1694
1695(defmethod hemlock-view ((self text-pane))
1696  (text-pane-hemlock-view self))
1697
1698;;; This method gets invoked on the text pane, which is its containing
1699;;; window's delegate object.
1700(objc:defmethod (#/windowDidResignKey: :void)
1701    ((self text-pane) notification)
1702  (declare (ignorable notification))
1703  ;; When the window loses focus, we should remove or change transient
1704  ;; highlighting (like matching-paren highlighting).  Maybe make this
1705  ;; more general ...
1706  ;; Currently, this only removes temporary attributes from matching
1707  ;; parens; other kinds of syntax highlighting stays visible when
1708  ;; the containing window loses keyboard focus
1709  (let* ((tv (text-pane-text-view self)))
1710    (remove-paren-highlight tv)
1711    (remove-paren-highlight (slot-value tv 'peer))))
1712
1713;;; Likewise, reactivate transient highlighting when the window gets
1714;;; focus.
1715(objc:defmethod (#/windowDidBecomeKey: :void)
1716    ((self text-pane) notification)
1717  (declare (ignorable notification))
1718  (let* ((tv (text-pane-text-view self)))
1719    (compute-temporary-attributes tv)
1720    (compute-temporary-attributes (slot-value tv 'peer))))
1721 
1722
1723;;; Mark the buffer's modeline as needing display.  This is called whenever
1724;;; "interesting" attributes of a buffer are changed.
1725(defun hemlock-ext:invalidate-modeline (buffer)
1726  (let* ((doc (hi::buffer-document buffer)))
1727    (when doc
1728      (document-invalidate-modeline doc))))
1729
1730;;; Process a file's "coding" file-option.
1731(defun hemlock-ext:set-buffer-external-format (buffer string)
1732  (let* ((ef (ccl::process-file-coding-option string (or (hi::buffer-line-termination buffer) :unix)))
1733         (encoding-val (nsstring-encoding-for-external-format ef)))
1734    (cond (encoding-val
1735           (setf (hi::buffer-line-termination buffer)
1736                 (external-format-line-termination ef))
1737           (let* ((doc (hi::buffer-document buffer)))
1738             (when doc
1739               (with-slots (encoding) doc
1740                 (setq encoding encoding-val))))
1741           (hemlock-ext:invalidate-modeline buffer))
1742          (t
1743           (hi:loud-message "Can't parse coding option ~a." string)))))
1744                 
1745
1746(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
1747(def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane")
1748
1749
1750(objc:defmethod #/initWithFrame: ((self text-pane) (frame :<NSR>ect))
1751  (let* ((pane (call-next-method frame)))
1752    (unless (%null-ptr-p pane)
1753      (#/setAutoresizingMask: pane (logior
1754                                    #$NSViewWidthSizable
1755                                    #$NSViewHeightSizable))
1756      (#/setBoxType: pane #$NSBoxPrimary)
1757      (#/setBorderType: pane #$NSNoBorder)
1758      (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width*  *text-pane-margin-height*))
1759      (#/setTitlePosition: pane #$NSNoTitle))
1760    pane))
1761
1762(objc:defmethod #/defaultMenu ((class +hemlock-text-view))
1763  (text-view-context-menu))
1764
1765(defun pathname-for-namestring-fragment (string)
1766  "Return a pathname that STRING might designate."
1767  ;; We could get fancy here, but for now just be stupid.
1768  (let* ((rfs (ignore-errors (read-from-string string nil nil)))
1769         (pathname (or (ignore-errors (probe-file string))
1770                       (ignore-errors (probe-file rfs))
1771                       (ignore-errors (probe-file (merge-pathnames *.lisp-pathname* string)))
1772                       (ignore-errors (probe-file (merge-pathnames *.lisp-pathname* rfs))))))
1773    (if (and (pathnamep pathname)
1774             (not (directory-pathname-p pathname)))
1775      pathname)))
1776
1777#| broken in the case of a string that's already preceded by package name
1778(defun find-symbol-in-packages (string pkgs)
1779  (setq string (string-upcase string))
1780  (let (sym)
1781    (dolist (p pkgs)
1782      (when (setq sym (find-symbol string p))
1783        (return)))
1784    sym))
1785|#
1786
1787(defun find-symbol-in-packages (string pkgs)
1788  "Look up symbol named by string in given list of packages. If no list, just try to read the symbol itself,
1789   using current binding of *package* unless string has its own package designator."
1790  (cond (pkgs
1791         (let (sym)
1792           (dolist (p pkgs)
1793             (let ((*package* (find-package p)))
1794               (when (setq sym (ignore-errors (read-from-string string)))
1795                 (return))))
1796           sym))
1797        (t (ignore-errors (read-from-string string)))))
1798
1799(defun find-symbol-in-buffer-packages (string buffer)
1800  (let ((package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
1801        (packages nil))
1802    (unless (find #\: string) ; don't bother looking in other packages if the string itself contains a package designator
1803      (setf packages (append ; all packages in order, starting with the ones of this buffer
1804                      #1=(cons package-name (package-use-list package-name))
1805                      (set-difference (list-all-packages) #1#))))
1806    (find-symbol-in-packages string packages)))
1807
1808(defun choose-listener ()
1809  (ui-object-choose-listener-for-selection *NSApp* nil))
1810
1811(defun eval-in-listener (string)
1812  "Evals string in nearest listener, or creates one if none. Any errors reported during evaluation
1813   go to the listener, not the console."
1814  (let* ((target-listener (choose-listener)))
1815    (when target-listener
1816      (enqueue-listener-input (cocoa-listener-process-input-stream target-listener) string))))
1817
1818(objc:defmethod (#/openSelection: :void) ((self hemlock-text-view) sender)
1819  (declare (ignore sender))
1820  (with-string-under-cursor (self selection)
1821    (let* ((pathname (pathname-for-namestring-fragment selection)))
1822      (when pathname
1823        (eval-in-listener (format nil "(ed ~S)" pathname))))))
1824
1825(objc:defmethod (#/traceSelection: :void) ((self hemlock-text-view) sender)
1826  (declare (ignore sender))
1827  (with-string-under-cursor (self symbol-name buffer)
1828    (let* ((sym (find-symbol-in-buffer-packages symbol-name buffer)))
1829      (eval-in-listener (format nil "(trace ~S)" sym)))))
1830
1831(objc:defmethod (#/inspectSelection: :void) ((self hemlock-text-view) sender)
1832  (declare (ignore sender))
1833  (with-string-under-cursor (self symbol-name buffer)
1834    (let* ((sym (find-symbol-in-buffer-packages symbol-name buffer)))
1835      (inspect sym))))
1836
1837(objc:defmethod (#/sourceForSelection: :void) ((self hemlock-text-view) sender)
1838  (declare (ignore sender))
1839  (with-string-under-cursor (self symbol-name buffer)
1840    (let* ((sym (find-symbol-in-buffer-packages symbol-name buffer)))
1841      ;(execute-in-gui (lambda () (ed sym))) ; NO! If this errors, it throws to the console. Same with execute-in-buffer.
1842      (eval-in-listener (format nil "(ed '~S)" sym)))))
1843
1844(hi:defcommand "Inspect Symbol" (p)
1845  "Inspects current symbol."
1846  (declare (ignore p))
1847  (let* ((buffer (hi:current-buffer))
1848         (fun-name (hemlock::symbol-at-point buffer)))
1849    (if fun-name
1850      (inspect (find-symbol-in-buffer-packages fun-name buffer))
1851      (hi:beep))))
1852
1853;;; If we don't override this, NSTextView will start adding Google/
1854;;; Spotlight search options and dictionary lookup when a selection
1855;;; is active.
1856(objc:defmethod #/menuForEvent: ((self hemlock-text-view) event)
1857  (declare (ignore event))
1858  (with-string-under-cursor (self selection)
1859    (let* ((menu (if (> (length selection) 0)
1860                   (#/copy (#/menu self))
1861                   (#/retain (#/menu self))))
1862           (thingfound? (> (length selection) 0)))
1863      (flet ((make-contextual-menu-item (title selector &optional (key-equiv #@""))
1864               (let* ((nstitle (%make-nsstring title))
1865                      (item (make-instance 'ns:ns-menu-item :with-title nstitle
1866                              :action (ccl::%get-selector (ccl::load-objc-selector selector))
1867                              :key-equivalent key-equiv)))
1868                 (#/setTarget: item self)
1869                 (#/insertItem:atIndex: menu item 0)
1870                 (#/release item))))
1871        (when thingfound? (make-contextual-menu-item (concatenate 'string "Hyperspec " selection) '#/hyperSpecLookUp:))
1872        (when thingfound? (make-contextual-menu-item (concatenate 'string "Trace " selection) '#/traceSelection:))
1873        (when thingfound? (make-contextual-menu-item (concatenate 'string "Inspect " selection) '#/inspectSelection:))
1874        (when thingfound? (make-contextual-menu-item (concatenate 'string "Source of " selection) '#/sourceForSelection:))
1875        (when (and thingfound? (pathname-for-namestring-fragment selection))
1876          (make-contextual-menu-item (concatenate 'string "Open " selection) '#/openSelection:))
1877        (#/autorelease menu)))))
1878
1879(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color style)
1880  (let* ((scrollview (#/autorelease
1881                      (make-instance
1882                       'ns:ns-scroll-view
1883                       :with-frame (ns:make-ns-rect x y width height)))))
1884    (#/setBorderType: scrollview #$NSNoBorder)
1885    (#/setHasVerticalScroller: scrollview t)
1886    (#/setHasHorizontalScroller: scrollview t)
1887    (#/setRulersVisible: scrollview nil)
1888    (#/setAutoresizingMask: scrollview (logior
1889                                        #$NSViewWidthSizable
1890                                        #$NSViewHeightSizable))
1891    (#/setAutoresizesSubviews: (#/contentView scrollview) t)
1892    (let* ((layout (make-instance 'ns:ns-layout-manager)))
1893      #+suffer
1894      (#/setTypesetter: layout (make-instance 'hemlock-ats-typesetter))
1895      (#/addLayoutManager: textstorage layout)
1896      (#/setUsesScreenFonts: layout *use-screen-fonts*)
1897      (#/release layout)
1898      (let* ((contentsize (#/contentSize scrollview)))
1899        (ns:with-ns-size (containersize large-number-for-text large-number-for-text)
1900          (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
1901            (ns:init-ns-size containersize large-number-for-text large-number-for-text)
1902            (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
1903            (let* ((container (#/autorelease (make-instance
1904                                              'ns:ns-text-container
1905                                              :with-container-size containersize))))
1906              (#/addTextContainer: layout  container)
1907              (let* ((tv (#/autorelease (make-instance 'hemlock-text-view
1908                                                       :with-frame tv-frame
1909                                                       :text-container container))))
1910                (#/setDelegate: layout tv)
1911                (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize)))
1912                (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text))
1913                (#/setRichText: tv nil)
1914                (#/setAutoresizingMask: tv #$NSViewWidthSizable)
1915                (#/setBackgroundColor: tv color)
1916                (when (slot-exists-p textstorage 'styles)
1917                  (#/setTypingAttributes: tv (#/objectAtIndex:
1918                                              (#/styles textstorage) style)))
1919                #-cocotron
1920                (#/setSmartInsertDeleteEnabled: tv nil)
1921                (#/setAllowsUndo: tv nil) ; don't want NSTextView undo
1922                #-cocotron
1923                (#/setUsesFindPanel: tv t)
1924                #-cocotron
1925                (#/setUsesFontPanel: tv nil)
1926                (#/setMenu: tv (text-view-context-menu))
1927
1928                ;;  The container tracking and the text view sizability along a
1929                ;;  particular axis must always be different, or else things can
1930                ;;  get really confused (possibly causing an infinite loop).
1931
1932                (if (or tracks-width *wrap-lines-to-window*)
1933                  (progn
1934                    (#/setWidthTracksTextView: container t)
1935                    (#/setHeightTracksTextView: container nil)
1936                    (#/setHorizontallyResizable: tv nil)
1937                    (#/setVerticallyResizable: tv t))
1938                  (progn
1939                    (#/setWidthTracksTextView: container nil)
1940                    (#/setHeightTracksTextView: container nil)
1941                    (#/setHorizontallyResizable: tv t)
1942                    (#/setVerticallyResizable: tv t)))
1943                (#/setContentView: scrollview (make-instance 'text-pane-clip-view))
1944                (#/setDocumentView: scrollview tv)           
1945                (values tv scrollview)))))))))
1946
1947(defun make-scrolling-textview-for-pane (pane textstorage track-width color style)
1948  (let* ((contentrect (#/frame (#/contentView pane)) ))
1949    (multiple-value-bind (tv scrollview)
1950        (make-scrolling-text-view-for-textstorage
1951         textstorage
1952         (ns:ns-rect-x contentrect)
1953         (ns:ns-rect-y contentrect)
1954         (ns:ns-rect-width contentrect)
1955         (ns:ns-rect-height contentrect)
1956         track-width
1957         color
1958         style)
1959      (#/addSubview: pane scrollview)
1960      (let* ((r (#/frame scrollview)))
1961        (decf (ns:ns-rect-height r) 15)
1962        (incf (ns:ns-rect-y r) 15)
1963        (#/setFrame: scrollview r))
1964      #-cocotron
1965      (#/setAutohidesScrollers: scrollview t)
1966      (setf (slot-value pane 'scroll-view) scrollview
1967            (slot-value pane 'text-view) tv
1968            (slot-value tv 'pane) pane
1969            #|(slot-value scrollview 'pane) pane|#)
1970      ;;(let* ((modeline  (scroll-view-modeline scrollview)))
1971      (let* ((modeline  (make-instance 'modeline-view
1972                          :with-frame (ns:make-ns-rect 0 0 (ns:ns-rect-width contentrect)
1973                                                       15))))
1974        (#/setAutoresizingMask: modeline #$NSViewWidthSizable)
1975        (#/addSubview: pane modeline)
1976        (#/release modeline)
1977        (setf (slot-value pane 'mode-line) modeline
1978              (slot-value modeline 'pane) pane))
1979      tv)))
1980
1981(defmethod hemlock-view-size ((view hi:hemlock-view))
1982  (let* ((pane (hi::hemlock-view-pane view))
1983         (bounds (#/bounds (#/contentView (text-pane-scroll-view pane))))
1984         (tv (text-pane-text-view pane))
1985         (char-width (text-view-char-width tv))
1986         (line-height (text-view-line-height tv)))
1987    (values (floor (ns:ns-rect-width bounds) char-width)
1988            (floor (ns:ns-rect-height bounds) line-height))))
1989
1990
1991(defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane)
1992  #+debug (log-debug "change active pane to ~s" new-pane)
1993  (let* ((pane (hi::hemlock-view-pane view))
1994         (text-view (text-pane-text-view pane))
1995         (tv (ecase new-pane
1996               (:echo (slot-value text-view 'peer))
1997               (:text text-view))))
1998    (activate-hemlock-view tv)))
1999
2000(defclass echo-area-view (hemlock-textstorage-text-view)
2001    ()
2002  (:metaclass ns:+ns-object))
2003(declaim (special echo-area-view))
2004
2005(defmethod compute-temporary-attributes ((self echo-area-view))
2006)
2007
2008(defmethod update-paren-highlight ((self echo-area-view))
2009)
2010
2011;;; The "document" for an echo-area isn't a real NSDocument.
2012(defclass echo-area-document (ns:ns-object)
2013    ((textstorage :foreign-type :id))
2014  (:metaclass ns:+ns-object))
2015
2016(defmethod hemlock-buffer ((self echo-area-document))
2017  (let ((ts (slot-value self 'textstorage)))
2018    (unless (%null-ptr-p ts)
2019      (hemlock-buffer ts))))
2020
2021(objc:defmethod #/undoManager ((self echo-area-document))
2022  +null-ptr+) ;For now, undo is not supported for echo-areas
2023
2024(defmethod update-buffer-package ((doc echo-area-document))
2025  nil)
2026
2027(defmethod document-invalidate-modeline ((self echo-area-document))
2028  nil)
2029
2030(objc:defmethod (#/close :void) ((self echo-area-document))
2031  (let* ((ts (slot-value self 'textstorage)))
2032    (unless (%null-ptr-p ts)
2033      (setf (slot-value self 'textstorage) (%null-ptr))
2034      (close-hemlock-textstorage ts))))
2035
2036(objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :<NSD>ocument<C>hange<T>ype))
2037  (declare (ignore change)))
2038
2039(defun make-echo-area (the-hemlock-frame x y width height main-buffer color)
2040  (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height))))
2041    (#/setAutoresizingMask: box #$NSViewWidthSizable)
2042    (let* ((box-frame (#/bounds box))
2043           (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame)))
2044           (clipview (make-instance 'ns:ns-clip-view
2045                                    :with-frame box-frame)))
2046      (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable
2047                                               #$NSViewHeightSizable))
2048      (#/setBackgroundColor: clipview color)
2049      (#/addSubview: box clipview)
2050      (#/setAutoresizesSubviews: box t)
2051      (#/release clipview)
2052      (let* ((buffer (hi::make-echo-buffer))
2053             (textstorage
2054              (progn
2055                ;; What's the reason for sharing this?  Is it just the lock?
2056                (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer))
2057                (make-textstorage-for-hemlock-buffer buffer)))
2058             (doc (make-instance 'echo-area-document))
2059             (layout (make-instance 'ns:ns-layout-manager))
2060             (container (#/autorelease
2061                         (make-instance 'ns:ns-text-container
2062                                        :with-container-size
2063                                        containersize))))
2064        (#/addLayoutManager: textstorage layout)
2065        (#/setUsesScreenFonts: layout *use-screen-fonts*)
2066        (#/addTextContainer: layout container)
2067        (#/release layout)
2068        (let* ((echo (make-instance 'echo-area-view
2069                                    :with-frame box-frame
2070                                    :text-container container)))
2071          (#/setMinSize: echo (pref box-frame :<NSR>ect.size))
2072          (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text))
2073          (#/setRichText: echo nil)
2074          #-cocotron
2075          (#/setUsesFontPanel: echo nil)
2076          (#/setHorizontallyResizable: echo t)
2077          (#/setVerticallyResizable: echo nil)
2078          (#/setAutoresizingMask: echo #$NSViewNotSizable)
2079          (#/setBackgroundColor: echo color)
2080          (#/setWidthTracksTextView: container nil)
2081          (#/setHeightTracksTextView: container nil)
2082          (#/setMenu: echo +null-ptr+)
2083          (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer
2084                (slot-value doc 'textstorage) textstorage
2085                (hi::buffer-document buffer) doc)
2086          (#/setDocumentView: clipview echo)
2087          (#/setAutoresizesSubviews: clipview nil)
2088          (#/sizeToFit echo)
2089          (values echo box))))))
2090                   
2091(defun make-echo-area-for-window (w main-buffer color)
2092  (let* ((content-view (#/contentView w))
2093         (bounds (#/bounds content-view))
2094         (height (+ 1 (size-of-char-in-font *editor-font*))))
2095    (multiple-value-bind (echo-area box)
2096                         (make-echo-area w
2097                                         0.0f0
2098                                         0.0f0
2099                                         (- (ns:ns-rect-width bounds) 16.0f0)
2100                                         height
2101                                         main-buffer
2102                                         color)
2103      (#/addSubview: content-view box)
2104      echo-area)))
2105               
2106(defclass hemlock-frame (ns:ns-window)
2107    ((echo-area-view :foreign-type :id)
2108     (pane :foreign-type :id)
2109     (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
2110     (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream)
2111     (is-dup :initform nil)
2112     (wrap-lines-to-window :initform *wrap-lines-to-window*
2113                           :accessor wrap-lines-to-window))
2114  (:metaclass ns:+ns-object))
2115(declaim (special hemlock-frame))
2116
2117(objc:defmethod (#/setFrameAutosaveName: #>BOOL) ((self hemlock-frame)
2118                                                  string)
2119  (unless (slot-value self 'is-dup)
2120    (call-next-method string)))
2121
2122;;; If a window's document's edited status changes, update the modeline.
2123(objc:defmethod (#/setDocumentEdited: :void) ((w hemlock-frame)
2124                                              (edited #>BOOL))
2125  (let* ((was-edited (#/isDocumentEdited w)))
2126    (unless (eq was-edited edited)
2127      (#/setNeedsDisplay: (text-pane-mode-line (slot-value w 'pane)) t)))
2128  (call-next-method edited))
2129
2130(objc:defmethod (#/dealloc :void) ((self hemlock-frame))
2131  (let* ((pane (slot-value self 'pane))
2132         (echo-view (slot-value self 'echo-area-view)))
2133    (unless (%null-ptr-p pane)
2134      (setf (slot-value self 'pane) (%null-ptr))
2135      (#/release pane))
2136    (unless (%null-ptr-p echo-view)
2137      (setf (slot-value self 'echo-area-view) (%null-ptr))
2138      (#/release echo-view))
2139    (objc:remove-lisp-slots self)
2140    (call-next-method)))
2141 
2142
2143(objc:defmethod (#/miniaturize: :void) ((w hemlock-frame) sender)
2144  (let* ((event (#/currentEvent w))
2145         (flags (#/modifierFlags event)))
2146    (if (logtest #$NSControlKeyMask flags)
2147      (progn
2148        (#/orderOut: w nil)
2149        (#/changeWindowsItem:title:filename: *nsapp* w (#/title w) nil))
2150      (call-next-method sender))))
2151
2152(defmethod hemlock-view ((frame hemlock-frame))
2153  (let ((pane (slot-value frame 'pane)))
2154    (when (and pane (not (%null-ptr-p pane)))
2155      (hemlock-view pane))))
2156
2157(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message)
2158  #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
2159  (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
2160                       (if (logbitp 0 (random 2))
2161                         #@"Not OK, but what can you do?"
2162                         #@"The sky is falling. FRED never did this!")
2163                       +null-ptr+
2164                       +null-ptr+
2165                       self
2166                       self
2167                       +null-ptr+
2168                       +null-ptr+
2169                       +null-ptr+
2170                       message))
2171
2172(defun report-condition-in-hemlock-frame (condition frame)
2173  (assume-cocoa-thread)
2174  (let ((message (nsstring-for-lisp-condition condition)))
2175    (#/performSelectorOnMainThread:withObject:waitUntilDone:
2176     frame
2177     (@selector #/runErrorSheet:)
2178     message
2179     t)))
2180
2181(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition debug-p)
2182  (when debug-p (maybe-log-callback-error condition))
2183  (let ((pane (hi::hemlock-view-pane view)))
2184    (when (and pane (not (%null-ptr-p pane)))
2185      (report-condition-in-hemlock-frame condition (#/window pane)))))
2186
2187(defun window-menubar-height ()
2188  #+cocotron (objc:objc-message-send (ccl::@class "NSMainMenuView") "menuHeight" #>CGFloat)
2189  #-cocotron 0.0f0)
2190
2191
2192(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
2193  (let* ((window-content-view (#/contentView w))
2194         (window-frame (#/frame window-content-view)))
2195    (ns:with-ns-rect (pane-rect  0 reserve-below (ns:ns-rect-width window-frame) (- (ns:ns-rect-height window-frame) (+ reserve-above reserve-below)))
2196       (let* ((pane (make-instance 'text-pane :with-frame pane-rect)))
2197         (#/addSubview: window-content-view pane)
2198         (#/setDelegate: w pane)
2199         ;; Cocotron doesn't set the new window's initialFirstResponder which means
2200         ;; that the user must click in the window before they can edit.  So, do it here.
2201         ;; Remove this when Cocotron issue #374 is fixed
2202         ;;  (http://code.google.com/p/cocotron/issues/detail?id=374)
2203         #+cocotron (#/setInitialFirstResponder: w pane)
2204         pane))))
2205
2206(defun textpane-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
2207  (let* ((w (new-cocoa-window :class class :activate nil))
2208         (echo-area-height (+ 1 (size-of-char-in-font *editor-font*)))
2209         (pane (add-pane-to-window w :reserve-below echo-area-height)))
2210    (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color style)
2211    (multiple-value-bind (height width)
2212        (size-of-char-in-font (default-font))
2213      (size-text-pane pane height width nrows ncols))
2214    pane))
2215
2216
2217
2218
2219(defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
2220  (let* ((buffer (make-hemlock-buffer name :modes modes)))
2221    (nsstring-to-buffer nsstring buffer)))
2222
2223(defun %nsstring-to-hemlock-string (nsstring)
2224  "returns line-termination of string"
2225  (let* ((string (lisp-string-from-nsstring nsstring))
2226         (lfpos (position #\linefeed string))
2227         (crpos (position #\return string))
2228         (line-termination (if crpos
2229                             (if (eql lfpos (1+ crpos))
2230                               :crlf
2231                               :cr)
2232                             :unix))
2233         (hemlock-string (case line-termination
2234                           (:crlf (remove #\return string))
2235                           (:cr (nsubstitute #\linefeed #\return string))
2236                           (t string))))
2237    (values hemlock-string line-termination)))
2238
2239;: TODO: I think this is jumping through hoops because it want to be invokable outside the main
2240;; cocoa thread.
2241(defun nsstring-to-buffer (nsstring buffer)
2242  (let* ((document (hi::buffer-document buffer))
2243         (hi::*current-buffer* buffer)
2244         (region (hi::buffer-region buffer)))
2245    (multiple-value-bind (hemlock-string line-termination)
2246                         (%nsstring-to-hemlock-string nsstring)
2247      (setf (hi::buffer-line-termination buffer) line-termination)
2248
2249      (setf (hi::buffer-document buffer) nil) ;; What's this about??
2250      (unwind-protect
2251          (let ((point (hi::buffer-point buffer)))
2252            (hi::delete-region region)
2253            (hi::insert-string point hemlock-string)
2254            (setf (hi::buffer-modified buffer) nil)
2255            (hi::buffer-start point)
2256            ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping.
2257            (hi::renumber-region region)
2258            buffer)
2259        (setf (hi::buffer-document buffer) document)))))
2260
2261
2262(setq hi::*beep-function* #'(lambda (stream)
2263                              (declare (ignore stream))
2264                              (#_NSBeep)))
2265
2266
2267;;; This function must run in the main event thread.
2268(defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
2269  (assume-cocoa-thread)
2270  (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style))
2271         (buffer (hemlock-buffer ts))
2272         (frame (#/window pane))
2273         (echo-area (make-echo-area-for-window frame buffer color))
2274         (echo-buffer (hemlock-buffer (#/textStorage echo-area)))
2275         (tv (text-pane-text-view pane)))
2276    #+GZ (assert echo-buffer)
2277    (with-slots (peer) tv
2278      (setq peer echo-area))
2279    (with-slots (peer) echo-area
2280      (setq peer tv))
2281    (setf (slot-value frame 'echo-area-view) echo-area
2282          (slot-value frame 'pane) pane)
2283    (let* ((hemlock-view
2284            (make-instance 'hi:hemlock-view
2285                           :buffer buffer
2286                           :pane pane
2287                           :echo-area-buffer echo-buffer)))
2288      (setf (slot-value pane 'hemlock-view)
2289            hemlock-view
2290            (slot-value tv 'hemlock-view)
2291            hemlock-view
2292            (slot-value echo-area 'hemlock-view)
2293            hemlock-view))
2294    (activate-hemlock-view tv)
2295    frame))
2296
2297(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk)
2298  (assume-cocoa-thread)
2299  (when buffer ;; nil means just get rid of any prior buffer
2300    (setq buffer (require-type buffer 'hi::buffer)))
2301  (let ((old *buffer-being-edited*))
2302    (if (eq buffer old)
2303      (funcall thunk)
2304      (unwind-protect
2305          (progn
2306            (buffer-document-end-editing old)
2307            (buffer-document-begin-editing buffer)
2308            (funcall thunk))
2309        (buffer-document-end-editing buffer)
2310        (buffer-document-begin-editing old)))))
2311
2312(defun buffer-document-end-editing (buffer)
2313  (when buffer
2314    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
2315      (when document
2316        (setq *buffer-being-edited* nil)
2317        (let ((ts (slot-value document 'textstorage)))
2318          (#/endEditing ts)
2319          (update-hemlock-selection ts))))))
2320
2321(defun buffer-document-begin-editing (buffer)
2322  (when buffer
2323    (let* ((document (hi::buffer-document buffer)))
2324      (when document
2325        (setq *buffer-being-edited* buffer)
2326        (#/beginEditing (slot-value document 'textstorage))))))
2327
2328(defun document-edit-level (document)
2329  (assume-cocoa-thread) ;; see comment in #/editingInProgress
2330  (slot-value (slot-value document 'textstorage) 'edit-count))
2331
2332(defun buffer-edit-level (buffer)
2333  (if buffer
2334    (let* ((document (hi::buffer-document buffer)))
2335      (if document
2336        (document-edit-level document)
2337        0))
2338    0))
2339
2340(defun hemlock-ext:invoke-allowing-buffer-display (buffer thunk)
2341  ;; Call THUNK with the buffer's edit-level at 0, then restore the buffer's edit level.
2342  (let* ((level (buffer-edit-level buffer)))
2343    (dotimes (i level) (buffer-document-end-editing buffer))
2344    (unwind-protect
2345        (funcall thunk)
2346      (dotimes (i level) (buffer-document-begin-editing buffer)))))
2347
2348
2349(defun buffer-document-modified (buffer)
2350  (let* ((doc (hi::buffer-document buffer)))
2351    (if doc
2352      (#/isDocumentEdited doc))))
2353
2354(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
2355  (with-lock-grabbed (*buffer-change-invocation-lock*)
2356    (let* ((invocation *buffer-change-invocation*))
2357      (rlet ((ppos :<NSI>nteger pos)
2358             (pn :<NSI>nteger n)
2359             (pextra :<NSI>nteger extra))
2360        (#/setTarget: invocation textstorage)
2361        (#/setSelector: invocation selector)
2362        (#/setArgument:atIndex: invocation ppos 2)
2363        (#/setArgument:atIndex: invocation pn 3)
2364        (#/setArgument:atIndex: invocation pextra 4))
2365      (#/performSelectorOnMainThread:withObject:waitUntilDone:
2366       invocation
2367       (@selector #/invoke)
2368       +null-ptr+
2369       t))))
2370
2371
2372
2373
2374(defun hemlock-ext:buffer-note-font-change (buffer region font)
2375  (when (hi::bufferp buffer)
2376    (let* ((document (hi::buffer-document buffer))
2377           (textstorage (if document (slot-value document 'textstorage)))
2378           (pos (hi:mark-absolute-position (hi::region-start region)))
2379           (n (- (hi:mark-absolute-position (hi::region-end region)) pos)))
2380      (if (eq *current-process* *cocoa-event-process*)
2381        (#/noteHemlockAttrChangeAtPosition:length:fontNum: textstorage
2382                                                           pos
2383                                                           n
2384                                                           font)
2385        (perform-edit-change-notification textstorage
2386                                          (@selector #/noteHemlockAttrChangeAtPosition:length:fontNum:)
2387                                          pos
2388                                          n
2389                                          font)))))
2390
2391(defun buffer-active-font-attributes (buffer)
2392  (let* ((style 0)
2393         (region (hi::buffer-active-font-region buffer))
2394         (textstorage (slot-value (hi::buffer-document buffer) 'textstorage))
2395         (styles (#/styles textstorage)))
2396    (when region
2397      (let* ((start (hi::region-end region)))
2398        (setq style (hi::font-mark-font start))))
2399    (#/objectAtIndex: styles style)))
2400     
2401;; Note that inserted a string of length n at mark.  Assumes this is called after
2402;; buffer marks were updated.
2403(defun hemlock-ext:buffer-note-insertion (buffer mark n)
2404  (when (hi::bufferp buffer)
2405    (let* ((document (hi::buffer-document buffer))
2406           (textstorage (if document (slot-value document 'textstorage))))
2407      (when textstorage
2408        (let* ((pos (hi:mark-absolute-position mark)))
2409          (when (eq (hi::mark-%kind mark) :left-inserting)
2410            ;; Make up for the fact that the mark moved forward with the insertion.
2411            ;; For :right-inserting and :temporary marks, they should be left back.
2412            (decf pos n))
2413          (if (eq *current-process* *cocoa-event-process*)
2414            (#/noteHemlockInsertionAtPosition:length:extra: textstorage
2415                                                            pos
2416                                                            n
2417                                                            0)
2418            (perform-edit-change-notification textstorage
2419                                              (@selector #/noteHemlockInsertionAtPosition:length:extra:)
2420                                              pos
2421                                              n)))))))
2422
2423(defun hemlock-ext:buffer-note-modification (buffer mark n)
2424  (when (hi::bufferp buffer)
2425    (let* ((document (hi::buffer-document buffer))
2426           (textstorage (if document (slot-value document 'textstorage))))
2427      (when textstorage
2428        (if (eq *current-process* *cocoa-event-process*)
2429          (#/noteHemlockModificationAtPosition:length:extra: textstorage
2430                                                             (hi:mark-absolute-position mark)
2431                                                             n
2432                                                             0)
2433          (perform-edit-change-notification textstorage
2434                                            (@selector #/noteHemlockModificationAtPosition:length:extra:)
2435                                            (hi:mark-absolute-position mark)
2436                                            n))))))
2437 
2438
2439(defun hemlock-ext:buffer-note-deletion (buffer mark n)
2440  (when (hi::bufferp buffer)
2441    (let* ((document (hi::buffer-document buffer))
2442           (textstorage (if document (slot-value document 'textstorage))))
2443      (when textstorage
2444        (let* ((pos (hi:mark-absolute-position mark)))
2445          (if (eq *current-process* *cocoa-event-process*)
2446            (#/noteHemlockDeletionAtPosition:length:extra: textstorage
2447                                                           pos
2448                                                           (abs n)
2449                                                           0)
2450            (perform-edit-change-notification textstorage
2451                                              (@selector #/noteHemlockDeletionAtPosition:length:extra:)
2452                                              pos
2453                                              (abs n))))))))
2454
2455
2456
2457(defun hemlock-ext:note-buffer-saved (buffer)
2458  (assume-cocoa-thread)
2459  (let* ((document (hi::buffer-document buffer)))
2460    (when document
2461      ;; Hmm... I guess this is always done by the act of saving.
2462      nil)))
2463
2464(defun hemlock-ext:note-buffer-unsaved (buffer)
2465  (assume-cocoa-thread)
2466  (let* ((document (hi::buffer-document buffer)))
2467    (when document
2468      (#/updateChangeCount: document #$NSChangeCleared))))
2469
2470
2471(defun size-of-char-in-font (f)
2472  (let* ((sf (#/screenFont f))
2473         (screen-p *use-screen-fonts*))
2474    (if (%null-ptr-p sf) (setq sf f screen-p nil))
2475    (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager)))))
2476      (#/setUsesScreenFonts: layout screen-p)
2477      (values (fround (#/defaultLineHeightForFont: layout sf))
2478              (fround (ns:ns-size-width (#/advancementForGlyph: sf (char-code #\space))))))))
2479         
2480
2481
2482(defun size-text-pane (pane line-height char-width nrows ncols)
2483  (let* ((tv (text-pane-text-view pane))
2484         (height (fceiling (* nrows line-height)))
2485         (width (fceiling (* ncols char-width)))
2486         (scrollview (text-pane-scroll-view pane))
2487         (window (#/window scrollview))
2488         (has-horizontal-scroller (#/hasHorizontalScroller scrollview))
2489         (has-vertical-scroller (#/hasVerticalScroller scrollview)))
2490    (ns:with-ns-size (tv-size
2491                      (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv))))
2492                      height)
2493      (when has-vertical-scroller 
2494        (#/setVerticalLineScroll: scrollview line-height)
2495        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#))
2496      (when has-horizontal-scroller
2497        (#/setHorizontalLineScroll: scrollview char-width)
2498        (#/setHorizontalPageScroll: scrollview (cgfloat 0.0) #|char-width|#))
2499      (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview)))
2500             (pane-frame (#/frame pane))
2501             (margins (#/contentViewMargins pane)))
2502        (incf (ns:ns-size-height sv-size)
2503              (+ (ns:ns-rect-y pane-frame)
2504                 (* 2 (ns:ns-size-height  margins))))
2505        (incf (ns:ns-size-width sv-size)
2506              (ns:ns-size-width margins))
2507        (#/setContentSize: window sv-size)
2508        (setf (slot-value tv 'char-width) char-width
2509              (slot-value tv 'line-height) line-height)
2510        #-cocotron
2511        (#/setResizeIncrements: window
2512                                (ns:make-ns-size char-width line-height))))))
2513                                   
2514 
2515(defclass hemlock-editor-window-controller (ns:ns-window-controller)
2516  ((sequence :foreign-type :int))
2517  (:metaclass ns:+ns-object))
2518
2519;;; In certain cases, an NSTextView's selection changes without going
2520;;; through setSelectedRange: or similar methods.  In post-10.6
2521;;; systems, one of these cases is the find panel.  Synch up the
2522;;; selections between the NSTextView and the Hemlock buffer here.
2523(objc:defmethod (#/textViewDidChangeSelection: :void)
2524    ((self hemlock-editor-window-controller) notification)
2525  (let ((tv (#/object notification)))
2526    (with-hemlock-context (tv)
2527      (let ((buffer (hi:current-buffer)))
2528        (unless (> (buffer-edit-level buffer) 0) ;; if editing, hemlock position is the master position.
2529          (let* ((range (#/selectedRange tv))
2530                 (v0 (ns:ns-range-location range))
2531                 (v1 (+ v0 (ns:ns-range-length range))))
2532            (multiple-value-bind (b0 b1) (hi:buffer-selection-range buffer)
2533              ;; If the selections differ, synch them up.
2534              (unless (and (= b0 v0)
2535                           (= b1 v1))
2536                (let ((point (hi:buffer-point buffer)))
2537                  (hi:move-to-absolute-position point v0)
2538                  (when (> v1 v0)
2539                    (let ((mark (hi:copy-mark point :right-inserting)))
2540                      (hi:move-to-absolute-position mark v1)
2541                      (hemlock::%buffer-push-buffer-mark buffer mark t))))))))))))
2542
2543(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-editor-window-controller) docname)
2544  (let* ((seq (slot-value self 'sequence)))
2545    (if (zerop seq)
2546      docname
2547      (#/stringWithFormat: ns:ns-string #@"%@ <%d>" docname seq))))
2548 
2549
2550;;; This is borrowed from emacs.  The first click on the zoom button will
2551;;; zoom vertically.  The second will zoom completely.  The third will
2552;;; return to the original size.
2553(objc:defmethod (#/windowWillUseStandardFrame:defaultFrame: #>NSRect)
2554                ((wc hemlock-editor-window-controller) sender (default-frame #>NSRect))
2555  (let* ((r (#/frame sender)))
2556    (if (= (ns:ns-rect-height r) (ns:ns-rect-height default-frame))
2557      (setf r default-frame)
2558      (setf (ns:ns-rect-height r) (ns:ns-rect-height default-frame)
2559            (ns:ns-rect-y r) (ns:ns-rect-y default-frame)))
2560    r))
2561
2562(objc:defmethod (#/windowWillClose: :void) ((wc hemlock-editor-window-controller)
2563                                            notification)
2564  (declare (ignore notification))
2565  ;; The echo area "document" should probably be a slot in the document
2566  ;; object, and released when the document object is.
2567  (let* ((w (#/window wc)))
2568    ;; guard against cocotron lossage
2569    (if (#/isKindOfClass: w hemlock-frame)
2570      (let* ((buf (hemlock-frame-echo-area-buffer w))
2571             (echo-doc (if buf (hi::buffer-document buf))))
2572        (when echo-doc
2573          (setf (hemlock-frame-echo-area-buffer w) nil)
2574          (#/close echo-doc))
2575        (#/setFrameAutosaveName: w #@"")
2576        (#/autorelease w))
2577      (#_NSLog #@"window controller %@ got windowWillClose for odd window %@ "
2578               :address wc :address w))))
2579
2580(defmethod hemlock-view ((self hemlock-editor-window-controller))
2581  (let ((frame (#/window self)))
2582    (unless (%null-ptr-p frame)
2583      (hemlock-view frame))))
2584
2585#-cocotron
2586(defun nsstring-encoding-for-character-encoding-name (name)
2587  (let* ((string (string name))
2588         (len (length string)))
2589    (with-cstrs ((cstr string))
2590      (with-nsstr (nsstr cstr len)
2591        (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr)))
2592          (if (= cf #$kCFStringEncodingInvalidId)
2593            (setq cf (#_CFStringGetSystemEncoding)))
2594          (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf)))
2595            (if (= ns #$kCFStringEncodingInvalidId)
2596              (#/defaultCStringEncoding ns:ns-string)
2597              ns)))))))
2598
2599(defun nsstring-encoding-for-external-format (ef)
2600  (and ef (nsstring-encoding-for-character-encoding-name
2601           (ccl:external-format-character-encoding ef))))
2602
2603;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
2604(defun get-default-encoding ()
2605  #-cocotron                            ;need IANA conversion stuff
2606  (let* ((file-encoding *default-file-character-encoding*))
2607    (when (and (typep file-encoding 'keyword)
2608               (lookup-character-encoding file-encoding))
2609      (nsstring-encoding-for-character-encoding-name file-encoding))))
2610
2611(defclass hemlock-document-controller (ns:ns-document-controller)
2612    ((last-encoding :foreign-type :<NSS>tring<E>ncoding))
2613  (:metaclass ns:+ns-object))
2614(declaim (special hemlock-document-controller))
2615
2616(objc:defmethod #/init ((self hemlock-document-controller))
2617  (prog1
2618      (call-next-method)
2619    (setf (slot-value self 'last-encoding) 0)))
2620
2621
2622;;; The HemlockEditorDocument class.
2623
2624
2625(defclass hemlock-editor-document (ns:ns-document)
2626    ((textstorage :foreign-type :id)
2627     (encoding :foreign-type :<NSS>tring<E>ncoding)
2628     (dupcount :foreign-type :int))
2629  (:metaclass ns:+ns-object))
2630
2631(defmethod hemlock-buffer ((self hemlock-editor-document))
2632  (let ((ts (slot-value self 'textstorage)))
2633    (unless (%null-ptr-p ts)
2634      (hemlock-buffer ts))))
2635
2636(defmethod window-document ((w ns:ns-window))
2637  (let* ((sc (#/sharedDocumentController ns:ns-document-controller))
2638         (doc (#/documentForWindow: sc w)))
2639    (if (%null-ptr-p doc)
2640      nil
2641      doc)))
2642
2643(defmethod window-pathname ((w ns:ns-window))
2644  (document-pathname (window-document w)))
2645
2646(defmethod document-pathname ((doc NULL))
2647  nil)
2648
2649(defmethod document-pathname ((doc hemlock-editor-document))
2650  (hi:buffer-pathname (hemlock-buffer doc)))
2651
2652(defmethod assume-not-editing ((doc hemlock-editor-document))
2653  (assume-not-editing (slot-value doc 'textstorage)))
2654
2655(defmethod document-invalidate-modeline ((self hemlock-editor-document))
2656  (for-each-textview-using-storage
2657   (slot-value self 'textstorage)
2658   #'(lambda (tv)
2659       (let* ((pane (text-view-pane tv)))
2660         (unless (%null-ptr-p pane)
2661           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
2662
2663(defmethod update-buffer-package ((doc hemlock-editor-document))
2664  (hemlock:update-current-package))
2665
2666(defun hemlock-ext:note-selection-set-by-search (buffer)
2667  (let* ((doc (hi::buffer-document buffer)))
2668    (when doc
2669      (with-slots (textstorage) doc
2670        (when textstorage
2671          (with-slots (selection-set-by-search) textstorage
2672            (setq selection-set-by-search #$YES)))))))
2673
2674(objc:defmethod (#/validateMenuItem: :<BOOL>)
2675    ((self hemlock-text-view) item)
2676  (let* ((action (#/action item)))
2677    #+debug (#_NSLog #@"action = %s" :address action)
2678    (cond ((eql action (@selector #/hyperSpecLookUp:))
2679           (and *hyperspec-lookup-enabled*
2680                (hyperspec-root-url)
2681                (with-string-under-cursor (self selection)
2682                  (and selection (nth-value 1 (find-symbol (nstring-upcase selection) "CL"))))))
2683          ((eql action (@selector #/cut:))
2684           (let* ((selection (#/selectedRange self)))
2685             (and (> (ns:ns-range-length selection))
2686                  (#/shouldChangeTextInRange:replacementString: self selection #@""))))
2687          ((eql action (@selector #/evalSelection:))
2688           (when (hemlock-view self)
2689             (if (eql 0 (ns:ns-range-length (#/selectedRange self)))
2690               ;; Should check whether there is a current form
2691               (#/setTitle: item #@"Execute Expression")
2692               (#/setTitle: item #@"Execute Selection"))
2693             t))
2694          ((eql action (@selector #/evalAll:))
2695           (let* ((doc (#/document (#/windowController (#/window self)))))
2696             (and (not (%null-ptr-p doc))
2697                  (eq (type-of doc) 'hemlock-editor-document))))
2698          ;; if this hemlock-text-view is in an editor window and its buffer has
2699          ;; an associated pathname, then activate the Load Buffer item
2700          ((or (eql action (@selector #/loadBuffer:))
2701               (eql action (@selector #/compileBuffer:))
2702               (eql action (@selector #/compileAndLoadBuffer:))) 
2703           (let* ((buffer (hemlock-buffer self))
2704                  (pathname (hi::buffer-pathname buffer)))
2705             (not (null pathname))))
2706          ((eql action (@selector #/openSelection:))
2707           (with-string-under-cursor (self selection)
2708             (pathname-for-namestring-fragment selection)))
2709          ((or (eql action (@selector #/duplicate:))
2710               (eql action (@selector #/showListDefinitions:)))
2711           ;; Duplicating a listener "works", but listeners have all kinds
2712           ;; of references to the original window and text view and get
2713           ;; confused if the original is closed before all duplicates are.
2714           ;; Listing definitions is not applicable to listeners.
2715           (let* ((doc (#/document (#/windowController (#/window self)))))
2716             (not (typep doc 'hemlock-listener-document))))
2717           
2718          (t (call-next-method item)))))
2719
2720(defmethod user-input-style ((doc hemlock-editor-document))
2721  0)
2722
2723(defvar *encoding-name-hash* (make-hash-table))
2724
2725(defmethod document-encoding-name ((doc hemlock-editor-document))
2726  (with-slots (encoding) doc
2727    (if (eql encoding 0)
2728      "Automatic"
2729      (or (gethash encoding *encoding-name-hash*)
2730          (setf (gethash encoding *encoding-name-hash*)
2731                (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
2732
2733(defun hemlock-ext:buffer-encoding-name (buffer)
2734  (let ((doc (hi::buffer-document buffer)))
2735    (and doc (document-encoding-name doc))))
2736
2737;; TODO: make each buffer have a slot, and this is just the default value.
2738(defmethod textview-background-color ((doc hemlock-editor-document))
2739  *editor-background-color*)
2740
2741
2742(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts)
2743  (let* ((doc (%inc-ptr self 0))        ; workaround for stack-consed self
2744         (string (#/hemlockString ts))
2745         (buffer (hemlock-buffer string)))
2746    (unless (%null-ptr-p doc)
2747      (setf (slot-value doc 'textstorage) ts
2748            (hi::buffer-document buffer) doc))))
2749
2750;; This runs on the main thread.
2751(objc:defmethod (#/revertToSavedFromFile:ofType: :<BOOL>)
2752    ((self hemlock-editor-document) filename filetype)
2753  (declare (ignore filetype))
2754  (assume-cocoa-thread)
2755  #+debug
2756  (#_NSLog #@"revert to saved from file %@ of type %@"
2757           :id filename :id filetype)
2758  (let* ((encoding (slot-value self 'encoding))
2759         (nsstring (make-instance ns:ns-string
2760                                  :with-contents-of-file filename
2761                                  :encoding encoding
2762                                  :error +null-ptr+))
2763         (buffer (hemlock-buffer self))
2764         (old-length (hemlock-buffer-length buffer))
2765         (hi::*current-buffer* buffer)
2766         (textstorage (slot-value self 'textstorage))
2767         (point (hi::buffer-point buffer))
2768         (pointpos (hi:mark-absolute-position point)))
2769    (hemlock-ext:invoke-modifying-buffer-storage
2770     buffer
2771     #'(lambda ()
2772         (#/edited:range:changeInLength:
2773          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
2774         (nsstring-to-buffer nsstring buffer)
2775         (let* ((newlen (hemlock-buffer-length buffer)))
2776           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
2777           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
2778           (let* ((ts-string (#/hemlockString textstorage))
2779                  (display (hemlock-buffer-string-cache ts-string)))
2780             (reset-buffer-cache display) 
2781             (update-line-cache-for-index display 0)
2782             (move-hemlock-mark-to-absolute-position point
2783                                                     display
2784                                                     (min newlen pointpos))))
2785         (#/updateMirror textstorage)
2786         (setf (hi::buffer-modified buffer) nil)
2787         (hi::note-modeline-change buffer)))
2788    t))
2789
2790
2791(defvar *last-document-created* nil)
2792
2793(setf (hemlock::value hemlock::default-modes) '("Lisp" "Editor"))
2794
2795
2796(objc:defmethod #/init ((self hemlock-editor-document))
2797  (let* ((doc (call-next-method)))
2798    (unless  (%null-ptr-p doc)
2799      (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer
2800                              (make-hemlock-buffer
2801                               (lisp-string-from-nsstring
2802                                (#/displayName doc))))))
2803    (with-slots (encoding) doc
2804      (setq encoding (or (get-default-encoding) #$NSISOLatin1StringEncoding)))
2805    (setq *last-document-created* doc)
2806    doc))
2807
2808(defun make-buffer-for-document (ns-document pathname)
2809  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
2810         (buffer (make-hemlock-buffer buffer-name)))
2811    (setf (slot-value ns-document 'textstorage)
2812          (make-textstorage-for-hemlock-buffer buffer))
2813    (setf (hi::buffer-pathname buffer) pathname)
2814    buffer))
2815
2816;;; Try to read the URL's contents into an NSString which can be
2817;;; used to initialize the document's Hemlock buffer and related
2818;;; data structures.  First, try to use the encoding specified
2819;;; in the last call to the document controller's "open" panel;
2820;;; if that wasn't specified (was 0, "automatic") or if the string
2821;;; couldn't be initialized in that encoding, try to use the
2822;;; encoding specified in the "coding:" file option if that's present.
2823;;; If that wasn't specified or fails, fall back to the default
2824;;; encoding (based on CCL:*DEFAULT-FILE-CHARACTER-ENCODING*), and
2825;;; if that fails, try using :iso-8859-1 (which should always win
2826;;; but which may misinterpret some characters.)
2827;;; We should only lose because of a filesystem or permissions
2828;;; problem or because of a severe low-memory condition or something
2829;;; equally catastrophic.
2830;;; We should be careful to zero out the encoding from the last call
2831;;; to the "open" panel so that leftover value doesn't affect anything
2832;;; but the next call to this method, and if an encoding selected
2833;;; explicitly (via the "open" panel or the file-options line) didn't
2834;;; work, it'd be nice to (somehow) let the user know that.
2835;;; Whatever encoding works here is remembered as the document's
2836;;; encoding; that may be overridden when the file-options are parsed.
2837(objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
2838    ((self hemlock-editor-document) url type (perror (:* :id)))
2839  (declare (ignorable type))
2840  (with-callback-context "readFromURL"
2841    (let* ((data (#/dataWithContentsOfURL:options:error:
2842                  ns:ns-data url 0 perror))
2843           (bytes (#/bytes data))
2844           (length (#/length data))
2845           (pathname
2846            (lisp-string-from-nsstring
2847             (if (#/isFileURL url)
2848                   (#/path url)
2849               (#/absoluteString url))))
2850           (buffer (or (hemlock-buffer self)
2851                       (make-buffer-for-document self pathname)))
2852           (document-controller (#/sharedDocumentController (find-class 'hemlock-document-controller)))
2853           (string +null-ptr+))
2854      (flet ((try-encoding (encoding)
2855               (setq string 
2856                     (if (or (null encoding)
2857                             (zerop encoding))
2858                       +null-ptr+
2859                       (make-instance ns:ns-string
2860                                      :with-bytes-no-copy bytes
2861                                      :length length
2862                                      :encoding encoding
2863                                      :free-when-done nil)))
2864               (unless (%null-ptr-p string)
2865                 (setf (slot-value self 'encoding) encoding)
2866                 t)))
2867        (unless (try-encoding (with-slots (last-encoding) document-controller
2868                                (prog1 last-encoding
2869                                  (setq last-encoding 0))))
2870          (unless (try-encoding (nsstring-encoding-for-external-format (ccl::external-format-from-octet-buffer bytes length)))
2871            (unless (try-encoding (get-default-encoding))
2872              (try-encoding #$NSISOLatin1StringEncoding))))
2873        (unless (%null-ptr-p string)
2874          ;; ** TODO: Argh.  How about we just let hemlock insert it.
2875          (let* ((textstorage (slot-value self 'textstorage))
2876                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
2877                 (hi::*current-buffer* buffer))
2878            (hemlock-ext:invoke-modifying-buffer-storage
2879             buffer
2880             #'(lambda ()
2881                 (nsstring-to-buffer string buffer)
2882                 (reset-buffer-cache display) 
2883                 (#/updateMirror textstorage)
2884                 (update-line-cache-for-index display 0)
2885                 (textstorage-note-insertion-at-position
2886                  textstorage
2887                  0
2888                  (hemlock-buffer-length buffer))
2889                 (hi::note-modeline-change buffer)
2890                 (setf (hi::buffer-modified buffer) nil))))
2891            t)))))
2892
2893
2894
2895
2896(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files")
2897
2898(objc:defmethod (#/keepBackupFile :<BOOL>) ((self hemlock-editor-document))
2899  ;;; Don't use the NSDocument backup file scheme.
2900  nil)
2901
2902(objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :<BOOL>)
2903    ((self hemlock-editor-document)
2904     absolute-url
2905     type
2906     (save-operation :<NSS>ave<O>peration<T>ype)
2907     (error (:* :id)))
2908  (when (and *editor-keep-backup-files*
2909             (eql save-operation #$NSSaveOperation))
2910    (write-hemlock-backup-file (#/fileURL self)))
2911  (call-next-method absolute-url type save-operation error))
2912
2913(defun write-hemlock-backup-file (url)
2914  (unless (%null-ptr-p url)
2915    (when (#/isFileURL url)
2916      (let* ((path (#/path url)))
2917        (unless (%null-ptr-p path)
2918          (let* ((newpath (#/stringByAppendingString: path #@"~"))
2919                 (fm (#/defaultManager ns:ns-file-manager)))
2920            ;; There are all kinds of ways for this to lose.
2921            ;; In order for the copy to succeed, the destination can't exist.
2922            ;; (It might exist, but be a directory, or there could be
2923            ;; permission problems ...)
2924            (#/removeFileAtPath:handler: fm newpath +null-ptr+)
2925            (#/copyPath:toPath:handler: fm path newpath +null-ptr+)))))))
2926
2927             
2928
2929
2930
2931(defun hemlock-ext:all-hemlock-views ()
2932  "List of all hemlock views, in z-order, frontmost first"
2933  (loop for win in (windows)
2934    as buf = (and (typep win 'hemlock-frame) (hemlock-view win))
2935    when buf collect buf))
2936
2937(defmethod document-panes ((document hemlock-editor-document))
2938  (let* ((ts (slot-value document 'textstorage))
2939         (panes ()))
2940    (for-each-textview-using-storage
2941     ts
2942     #'(lambda (tv)
2943         (let* ((pane (text-view-pane tv)))
2944           (unless (%null-ptr-p pane)
2945             (push pane panes)))))
2946    panes))
2947
2948(objc:defmethod (#/noteEncodingChange: :void) ((self hemlock-editor-document)
2949                                               popup)
2950  (with-slots (encoding) self
2951    (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
2952    (hi::note-modeline-change (hemlock-buffer self))))
2953
2954#-cocotron
2955(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
2956                                               panel)
2957  (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller))))
2958      (#/setAction: popup (@selector #/noteEncodingChange:))
2959      (#/setTarget: popup self)
2960      (#/setAccessoryView: panel popup))
2961  (#/setExtensionHidden: panel nil)
2962  (#/setCanSelectHiddenExtension: panel nil)
2963  (#/setAllowedFileTypes: panel +null-ptr+)
2964  (call-next-method panel))
2965
2966
2967(defloadvar *ns-cr-string* (%make-nsstring (string #\return)))
2968(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed)))
2969(defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*))))
2970
2971(objc:defmethod (#/writeToURL:ofType:error: :<BOOL>)
2972    ((self hemlock-editor-document) url type (error (:* :id)))
2973  (declare (ignore type))
2974  (with-slots (encoding textstorage) self
2975    (let* ((string (#/string textstorage))
2976           (buffer (hemlock-buffer self)))
2977      (case (when buffer (hi::buffer-line-termination buffer))
2978        (:crlf (unless (typep string 'ns:ns-mutable-string)
2979                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
2980                 (#/replaceOccurrencesOfString:withString:options:range:
2981                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
2982        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
2983                            string
2984                            (make-instance 'ns:ns-mutable-string :with string string)))
2985             (#/replaceOccurrencesOfString:withString:options:range:
2986              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
2987      (when (#/writeToURL:atomically:encoding:error:
2988             string url t encoding error)
2989        (when buffer
2990          (setf (hi::buffer-modified buffer) nil))
2991        t))))
2992
2993;;; Cocotron's NSDocument uses the deprecated as of 10.4 methods to implement the NSSavePanel
2994#+cocotron
2995(objc:defmethod (#/writeToFile:ofType: :<BOOL>)
2996    ((self hemlock-editor-document) path type)
2997  (rlet ((perror :id +null-ptr+))
2998    (#/writeToURL:ofType:error: self (#/fileURLWithPath: ns:ns-url path) type perror)))
2999
3000
3001;;; Shadow the setFileURL: method, so that we can keep the buffer
3002;;; name and pathname in synch with the document.
3003(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document)
3004                                        url)
3005  (call-next-method url)
3006  (let* ((path nil)
3007         (controllers (#/windowControllers self)))
3008    (dotimes (i (#/count controllers))
3009      (let* ((controller (#/objectAtIndex: controllers i))
3010             (window (#/window controller)))
3011        (#/setFrameAutosaveName: window (or path (setq path (#/path url)))))))
3012  (let* ((buffer (hemlock-buffer self)))
3013    (when buffer
3014      (let* ((new-pathname (lisp-string-from-nsstring (#/path url))))
3015        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
3016        (setf (hi::buffer-pathname buffer) new-pathname)))))
3017
3018
3019(def-cocoa-default *initial-editor-x-pos* :float 20.0f0 "X position of upper-left corner of initial editor")
3020
3021(def-cocoa-default *initial-editor-y-pos* :float 10.0f0 "Y position of upper-left corner of initial editor")
3022
3023(defloadvar *editor-cascade-point* nil)
3024
3025(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized
3026(defloadvar *next-editor-y-pos* nil)
3027
3028(defun x-pos-for-window (window x)
3029  (let* ((frame (#/frame window))
3030         (screen (#/screen window)))
3031    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
3032    (let* ((screen-rect (#/visibleFrame screen)))
3033      (if (>= x 0)
3034        (+ x (ns:ns-rect-x screen-rect))
3035        (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame))))))
3036
3037(defun y-pos-for-window (window y)
3038  (let* ((frame (#/frame window))
3039         (screen (#/screen window)))
3040    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
3041    (let* ((screen-rect (#/visibleFrame screen)))
3042      (if (>= y 0)
3043        (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame))
3044        (+ (ns:ns-rect-height screen-rect) y)))))
3045
3046(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document))
3047  #+debug
3048  (#_NSLog #@"Make window controllers")
3049    (let* ((textstorage  (slot-value self 'textstorage))
3050           (window (%hemlock-frame-for-textstorage
3051                    hemlock-frame
3052                    textstorage
3053                    *editor-columns*
3054                    *editor-rows*
3055                    nil
3056                    (textview-background-color self)
3057                    (user-input-style self)))
3058           (dupcount (slot-value self 'dupcount))
3059           (controller (make-instance
3060                           'hemlock-editor-window-controller
3061                         :with-window window))
3062           (url (#/fileURL self))
3063           (path (unless (%null-ptr-p url) (#/path url))))
3064      ;;(#/setDelegate: window self)
3065      (#/setDelegate: window controller)
3066      (setf (slot-value controller 'sequence) dupcount)
3067      (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) controller)
3068      (#/addWindowController: self controller)
3069      (#/release controller)
3070      (#/setShouldCascadeWindows: controller nil)
3071      (unless (eql dupcount 0)
3072        (setf (slot-value window 'is-dup) t))
3073      (when path
3074        (unless (and (eql dupcount 0) (#/setFrameAutosaveName: window path))
3075          (setq path nil)))
3076      (unless (and path
3077                   (#/setFrameUsingName: window path))
3078        ;; Cascade windows from the top left corner of the topmost editor window.
3079        ;; If there's no editor window, use the default position.
3080        (flet ((editor-window-p (w)
3081                 (and (not (eql w window))
3082                      (eql (#/class (#/windowController w))
3083                           (find-class 'hemlock-editor-window-controller)))))
3084          (let* ((editors (remove-if-not #'editor-window-p (windows)))
3085                 (top-editor (car editors)))
3086            (if top-editor
3087              (ns:with-ns-point (zp 0 0)
3088                (setq *editor-cascade-point* (#/cascadeTopLeftFromPoint:
3089                                              top-editor zp)))
3090              (let* ((screen-frame (#/visibleFrame (#/screen window)))
3091                     (pt (ns:make-ns-point *initial-editor-x-pos*
3092                                           (- (ns:ns-rect-height screen-frame)
3093                                              *initial-editor-y-pos*))))
3094                (setq *editor-cascade-point* pt)))))
3095        (#/cascadeTopLeftFromPoint: window *editor-cascade-point*))
3096      (when (eql dupcount 0)
3097        (let ((view (hemlock-view window)))
3098          (hi::handle-hemlock-event view #'(lambda ()
3099                                             (hi::process-file-options)))))
3100      (#/synchronizeWindowTitleWithDocumentName controller)))
3101
3102(objc:defmethod (#/duplicate: :void) ((self hemlock-frame) sender)
3103  (declare (ignorable sender))
3104  (let* ((self-controller (#/windowController self))
3105         (doc (#/document self-controller)))
3106    (when (typep doc 'hemlock-editor-document)
3107      (with-hemlock-context (self) ;; default values from this view when creating new view
3108        (let* ((sequence-number (incf (slot-value doc 'dupcount))))
3109          (#/makeWindowControllers doc) ;; creates hemlock-view
3110          ;; Now we have to find the window controller that was just made ...
3111          (let* ((controllers (#/windowControllers doc))
3112                 (count (#/count controllers))
3113                 (controller (dotimes (i count)
3114                               (let* ((c (#/objectAtIndex: controllers i)))
3115                                 (when (eql sequence-number (slot-value c 'sequence))
3116                                   (return c))))))
3117           
3118            (when controller
3119              (let* ((window (#/window controller))
3120                     (new-text-view (text-pane-text-view (slot-value window 'pane))))
3121                (update-hemlock-selection (#/textStorage new-text-view))
3122                (#/scrollRangeToVisible: new-text-view
3123                                         (#/selectedRange new-text-view))
3124                (#/makeKeyAndOrderFront: window +null-ptr+)))))))))
3125             
3126     
3127
3128(objc:defmethod (#/close :void) ((self hemlock-editor-document))
3129  #+debug
3130  (#_NSLog #@"Document close: %@" :id self)
3131  (let* ((textstorage (slot-value self 'textstorage)))
3132    (unless (%null-ptr-p textstorage)
3133      (setf (slot-value self 'textstorage) (%null-ptr))
3134      (close-hemlock-textstorage textstorage)))
3135  (call-next-method))
3136
3137(objc:defmethod (#/dealloc :void) ((self hemlock-editor-document))
3138  (let* ((textstorage (slot-value self 'textstorage)))
3139    (unless (%null-ptr-p textstorage)
3140      (setf (slot-value self 'textstorage) (%null-ptr))
3141      (close-hemlock-textstorage textstorage)))
3142  (objc:remove-lisp-slots self)
3143  (call-next-method))
3144
3145
3146
3147(defmethod view-screen-lines ((view hi:hemlock-view))
3148    (let* ((pane (hi::hemlock-view-pane view)))
3149      (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane)))
3150             (text-view-line-height (text-pane-text-view pane)))))
3151
3152;; Beware this doesn't seem to take horizontal scrolling into account.
3153(defun visible-charpos-range (tv)
3154  (let* ((rect (#/visibleRect tv))
3155         (container-origin (#/textContainerOrigin tv))
3156         (layout (#/layoutManager tv)))
3157    ;; Convert from view coordinates to container coordinates
3158    (decf (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
3159    (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y))
3160    (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
3161                         layout rect (#/textContainer tv)))
3162           (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
3163                        layout glyph-range +null-ptr+)))
3164      (values (pref char-range :<NSR>ange.location)
3165              (pref char-range :<NSR>ange.length)))))
3166
3167(defun charpos-xy (tv charpos)
3168  (let* ((layout (#/layoutManager tv))
3169         (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
3170                       layout
3171                       (ns:make-ns-range charpos 0)
3172                       +null-ptr+))
3173         (rect (#/boundingRectForGlyphRange:inTextContainer:
3174                layout
3175                glyph-range
3176                (#/textContainer tv)))
3177         (container-origin (#/textContainerOrigin tv)))
3178    (values (+ (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
3179            (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y)))))
3180
3181;;(nth-value 1 (charpos-xy tv (visible-charpos-range tv))) - this is smaller as it
3182;; only includes lines fully scrolled off...
3183(defun text-view-vscroll (tv)
3184  ;; Return the number of pixels scrolled off the top of the view.
3185  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
3186         (clip-view (#/contentView scroll-view))
3187         (bounds (#/bounds clip-view)))
3188    (ns:ns-rect-y bounds)))
3189
3190(defun set-text-view-vscroll (tv vscroll)
3191  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
3192         (clip-view (#/contentView scroll-view))
3193         (bounds (#/bounds clip-view)))
3194    (decf vscroll (mod vscroll (text-view-line-height tv))) ;; show whole line
3195    (ns:with-ns-point (new-origin (ns:ns-rect-x bounds) vscroll)
3196      (#/scrollToPoint: clip-view (#/constrainScrollPoint: clip-view new-origin))
3197      (#/reflectScrolledClipView: scroll-view clip-view))))
3198
3199(defun scroll-by-lines (tv nlines)
3200  "Change the vertical origin of the containing scrollview's clipview"
3201  (set-text-view-vscroll tv (+ (text-view-vscroll tv)
3202                               (* nlines (text-view-line-height tv)))))
3203
3204;; TODO: should be a hemlock variable..
3205(defvar *next-screen-context-lines* 2)
3206
3207(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where)
3208  (assume-cocoa-thread)
3209  (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view)))
3210         (may-change-selection t))
3211    (when (eq how :line)
3212      (setq where (require-type where '(integer 0)))
3213      (let* ((line-y (nth-value 1 (charpos-xy tv where)))
3214             (top-y (text-view-vscroll tv))
3215             (nlines (floor (- line-y top-y) (text-view-line-height tv))))
3216        (setq how :lines-down where nlines)))
3217    (ecase how
3218      (:center-selection
3219       (#/centerSelectionInVisibleArea: tv +null-ptr+))
3220      ((:page-up :view-page-up)
3221       (when (eq how :view-page-up)
3222         (setq may-change-selection nil))
3223       (require-type where 'null)
3224       ;; TODO: next-screen-context-lines
3225       (scroll-by-lines tv (- *next-screen-context-lines* (view-screen-lines view))))
3226      ((:page-down :view-page-down)
3227       (when (eq how :view-page-down)
3228         (setq may-change-selection nil))
3229       (require-type where 'null)
3230       (scroll-by-lines tv (- (view-screen-lines view) *next-screen-context-lines*)))
3231      (:lines-up
3232       (scroll-by-lines tv (- (require-type where 'integer))))
3233      (:lines-down
3234       (scroll-by-lines tv (require-type where 'integer))))
3235    ;; If point is not on screen, move it.
3236    (when may-change-selection
3237      (let* ((point (hi::current-point))
3238             (point-pos (hi::mark-absolute-position point)))
3239        (multiple-value-bind (win-pos win-len) (visible-charpos-range tv)
3240          (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
3241            (let* ((point (hi::current-point-collapsing-selection))
3242                   (cache (hemlock-buffer-string-cache (#/hemlockString (#/textStorage tv)))))
3243              (move-hemlock-mark-to-absolute-position point cache win-pos)
3244              (update-hemlock-selection (#/textStorage tv)))))))))
3245
3246(defun iana-charset-name-of-nsstringencoding (ns)
3247  #+cocotron (declare (ignore ns))
3248  #+cocotron +null-ptr+
3249  #-cocotron
3250  (#_CFStringConvertEncodingToIANACharSetName
3251   (#_CFStringConvertNSStringEncodingToEncoding ns)))
3252   
3253(defun nsstring-for-nsstring-encoding (ns)
3254  (let* ((iana (iana-charset-name-of-nsstringencoding ns)))
3255    (if (%null-ptr-p iana)
3256      (#/stringWithFormat: ns:ns-string #@"{%@}"
3257                           (#/localizedNameOfStringEncoding: ns:ns-string ns))
3258      iana)))
3259
3260;;; Return T if the specified #>NSStringEncoding names something that
3261;;; CCL supports.  (Could also have a set of other encoding names that
3262;;; the user is interested in, maintained by preferences.
3263
3264(defun supported-string-encoding-p (ns-string-encoding)
3265  #-cocotron
3266  (let* ((cfname (#_CFStringConvertEncodingToIANACharSetName
3267                  (#_CFStringConvertNSStringEncodingToEncoding ns-string-encoding)))
3268         (name (unless (%null-ptr-p cfname)
3269                 (nstring-upcase (ccl::lisp-string-from-nsstring cfname))))
3270         (keyword (when (and name (find-symbol name "KEYWORD"))
3271                    (intern name "KEYWORD"))))
3272    (or (and keyword (not (null (lookup-character-encoding keyword))))
3273        ;; look in other table maintained by preferences
3274        )))
3275   
3276         
3277
3278
3279 
3280;;; Return a list of :<NSS>tring<E>ncodings, sorted by the
3281;;; (localized) name of each encoding.
3282(defun supported-nsstring-encodings ()
3283  (ccl::collect ((ids))
3284    (let* ((ns-ids (#/availableStringEncodings ns:ns-string)))
3285      (unless (%null-ptr-p ns-ids)
3286        (do* ((i 0 (1+ i)))
3287             ()
3288          (let* ((id (paref ns-ids (:* :<NSS>tring<E>ncoding) i)))
3289            (if (zerop id)
3290              (return (sort (ids)
3291                            #'(lambda (x y)
3292                                (= #$NSOrderedAscending
3293                                   (#/localizedCompare:
3294                                    (nsstring-for-nsstring-encoding x)
3295                                    (nsstring-for-nsstring-encoding y))))))
3296              (when (supported-string-encoding-p id)             
3297                (ids id)))))))))
3298
3299
3300
3301
3302
3303;;; TexEdit.app has support for allowing the encoding list in this
3304;;; popup to be customized (e.g., to suppress encodings that the
3305;;; user isn't interested in.)
3306(defmethod build-encodings-popup ((self hemlock-document-controller)
3307                                  &optional preferred-encoding)
3308  (declare (ignorable preferred-encoding))
3309  (let* ((id-list (supported-nsstring-encodings))
3310         (popup (make-instance 'ns:ns-pop-up-button)))
3311    ;;; Add a fake "Automatic" item with tag 0.
3312    (#/addItemWithTitle: popup #@"Automatic")
3313    (#/setTag: (#/itemAtIndex: popup 0) 0)
3314    (dolist (id id-list)
3315      (#/addItemWithTitle: popup (nsstring-for-nsstring-encoding id))
3316      (#/setTag: (#/lastItem popup) (nsstring-encoding-to-nsinteger id)))
3317    (#/selectItemWithTag: popup (if preferred-encoding (nsstring-encoding-to-nsinteger preferred-encoding) 0))
3318    (#/sizeToFit popup)
3319    popup))
3320
3321
3322(objc:defmethod (#/runModalOpenPanel:forTypes: :<NSI>nteger)
3323    ((self hemlock-document-controller) panel types)
3324  (let* (#-cocotron (popup (build-encodings-popup self #|preferred|#)))
3325    #-cocotron (#/setAccessoryView: panel popup)
3326    (let* ((result (call-next-method panel types)))
3327      (when (= result #$NSOKButton)
3328        #-cocotron
3329        (with-slots (last-encoding) self
3330          (setq last-encoding
3331                (nsinteger-to-nsstring-encoding (#/tag (#/selectedItem popup))))))
3332      result)))
3333 
3334(defun hemlock-ext:open-hemlock-buffer (&key (pathname :prompt))
3335  (assert (eq pathname :prompt)) ;; TODO: should handle pathname
3336  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3337   (#/sharedDocumentController hemlock-document-controller)
3338   (@selector #/openDocument:) +null-ptr+ t))
3339 
3340(defun hemlock-ext:save-hemlock-buffer (buffer &key pathname copy)
3341  (let ((doc (hi::buffer-document buffer)))
3342    (cond (copy
3343           (assert (eq pathname :prompt)) ;; TODO: should handle pathname
3344           (save-hemlock-document-as doc))
3345          ((null pathname)
3346           (save-hemlock-document doc))
3347          (t
3348           (assert (eq pathname :prompt)) ;; TODO: should handle pathname
3349           (save-hemlock-document-to doc)))))
3350
3351(defmethod save-hemlock-document ((self hemlock-editor-document))
3352  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3353   self (@selector #/saveDocument:) +null-ptr+ t))
3354
3355(defmethod save-hemlock-document-as ((self hemlock-editor-document))
3356  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3357   self (@selector #/saveDocumentAs:) +null-ptr+ t))
3358
3359(defmethod save-hemlock-document-to ((self hemlock-editor-document))
3360  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3361   self (@selector #/saveDocumentTo:) +null-ptr+ t))
3362
3363
3364
3365
3366   
3367
3368(defun initialize-user-interface ()
3369  ;; The first created instance of an NSDocumentController (or
3370  ;; subclass thereof) becomes the shared document controller.  So it
3371  ;; may look like we're dropping this instance on the floor, but
3372  ;; we're really not.
3373  (make-instance 'hemlock-document-controller)
3374  ;(#/sharedPanel lisp-preferences-panel)
3375  (make-editor-style-map))
3376 
3377
3378;;; This needs to run on the main thread.  Sets the cocoa selection from the
3379;;; hemlock selection.
3380(defmethod update-hemlock-selection ((self hemlock-text-storage))
3381  (assume-cocoa-thread)
3382  (for-each-textview-using-storage
3383   self
3384   (lambda (tv)
3385     (with-hemlock-context (tv)
3386       (multiple-value-bind (start end) (hi:buffer-selection-range (hi:current-buffer))
3387         #+debug
3388         (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
3389                  :int (hi::mark-charpos (hi:current-point)) :int start)
3390         (#/updateSelection:length:affinity: tv
3391                                             start
3392                                             (- end start)
3393                                             (if (eql start 0)
3394                                               #$NSSelectionAffinityUpstream
3395                                               #$NSSelectionAffinityDownstream)))))))
3396
3397;; This should be invoked by any command that modifies the buffer, so it can show the
3398;; user what happened...  This ensures the Cocoa selection is made visible, so it
3399;; assumes the Cocoa selection has already been synchronized with the hemlock one.
3400(defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view))
3401  (let ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
3402    (#/scrollRangeToVisible: tv (#/selectedRange tv))))
3403
3404(defun hemlock-ext:string-to-clipboard (string)
3405  (when (> (length string) 0)
3406    (with-cfstring (s string)
3407      (#/performSelectorOnMainThread:withObject:waitUntilDone:
3408       *nsapp* (@selector #/stringToPasteBoard:) s t))))
3409
3410#+cocotron
3411;;; Work around a byte-order bug that affects #/paste.
3412(defun maybe-byte-reverse-string (nsstring)
3413  (let* ((len (#/length nsstring))
3414         (maybe-reversed-count  0))
3415    (dotimes (i len)
3416      (when (not (logtest #xff (#/characterAtIndex: nsstring i)))
3417        (incf maybe-reversed-count)))
3418    (if (> maybe-reversed-count (ash len -1))
3419      (%stack-block ((chars (* 2 len)))
3420        (ns:with-ns-range (r 0 len)
3421          (#/getCharacters:range: nsstring chars r)
3422          (dotimes (i len)
3423            (declare (fixnum i))
3424            (let* ((j (+ i i)))
3425              (declare (fixnum j))
3426              (let* ((w (%get-unsigned-word chars j)))
3427                (setf (%get-unsigned-word chars j)
3428                      (dpb (ldb (byte 8 0) w)
3429                           (byte 8 8)
3430                           (ldb (byte 8 8) w))))))
3431
3432           
3433          (#/autorelease
3434           (make-instance ns:ns-string
3435                          :with-characters chars
3436                          :length len))))
3437      nsstring)))
3438                       
3439                   
3440                                                           
3441;;; The default #/paste method seems to want to set the font to
3442;;; something ... inappropriate.  If we can figure out why it
3443;;; does that and persuade it not to, we wouldn't have to do
3444;;; this here.
3445;;; (It's likely to also be the case that Carbon applications
3446;;; terminate lines with #\Return when writing to the clipboard;
3447;;; we may need to continue to override this method in order to
3448;;; fix that.)
3449(objc:defmethod (#/paste: :void) ((self hemlock-textstorage-text-view) sender)
3450  (declare (ignorable sender))
3451  #+debug (#_NSLog #@"Paste: sender = %@" :id sender)
3452  (let* ((pb (#/generalPasteboard ns:ns-pasteboard))
3453         (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType))))
3454    #+debug (log-debug "   string = ~s" string)
3455    (unless (%null-ptr-p string)
3456      #+cocotron (setq string (maybe-byte-reverse-string string))
3457      (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*)))
3458        (setq string (make-instance 'ns:ns-mutable-string :with-string string))
3459        (#/replaceOccurrencesOfString:withString:options:range:
3460                string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))
3461      (let* ((textstorage (#/textStorage self)))
3462        (unless (#/shouldChangeTextInRange:replacementString: self (#/selectedRange self) string)
3463          (#/setSelectedRange: self (ns:make-ns-range (#/length textstorage) 0)))
3464        (let* ((selectedrange (#/selectedRange self)))
3465          ;; We really should bracket the call to
3466          ;; #/repaceCharactersInRange:withString: here with calls
3467          ;; to #/beginEditing and #/endEditing, but our implementation
3468          ;; of #/replaceCharactersInRange:withString: calls code that
3469          ;; asserts that editing isn't in progress.  Once that's
3470          ;; fixed, this should be fixed as well.
3471          (#/beginEditing textstorage)
3472          (#/replaceCharactersInRange:withString: textstorage selectedrange string)
3473          (#/endEditing textstorage)
3474          (update-hemlock-selection textstorage) )))))
3475
3476(objc:defmethod (#/hyperSpecLookUp: :void) ((self hemlock-text-view) sender)
3477  (declare (ignore sender))
3478  (with-string-under-cursor (self selection)
3479    (multiple-value-bind (symbol win) (find-symbol (nstring-upcase selection) "CL")
3480      (when win
3481        (lookup-hyperspec-symbol symbol self)))))
3482
3483;; This is called by stuff that makes a window programmatically, e.g. m-. or grep.
3484;; But the Open and New menus invoke the cocoa fns below directly. So just changing
3485;; things here will not change how the menus create views.  Instead,f make changes to
3486;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers.
3487(defun find-or-make-hemlock-view (&optional pathname)
3488  (assume-cocoa-thread)
3489  (rlet ((perror :id +null-ptr+))
3490    (let* ((doc (if pathname
3491                  (#/openDocumentWithContentsOfURL:display:error:
3492                   (#/sharedDocumentController ns:ns-document-controller)
3493                   (pathname-to-url (truename pathname))
3494                   #$YES
3495                   perror)
3496                  (let ((*last-document-created* nil))
3497                    (#/newDocument: 
3498                     (#/sharedDocumentController hemlock-document-controller)
3499                     +null-ptr+)
3500                    *last-document-created*))))
3501      #+debug (log-debug "created ~s" doc)
3502      (when (%null-ptr-p doc)
3503        (error "Couldn't open ~s: ~a" pathname
3504               (let ((error (pref perror :id)))
3505                 (if (%null-ptr-p error)
3506                   "unknown error encountered"
3507                   (lisp-string-from-nsstring (#/localizedDescription error))))))
3508      (front-view-for-buffer (hemlock-buffer doc)))))
3509
3510;; Execute in cocoa thread in a dynamic context that allows hemlock buffer functions to work.
3511;; The function should not modify the buffer, since display will not be updated, for that go
3512;; through hi::handle-hemlock-event instead.
3513(defun execute-in-buffer (buffer thunk)
3514  (check-type buffer hi:buffer)
3515  (let ((emsg nil))
3516    (multiple-value-prog1
3517        (execute-in-gui (lambda ()
3518                         (block exit
3519                           (handler-bind ((error (lambda (cc)
3520                                                   (setq emsg
3521                                                         (with-standard-io-syntax
3522                                                             (or (ignore-errors (princ-to-string cc))
3523                                                                 "#<error printing error message>")))
3524                                                   (return-from exit))))
3525                             (let ((hi::*current-buffer* buffer))
3526                               (funcall thunk))))))
3527      (when emsg (error "~a" emsg)))))
3528
3529
3530
3531(defun hemlock-ext:execute-in-file-view (pathname thunk)
3532  (execute-in-gui #'(lambda ()
3533                      (assume-cocoa-thread)
3534                      (handler-case
3535                          (let ((view (find-or-make-hemlock-view pathname)))
3536                            (hi::handle-hemlock-event view thunk))
3537                        (error (c)
3538                          (alert-window :title "Error in Hemlock command processing"
3539                                        :message (or (ignore-errors (princ-to-string c))
3540                                                     "#<error printing error message>")
3541                                        :default-button "Ok"))))))
3542
3543;; Bring view to front.
3544(defun hemlock-ext:select-view (view)
3545  (execute-in-gui (lambda ()
3546                    (#/makeKeyAndOrderFront: (#/window (hi::hemlock-view-pane view)) (%null-ptr)))))
3547
3548(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
3549  (make-instance 'sequence-window-controller
3550    :title title
3551    :sequence sequence
3552    :result-callback action
3553    :display printer))
3554
3555(objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
3556                                                    type)
3557  (if (#/isEqualToString: type #@"html")
3558      display-document
3559      (call-next-method type)))
3560     
3561
3562(objc:defmethod #/newDisplayDocumentWithTitle:content:
3563                ((self hemlock-document-controller)
3564                 title
3565                 string)
3566  (assume-cocoa-thread)
3567  (let* ((doc #+cocotron (#/makeUntitledDocumentOfType: self #@"html")
3568              #-cocotron (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+)))
3569    (unless (%null-ptr-p doc)
3570      (#/addDocument: self doc)
3571      (#/makeWindowControllers doc)
3572      (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0))))
3573        (#/setTitle: window title)
3574        (let* ((tv (slot-value doc 'text-view))
3575               (lm (#/layoutManager tv))
3576               (ts (#/textStorage lm)))
3577          (#/beginEditing ts)
3578          (#/replaceCharactersInRange:withAttributedString:
3579           ts
3580           (ns:make-ns-range 0 (#/length ts))
3581           string)
3582          (#/endEditing ts))
3583        (#/makeKeyAndOrderFront: window self)))
3584    doc))
3585
3586(defun hemlock-ext:revert-hemlock-buffer (buffer)
3587  (let* ((doc (hi::buffer-document buffer)))
3588    (when doc
3589      (#/performSelectorOnMainThread:withObject:waitUntilDone:
3590       doc
3591       (@selector #/revertDocumentToSaved:)
3592       +null-ptr+
3593       t))))
3594
3595(defun hemlock-ext:raise-buffer-view (buffer &optional action)
3596  "Bring a window containing buffer to front and then execute action in
3597   the window.  Returns before operation completes."
3598  ;; Queue for after this event, so don't screw up current context.
3599  (queue-for-gui #'(lambda ()
3600                     (let ((doc (hi::buffer-document buffer)))
3601                       (unless (and doc (not (%null-ptr-p doc)))
3602                         (hi:editor-error "Deleted buffer: ~s" buffer))
3603                       (#/showWindows doc)
3604                       (when action
3605                         (hi::handle-hemlock-event (front-view-for-buffer buffer) action))))))
3606
3607;;; Enable CL:ED
3608(defun cocoa-edit (&optional arg)
3609  (cond ((or (null arg)
3610             (typep arg 'string)
3611             (typep arg 'pathname))
3612         (when arg
3613           (unless (probe-file arg)
3614             (let ((lpath (merge-pathnames arg *.lisp-pathname*)))
3615               (when (probe-file lpath) (setq arg lpath)))))
3616         ;; Avoid taking the error inside gui.
3617         (truename arg)
3618         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
3619        ((ccl::valid-function-name-p arg)
3620         (hemlock:edit-definition arg)
3621         nil)
3622        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
3623
3624(setq ccl::*resident-editor-hook* 'cocoa-edit)
3625
3626#-cocotron
3627(defclass url-handler-command (ns:ns-script-command)
3628  ()
3629  (:documentation
3630   "Handles AppleEvents that send us URLs to open. Both logical pathnames
3631    ('ccl:lib;foo.lisp') and symbols (ccl::*current-process*) can be parsed as a URL
3632    with a scheme of 'ccl'. So, we accept those as URLs, and handle them appropriately.")
3633  (:metaclass ns:+ns-script-command))
3634
3635#-cocotron
3636(objc:defmethod #/performDefaultImplementation ((self url-handler-command))
3637  (let* ((string (ccl::lisp-string-from-nsstring (#/directParameter self)))
3638         (symbol (let ((*read-eval* nil))
3639                   (handler-case (read-from-string string)
3640                     (error () nil)))))
3641    (if symbol
3642      (hemlock:edit-definition symbol)
3643      (execute-in-gui #'(lambda ()
3644                          (find-or-make-hemlock-view
3645                           (if (probe-file string)
3646                             string
3647                             (let ((lpath (merge-pathnames string *.lisp-pathname*)))
3648                               (when (probe-file lpath)
3649                                 lpath))))))))
3650  +null-ptr+)
3651
Note: See TracBrowser for help on using the repository browser.