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

Last change on this file since 16088 was 16088, checked in by svspire, 8 years ago

When wrapping lines to window, support doing line breaks at spaces between words rather than at the nearest character.
(setf gui::*default-line-break-mode* :word) for this behavior
[must set this before opening the window on which you want it to take effect]
Partially addresses ticket:1172

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