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

Last change on this file since 15291 was 15291, checked in by gb, 8 years ago

cocoa-ide/app-delegate.lisp: move MAYBE-FIXUP-APPLICATION-MENU here,
split it off from INITIALIZE-USER-INTERFACE, call it in delegate's
#/applicationWillFinishLaunching: method

cf-utils.lisp: don't depend on read-time behavior of #_ in macroexpansions.

cocoa-application.lisp: try to nuke command-line args when this file
is loaded (so that Cocoa doesn't try to process things like '-e
\(require \"COCOA-APPLICATION\"\)'.)

cocoa-backtrace.lisp: in COUNT-STACK-DESCRIPTOR-FRAME, only count
frames that satisfy CCL::FUNCTION-FRAME-P. (I believe that this is
correct for some fairly subtle reason that I don't remember ...)

cocoa-editor.lisp,cocoa-listener.lisp: better support multiple views/windows
on the same buffer. (The listener support should more-or-less work, but
there are secondary listener-specific issues.

Add an item to a Hemlock text view's context menu which offers to duplicate
the current window; that creates a new window/view hierarchy that shares
the text view's buffer and document but maintains view-specific selection
state. Windows and views created via this menu item are functionally
equvalent to the original; if the shared document is modified, the Cocoa
document architecture will offer to save it (on those OSX versions that
trust the appliance owner/user to make this sort of decision ...) when the
last window sharing the document is closed. (The last window needn't be
the original.) Listeners have state (streams) that refer to the original
window/view and closing that window/view before closing secondary windows
doesn't work; we need to either change how listener streams work or make
it hard to close the original window when duplicates of it still exist,
but I haven't done this.

The HEMLOCK-VIEW for a text view/echo-area view is maintained in a slot;
the idea's to make it a bit easier to embed multiple text views (which
may refer to multiple buffers) in a window (where the concept of "the
window's HEMLOCK-VIEW" may not apply.)

hemlock/src/command.lisp: a buffer's mark-ring is just a field referenced
by a BUFFER structure, not the value of a buffer-local Hemlock variable.

hemlock/src/killcoms.lisp: mark-ring changes, don't put any reasonable
number of consecutive Ds on the kill ring.

hemlock/src/lispmode.lisp: don't loop forever at end/beginning of buffer
in %LIST-OFFSET macro. Provide a terse description of the error in most
EDITOR-ERROR calls in this file.

hemlock/src/morecoms.lisp: mark-ring changes.

hemlock/src/struct.lisp: move some fields (-point, -%mark, the mark-ring,
the active region indicator) from BUFFER to a new SELECTION-INFO struct
that BUFFER references; redefine traditional accessors to indirect through
the SELECTION-INFO. (Views can maintain their own SELECTION-INFO; view-based
operations temporarily install the view's SELECTION-INFO in the buffer.)

Add a TEXTSTORAGE slot to BUFFER; the idea (NYI) is that buffers can have
Cocoa textstorage associated with them independent of the buffer's DOCUMENT
object.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 158.4 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 :char)
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;;; referenence 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-left-pos :foreign-type #>NSUInteger :accessor text-view-paren-highlight-left-pos)
914     (paren-highlight-right-pos :foreign-type #>NSUInteger :accessor text-view-paren-highlight-right-pos)
915     (paren-highlight-color-attribute :foreign-type :id :accessor text-view-paren-highlight-color)
916     (paren-highlight-enabled :foreign-type #>BOOL :accessor text-view-paren-highlight-enabled)
917     (peer :foreign-type :id)
918     (hemlock-view :initform nil)
919     (selection-info :initform nil :accessor view-selection-info))
920  (:metaclass ns:+ns-object))
921(declaim (special hemlock-textstorage-text-view))
922
923#| causes more problems than it solves.
924   removed until a better implementation manifests itself --me
925(objc:defmethod (#/performDragOperation: #>BOOL)
926    ((self hemlock-textstorage-text-view)
927     (sender :id))
928  (let* ((pboard (#/draggingPasteboard sender))
929         (pbTypes (#/arrayWithObjects: ns:ns-array #&NSFilenamesPboardType
930                                       +null-ptr+))
931         (available-type (#/availableTypeFromArray: pboard pbTypes)))
932    (if (%null-ptr-p available-type)
933        (progn (log-debug "No data available of type NSFilenamesPboardType")
934               (call-next-method sender))
935        (let* ((plist (#/propertyListForType: pboard #&NSFilenamesPboardType)))
936          (cond
937            ;; we found NSFilenamesPboardType and it's an array of pathnames
938            ((#/isKindOfClass: plist ns:ns-array)
939             (with-autorelease-pool
940               (let* ((strings-for-dropped-objects
941                       (mapcar (lambda (d)
942                                 (if (#/isKindOfClass: d ns:ns-string)
943                                     (ccl::lisp-string-from-nsstring d)
944                                     (#/description d)))
945                               (list-from-ns-array plist)))
946                      (canonical-dropped-paths
947                       (mapcar (lambda (s)
948                                 (if (and (probe-file s)
949                                          (directoryp s))
950                                     (ccl::ensure-directory-pathname s)
951                                     s))
952                               strings-for-dropped-objects))
953                      (dropstr (if (= (length canonical-dropped-paths) 1)
954                                   (with-output-to-string (out)
955                                     (format out "~S~%" (first canonical-dropped-paths)))
956                                   nil)))
957                 ;; TODO: insert them in the window
958                 (if dropstr
959                     (let* ((hview (hemlock-view self))
960                            (buf (hi:hemlock-view-buffer hview))
961                            (point (hi::buffer-point buf))
962                            (hi::*current-buffer* buf))
963                       (hi::insert-string point dropstr)
964                       #$YES)
965                     #$NO))))
966            ;; we found NSFilenamesPboardType, but didn't get an array of pathnames; huh???
967            (t (log-debug "hemlock-textstorage-text-view received an unrecognized data type in a drag operation: '~S'"
968                          (#/description plist))
969               (call-next-method sender)))))))
970|#
971
972(defmethod hemlock-view ((self hemlock-textstorage-text-view))
973  (slot-value self 'hemlock-view))
974
975
976(defmethod activate-hemlock-view ((self hemlock-textstorage-text-view))
977  (assume-cocoa-thread)
978  (let* ((the-hemlock-frame (#/window self)))
979    #+debug (log-debug "Activating ~s" self)
980    (with-slots ((echo peer)) self
981      (deactivate-hemlock-view echo))
982    (#/setEditable: self t)
983    (#/makeFirstResponder: the-hemlock-frame self)))
984
985(defmethod deactivate-hemlock-view ((self hemlock-textstorage-text-view))
986  (assume-cocoa-thread)
987  #+debug (log-debug "deactivating ~s" self)
988  (assume-not-editing self)
989  (#/setSelectable: self nil)
990  (disable-paren-highlight self))
991
992
993
994     
995
996(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view))
997  ;; Return true if cmd-. is in the queue.  Not sure what to do about c-g:
998  ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe
999  ;; c-g will need to be synchronous meaning just end current command,
1000  ;; while cmd-. is the real abort.
1001  #|
1002   (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0)))
1003    (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue:
1004                         target (logior #$whatever) now #&NSDefaultRunLoopMode t)))
1005            (when (%null-ptr-p event) (return)))))
1006  "target" can either be an NSWindow or the global shared application object;
1007  |#
1008  nil)
1009
1010(defvar *buffer-being-edited* nil)
1011
1012#-darwin-target
1013(objc:defmethod (#/hasMarkedText #>BOOL) ((self hemlock-textstorage-text-view))
1014  nil)
1015
1016(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event)
1017  #+debug (#_NSLog #@"Key down event in %@  = %@" :id self :address event)
1018  (let* ((view (hemlock-view self))
1019         ;; quote-p means handle characters natively
1020         (quote-p (and view (hi::hemlock-view-quote-next-p view))))
1021    #+debug (log-debug "~&quote-p ~s event ~s" quote-p event)
1022    (cond ((or (null view) (#/hasMarkedText self) (eq quote-p :native))
1023           (when (and quote-p (not (eq quote-p :native)))       ;; see ticket:461
1024             (setf (hi::hemlock-view-quote-next-p view) nil))
1025           (call-next-method event))
1026          ((not (eventqueue-abort-pending-p self))
1027           (let ((hemlock-key (nsevent-to-key-event event quote-p)))
1028             (if (and hemlock-key
1029                      (not (hi:native-key-event-p hemlock-key)))
1030               (progn
1031                 (#/setHiddenUntilMouseMoves: ns:ns-cursor t)
1032                 (hi::handle-hemlock-event view hemlock-key))
1033               (call-next-method event)))))))
1034
1035
1036(defmacro with-view-selection-info ((text-view buffer) &body body)
1037  (let* ((old (gensym)))
1038    `(let* ((,old (hi::buffer-selection-info ,buffer)))
1039      (unwind-protect
1040           (progn
1041             (setf (hi::buffer-selection-info ,buffer)
1042                   (view-selection-info ,text-view))
1043             ,@body)
1044        (setf (hi::buffer-selection-info ,buffer) ,old)))))
1045     
1046(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
1047  (declare (ignore event))
1048  (with-view-selection-info ((text-pane-text-view (hi::hemlock-view-pane view))
1049                             (hi::hemlock-view-buffer view))
1050    (with-autorelease-pool
1051        (call-next-method))))
1052
1053(defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift"))
1054
1055;;; Translate a keyDown NSEvent to a Hemlock key-event.
1056(defun nsevent-to-key-event (event quote-p)
1057  (let* ((modifiers (#/modifierFlags event)))
1058    (unless (logtest #$NSCommandKeyMask modifiers)
1059      (let* ((native-chars (#/characters event))
1060             (native-len (if (%null-ptr-p native-chars)
1061                           0
1062                           (#/length native-chars)))
1063             (native-c (and (eql 1 native-len)
1064                            (#/characterAtIndex: native-chars 0)))
1065             (option-p (logtest #$NSAlternateKeyMask modifiers)))
1066        ;; If a standalone dead key (e.g. ^'` on a French keyboard,) was pressed,
1067        ;; reverse the meaning of quote-p, i.e. use the system meaning if NOT quoted.
1068        ;; (I have no idea what makes standalone dead keys somehow different from
1069        ;; non-standalone dead keys).
1070        (when (and (not option-p) (eql 0 native-len))
1071          (setq quote-p (not quote-p)))
1072        (let ((c (if (or quote-p
1073                         (and option-p
1074                              (or (not *option-is-meta*)
1075                                  #-cocotron
1076                                  (and native-c
1077                                       (ccl::valid-char-code-p native-c)
1078                                       (standard-char-p (code-char (the ccl::valid-char-code native-c)))))
1079                              (setq quote-p t)))
1080                   native-c
1081                   (let ((chars (#/charactersIgnoringModifiers event)))
1082                     (and (not (%null-ptr-p chars))
1083                          (eql 1 (#/length chars))
1084                          (#/characterAtIndex: chars 0))))))
1085          (when c
1086            (let ((bits 0)
1087                  (useful-modifiers (logandc2 modifiers
1088                                              (logior
1089                                               ;;#$NSShiftKeyMask
1090                                               #$NSAlphaShiftKeyMask))))
1091              (unless quote-p
1092                (dolist (map hi:*modifier-translations*)
1093                  (when (logtest useful-modifiers (car map))
1094                    (setq bits (logior bits
1095                                       (hi:key-event-modifier-mask (cdr map)))))))
1096              (let* ((char (code-char c)))
1097                (when (and char (alpha-char-p char))
1098                  (setq bits (logandc2 bits +shift-event-mask+)))
1099                (when (logtest #$NSAlphaShiftKeyMask modifiers)
1100                  (setf c (char-code (char-upcase char)))))
1101              (hi:make-key-event c bits))))))))
1102
1103;; For now, this is only used to abort i-search.  All actual mouse handling is done
1104;; by Cocoa.   In the future might want to allow users to extend via hemlock, e.g.
1105;; to implement mouse-copy.
1106;; Also -- shouldn't this happen on mouse up?
1107(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
1108  ;; If no modifier keys are pressed, send hemlock a no-op.
1109  ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect)
1110  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
1111    (let* ((view (hemlock-view self)))
1112      (when view
1113        (unless (eventqueue-abort-pending-p self)
1114          (hi::handle-hemlock-event view #k"leftdown")))))
1115  (call-next-method event))
1116
1117(defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
1118  (assume-not-editing (#/textStorage tv)))
1119
1120(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view)
1121                                        sender)
1122  (declare (ignorable sender))
1123  #+debug (#_NSLog #@"Change color to = %@" :id (#/color sender)))
1124
1125(def-cocoa-default *layout-text-in-background* :bool t "When true, do text layout when idle.")
1126
1127(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void)
1128    ((self hemlock-textstorage-text-view) layout cont (flag :<BOOL>))
1129  (declare (ignorable cont flag))
1130  #+debug (#_NSLog #@"layout complete: container = %@, atend = %d" :id cont :int (if flag 1 0))
1131  (unless *layout-text-in-background*
1132    (#/setDelegate: layout +null-ptr+)
1133    #-cocotron
1134    (#/setBackgroundLayoutEnabled: layout nil)))
1135
1136(defloadvar *paren-highlight-background-color* ())
1137
1138(defun paren-highlight-background-color ()
1139  (or *paren-highlight-background-color*
1140      (setq *paren-highlight-background-color*
1141            (#/retain (#/colorWithCalibratedRed:green:blue:alpha:
1142                       ns:ns-color
1143                       .3
1144                       .875
1145                       .8125
1146                       1.0)))))
1147                                                       
1148
1149(defmethod remove-paren-highlight ((self hemlock-textstorage-text-view))
1150  #-cocotron
1151  (let* ((left (text-view-paren-highlight-left-pos self))
1152         (right (text-view-paren-highlight-right-pos self)))
1153    (ns:with-ns-range (char-range left 1)
1154      (let* ((layout (#/layoutManager self)))
1155        (#/removeTemporaryAttribute:forCharacterRange: layout
1156                                                       #&NSBackgroundColorAttributeName
1157                                                       char-range)
1158        (setf (pref char-range #>NSRange.location) right)
1159        (#/removeTemporaryAttribute:forCharacterRange: layout
1160                                                       #&NSBackgroundColorAttributeName
1161                                                       char-range))))
1162  ;;; This assumes that NSBackgroundColorAttributeName can only be
1163  ;;; present id it's (possibly stale) paren highlighting info.
1164  ;;; We can't be sure of the locations (because of insertions/deletions),
1165  ;;; so remove the attribute from the entire textstorage.
1166  #+cocotron
1167  (let* ((textstorage (#/textStorage self))
1168         (len (#/length textstorage)))
1169    (#/beginEditing textstorage)
1170    (ns:with-ns-range (char-range 0 len)
1171      (#/removeAttribute:range: textstorage #&NSBackgroundColorAttributeName
1172                                char-range))
1173    (#/endEditing textstorage)))
1174
1175(defmethod disable-paren-highlight ((self hemlock-textstorage-text-view))
1176  (when (eql (text-view-paren-highlight-enabled self) #$YES)
1177    (setf (text-view-paren-highlight-enabled self) #$NO)
1178    (remove-paren-highlight self)))
1179
1180
1181(defmethod compute-temporary-attributes ((self hemlock-textstorage-text-view))
1182  #-cocotron
1183  (let* ((container (#/textContainer self))
1184         ;; If there's a containing scroll view, use its contentview         
1185         ;; Otherwise, just use the current view.
1186         (scrollview (#/enclosingScrollView self))
1187         (contentview (if (%null-ptr-p scrollview) self (#/contentView scrollview)))
1188         (rect (#/bounds contentview))
1189         (layout (#/layoutManager container))
1190         (glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
1191                       layout rect container))
1192         (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
1193                      layout glyph-range +null-ptr+))
1194         (start (ns:ns-range-location char-range))
1195         (length (ns:ns-range-length char-range)))
1196    (when (> length 0)
1197      ;; Remove all temporary attributes from the character range
1198      (#/removeTemporaryAttribute:forCharacterRange:
1199       layout #&NSForegroundColorAttributeName char-range)
1200      (#/removeTemporaryAttribute:forCharacterRange:
1201       layout #&NSBackgroundColorAttributeName char-range)
1202      (let* ((ts (#/textStorage self))
1203             (cache (hemlock-buffer-string-cache (slot-value ts 'hemlock-string)))
1204             (hi::*current-buffer* (buffer-cache-buffer cache)))
1205        (multiple-value-bind (start-line start-offset)
1206            (update-line-cache-for-index cache start)
1207          (let* ((end-line (update-line-cache-for-index cache (+ start length))))
1208            (set-temporary-character-attributes
1209             layout
1210             (- start start-offset)
1211             start-line
1212             (hi::line-next end-line)))))))
1213  (when (eql #$YES (text-view-paren-highlight-enabled self))
1214    (let* ((background #&NSBackgroundColorAttributeName)
1215           (paren-highlight-left (text-view-paren-highlight-left-pos self))
1216           (paren-highlight-right (text-view-paren-highlight-right-pos self))
1217           (paren-highlight-color (text-view-paren-highlight-color self))
1218           (attrs (#/dictionaryWithObject:forKey: ns:ns-dictionary
1219                                                  paren-highlight-color
1220                                                  background)))
1221      (ns:with-ns-range (left-range paren-highlight-left 1)
1222        (ns:with-ns-range (right-range paren-highlight-right 1)
1223          #-cocotron
1224          (let ((layout (#/layoutManager (#/textContainer self))))
1225            (#/addTemporaryAttributes:forCharacterRange: layout attrs left-range)
1226            (#/addTemporaryAttributes:forCharacterRange: layout attrs right-range))
1227          #+cocotron
1228          (let ((ts (#/textStorage self)))
1229            (#/beginEditing ts)
1230            (#/addAttributes:range: ts attrs left-range)
1231            (#/addAttributes:range: ts attrs right-range)
1232            (#/endEditing ts)))))))
1233
1234(defmethod update-paren-highlight ((self hemlock-textstorage-text-view))
1235  (disable-paren-highlight self)
1236  (let* ((buffer (hemlock-buffer self)))
1237    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
1238      (let* ((hi::*current-buffer* buffer)
1239             (point (hi::buffer-point buffer)))
1240        #+debug (#_NSLog #@"Syntax check for paren-highlighting")
1241        (update-buffer-package (hi::buffer-document buffer) buffer)
1242        (cond ((eql (hi::next-character point) #\()
1243               (hemlock::pre-command-parse-check point)
1244               (when (hemlock::valid-spot point t)
1245                 (hi::with-mark ((temp point))
1246                   (when (hemlock::list-offset temp 1)
1247                     #+debug (#_NSLog #@"enable paren-highlight, forward")
1248                     (setf (text-view-paren-highlight-right-pos self)
1249                           (1- (hi:mark-absolute-position temp))
1250                           (text-view-paren-highlight-left-pos self)
1251                           (hi::mark-absolute-position point)
1252                           (text-view-paren-highlight-enabled self) #$YES)))))
1253              ((eql (hi::previous-character point) #\))
1254               (hemlock::pre-command-parse-check point)
1255               (when (hemlock::valid-spot point nil)
1256                 (hi::with-mark ((temp point))
1257                   (when (hemlock::list-offset temp -1)
1258                     #+debug (#_NSLog #@"enable paren-highlight, backward")
1259                     (setf (text-view-paren-highlight-left-pos self)
1260                           (hi:mark-absolute-position temp)
1261                           (text-view-paren-highlight-right-pos self)
1262                           (1- (hi:mark-absolute-position point))
1263                           (text-view-paren-highlight-enabled self) #$YES))))))
1264        (compute-temporary-attributes self)))))
1265
1266
1267
1268;;; Set and display the selection at pos, whose length is len and whose
1269;;; affinity is affinity.  This should never be called from any Cocoa
1270;;; event handler; it should not call anything that'll try to set the
1271;;; underlying buffer's point and/or mark
1272
1273(objc:defmethod (#/updateSelection:length:affinity: :void)
1274    ((self hemlock-textstorage-text-view)
1275     (pos :int)
1276     (length :int)
1277     (affinity :<NSS>election<A>ffinity))
1278  (assume-cocoa-thread)
1279  (when (eql length 0)
1280    (update-paren-highlight self))
1281  (let* ((buffer (hemlock-buffer self)))
1282    (with-view-selection-info (self buffer)
1283      (setf (hi::buffer-selection-set-by-command buffer) (> length 0))
1284      (rlet ((range :ns-range :location pos :length length))
1285        (ccl::%call-next-objc-method self
1286                                     hemlock-textstorage-text-view
1287                                     (@selector #/setSelectedRange:affinity:stillSelecting:)
1288                                     '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
1289                                     range
1290                                     affinity
1291                                     nil)
1292        (assume-not-editing self)
1293        (when (> length 0)
1294          (let* ((ts (#/textStorage self)))
1295            (with-slots (selection-set-by-search) ts
1296              (when (prog1 (eql #$YES selection-set-by-search)
1297                      (setq selection-set-by-search #$NO))
1298                (highlight-search-selection self pos length)))))
1299    ))))
1300
1301(defloadvar *can-use-show-find-indicator-for-range*
1302    (#/instancesRespondToSelector: ns:ns-text-view (@selector "showFindIndicatorForRange:")))
1303
1304;;; Add transient highlighting to a selection established via a search
1305;;; primitive, if the OS supports it.
1306(defun highlight-search-selection (tv pos length)
1307  (when *can-use-show-find-indicator-for-range*
1308    (ns:with-ns-range (r pos length)
1309      (objc-message-send tv "showFindIndicatorForRange:" :<NSR>ange r :void))))
1310 
1311;;; A specialized NSTextView. The NSTextView is part of the "pane"
1312;;; object that displays buffers.
1313(defclass hemlock-text-view (hemlock-textstorage-text-view)
1314    ((pane :foreign-type :id :accessor text-view-pane)
1315     (char-width :foreign-type :<CGF>loat :accessor text-view-char-width)
1316     (line-height :foreign-type :<CGF>loat :accessor text-view-line-height))
1317  (:metaclass ns:+ns-object))
1318(declaim (special hemlock-text-view))
1319
1320(objc:defmethod (#/duplicate: :void) ((self hemlock-text-view) sender)
1321  (#/duplicate: (#/window self) sender))
1322
1323
1324(defloadvar *lisp-string-color* (#/blueColor ns:ns-color))
1325(defloadvar *lisp-comment-color* (#/brownColor ns:ns-color))
1326
1327;;; LAYOUT is an NSLayoutManager in which we'll set temporary character
1328;;; attrubutes before redisplay.
1329;;; POS is the absolute character position of the start of START-LINE.
1330;;; END-LINE is either EQ to START-LNE (in the degenerate case) or
1331;;; follows it in the buffer; it may be NIL and is the exclusive
1332;;; end of a range of lines
1333;;; HI::*CURRENT-BUFFER* is bound to the buffer containing START-LINE
1334;;; and END-LINE
1335#-cocotron
1336(defun set-temporary-character-attributes (layout pos start-line end-line)
1337  (ns:with-ns-range (range)
1338    (let* ((color-attribute #&NSForegroundColorAttributeName)
1339           (string-color  *lisp-string-color* )
1340           (comment-color *lisp-comment-color*))
1341      (hi::with-mark ((m (hi::buffer-start-mark hi::*current-buffer*)))
1342        (hi::line-start m start-line)
1343        (hi::pre-command-parse-check m))
1344      (do ((p pos (+ p (1+ (hi::line-length line))))
1345           (line start-line (hi::line-next line)))
1346          ((eq line end-line))
1347        (let* ((parse-info (getf (hi::line-plist line) 'hemlock::lisp-info))
1348               (last-end 0))
1349          (when parse-info
1350            (dolist (r (hemlock::lisp-info-ranges-to-ignore parse-info))
1351              (destructuring-bind (istart . iend) r
1352                (let* ((attr (if (= istart 0)
1353                               (hemlock::lisp-info-begins-quoted parse-info)
1354                               (if (< last-end istart)
1355                                 (hi:character-attribute :lisp-syntax
1356                                                         (hi::line-character line (1- istart)))
1357                                 :comment)))
1358                       (type (case attr
1359                               ((:char-quote :symbol-quote) nil)
1360                               (:string-quote :string)
1361                               (t :comment)))
1362                       (start (+ p istart))
1363                       (len (- iend istart)))
1364                  (when type
1365                    (when (eq type :string)
1366                      (decf start)
1367                      (incf len 2))
1368                    (setf (ns:ns-range-location range) start
1369                          (ns:ns-range-length range) len)
1370                    (let ((attrs (if (eq type :string) string-color comment-color)))
1371                      (#/addTemporaryAttribute:value:forCharacterRange:
1372                       layout color-attribute attrs range)))
1373                  (setq last-end iend))))))))))
1374
1375#+no
1376(objc:defmethod (#/drawRect: :void) ((self hemlock-text-view) (rect :<NSR>ect))
1377  ;; Um, don't forget to actually draw the view..
1378  (call-next-method  rect))
1379
1380
1381
1382(defmethod hemlock-view ((self hemlock-text-view))
1383  (slot-value self 'hemlock-view))
1384
1385(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender)
1386  (declare (ignore sender))
1387  (let* ((view (hemlock-view self)))
1388    (when view
1389      (hi::handle-hemlock-event view #'(lambda ()
1390                                         (hemlock::editor-execute-expression-command nil))))))
1391
1392(objc:defmethod (#/evalAll: :void) ((self hemlock-text-view) sender)
1393  (declare (ignore sender))
1394  (let* ((buffer (hemlock-buffer self))
1395         (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
1396         (pathname (hi::buffer-pathname buffer))
1397         (s (lisp-string-from-nsstring (#/string self))))
1398    (ui-object-eval-selection *NSApp* (list package-name pathname s))))
1399
1400(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender)
1401  (declare (ignore sender))
1402  (let* ((buffer (hemlock-buffer self))
1403         (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
1404         (pathname (hi::buffer-pathname buffer)))
1405    (ui-object-load-buffer *NSApp* (list package-name pathname))))
1406
1407(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender)
1408  (declare (ignore sender))
1409  (let* ((buffer (hemlock-buffer self))
1410         (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
1411         (pathname (hi::buffer-pathname buffer)))
1412    (ui-object-compile-buffer *NSApp* (list package-name pathname))))
1413
1414(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender)
1415  (declare (ignore sender))
1416  (let* ((buffer (hemlock-buffer self))
1417         (package-name (hi::variable-value 'hemlock::default-package :buffer buffer))
1418         (pathname (hi::buffer-pathname buffer)))
1419    (ui-object-compile-and-load-buffer *NSApp* (list package-name pathname))))
1420
1421(defloadvar *text-view-context-menu* ())
1422
1423(defun text-view-context-menu ()
1424  (or *text-view-context-menu*
1425      (setq *text-view-context-menu*
1426            (#/retain
1427             (let* ((menu (make-instance 'ns:ns-menu :with-title #@"Menu")))
1428               (#/addItemWithTitle:action:keyEquivalent:
1429                menu #@"Cut" (@selector #/cut:) #@"")
1430               (#/addItemWithTitle:action:keyEquivalent:
1431                menu #@"Copy" (@selector #/copy:) #@"")
1432               (#/addItemWithTitle:action:keyEquivalent:
1433                menu #@"Paste" (@selector #/paste:) #@"")
1434               ;; Separator
1435               (#/addItem: menu (#/separatorItem ns:ns-menu-item))
1436               (#/addItemWithTitle:action:keyEquivalent:
1437                menu #@"Background Color ..." (@selector #/changeBackgroundColor:) #@"")
1438               (#/addItemWithTitle:action:keyEquivalent:
1439                menu #@"Text Color ..." (@selector #/changeTextColor:) #@"")
1440               ;; Separator
1441               (#/addItem: menu (#/separatorItem ns:ns-menu-item))
1442               (#/addItemWithTitle:action:keyEquivalent:
1443                menu #@"Duplicate this window" (@selector #/duplicate:) #@"")
1444               menu)))))
1445
1446
1447
1448
1449
1450(objc:defmethod (#/changeBackgroundColor: :void)
1451    ((self hemlock-text-view) sender)
1452  (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel))
1453         (color (#/backgroundColor self)))
1454    (#/close colorpanel)
1455    (#/setAction: colorpanel (@selector #/updateBackgroundColor:))
1456    (#/setColor: colorpanel color)
1457    (#/setTarget: colorpanel self)
1458    (#/setContinuous: colorpanel nil)
1459    (#/orderFrontColorPanel: *NSApp* sender)))
1460
1461
1462
1463(objc:defmethod (#/updateBackgroundColor: :void)
1464    ((self hemlock-text-view) sender)
1465  (when (#/isVisible sender)
1466    (let* ((color (#/color sender)))
1467      (unless (typep self 'echo-area-view)
1468        (let* ((window (#/window self))
1469               (echo-view (unless (%null-ptr-p window)
1470                            (slot-value window 'echo-area-view))))
1471          (when echo-view (#/setBackgroundColor: echo-view color))))
1472      #+debug (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender)
1473      (#/setBackgroundColor: self color))))
1474
1475(objc:defmethod (#/changeTextColor: :void)
1476    ((self hemlock-text-view) sender)
1477  (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel))
1478         (textstorage (#/textStorage self))
1479         (color (#/objectForKey:
1480                 (#/objectAtIndex: (slot-value textstorage 'styles) 0)
1481                 #&NSForegroundColorAttributeName)))
1482    (#/close colorpanel)
1483    (#/setAction: colorpanel (@selector #/updateTextColor:))
1484    (#/setColor: colorpanel color)
1485    (#/setTarget: colorpanel self)
1486    (#/setContinuous: colorpanel nil)
1487    (#/orderFrontColorPanel: *NSApp* sender)))
1488
1489
1490
1491
1492
1493
1494   
1495(objc:defmethod (#/updateTextColor: :void)
1496    ((self hemlock-textstorage-text-view) sender)
1497  (unwind-protect
1498      (progn
1499        (#/setUsesFontPanel: self t)
1500        (ccl::%call-next-objc-method
1501         self
1502         hemlock-textstorage-text-view
1503         (@selector #/changeColor:)
1504         '(:void :id)
1505         sender))
1506    (#/setUsesFontPanel: self nil))
1507  (#/setNeedsDisplay: self t))
1508   
1509(objc:defmethod (#/updateTextColor: :void)
1510    ((self hemlock-text-view) sender)
1511  (let* ((textstorage (#/textStorage self))
1512         (styles (slot-value textstorage 'styles))
1513         (newcolor (#/color sender)))
1514    (dotimes (i (#/count styles))
1515      (let* ((dict (#/objectAtIndex: styles i)))
1516        (#/setValue:forKey: dict newcolor #&NSForegroundColorAttributeName)))
1517    (call-next-method sender)))
1518
1519
1520
1521(defmethod text-view-string-cache ((self hemlock-textstorage-text-view))
1522  (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
1523
1524(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range)
1525    ((self hemlock-textstorage-text-view)
1526     (proposed :ns-range)
1527     (g :<NSS>election<G>ranularity))
1528  #+debug
1529  (#_NSLog #@"Granularity = %d" :int g)
1530  (objc:returning-foreign-struct (r)
1531     (block HANDLED
1532       (let* ((index (ns:ns-range-location proposed))
1533              (length (ns:ns-range-length proposed))
1534              (textstorage (#/textStorage self))
1535              (event (#/currentEvent (#/window self)))
1536              (event-type (#/type event)))
1537         ;; Workaround for bug #150
1538         (when (and (eql g #$NSSelectByCharacter)
1539                    (eql index (#/length textstorage))
1540                    (or (eql event-type #$NSLeftMouseDown) (eql event-type #$NSLeftMouseUp)))
1541           (setq g (case (#/clickCount event)
1542                     ((0 1) #$NSSelectByCharacter)
1543                     (2 #$NSSelectByWord)
1544                     (t #$NSSelectByParagraph))))
1545         (unless (eql g #$NSSelectByCharacter)
1546           (let* ((cache (hemlock-buffer-string-cache (#/hemlockString textstorage)))
1547                  (buffer (buffer-cache-buffer cache))
1548                  (hi::*current-buffer* buffer)
1549                  (point (hi:buffer-point buffer))
1550                  (atom-mode (eql g #$NSSelectByParagraph)))
1551             (hi:with-mark ((mark point))
1552               (when (or (= length 0) (hi:move-to-absolute-position mark index))
1553                 (let* ((region (selection-for-click mark atom-mode))
1554                        (other-region (and (< 0 length)
1555                                           (hi:character-offset mark length)
1556                                           (selection-for-click mark atom-mode))))
1557                   (when (null region) (setq region other-region other-region nil))
1558                   (when region
1559                     (let ((start-pos (min (hi:mark-absolute-position (hi:region-start region))
1560                                           (if other-region
1561                                             (hi:mark-absolute-position (hi:region-start other-region))
1562                                             index)))
1563                           (end-pos (max (hi:mark-absolute-position (hi:region-end region))
1564                                         (if other-region
1565                                           (hi:mark-absolute-position (hi:region-end other-region))
1566                                           (+ index length)))))
1567                       (assert (<= start-pos end-pos))
1568                       ;; Act as if we started the selection at the other end, so the heuristic
1569                       ;; in #/setSelectedRange does the right thing.  ref bug #565.
1570                       ;; However, only do so at the end, so don't keep toggling during selection, ref bug #851.
1571                       (when (and (eql event-type #$NSLeftMouseUp) (< start-pos end-pos))
1572                         (let ((point-pos (hi:mark-absolute-position point)))
1573                           (cond ((eql point-pos start-pos)
1574                                  (hi:move-to-absolute-position point end-pos))
1575                                 ((eql point-pos end-pos)
1576                                  (hi:move-to-absolute-position point start-pos)))))
1577                       (ns:init-ns-range r start-pos (- end-pos start-pos))
1578                       #+debug
1579                       (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
1580                                :address (#_NSStringFromRange r)
1581                                :address (#_NSStringFromRange proposed)
1582                                :<NSS>election<G>ranularity g)
1583                       (return-from HANDLED r))))))))
1584         (prog1
1585             (call-next-method proposed g)
1586           #+debug
1587           (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
1588                    :address (#_NSStringFromRange r)
1589                    :address (#_NSStringFromRange proposed)
1590                    :<NSS>election<G>ranularity g))))))
1591
1592;; Return nil to use the default Cocoa selection, which will be word for double-click, line for triple.
1593(defun selection-for-click (mark paragraph-mode-p)
1594  ;; Handle lisp mode specially, otherwise just go with default Cocoa behavior
1595  (when (string= (hi:buffer-major-mode (hi::mark-buffer mark)) "Lisp") ;; gag
1596    (unless paragraph-mode-p
1597      (let ((region (hemlock::word-region-at-mark mark)))
1598        (when region
1599          (return-from selection-for-click region))))
1600    (hemlock::pre-command-parse-check mark)
1601    (hemlock::form-region-at-mark mark)))
1602
1603(defun append-output (view string)
1604  (assume-cocoa-thread)
1605  ;; Arrange to do the append in command context
1606  (when view
1607    (hi::handle-hemlock-event view #'(lambda ()
1608                                       (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string)))))
1609
1610
1611(defun move-point-for-click (buffer index)
1612  (let* ((point (hi::buffer-point buffer))
1613         (mark (and (hemlock::%buffer-region-active-p buffer) (hi::buffer-mark buffer))))
1614    (setf (hi::buffer-region-active buffer) nil)
1615    (unless (eql (hi:mark-absolute-position point) index)  ;; if point is already at target, leave mark alone
1616      (if (and mark (eql (hi:mark-absolute-position mark) index))
1617        (hi:move-mark mark point)
1618        (hi::push-new-buffer-mark point))
1619      (hi:move-to-absolute-position point index))))
1620 
1621;;; Update the underlying buffer's point (and "active region", if appropriate.
1622;;; This is called in response to a mouse click or other event; it shouldn't
1623;;; be called from the Hemlock side of things.
1624
1625(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void)
1626    ((self hemlock-text-view)
1627     (r :<NSR>ange)
1628     (affinity :<NSS>election<A>ffinity)
1629     (still-selecting :<BOOL>))
1630  #+debug
1631  (#_NSLog #@"Set selected range called: range = %@, affinity = %d, still-selecting = %d"
1632           :address (#_NSStringFromRange r)
1633           :<NSS>election<A>ffinity affinity
1634           :<BOOL> (if still-selecting #$YES #$NO))
1635  #+debug
1636  (#_NSLog #@"text view string = %@, textstorage string = %@"
1637           :id (#/string self)
1638           :id (#/string (#/textStorage self)))
1639  (unless (#/editingInProgress (#/textStorage self))
1640    (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
1641           (buffer (buffer-cache-buffer d))
1642           (hi::*current-buffer* buffer)
1643           (location (pref r :<NSR>ange.location))
1644           (len (pref r :<NSR>ange.length)))
1645      (setf (hi::buffer-selection-set-by-command buffer) nil)
1646      (with-view-selection-info (self buffer)
1647        (cond ((eql len 0)
1648               #+debug
1649               (#_NSLog #@"Moving point to absolute position %d" :int location)
1650               ;; Do this even if still-selecting, in order to enable the heuristic below.
1651               (move-point-for-click buffer location)
1652               (update-paren-highlight self))
1653              (t
1654               ;; We don't get much information about which end of the
1655               ;; selection the mark's at and which end point is at, so
1656               ;; we have to sort of guess.  In every case I've ever seen,
1657               ;; selection via the mouse generates a sequence of calls to
1658               ;; this method whose parameters look like:
1659               ;; a: range: {n0,0} still-selecting: false  [ rarely repeats ] (this doesn't actually happen)
1660               ;; b: range: {n0,0) still-selecting: true   [ rarely repeats ]
1661               ;; c: range: {n1,m} still-selecting: true   [ often repeats ]
1662               ;; d: range: {n1,m} still-selecting: false  [ rarely repeats ] (mouse up)
1663               ;;
1664               ;; (Sadly, "affinity" doesn't tell us anything interesting.)
1665               ;; We've handled a and b in the clause above; after handling
1666               ;; b, point references buffer position n0 and the
1667               ;; region is inactive.
1668               ;; Let's ignore c, and wait until the selection's stabilized.
1669               ;; Make a new mark, a copy of point (position n0).
1670               ;; At step d (here), we should have either
1671               ;; d1) n1=n0.  Mark stays at n0, point moves to n0+m.
1672               ;; d2) n1+m=n0.  Mark stays at n0, point moves to n0-m.
1673               ;; If neither d1 nor d2 apply, arbitrarily assume forward
1674               ;; selection: mark at n1, point at n1+m.
1675               ;; In all cases, activate Hemlock selection.
1676               (unless still-selecting
1677                 (let* ((point (hi::buffer-point buffer))
1678                        (pointpos (hi:mark-absolute-position point))
1679                        (selection-end (+ location len))
1680                        (mark (hi::copy-mark point :right-inserting)))
1681                   (cond ((eql pointpos location)
1682                          (move-hemlock-mark-to-absolute-position point
1683                                                                  d
1684                                                                  selection-end))
1685                         ((eql pointpos selection-end)
1686                          (move-hemlock-mark-to-absolute-position point
1687                                                                  d
1688                                                                  location))
1689                         (t
1690                          (move-hemlock-mark-to-absolute-position mark
1691                                                                  d
1692                                                                  location)
1693                          (move-hemlock-mark-to-absolute-position point
1694                                                                  d
1695                                                                  selection-end)))
1696                   (hemlock::%buffer-push-buffer-mark buffer mark t))))))))
1697  (call-next-method r affinity still-selecting))
1698
1699
1700
1701;;; Modeline-view
1702
1703(defclass modeline-view (ns:ns-view)
1704    ((pane :foreign-type :id :accessor modeline-view-pane)
1705     (text-attributes :foreign-type :id :accessor modeline-text-attributes))
1706  (:metaclass ns:+ns-object))
1707
1708(objc:defmethod #/initWithFrame: ((self modeline-view) (frame :<NSR>ect))
1709  (call-next-method frame)
1710  (let* ((size (#/smallSystemFontSize ns:ns-font))
1711         (font (#/systemFontOfSize: ns:ns-font size))
1712         (dict (#/dictionaryWithObject:forKey: ns:ns-dictionary font #&NSFontAttributeName)))
1713    (setf (modeline-text-attributes self) (#/retain dict)))
1714  self)
1715
1716;;; Find the underlying buffer.
1717(defun buffer-for-modeline-view (mv)
1718  (let* ((pane (modeline-view-pane mv)))
1719    (unless (%null-ptr-p pane)
1720      (let* ((tv (text-pane-text-view pane)))
1721        (unless (%null-ptr-p tv)
1722          (hemlock-buffer tv))))))
1723
1724;;; Draw a string in the modeline view.  The font and other attributes
1725;;; are initialized lazily; apparently, calling the Font Manager too
1726;;; early in the loading sequence confuses some Carbon libraries that're
1727;;; used in the event dispatch mechanism,
1728(defun draw-modeline-string (the-modeline-view)
1729  (with-slots (text-attributes) the-modeline-view
1730    (let* ((buffer (buffer-for-modeline-view the-modeline-view)))
1731      (when buffer
1732        (let* ((string
1733                (apply #'concatenate 'string
1734                       (mapcar
1735                        #'(lambda (field)
1736                            (or (ignore-errors 
1737                                  (funcall (hi::modeline-field-function field) buffer))
1738                                ""))
1739                        (hi::buffer-modeline-fields buffer)))))
1740          (#/drawAtPoint:withAttributes: (#/autorelease (%make-nsstring string))
1741                                         (ns:make-ns-point 5 1)
1742                                         text-attributes))))))
1743
1744(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :<NSR>ect))
1745  (declare (ignorable rect))
1746  (let* ((bounds (#/bounds self))
1747         (context (#/currentContext ns:ns-graphics-context)))
1748    (#/saveGraphicsState context)
1749    (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.9 1.0))
1750    (#_NSRectFill bounds)
1751    (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.3333 1.0))
1752    ;; Draw borders on top and bottom.
1753    (ns:with-ns-rect (r 0 0.5 (ns:ns-rect-width bounds) 0.5)
1754      (#_NSRectFill r))
1755    (ns:with-ns-rect (r 0 (- (ns:ns-rect-height bounds) 0.5)
1756                        (ns:ns-rect-width bounds) (- (ns:ns-rect-height bounds) 0.5))
1757      (#_NSRectFill r))
1758    (draw-modeline-string self)
1759    (#/restoreGraphicsState context)))
1760
1761;;; Hook things up so that the modeline is updated whenever certain buffer
1762;;; attributes change.
1763(hi::%init-mode-redisplay)
1764
1765
1766;;; A clip view subclass, which exists mostly so that we can track origin changes.
1767(defclass text-pane-clip-view (ns:ns-clip-view)
1768  ()
1769  (:metaclass ns:+ns-object))
1770
1771(objc:defmethod (#/scrollToPoint: :void) ((self text-pane-clip-view)
1772                                           (origin #>NSPoint))
1773  (unless (#/inLiveResize self)
1774    (call-next-method origin)
1775    (compute-temporary-attributes (#/documentView self))))
1776
1777;;; Text-pane
1778
1779;;; The text pane is just an NSBox that (a) provides a draggable border
1780;;; around (b) encapsulates the text view and the mode line.
1781
1782(defclass text-pane (ns:ns-box)
1783    ((hemlock-view :initform nil :reader text-pane-hemlock-view)
1784     (text-view :foreign-type :id :accessor text-pane-text-view)
1785     (mode-line :foreign-type :id :accessor text-pane-mode-line)
1786     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
1787  (:metaclass ns:+ns-object))
1788
1789(defmethod hemlock-view ((self text-pane))
1790  (text-pane-hemlock-view self))
1791
1792;;; This method gets invoked on the text pane, which is its containing
1793;;; window's delegate object.
1794(objc:defmethod (#/windowDidResignKey: :void)
1795    ((self text-pane) notification)
1796  (declare (ignorable notification))
1797  ;; When the window loses focus, we should remove or change transient
1798  ;; highlighting (like matching-paren highlighting).  Maybe make this
1799  ;; more general ...
1800  ;; Currently, this only removes temporary attributes from matching
1801  ;; parens; other kinds of syntax highlighting stays visible when
1802  ;; the containing window loses keyboard focus
1803  (let* ((tv (text-pane-text-view self)))
1804    (remove-paren-highlight tv)
1805    (remove-paren-highlight (slot-value tv 'peer))))
1806
1807;;; Likewise, reactivate transient highlighting when the window gets
1808;;; focus.
1809(objc:defmethod (#/windowDidBecomeKey: :void)
1810    ((self text-pane) notification)
1811  (declare (ignorable notification))
1812  (let* ((tv (text-pane-text-view self)))
1813    (compute-temporary-attributes tv)
1814    (compute-temporary-attributes (slot-value tv 'peer))))
1815 
1816
1817;;; Mark the buffer's modeline as needing display.  This is called whenever
1818;;; "interesting" attributes of a buffer are changed.
1819(defun hemlock-ext:invalidate-modeline (buffer)
1820  (let* ((doc (hi::buffer-document buffer)))
1821    (when doc
1822      (document-invalidate-modeline doc))))
1823
1824(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
1825(def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane")
1826
1827
1828(objc:defmethod #/initWithFrame: ((self text-pane) (frame :<NSR>ect))
1829  (let* ((pane (call-next-method frame)))
1830    (unless (%null-ptr-p pane)
1831      (#/setAutoresizingMask: pane (logior
1832                                    #$NSViewWidthSizable
1833                                    #$NSViewHeightSizable))
1834      (#/setBoxType: pane #$NSBoxPrimary)
1835      (#/setBorderType: pane #$NSNoBorder)
1836      (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width*  *text-pane-margin-height*))
1837      (#/setTitlePosition: pane #$NSNoTitle))
1838    pane))
1839
1840(objc:defmethod #/defaultMenu ((class +hemlock-text-view))
1841  (text-view-context-menu))
1842
1843(defun pathname-for-namestring-fragment (string)
1844  "Return a pathname that STRING might designate."
1845  ;; We could get fancy here, but for now just be stupid.
1846  (let* ((rfs (ignore-errors (read-from-string string nil nil)))
1847         (pathname (or (ignore-errors (probe-file string))
1848                       (ignore-errors (probe-file rfs))
1849                       (ignore-errors (probe-file (merge-pathnames *.lisp-pathname* string)))
1850                       (ignore-errors (probe-file (merge-pathnames *.lisp-pathname* rfs))))))
1851    (if (and (pathnamep pathname)
1852             (not (directory-pathname-p pathname)))
1853      pathname)))
1854
1855(defun find-symbol-in-packages (string pkgs)
1856  (setq string (string-upcase string))
1857  (let (sym)
1858    (dolist (p pkgs)
1859      (when (setq sym (find-symbol string p))
1860        (return)))
1861    sym))
1862
1863(objc:defmethod (#/openSelection: :void) ((self hemlock-text-view) sender)
1864  (declare (ignore sender))
1865  (let* ((text (#/string self))
1866         (selection (#/substringWithRange: text (#/selectedRange self)))
1867         (pathname (pathname-for-namestring-fragment
1868                    (lisp-string-from-nsstring selection))))
1869    (when (pathnamep pathname)
1870      (ed pathname))))
1871
1872;;; If we get here, we've already checked that the selection represents
1873;;; a valid symbol name.
1874(objc:defmethod (#/inspectSelection: :void) ((self hemlock-text-view) sender)
1875  (declare (ignore sender))
1876  (let* ((text (#/string self))
1877         (selection (#/substringWithRange: text (#/selectedRange self)))
1878         (symbol-name (string-upcase (lisp-string-from-nsstring selection)))
1879         (buffer (hemlock-buffer self))
1880         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)))
1881    (inspect (find-symbol-in-packages symbol-name 
1882                                      (cons package-name
1883                                            (package-use-list package-name))))))
1884
1885(objc:defmethod (#/sourceForSelection: :void) ((self hemlock-text-view) sender)
1886  (declare (ignore sender))
1887  (let* ((text (#/string self))
1888         (selection (#/substringWithRange: text (#/selectedRange self)))
1889         (sym (find-symbol-in-packages (lisp-string-from-nsstring selection)
1890                                       (list-all-packages))))
1891    (ed sym)))
1892
1893;;; If we don't override this, NSTextView will start adding Google/
1894;;; Spotlight search options and dictionary lookup when a selection
1895;;; is active.
1896(objc:defmethod #/menuForEvent: ((self hemlock-text-view) event)
1897  (declare (ignore event))
1898  (let* ((text (#/string self))
1899         (selection (#/substringWithRange: text (#/selectedRange self)))
1900         (s (lisp-string-from-nsstring selection))
1901         (menu (if (> (length s) 0)
1902                 (#/copy (#/menu self))
1903                 (#/retain (#/menu self))))
1904         (buffer (hemlock-buffer self))
1905         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)))
1906    (when (find-symbol-in-packages (string-upcase s)
1907                                   (cons package-name
1908                                         (package-use-list package-name)))
1909      (let* ((title (#/stringByAppendingString: #@"Inspect " selection))
1910             (item (make-instance 'ns:ns-menu-item :with-title title
1911                     :action (@selector #/inspectSelection:)
1912                     :key-equivalent #@"")))
1913        (#/setTarget: item self)
1914        (#/insertItem:atIndex: menu item 0)
1915        (#/release item)))
1916    (when (find-symbol-in-packages (string-upcase s) (list-all-packages))
1917      (let* ((title (#/stringByAppendingString: #@"Source of " selection))
1918             (item (make-instance 'ns:ns-menu-item :with-title title
1919                     :action (@selector #/sourceForSelection:)
1920                     :key-equivalent #@"")))
1921        (#/setTarget: item self)
1922        (#/insertItem:atIndex: menu item 0)
1923        (#/release item)))
1924    (when (pathname-for-namestring-fragment s)
1925      (let* ((title (#/stringByAppendingString: #@"Open " selection))
1926             (item (make-instance 'ns:ns-menu-item :with-title title
1927                     :action (@selector #/openSelection:)
1928                     :key-equivalent #@"")))
1929        (#/setTarget: item self)
1930        (#/insertItem:atIndex: menu item 0)
1931        (#/release item)))
1932
1933    (#/autorelease menu)))
1934
1935(defun init-selection-info-for-textview (tv buffer)
1936  (let* ((buffer-info (hi::buffer-selection-info buffer))
1937         (view-info (hi::make-selection-info :point (hi::copy-mark (hi::selection-info-point buffer-info))
1938                                             :%mark (let* ((mark (hi::selection-info-%mark buffer-info)))
1939                                                      (if mark (hi::copy-mark mark)))
1940                                             :view tv)))
1941    (setf (view-selection-info tv) view-info)))
1942                                                     
1943(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color style)
1944  (let* ((scrollview (#/autorelease
1945                      (make-instance
1946                       'ns:ns-scroll-view
1947                       :with-frame (ns:make-ns-rect x y width height)))))
1948    (#/setBorderType: scrollview #$NSNoBorder)
1949    (#/setHasVerticalScroller: scrollview t)
1950    (#/setHasHorizontalScroller: scrollview t)
1951    (#/setRulersVisible: scrollview nil)
1952    (#/setAutoresizingMask: scrollview (logior
1953                                        #$NSViewWidthSizable
1954                                        #$NSViewHeightSizable))
1955    (#/setAutoresizesSubviews: (#/contentView scrollview) t)
1956    (let* ((layout (make-instance 'ns:ns-layout-manager)))
1957      #+suffer
1958      (#/setTypesetter: layout (make-instance 'hemlock-ats-typesetter))
1959      (#/addLayoutManager: textstorage layout)
1960      (#/setUsesScreenFonts: layout *use-screen-fonts*)
1961      (#/release layout)
1962      (let* ((contentsize (#/contentSize scrollview)))
1963        (ns:with-ns-size (containersize large-number-for-text large-number-for-text)
1964          (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
1965            (ns:init-ns-size containersize large-number-for-text large-number-for-text)
1966            (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
1967            (let* ((container (#/autorelease (make-instance
1968                                              'ns:ns-text-container
1969                                              :with-container-size containersize))))
1970              (#/addTextContainer: layout  container)
1971              (let* ((tv (#/autorelease (make-instance 'hemlock-text-view
1972                                                       :with-frame tv-frame
1973                                                       :text-container container))))
1974                (init-selection-info-for-textview tv (hemlock-buffer textstorage))
1975                (setf (text-view-paren-highlight-color tv) (paren-highlight-background-color))
1976                (#/setDelegate: layout tv)
1977                (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize)))
1978                (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text))
1979                (#/setRichText: tv nil)
1980                (#/setAutoresizingMask: tv #$NSViewWidthSizable)
1981                (#/setBackgroundColor: tv color)
1982                (when (slot-exists-p textstorage 'styles)
1983                  (#/setTypingAttributes: tv (#/objectAtIndex:
1984                                              (#/styles textstorage) style)))
1985                #-cocotron
1986                (#/setSmartInsertDeleteEnabled: tv nil)
1987                (#/setAllowsUndo: tv nil) ; don't want NSTextView undo
1988                #-cocotron
1989                (#/setUsesFindPanel: tv t)
1990                #-cocotron
1991                (#/setUsesFontPanel: tv nil)
1992                (#/setMenu: tv (text-view-context-menu))
1993
1994                ;;  The container tracking and the text view sizability along a
1995                ;;  particular axis must always be different, or else things can
1996                ;;  get really confused (possibly causing an infinite loop).
1997
1998                (if (or tracks-width *wrap-lines-to-window*)
1999                  (progn
2000                    (#/setWidthTracksTextView: container t)
2001                    (#/setHeightTracksTextView: container nil)
2002                    (#/setHorizontallyResizable: tv nil)
2003                    (#/setVerticallyResizable: tv t))
2004                  (progn
2005                    (#/setWidthTracksTextView: container nil)
2006                    (#/setHeightTracksTextView: container nil)
2007                    (#/setHorizontallyResizable: tv t)
2008                    (#/setVerticallyResizable: tv t)))
2009                (#/setContentView: scrollview (make-instance 'text-pane-clip-view))
2010                (#/setDocumentView: scrollview tv)           
2011                (values tv scrollview)))))))))
2012
2013(defun make-scrolling-textview-for-pane (pane textstorage track-width color style)
2014  (let* ((contentrect (#/frame (#/contentView pane)) ))
2015    (multiple-value-bind (tv scrollview)
2016        (make-scrolling-text-view-for-textstorage
2017         textstorage
2018         (ns:ns-rect-x contentrect)
2019         (ns:ns-rect-y contentrect)
2020         (ns:ns-rect-width contentrect)
2021         (ns:ns-rect-height contentrect)
2022         track-width
2023         color
2024         style)
2025      (#/addSubview: pane scrollview)
2026      (let* ((r (#/frame scrollview)))
2027        (decf (ns:ns-rect-height r) 15)
2028        (incf (ns:ns-rect-y r) 15)
2029        (#/setFrame: scrollview r))
2030      #-cocotron
2031      (#/setAutohidesScrollers: scrollview t)
2032      (setf (slot-value pane 'scroll-view) scrollview
2033            (slot-value pane 'text-view) tv
2034            (slot-value tv 'pane) pane
2035            #|(slot-value scrollview 'pane) pane|#)
2036      ;;(let* ((modeline  (scroll-view-modeline scrollview)))
2037      (let* ((modeline  (make-instance 'modeline-view
2038                          :with-frame (ns:make-ns-rect 0 0 (ns:ns-rect-width contentrect)
2039                                                       15))))
2040        (#/setAutoresizingMask: modeline #$NSViewWidthSizable)
2041        (#/addSubview: pane modeline)
2042        (#/release modeline)
2043        (setf (slot-value pane 'mode-line) modeline
2044              (slot-value modeline 'pane) pane))
2045      tv)))
2046
2047(defmethod hemlock-view-size ((view hi:hemlock-view))
2048  (let* ((pane (hi::hemlock-view-pane view))
2049         (bounds (#/bounds (#/contentView (text-pane-scroll-view pane))))
2050         (tv (text-pane-text-view pane))
2051         (char-width (text-view-char-width tv))
2052         (line-height (text-view-line-height tv)))
2053    (values (floor (ns:ns-rect-width bounds) char-width)
2054            (floor (ns:ns-rect-height bounds) line-height))))
2055
2056
2057(defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane)
2058  #+debug (log-debug "change active pane to ~s" new-pane)
2059  (let* ((pane (hi::hemlock-view-pane view))
2060         (text-view (text-pane-text-view pane))
2061         (tv (ecase new-pane
2062               (:echo (slot-value text-view 'peer))
2063               (:text text-view))))
2064    (activate-hemlock-view tv)))
2065
2066(defclass echo-area-view (hemlock-textstorage-text-view)
2067    ()
2068  (:metaclass ns:+ns-object))
2069(declaim (special echo-area-view))
2070
2071(defmethod compute-temporary-attributes ((self echo-area-view))
2072)
2073
2074(defmethod update-paren-highlight ((self echo-area-view))
2075)
2076
2077(defmethod hemlock-view ((self echo-area-view))
2078  (slot-value self 'hemlock-view))
2079
2080;;; The "document" for an echo-area isn't a real NSDocument.
2081(defclass echo-area-document (ns:ns-object)
2082    ((textstorage :foreign-type :id))
2083  (:metaclass ns:+ns-object))
2084
2085(defmethod hemlock-buffer ((self echo-area-document))
2086  (let ((ts (slot-value self 'textstorage)))
2087    (unless (%null-ptr-p ts)
2088      (hemlock-buffer ts))))
2089
2090(objc:defmethod #/undoManager ((self echo-area-document))
2091  +null-ptr+) ;For now, undo is not supported for echo-areas
2092
2093(defmethod update-buffer-package ((doc echo-area-document) buffer)
2094  (declare (ignore buffer)))
2095
2096(defmethod document-invalidate-modeline ((self echo-area-document))
2097  nil)
2098
2099(objc:defmethod (#/close :void) ((self echo-area-document))
2100  (let* ((ts (slot-value self 'textstorage)))
2101    (unless (%null-ptr-p ts)
2102      (setf (slot-value self 'textstorage) (%null-ptr))
2103      (close-hemlock-textstorage ts))))
2104
2105(objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :<NSD>ocument<C>hange<T>ype))
2106  (declare (ignore change)))
2107
2108(defun make-echo-area (the-hemlock-frame x y width height main-buffer color)
2109  (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height))))
2110    (#/setAutoresizingMask: box #$NSViewWidthSizable)
2111    (let* ((box-frame (#/bounds box))
2112           (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame)))
2113           (clipview (make-instance 'ns:ns-clip-view
2114                                    :with-frame box-frame)))
2115      (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable
2116                                               #$NSViewHeightSizable))
2117      (#/setBackgroundColor: clipview color)
2118      (#/addSubview: box clipview)
2119      (#/setAutoresizesSubviews: box t)
2120      (#/release clipview)
2121      (let* ((buffer (hi::make-echo-buffer))
2122             (textstorage
2123              (progn
2124                ;; What's the reason for sharing this?  Is it just the lock?
2125                (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer))
2126                (make-textstorage-for-hemlock-buffer buffer)))
2127             (doc (make-instance 'echo-area-document))
2128             (layout (make-instance 'ns:ns-layout-manager))
2129             (container (#/autorelease
2130                         (make-instance 'ns:ns-text-container
2131                                        :with-container-size
2132                                        containersize))))
2133        (#/addLayoutManager: textstorage layout)
2134        (#/setUsesScreenFonts: layout *use-screen-fonts*)
2135        (#/addTextContainer: layout container)
2136        (#/release layout)
2137        (let* ((echo (make-instance 'echo-area-view
2138                                    :with-frame box-frame
2139                                    :text-container container))
2140               (info (hi::buffer-selection-info (hemlock-buffer textstorage))))
2141          (setf (view-selection-info echo) info
2142                (hi::selection-info-view info) echo)
2143          (#/setMinSize: echo (pref box-frame :<NSR>ect.size))
2144          (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text))
2145          (#/setRichText: echo nil)
2146          #-cocotron
2147          (#/setUsesFontPanel: echo nil)
2148          (#/setHorizontallyResizable: echo t)
2149          (#/setVerticallyResizable: echo nil)
2150          (#/setAutoresizingMask: echo #$NSViewNotSizable)
2151          (#/setBackgroundColor: echo color)
2152          (#/setWidthTracksTextView: container nil)
2153          (#/setHeightTracksTextView: container nil)
2154          (#/setMenu: echo +null-ptr+)
2155          (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer
2156                (slot-value doc 'textstorage) textstorage
2157                (hi::buffer-document buffer) doc)
2158          (#/setDocumentView: clipview echo)
2159          (#/setAutoresizesSubviews: clipview nil)
2160          (#/sizeToFit echo)
2161          (values echo box))))))
2162                   
2163(defun make-echo-area-for-window (w main-buffer color)
2164  (let* ((content-view (#/contentView w))
2165         (bounds (#/bounds content-view))
2166         (height (+ 1 (size-of-char-in-font *editor-font*))))
2167    (multiple-value-bind (echo-area box)
2168                         (make-echo-area w
2169                                         0.0f0
2170                                         0.0f0
2171                                         (- (ns:ns-rect-width bounds) 16.0f0)
2172                                         height
2173                                         main-buffer
2174                                         color)
2175      (#/addSubview: content-view box)
2176      echo-area)))
2177               
2178(defclass hemlock-frame (ns:ns-window)
2179    ((echo-area-view :foreign-type :id)
2180     (pane :foreign-type :id)
2181     (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
2182     (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream))
2183  (:metaclass ns:+ns-object))
2184(declaim (special hemlock-frame))
2185
2186;;; If a window's document's edited status changes, update the modeline.
2187(objc:defmethod (#/setDocumentEdited: :void) ((w hemlock-frame)
2188                                              (edited #>BOOL))
2189  (let* ((was-edited (#/isDocumentEdited w)))
2190    (unless (eq was-edited edited)
2191      (#/setNeedsDisplay: (text-pane-mode-line (slot-value w 'pane)) t)))
2192  (call-next-method edited))
2193
2194(objc:defmethod (#/dealloc :void) ((self hemlock-frame))
2195  (let* ((pane (slot-value self 'pane))
2196         (echo-view (slot-value self 'echo-area-view)))
2197    (unless (%null-ptr-p pane)
2198      (setf (slot-value self 'pane) (%null-ptr))
2199      (#/release pane))
2200    (unless (%null-ptr-p echo-view)
2201      (setf (slot-value self 'echo-area-view) (%null-ptr))
2202      (#/release echo-view))
2203    (objc:remove-lisp-slots self)
2204    (call-next-method)))
2205 
2206
2207(objc:defmethod (#/miniaturize: :void) ((w hemlock-frame) sender)
2208  (let* ((event (#/currentEvent w))
2209         (flags (#/modifierFlags event)))
2210    (if (logtest #$NSControlKeyMask flags)
2211      (progn
2212        (#/orderOut: w nil)
2213        (#/changeWindowsItem:title:filename: *nsapp* w (#/title w) nil))
2214      (call-next-method sender))))
2215
2216(defmethod hemlock-view ((frame hemlock-frame))
2217  (let ((pane (slot-value frame 'pane)))
2218    (when (and pane (not (%null-ptr-p pane)))
2219      (hemlock-view pane))))
2220
2221(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message)
2222  #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
2223  (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
2224                       (if (logbitp 0 (random 2))
2225                         #@"Not OK, but what can you do?"
2226                         #@"The sky is falling. FRED never did this!")
2227                       +null-ptr+
2228                       +null-ptr+
2229                       self
2230                       self
2231                       +null-ptr+
2232                       +null-ptr+
2233                       +null-ptr+
2234                       message))
2235
2236(defun report-condition-in-hemlock-frame (condition frame)
2237  (assume-cocoa-thread)
2238  (let ((message (nsstring-for-lisp-condition condition)))
2239    (#/performSelectorOnMainThread:withObject:waitUntilDone:
2240     frame
2241     (@selector #/runErrorSheet:)
2242     message
2243     t)))
2244
2245(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition debug-p)
2246  (when debug-p (maybe-log-callback-error condition))
2247  (let ((pane (hi::hemlock-view-pane view)))
2248    (when (and pane (not (%null-ptr-p pane)))
2249      (report-condition-in-hemlock-frame condition (#/window pane)))))
2250
2251(defun window-menubar-height ()
2252  #+cocotron (objc:objc-message-send (ccl::@class "NSMainMenuView") "menuHeight" #>CGFloat)
2253  #-cocotron 0.0f0)
2254
2255(defun new-hemlock-document-window (class)
2256  (let* ((w (new-cocoa-window :class class
2257                              :activate nil))
2258         (echo-area-height (+ 1 (size-of-char-in-font *editor-font*))))
2259      (values w (add-pane-to-window w :reserve-below echo-area-height))))
2260
2261
2262
2263(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
2264  (let* ((window-content-view (#/contentView w))
2265         (window-frame (#/frame window-content-view)))
2266    (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)))
2267       (let* ((pane (make-instance 'text-pane :with-frame pane-rect)))
2268         (#/addSubview: window-content-view pane)
2269         (#/setDelegate: w pane)
2270         ;; Cocotron doesn't set the new window's initialFirstResponder which means
2271         ;; that the user must click in the window before they can edit.  So, do it here.
2272         ;; Remove this when Cocotron issue #374 is fixed
2273         ;;  (http://code.google.com/p/cocotron/issues/detail?id=374)
2274         #+cocotron (#/setInitialFirstResponder: w pane)
2275         pane))))
2276
2277(defun textpane-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
2278  (let* ((pane (nth-value
2279                1
2280                (new-hemlock-document-window class))))
2281    (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color style)
2282    (multiple-value-bind (height width)
2283        (size-of-char-in-font (default-font))
2284      (size-text-pane pane height width nrows ncols))
2285    pane))
2286
2287
2288
2289
2290(defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
2291  (let* ((buffer (make-hemlock-buffer name :modes modes)))
2292    (nsstring-to-buffer nsstring buffer)))
2293
2294(defun %nsstring-to-hemlock-string (nsstring)
2295  "returns line-termination of string"
2296  (let* ((string (lisp-string-from-nsstring nsstring))
2297         (lfpos (position #\linefeed string))
2298         (crpos (position #\return string))
2299         (line-termination (if crpos
2300                             (if (eql lfpos (1+ crpos))
2301                               :crlf
2302                               :cr)
2303                             :lf))
2304         (hemlock-string (case line-termination
2305                           (:crlf (remove #\return string))
2306                           (:cr (nsubstitute #\linefeed #\return string))
2307                           (t string))))
2308    (values hemlock-string line-termination)))
2309
2310;: TODO: I think this is jumping through hoops because it want to be invokable outside the main
2311;; cocoa thread.
2312(defun nsstring-to-buffer (nsstring buffer)
2313  (let* ((document (hi::buffer-document buffer))
2314         (hi::*current-buffer* buffer)
2315         (region (hi::buffer-region buffer)))
2316    (multiple-value-bind (hemlock-string line-termination)
2317                         (%nsstring-to-hemlock-string nsstring)
2318      (setf (hi::buffer-line-termination buffer) line-termination)
2319
2320      (setf (hi::buffer-document buffer) nil) ;; What's this about??
2321      (unwind-protect
2322          (let ((point (hi::buffer-point buffer)))
2323            (hi::delete-region region)
2324            (hi::insert-string point hemlock-string)
2325            (setf (hi::buffer-modified buffer) nil)
2326            (hi::buffer-start point)
2327            ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping.
2328            (hi::renumber-region region)
2329            buffer)
2330        (setf (hi::buffer-document buffer) document)))))
2331
2332
2333(setq hi::*beep-function* #'(lambda (stream)
2334                              (declare (ignore stream))
2335                              (#_NSBeep)))
2336
2337
2338;;; This function must run in the main event thread.
2339(defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
2340  (assume-cocoa-thread)
2341  (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style))
2342         (buffer (hemlock-buffer ts))
2343         (frame (#/window pane))
2344         (echo-area (make-echo-area-for-window frame buffer color))
2345         (echo-buffer (hemlock-buffer (#/textStorage echo-area)))
2346         (tv (text-pane-text-view pane)))
2347    #+GZ (assert echo-buffer)
2348    (with-slots (peer) tv
2349      (setq peer echo-area))
2350    (with-slots (peer) echo-area
2351      (setq peer tv))
2352    (setf (slot-value frame 'echo-area-view) echo-area
2353          (slot-value frame 'pane) pane)
2354    (let* ((hemlock-view
2355            (make-instance 'hi:hemlock-view
2356                           :buffer buffer
2357                           :pane pane
2358                           :echo-area-buffer echo-buffer)))
2359      (setf (slot-value pane 'hemlock-view)
2360            hemlock-view
2361            (slot-value tv 'hemlock-view)
2362            hemlock-view
2363            (slot-value echo-area 'hemlock-view)
2364            hemlock-view))
2365    (activate-hemlock-view tv)
2366    frame))
2367
2368(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk)
2369  (assume-cocoa-thread)
2370  (when buffer ;; nil means just get rid of any prior buffer
2371    (setq buffer (require-type buffer 'hi::buffer)))
2372  (let ((old *buffer-being-edited*))
2373    (if (eq buffer old)
2374      (funcall thunk)
2375      (unwind-protect
2376          (progn
2377            (buffer-document-end-editing old)
2378            (buffer-document-begin-editing buffer)
2379            (funcall thunk))
2380        (buffer-document-end-editing buffer)
2381        (buffer-document-begin-editing old)))))
2382
2383(defun buffer-document-end-editing (buffer)
2384  (when buffer
2385    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
2386      (when document
2387        (setq *buffer-being-edited* nil)
2388        (let ((ts (slot-value document 'textstorage)))
2389          (#/endEditing ts)
2390          (update-hemlock-selection ts))))))
2391
2392(defun buffer-document-begin-editing (buffer)
2393  (when buffer
2394    (let* ((document (hi::buffer-document buffer)))
2395      (when document
2396        (setq *buffer-being-edited* buffer)
2397        (#/beginEditing (slot-value document 'textstorage))))))
2398
2399(defun document-edit-level (document)
2400  (assume-cocoa-thread) ;; see comment in #/editingInProgress
2401  (slot-value (slot-value document 'textstorage) 'edit-count))
2402
2403(defun buffer-edit-level (buffer)
2404  (if buffer
2405    (let* ((document (hi::buffer-document buffer)))
2406      (if document
2407        (document-edit-level document)
2408        0))
2409    0))
2410
2411(defun hemlock-ext:invoke-allowing-buffer-display (buffer thunk)
2412  ;; Call THUNK with the buffer's edit-level at 0, then restore the buffer's edit level.
2413  (let* ((level (buffer-edit-level buffer)))
2414    (dotimes (i level) (buffer-document-end-editing buffer))
2415    (unwind-protect
2416        (funcall thunk)
2417      (dotimes (i level) (buffer-document-begin-editing buffer)))))
2418
2419
2420(defun buffer-document-modified (buffer)
2421  (let* ((doc (hi::buffer-document buffer)))
2422    (if doc
2423      (#/isDocumentEdited doc))))
2424
2425(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
2426  (with-lock-grabbed (*buffer-change-invocation-lock*)
2427    (let* ((invocation *buffer-change-invocation*))
2428      (rlet ((ppos :<NSI>nteger pos)
2429             (pn :<NSI>nteger n)
2430             (pextra :<NSI>nteger extra))
2431        (#/setTarget: invocation textstorage)
2432        (#/setSelector: invocation selector)
2433        (#/setArgument:atIndex: invocation ppos 2)
2434        (#/setArgument:atIndex: invocation pn 3)
2435        (#/setArgument:atIndex: invocation pextra 4))
2436      (#/performSelectorOnMainThread:withObject:waitUntilDone:
2437       invocation
2438       (@selector #/invoke)
2439       +null-ptr+
2440       t))))
2441
2442
2443
2444
2445(defun hemlock-ext:buffer-note-font-change (buffer region font)
2446  (when (hi::bufferp buffer)
2447    (let* ((document (hi::buffer-document buffer))
2448           (textstorage (if document (slot-value document 'textstorage)))
2449           (pos (hi:mark-absolute-position (hi::region-start region)))
2450           (n (- (hi:mark-absolute-position (hi::region-end region)) pos)))
2451      (if (eq *current-process* *cocoa-event-process*)
2452        (#/noteHemlockAttrChangeAtPosition:length:fontNum: textstorage
2453                                                           pos
2454                                                           n
2455                                                           font)
2456        (perform-edit-change-notification textstorage
2457                                          (@selector #/noteHemlockAttrChangeAtPosition:length:fontNum:)
2458                                          pos
2459                                          n
2460                                          font)))))
2461
2462(defun buffer-active-font-attributes (buffer)
2463  (let* ((style 0)
2464         (region (hi::buffer-active-font-region buffer))
2465         (textstorage (slot-value (hi::buffer-document buffer) 'textstorage))
2466         (styles (#/styles textstorage)))
2467    (when region
2468      (let* ((start (hi::region-end region)))
2469        (setq style (hi::font-mark-font start))))
2470    (#/objectAtIndex: styles style)))
2471     
2472;; Note that inserted a string of length n at mark.  Assumes this is called after
2473;; buffer marks were updated.
2474(defun hemlock-ext:buffer-note-insertion (buffer mark n)
2475  (when (hi::bufferp buffer)
2476    (let* ((document (hi::buffer-document buffer))
2477           (textstorage (if document (slot-value document 'textstorage))))
2478      (when textstorage
2479        (let* ((pos (hi:mark-absolute-position mark)))
2480          (when (eq (hi::mark-%kind mark) :left-inserting)
2481            ;; Make up for the fact that the mark moved forward with the insertion.
2482            ;; For :right-inserting and :temporary marks, they should be left back.
2483            (decf pos n))
2484          (if (eq *current-process* *cocoa-event-process*)
2485            (#/noteHemlockInsertionAtPosition:length:extra: textstorage
2486                                                            pos
2487                                                            n
2488                                                            0)
2489            (perform-edit-change-notification textstorage
2490                                              (@selector #/noteHemlockInsertionAtPosition:length:extra:)
2491                                              pos
2492                                              n)))))))
2493
2494(defun hemlock-ext:buffer-note-modification (buffer mark n)
2495  (when (hi::bufferp buffer)
2496    (let* ((document (hi::buffer-document buffer))
2497           (textstorage (if document (slot-value document 'textstorage))))
2498      (when textstorage
2499        (if (eq *current-process* *cocoa-event-process*)
2500          (#/noteHemlockModificationAtPosition:length:extra: textstorage
2501                                                             (hi:mark-absolute-position mark)
2502                                                             n
2503                                                             0)
2504          (perform-edit-change-notification textstorage
2505                                            (@selector #/noteHemlockModificationAtPosition:length:extra:)
2506                                            (hi:mark-absolute-position mark)
2507                                            n))))))
2508 
2509
2510(defun hemlock-ext:buffer-note-deletion (buffer mark n)
2511  (when (hi::bufferp buffer)
2512    (let* ((document (hi::buffer-document buffer))
2513           (textstorage (if document (slot-value document 'textstorage))))
2514      (when textstorage
2515        (let* ((pos (hi:mark-absolute-position mark)))
2516          (if (eq *current-process* *cocoa-event-process*)
2517            (#/noteHemlockDeletionAtPosition:length:extra: textstorage
2518                                                           pos
2519                                                           (abs n)
2520                                                           0)
2521            (perform-edit-change-notification textstorage
2522                                              (@selector #/noteHemlockDeletionAtPosition:length:extra:)
2523                                              pos
2524                                              (abs n))))))))
2525
2526
2527
2528(defun hemlock-ext:note-buffer-saved (buffer)
2529  (assume-cocoa-thread)
2530  (let* ((document (hi::buffer-document buffer)))
2531    (when document
2532      ;; Hmm... I guess this is always done by the act of saving.
2533      nil)))
2534
2535(defun hemlock-ext:note-buffer-unsaved (buffer)
2536  (assume-cocoa-thread)
2537  (let* ((document (hi::buffer-document buffer)))
2538    (when document
2539      (#/updateChangeCount: document #$NSChangeCleared))))
2540
2541
2542(defun size-of-char-in-font (f)
2543  (let* ((sf (#/screenFont f))
2544         (screen-p *use-screen-fonts*))
2545    (if (%null-ptr-p sf) (setq sf f screen-p nil))
2546    (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager)))))
2547      (#/setUsesScreenFonts: layout screen-p)
2548      (values (fround (#/defaultLineHeightForFont: layout sf))
2549              (fround (ns:ns-size-width (#/advancementForGlyph: sf (char-code #\space))))))))
2550         
2551
2552
2553(defun size-text-pane (pane line-height char-width nrows ncols)
2554  (let* ((tv (text-pane-text-view pane))
2555         (height (fceiling (* nrows line-height)))
2556         (width (fceiling (* ncols char-width)))
2557         (scrollview (text-pane-scroll-view pane))
2558         (window (#/window scrollview))
2559         (has-horizontal-scroller (#/hasHorizontalScroller scrollview))
2560         (has-vertical-scroller (#/hasVerticalScroller scrollview)))
2561    (ns:with-ns-size (tv-size
2562                      (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv))))
2563                      height)
2564      (when has-vertical-scroller 
2565        (#/setVerticalLineScroll: scrollview line-height)
2566        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#))
2567      (when has-horizontal-scroller
2568        (#/setHorizontalLineScroll: scrollview char-width)
2569        (#/setHorizontalPageScroll: scrollview (cgfloat 0.0) #|char-width|#))
2570      (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview)))
2571             (pane-frame (#/frame pane))
2572             (margins (#/contentViewMargins pane)))
2573        (incf (ns:ns-size-height sv-size)
2574              (+ (ns:ns-rect-y pane-frame)
2575                 (* 2 (ns:ns-size-height  margins))))
2576        (incf (ns:ns-size-width sv-size)
2577              (ns:ns-size-width margins))
2578        (#/setContentSize: window sv-size)
2579        (setf (slot-value tv 'char-width) char-width
2580              (slot-value tv 'line-height) line-height)
2581        #-cocotron
2582        (#/setResizeIncrements: window
2583                                (ns:make-ns-size char-width line-height))))))
2584                                   
2585 
2586(defclass hemlock-editor-window-controller (ns:ns-window-controller)
2587  ((sequence :foreign-type :int))
2588  (:metaclass ns:+ns-object))
2589
2590(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-editor-window-controller) docname)
2591  (let* ((seq (slot-value self 'sequence)))
2592    (if (zerop seq)
2593      docname
2594      (#/stringWithFormat: ns:ns-string #@"%@ <%d>" docname seq))))
2595 
2596
2597;;; This is borrowed from emacs.  The first click on the zoom button will
2598;;; zoom vertically.  The second will zoom completely.  The third will
2599;;; return to the original size.
2600(objc:defmethod (#/windowWillUseStandardFrame:defaultFrame: #>NSRect)
2601                ((wc hemlock-editor-window-controller) sender (default-frame #>NSRect))
2602  (let* ((r (#/frame sender)))
2603    (if (= (ns:ns-rect-height r) (ns:ns-rect-height default-frame))
2604      (setf r default-frame)
2605      (setf (ns:ns-rect-height r) (ns:ns-rect-height default-frame)
2606            (ns:ns-rect-y r) (ns:ns-rect-y default-frame)))
2607    r))
2608
2609(objc:defmethod (#/windowWillClose: :void) ((wc hemlock-editor-window-controller)
2610                                            notification)
2611  (declare (ignore notification))
2612  ;; The echo area "document" should probably be a slot in the document
2613  ;; object, and released when the document object is.
2614  (let* ((w (#/window wc)))
2615    ;; guard against cocotron lossage
2616    (if (#/isKindOfClass: w hemlock-frame)
2617      (let* ((buf (hemlock-frame-echo-area-buffer w))
2618             (echo-doc (if buf (hi::buffer-document buf))))
2619        (when echo-doc
2620          (setf (hemlock-frame-echo-area-buffer w) nil)
2621          (#/close echo-doc))
2622        (#/setFrameAutosaveName: w #@"")
2623        (#/autorelease w))
2624      (#_NSLog #@"window controller %@ got windowWillClose for odd window %@ "
2625               :address wc :address w))))
2626
2627(defmethod hemlock-view ((self hemlock-editor-window-controller))
2628  (let ((frame (#/window self)))
2629    (unless (%null-ptr-p frame)
2630      (hemlock-view frame))))
2631
2632;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
2633(defun get-default-encoding ()
2634  #-cocotron                            ;need IANA conversion stuff
2635  (let* ((file-encoding *default-file-character-encoding*))
2636    (when (and (typep file-encoding 'keyword)
2637               (lookup-character-encoding file-encoding))
2638      (let* ((string (string file-encoding))
2639             (len (length string)))
2640        (with-cstrs ((cstr string))
2641          (with-nsstr (nsstr cstr len)
2642            (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr)))
2643              (if (= cf #$kCFStringEncodingInvalidId)
2644                (setq cf (#_CFStringGetSystemEncoding)))
2645              (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf)))
2646                (if (= ns #$kCFStringEncodingInvalidId)
2647                  (#/defaultCStringEncoding ns:ns-string)
2648                  ns)))))))))
2649
2650(defclass hemlock-document-controller (ns:ns-document-controller)
2651    ((last-encoding :foreign-type :<NSS>tring<E>ncoding))
2652  (:metaclass ns:+ns-object))
2653(declaim (special hemlock-document-controller))
2654
2655(objc:defmethod #/init ((self hemlock-document-controller))
2656  (prog1
2657      (call-next-method)
2658    (setf (slot-value self 'last-encoding) 0)))
2659
2660
2661;;; The HemlockEditorDocument class.
2662
2663
2664(defclass hemlock-editor-document (ns:ns-document)
2665    ((textstorage :foreign-type :id)
2666     (encoding :foreign-type :<NSS>tring<E>ncoding)
2667     (dupcount :foreign-type :int))
2668  (:metaclass ns:+ns-object))
2669
2670(defmethod hemlock-buffer ((self hemlock-editor-document))
2671  (let ((ts (slot-value self 'textstorage)))
2672    (unless (%null-ptr-p ts)
2673      (hemlock-buffer ts))))
2674
2675(defmethod window-document ((w ns:ns-window))
2676  (let* ((sc (#/sharedDocumentController ns:ns-document-controller))
2677         (doc (#/documentForWindow: sc w)))
2678    (if (%null-ptr-p doc)
2679      nil
2680      doc)))
2681
2682(defmethod window-pathname ((w ns:ns-window))
2683  (document-pathname (window-document w)))
2684
2685(defmethod document-pathname ((doc NULL))
2686  nil)
2687
2688(defmethod document-pathname ((doc hemlock-editor-document))
2689  (hi:buffer-pathname (hemlock-buffer doc)))
2690
2691(defmethod assume-not-editing ((doc hemlock-editor-document))
2692  (assume-not-editing (slot-value doc 'textstorage)))
2693
2694(defmethod document-invalidate-modeline ((self hemlock-editor-document))
2695  (for-each-textview-using-storage
2696   (slot-value self 'textstorage)
2697   #'(lambda (tv)
2698       (let* ((pane (text-view-pane tv)))
2699         (unless (%null-ptr-p pane)
2700           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
2701
2702(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
2703  (let* ((name (or (hemlock::package-at-mark (hi::buffer-point buffer))
2704                   (hi::variable-value 'hemlock::default-package :buffer buffer))))
2705    (when name
2706      (let* ((pkg (find-package name)))
2707        (if pkg
2708          (setq name (shortest-package-name pkg))))
2709      (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer)))
2710        (if (or (null curname)
2711                (not (string= curname name)))
2712          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
2713
2714(defun hemlock-ext:note-selection-set-by-search (buffer)
2715  (let* ((doc (hi::buffer-document buffer)))
2716    (when doc
2717      (with-slots (textstorage) doc
2718        (when textstorage
2719          (with-slots (selection-set-by-search) textstorage
2720            (setq selection-set-by-search #$YES)))))))
2721
2722(objc:defmethod (#/validateMenuItem: :<BOOL>)
2723    ((self hemlock-text-view) item)
2724  (let* ((action (#/action item)))
2725    #+debug (#_NSLog #@"action = %s" :address action)
2726    (cond ((eql action (@selector #/hyperSpecLookUp:))
2727           ;; For now, demand a selection.
2728           (and *hyperspec-lookup-enabled*
2729                (hyperspec-root-url)
2730                (not (eql 0 (ns:ns-range-length (#/selectedRange self))))))
2731          ((eql action (@selector #/cut:))
2732           (let* ((selection (#/selectedRange self)))
2733             (and (> (ns:ns-range-length selection))
2734                  (#/shouldChangeTextInRange:replacementString: self selection #@""))))
2735          ((eql action (@selector #/evalSelection:))
2736           (when (hemlock-view self)
2737             (if (eql 0 (ns:ns-range-length (#/selectedRange self)))
2738               ;; Should check whether there is a current form
2739               (#/setTitle: item #@"Execute Expression")
2740               (#/setTitle: item #@"Execute Selection"))
2741             t))
2742          ((eql action (@selector #/evalAll:))
2743           (let* ((doc (#/document (#/windowController (#/window self)))))
2744             (and (not (%null-ptr-p doc))
2745                  (eq (type-of doc) 'hemlock-editor-document))))
2746          ;; if this hemlock-text-view is in an editor window and its buffer has
2747          ;; an associated pathname, then activate the Load Buffer item
2748          ((or (eql action (@selector #/loadBuffer:))
2749               (eql action (@selector #/compileBuffer:))
2750               (eql action (@selector #/compileAndLoadBuffer:))) 
2751           (let* ((buffer (hemlock-buffer self))
2752                  (pathname (hi::buffer-pathname buffer)))
2753             (not (null pathname))))
2754          ((eql action (@selector #/openSelection:))
2755           (let* ((text (#/string self))
2756                  (selection (#/substringWithRange: text (#/selectedRange self))))
2757             (pathname-for-namestring-fragment (lisp-string-from-nsstring selection))))
2758          ((eql action (@selector #/duplicate:))
2759           ;; Duplicating a listener "works", but listeners have all kinds
2760           ;; of references to the original window and text view and get
2761           ;; confused if the original is closed before all duplicates are.
2762           (let* ((doc (#/document (#/windowController (#/window self)))))
2763             (not (typep doc 'hemlock-listener-document))))
2764           
2765          (t (call-next-method item)))))
2766
2767(defmethod user-input-style ((doc hemlock-editor-document))
2768  0)
2769
2770(defvar *encoding-name-hash* (make-hash-table))
2771
2772(defmethod document-encoding-name ((doc hemlock-editor-document))
2773  (with-slots (encoding) doc
2774    (if (eql encoding 0)
2775      "Automatic"
2776      (or (gethash encoding *encoding-name-hash*)
2777          (setf (gethash encoding *encoding-name-hash*)
2778                (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
2779
2780(defun hemlock-ext:buffer-encoding-name (buffer)
2781  (let ((doc (hi::buffer-document buffer)))
2782    (and doc (document-encoding-name doc))))
2783
2784;; TODO: make each buffer have a slot, and this is just the default value.
2785(defmethod textview-background-color ((doc hemlock-editor-document))
2786  *editor-background-color*)
2787
2788
2789(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts)
2790  (let* ((doc (%inc-ptr self 0))        ; workaround for stack-consed self
2791         (string (#/hemlockString ts))
2792         (buffer (hemlock-buffer string)))
2793    (unless (%null-ptr-p doc)
2794      (setf (slot-value doc 'textstorage) ts
2795            (hi::buffer-document buffer) doc))))
2796
2797;; This runs on the main thread.
2798(objc:defmethod (#/revertToSavedFromFile:ofType: :<BOOL>)
2799    ((self hemlock-editor-document) filename filetype)
2800  (declare (ignore filetype))
2801  (assume-cocoa-thread)
2802  #+debug
2803  (#_NSLog #@"revert to saved from file %@ of type %@"
2804           :id filename :id filetype)
2805  (let* ((encoding (slot-value self 'encoding))
2806         (nsstring (make-instance ns:ns-string
2807                                  :with-contents-of-file filename
2808                                  :encoding encoding
2809                                  :error +null-ptr+))
2810         (buffer (hemlock-buffer self))
2811         (old-length (hemlock-buffer-length buffer))
2812         (hi::*current-buffer* buffer)
2813         (textstorage (slot-value self 'textstorage))
2814         (point (hi::buffer-point buffer))
2815         (pointpos (hi:mark-absolute-position point)))
2816    (hemlock-ext:invoke-modifying-buffer-storage
2817     buffer
2818     #'(lambda ()
2819         (#/edited:range:changeInLength:
2820          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
2821         (nsstring-to-buffer nsstring buffer)
2822         (let* ((newlen (hemlock-buffer-length buffer)))
2823           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
2824           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
2825           (let* ((ts-string (#/hemlockString textstorage))
2826                  (display (hemlock-buffer-string-cache ts-string)))
2827             (reset-buffer-cache display) 
2828             (update-line-cache-for-index display 0)
2829             (move-hemlock-mark-to-absolute-position point
2830                                                     display
2831                                                     (min newlen pointpos))))
2832         (#/updateMirror textstorage)
2833         (setf (hi::buffer-modified buffer) nil)
2834         (hi::note-modeline-change buffer)))
2835    t))
2836
2837
2838(defvar *last-document-created* nil)
2839
2840(objc:defmethod #/init ((self hemlock-editor-document))
2841  (let* ((doc (call-next-method)))
2842    (unless  (%null-ptr-p doc)
2843      (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer
2844                              (make-hemlock-buffer
2845                               (lisp-string-from-nsstring
2846                                (#/displayName doc))
2847                               :modes '("Lisp" "Editor")))))
2848    (with-slots (encoding) doc
2849      (setq encoding (or (get-default-encoding) #$NSISOLatin1StringEncoding)))
2850    (setq *last-document-created* doc)
2851    doc))
2852
2853 
2854(defun make-buffer-for-document (ns-document pathname)
2855  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
2856         (buffer (make-hemlock-buffer buffer-name)))
2857    (setf (slot-value ns-document 'textstorage)
2858          (make-textstorage-for-hemlock-buffer buffer))
2859    (setf (hi::buffer-pathname buffer) pathname)
2860    buffer))
2861
2862(objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
2863    ((self hemlock-editor-document) url type (perror (:* :id)))
2864  (declare (ignorable type))
2865  (with-callback-context "readFromURL"
2866    (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
2867      (let* ((pathname
2868              (lisp-string-from-nsstring
2869               (if (#/isFileURL url)
2870                 (#/path url)
2871                 (#/absoluteString url))))
2872             (buffer (or (hemlock-buffer self)
2873                         (make-buffer-for-document self pathname)))
2874             (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
2875             (string
2876              (if (zerop selected-encoding)
2877                (#/stringWithContentsOfURL:usedEncoding:error:
2878                 ns:ns-string
2879                 url
2880                 pused-encoding
2881                 perror)
2882                +null-ptr+)))
2883       
2884        (if (%null-ptr-p string)
2885          (progn
2886            (if (zerop selected-encoding)
2887              (setq selected-encoding (or (get-default-encoding) #$NSISOLatin1StringEncoding)))
2888            (setq string (#/stringWithContentsOfURL:encoding:error:
2889                          ns:ns-string
2890                          url
2891                          selected-encoding
2892                          perror)))
2893          (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
2894        (unless (%null-ptr-p string)
2895          (with-slots (encoding) self (setq encoding selected-encoding))
2896
2897          ;; ** TODO: Argh.  How about we just let hemlock insert it.
2898          (let* ((textstorage (slot-value self 'textstorage))
2899                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
2900                 (hi::*current-buffer* buffer))
2901            (hemlock-ext:invoke-modifying-buffer-storage
2902             buffer
2903             #'(lambda ()
2904                 (nsstring-to-buffer string buffer)
2905                 (reset-buffer-cache display) 
2906                 (#/updateMirror textstorage)
2907                 (update-line-cache-for-index display 0)
2908                 (textstorage-note-insertion-at-position
2909                  textstorage
2910                  0
2911                  (hemlock-buffer-length buffer))
2912                 (hi::note-modeline-change buffer)
2913                 (setf (hi::buffer-modified buffer) nil))))
2914          t)))))
2915
2916
2917
2918
2919(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files")
2920
2921(objc:defmethod (#/keepBackupFile :<BOOL>) ((self hemlock-editor-document))
2922  ;;; Don't use the NSDocument backup file scheme.
2923  nil)
2924
2925(objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :<BOOL>)
2926    ((self hemlock-editor-document)
2927     absolute-url
2928     type
2929     (save-operation :<NSS>ave<O>peration<T>ype)
2930     (error (:* :id)))
2931  (when (and *editor-keep-backup-files*
2932             (eql save-operation #$NSSaveOperation))
2933    (write-hemlock-backup-file (#/fileURL self)))
2934  (call-next-method absolute-url type save-operation error))
2935
2936(defun write-hemlock-backup-file (url)
2937  (unless (%null-ptr-p url)
2938    (when (#/isFileURL url)
2939      (let* ((path (#/path url)))
2940        (unless (%null-ptr-p path)
2941          (let* ((newpath (#/stringByAppendingString: path #@"~"))
2942                 (fm (#/defaultManager ns:ns-file-manager)))
2943            ;; There are all kinds of ways for this to lose.
2944            ;; In order for the copy to succeed, the destination can't exist.
2945            ;; (It might exist, but be a directory, or there could be
2946            ;; permission problems ...)
2947            (#/removeFileAtPath:handler: fm newpath +null-ptr+)
2948            (#/copyPath:toPath:handler: fm path newpath +null-ptr+)))))))
2949
2950             
2951
2952
2953
2954(defun hemlock-ext:all-hemlock-views ()
2955  "List of all hemlock views, in z-order, frontmost first"
2956  (loop for win in (windows)
2957    as buf = (and (typep win 'hemlock-frame) (hemlock-view win))
2958    when buf collect buf))
2959
2960(defmethod document-panes ((document hemlock-editor-document))
2961  (let* ((ts (slot-value document 'textstorage))
2962         (panes ()))
2963    (for-each-textview-using-storage
2964     ts
2965     #'(lambda (tv)
2966         (let* ((pane (text-view-pane tv)))
2967           (unless (%null-ptr-p pane)
2968             (push pane panes)))))
2969    panes))
2970
2971(objc:defmethod (#/noteEncodingChange: :void) ((self hemlock-editor-document)
2972                                               popup)
2973  (with-slots (encoding) self
2974    (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
2975    (hi::note-modeline-change (hemlock-buffer self))))
2976
2977#-cocotron
2978(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
2979                                               panel)
2980  (with-slots (encoding) self
2981    (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller) encoding)))
2982      (#/setAction: popup (@selector #/noteEncodingChange:))
2983      (#/setTarget: popup self)
2984      (#/setAccessoryView: panel popup)))
2985  (#/setExtensionHidden: panel nil)
2986  (#/setCanSelectHiddenExtension: panel nil)
2987  (#/setAllowedFileTypes: panel +null-ptr+)
2988  (call-next-method panel))
2989
2990
2991(defloadvar *ns-cr-string* (%make-nsstring (string #\return)))
2992(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed)))
2993(defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*))))
2994
2995(objc:defmethod (#/writeToURL:ofType:error: :<BOOL>)
2996    ((self hemlock-editor-document) url type (error (:* :id)))
2997  (declare (ignore type))
2998  (with-slots (encoding textstorage) self
2999    (let* ((string (#/string textstorage))
3000           (buffer (hemlock-buffer self)))
3001      (case (when buffer (hi::buffer-line-termination buffer))
3002        (:crlf (unless (typep string 'ns:ns-mutable-string)
3003                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
3004                 (#/replaceOccurrencesOfString:withString:options:range:
3005                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
3006        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
3007                            string
3008                            (make-instance 'ns:ns-mutable-string :with string string)))
3009             (#/replaceOccurrencesOfString:withString:options:range:
3010              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
3011      (when (#/writeToURL:atomically:encoding:error:
3012             string url t encoding error)
3013        (when buffer
3014          (setf (hi::buffer-modified buffer) nil))
3015        t))))
3016
3017;;; Cocotron's NSDocument uses the deprecated as of 10.4 methods to implement the NSSavePanel
3018#+cocotron
3019(objc:defmethod (#/writeToFile:ofType: :<BOOL>)
3020    ((self hemlock-editor-document) path type)
3021  (rlet ((perror :id +null-ptr+))
3022    (#/writeToURL:ofType:error: self (#/fileURLWithPath: ns:ns-url path) type perror)))
3023
3024
3025;;; Shadow the setFileURL: method, so that we can keep the buffer
3026;;; name and pathname in synch with the document.
3027(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document)
3028                                        url)
3029  (call-next-method url)
3030  (let* ((path nil)
3031         (controllers (#/windowControllers self)))
3032    (dotimes (i (#/count controllers))
3033      (let* ((controller (#/objectAtIndex: controllers i))
3034             (window (#/window controller)))
3035        (#/setFrameAutosaveName: window (or path (setq path (#/path url)))))))
3036  (let* ((buffer (hemlock-buffer self)))
3037    (when buffer
3038      (let* ((new-pathname (lisp-string-from-nsstring (#/path url))))
3039        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
3040        (setf (hi::buffer-pathname buffer) new-pathname)))))
3041
3042
3043(def-cocoa-default *initial-editor-x-pos* :float 20.0f0 "X position of upper-left corner of initial editor")
3044
3045(def-cocoa-default *initial-editor-y-pos* :float 10.0f0 "Y position of upper-left corner of initial editor")
3046
3047(defloadvar *editor-cascade-point* nil)
3048
3049(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized
3050(defloadvar *next-editor-y-pos* nil)
3051
3052(defun x-pos-for-window (window x)
3053  (let* ((frame (#/frame window))
3054         (screen (#/screen window)))
3055    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
3056    (let* ((screen-rect (#/visibleFrame screen)))
3057      (if (>= x 0)
3058        (+ x (ns:ns-rect-x screen-rect))
3059        (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame))))))
3060
3061(defun y-pos-for-window (window y)
3062  (let* ((frame (#/frame window))
3063         (screen (#/screen window)))
3064    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
3065    (let* ((screen-rect (#/visibleFrame screen)))
3066      (if (>= y 0)
3067        (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame))
3068        (+ (ns:ns-rect-height screen-rect) y)))))
3069
3070(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document))
3071  #+debug
3072  (#_NSLog #@"Make window controllers")
3073    (let* ((textstorage  (slot-value self 'textstorage))
3074           (window (%hemlock-frame-for-textstorage
3075                    hemlock-frame
3076                    textstorage
3077                    *editor-columns*
3078                    *editor-rows*
3079                    nil
3080                    (textview-background-color self)
3081                    (user-input-style self)))
3082           (dupcount (slot-value self 'dupcount))
3083           (controller (make-instance
3084                           'hemlock-editor-window-controller
3085                         :with-window window))
3086           (url (#/fileURL self))
3087           (path (unless (%null-ptr-p url) (#/path url))))
3088      ;;(#/setDelegate: window self)
3089      (#/setDelegate: window controller)
3090      (setf (slot-value controller 'sequence) dupcount)
3091      (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
3092      (#/addWindowController: self controller)
3093      (#/release controller)
3094      (#/setShouldCascadeWindows: controller nil)
3095      (when path
3096        (unless (and (eql dupcount 0) (#/setFrameAutosaveName: window path))
3097          (setq path nil)))
3098      (unless (and path
3099                   (#/setFrameUsingName: window path))
3100        ;; Cascade windows from the top left corner of the topmost editor window.
3101        ;; If there's no editor window, use the default position.
3102        (flet ((editor-window-p (w)
3103                 (and (not (eql w window))
3104                      (eql (#/class (#/windowController w))
3105                           (find-class 'hemlock-editor-window-controller)))))
3106          (let* ((editors (remove-if-not #'editor-window-p (windows)))
3107                 (top-editor (car editors)))
3108            (if top-editor
3109              (ns:with-ns-point (zp 0 0)
3110                (setq *editor-cascade-point* (#/cascadeTopLeftFromPoint:
3111                                              top-editor zp)))
3112              (let* ((screen-frame (#/visibleFrame (#/screen window)))
3113                     (pt (ns:make-ns-point *initial-editor-x-pos*
3114                                           (- (ns:ns-rect-height screen-frame)
3115                                              *initial-editor-y-pos*))))
3116                (setq *editor-cascade-point* pt)))))
3117        (#/cascadeTopLeftFromPoint: window *editor-cascade-point*))
3118      (when (eql dupcount 0)
3119        (let ((view (hemlock-view window)))
3120          (hi::handle-hemlock-event view #'(lambda ()
3121                                             (hi::process-file-options)))))
3122      (#/synchronizeWindowTitleWithDocumentName controller)))
3123
3124(objc:defmethod (#/duplicate: :void) ((self hemlock-frame) sender)
3125  (declare (ignorable sender))
3126  (let* ((self-controller (#/windowController self))
3127         (doc (#/document self-controller)))
3128    (when (typep doc 'hemlock-editor-document
3129      (let* ((sequence-number (incf (slot-value doc 'dupcount))))
3130        (#/makeWindowControllers doc)
3131        ;; Now we have to find the window controller that was just made ...
3132        (let* ((controllers (#/windowControllers doc))
3133               (count (#/count controllers))
3134               (controller (dotimes (i count)
3135                             (let* ((c (#/objectAtIndex: controllers i)))
3136                               (when (eql sequence-number (slot-value c 'sequence))
3137                                 (return c))))))
3138
3139          (when controller
3140            (let* ((window (#/window controller))
3141                   (new-text-view (text-pane-text-view (slot-value window 'pane)))
3142                   (new-selection-info (view-selection-info new-text-view))
3143                   (old-selection-info (view-selection-info (text-pane-text-view (slot-value self 'pane))))
3144                   (old-mark (hi::selection-info-%mark old-selection-info)))
3145              (hi::move-mark (hi::selection-info-point new-selection-info)
3146                             (hi::selection-info-point old-selection-info))
3147              (setf (hi::selection-info-%mark new-selection-info)
3148                    (if old-mark (hi::copy-mark old-mark))
3149                    (hi::selection-info-region-active new-selection-info)
3150                    (hi::selection-info-region-active old-selection-info))
3151              (update-hemlock-selection (#/textStorage new-text-view))
3152              (#/scrollRangeToVisible: new-text-view
3153                                       (#/selectedRange new-text-view))
3154              (#/makeKeyAndOrderFront: window +null-ptr+)))))))))
3155             
3156     
3157
3158(objc:defmethod (#/close :void) ((self hemlock-editor-document))
3159  #+debug
3160  (#_NSLog #@"Document close: %@" :id self)
3161  (let* ((textstorage (slot-value self 'textstorage)))
3162    (unless (%null-ptr-p textstorage)
3163      (setf (slot-value self 'textstorage) (%null-ptr))
3164      (close-hemlock-textstorage textstorage)))
3165  (call-next-method))
3166
3167(objc:defmethod (#/dealloc :void) ((self hemlock-editor-document))
3168  (let* ((textstorage (slot-value self 'textstorage)))
3169    (unless (%null-ptr-p textstorage)
3170      (setf (slot-value self 'textstorage) (%null-ptr))
3171      (close-hemlock-textstorage textstorage)))
3172  (objc:remove-lisp-slots self)
3173  (call-next-method))
3174
3175
3176
3177(defmethod view-screen-lines ((view hi:hemlock-view))
3178    (let* ((pane (hi::hemlock-view-pane view)))
3179      (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane)))
3180             (text-view-line-height (text-pane-text-view pane)))))
3181
3182;; Beware this doesn't seem to take horizontal scrolling into account.
3183(defun visible-charpos-range (tv)
3184  (let* ((rect (#/visibleRect tv))
3185         (container-origin (#/textContainerOrigin tv))
3186         (layout (#/layoutManager tv)))
3187    ;; Convert from view coordinates to container coordinates
3188    (decf (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
3189    (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y))
3190    (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
3191                         layout rect (#/textContainer tv)))
3192           (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
3193                        layout glyph-range +null-ptr+)))
3194      (values (pref char-range :<NSR>ange.location)
3195              (pref char-range :<NSR>ange.length)))))
3196
3197(defun charpos-xy (tv charpos)
3198  (let* ((layout (#/layoutManager tv))
3199         (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
3200                       layout
3201                       (ns:make-ns-range charpos 0)
3202                       +null-ptr+))
3203         (rect (#/boundingRectForGlyphRange:inTextContainer:
3204                layout
3205                glyph-range
3206                (#/textContainer tv)))
3207         (container-origin (#/textContainerOrigin tv)))
3208    (values (+ (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
3209            (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y)))))
3210
3211;;(nth-value 1 (charpos-xy tv (visible-charpos-range tv))) - this is smaller as it
3212;; only includes lines fully scrolled off...
3213(defun text-view-vscroll (tv)
3214  ;; Return the number of pixels scrolled off the top of the view.
3215  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
3216         (clip-view (#/contentView scroll-view))
3217         (bounds (#/bounds clip-view)))
3218    (ns:ns-rect-y bounds)))
3219
3220(defun set-text-view-vscroll (tv vscroll)
3221  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
3222         (clip-view (#/contentView scroll-view))
3223         (bounds (#/bounds clip-view)))
3224    (decf vscroll (mod vscroll (text-view-line-height tv))) ;; show whole line
3225    (ns:with-ns-point (new-origin (ns:ns-rect-x bounds) vscroll)
3226      (#/scrollToPoint: clip-view (#/constrainScrollPoint: clip-view new-origin))
3227      (#/reflectScrolledClipView: scroll-view clip-view))))
3228
3229(defun scroll-by-lines (tv nlines)
3230  "Change the vertical origin of the containing scrollview's clipview"
3231  (set-text-view-vscroll tv (+ (text-view-vscroll tv)
3232                               (* nlines (text-view-line-height tv)))))
3233
3234;; TODO: should be a hemlock variable..
3235(defvar *next-screen-context-lines* 2)
3236
3237(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where)
3238  (assume-cocoa-thread)
3239  (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view)))
3240         (may-change-selection t))
3241    (when (eq how :line)
3242      (setq where (require-type where '(integer 0)))
3243      (let* ((line-y (nth-value 1 (charpos-xy tv where)))
3244             (top-y (text-view-vscroll tv))
3245             (nlines (floor (- line-y top-y) (text-view-line-height tv))))
3246        (setq how :lines-down where nlines)))
3247    (ecase how
3248      (:center-selection
3249       (#/centerSelectionInVisibleArea: tv +null-ptr+))
3250      ((:page-up :view-page-up)
3251       (when (eq how :view-page-up)
3252         (setq may-change-selection nil))
3253       (require-type where 'null)
3254       ;; TODO: next-screen-context-lines
3255       (scroll-by-lines tv (- *next-screen-context-lines* (view-screen-lines view))))
3256      ((:page-down :view-page-down)
3257       (when (eq how :view-page-down)
3258         (setq may-change-selection nil))
3259       (require-type where 'null)
3260       (scroll-by-lines tv (- (view-screen-lines view) *next-screen-context-lines*)))
3261      (:lines-up
3262       (scroll-by-lines tv (- (require-type where 'integer))))
3263      (:lines-down
3264       (scroll-by-lines tv (require-type where 'integer))))
3265    ;; If point is not on screen, move it.
3266    (when may-change-selection
3267      (let* ((point (hi::current-point))
3268             (point-pos (hi::mark-absolute-position point)))
3269        (multiple-value-bind (win-pos win-len) (visible-charpos-range tv)
3270          (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
3271            (let* ((point (hi::current-point-collapsing-selection))
3272                   (cache (hemlock-buffer-string-cache (#/hemlockString (#/textStorage tv)))))
3273              (move-hemlock-mark-to-absolute-position point cache win-pos)
3274              (update-hemlock-selection (#/textStorage tv)))))))))
3275
3276(defun iana-charset-name-of-nsstringencoding (ns)
3277  #+cocotron (declare (ignore ns))
3278  #+cocotron +null-ptr+
3279  #-cocotron
3280  (#_CFStringConvertEncodingToIANACharSetName
3281   (#_CFStringConvertNSStringEncodingToEncoding ns)))
3282   
3283(defun nsstring-for-nsstring-encoding (ns)
3284  (let* ((iana (iana-charset-name-of-nsstringencoding ns)))
3285    (if (%null-ptr-p iana)
3286      (#/stringWithFormat: ns:ns-string #@"{%@}"
3287                           (#/localizedNameOfStringEncoding: ns:ns-string ns))
3288      iana)))
3289
3290;;; Return T if the specified #>NSStringEncoding names something that
3291;;; CCL supports.  (Could also have a set of other encoding names that
3292;;; the user is interested in, maintained by preferences.
3293
3294(defun supported-string-encoding-p (ns-string-encoding)
3295  #-cocotron
3296  (let* ((cfname (#_CFStringConvertEncodingToIANACharSetName
3297                  (#_CFStringConvertNSStringEncodingToEncoding ns-string-encoding)))
3298         (name (unless (%null-ptr-p cfname)
3299                 (nstring-upcase (ccl::lisp-string-from-nsstring cfname))))
3300         (keyword (when (and name (find-symbol name "KEYWORD"))
3301                    (intern name "KEYWORD"))))
3302    (or (and keyword (not (null (lookup-character-encoding keyword))))
3303        ;; look in other table maintained by preferences
3304        )))
3305   
3306         
3307
3308
3309 
3310;;; Return a list of :<NSS>tring<E>ncodings, sorted by the
3311;;; (localized) name of each encoding.
3312(defun supported-nsstring-encodings ()
3313  (ccl::collect ((ids))
3314    (let* ((ns-ids (#/availableStringEncodings ns:ns-string)))
3315      (unless (%null-ptr-p ns-ids)
3316        (do* ((i 0 (1+ i)))
3317             ()
3318          (let* ((id (paref ns-ids (:* :<NSS>tring<E>ncoding) i)))
3319            (if (zerop id)
3320              (return (sort (ids)
3321                            #'(lambda (x y)
3322                                (= #$NSOrderedAscending
3323                                   (#/localizedCompare:
3324                                    (nsstring-for-nsstring-encoding x)
3325                                    (nsstring-for-nsstring-encoding y))))))
3326              (when (supported-string-encoding-p id)             
3327                (ids id)))))))))
3328
3329
3330
3331
3332
3333;;; TexEdit.app has support for allowing the encoding list in this
3334;;; popup to be customized (e.g., to suppress encodings that the
3335;;; user isn't interested in.)
3336(defmethod build-encodings-popup ((self hemlock-document-controller)
3337                                  &optional (preferred-encoding (get-default-encoding)))
3338  (let* ((id-list (supported-nsstring-encodings))
3339         (popup (make-instance 'ns:ns-pop-up-button)))
3340    ;;; Add a fake "Automatic" item with tag 0.
3341    (#/addItemWithTitle: popup #@"Automatic")
3342    (#/setTag: (#/itemAtIndex: popup 0) 0)
3343    (dolist (id id-list)
3344      (#/addItemWithTitle: popup (nsstring-for-nsstring-encoding id))
3345      (#/setTag: (#/lastItem popup) (nsstring-encoding-to-nsinteger id)))
3346    (when preferred-encoding
3347      (#/selectItemWithTag: popup (nsstring-encoding-to-nsinteger preferred-encoding)))
3348    (#/sizeToFit popup)
3349    popup))
3350
3351
3352(objc:defmethod (#/runModalOpenPanel:forTypes: :<NSI>nteger)
3353    ((self hemlock-document-controller) panel types)
3354  (let* (#-cocotron (popup (build-encodings-popup self #|preferred|#)))
3355    #-cocotron (#/setAccessoryView: panel popup)
3356    (let* ((result (call-next-method panel types)))
3357      (when (= result #$NSOKButton)
3358        #-cocotron
3359        (with-slots (last-encoding) self
3360          (setq last-encoding
3361                (nsinteger-to-nsstring-encoding (#/tag (#/selectedItem popup))))))
3362      result)))
3363 
3364(defun hemlock-ext:open-hemlock-buffer (&key (pathname :prompt))
3365  (assert (eq pathname :prompt)) ;; TODO: should handle pathname
3366  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3367   (#/sharedDocumentController hemlock-document-controller)
3368   (@selector #/openDocument:) +null-ptr+ t))
3369 
3370(defun hemlock-ext:save-hemlock-buffer (buffer &key pathname copy)
3371  (let ((doc (hi::buffer-document buffer)))
3372    (cond (copy
3373           (assert (eq pathname :prompt)) ;; TODO: should handle pathname
3374           (save-hemlock-document-as doc))
3375          ((null pathname)
3376           (save-hemlock-document doc))
3377          (t
3378           (assert (eq pathname :prompt)) ;; TODO: should handle pathname
3379           (save-hemlock-document-to doc)))))
3380
3381(defmethod save-hemlock-document ((self hemlock-editor-document))
3382  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3383   self (@selector #/saveDocument:) +null-ptr+ t))
3384
3385(defmethod save-hemlock-document-as ((self hemlock-editor-document))
3386  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3387   self (@selector #/saveDocumentAs:) +null-ptr+ t))
3388
3389(defmethod save-hemlock-document-to ((self hemlock-editor-document))
3390  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3391   self (@selector #/saveDocumentTo:) +null-ptr+ t))
3392
3393
3394
3395
3396   
3397
3398(defun initialize-user-interface ()
3399  ;; The first created instance of an NSDocumentController (or
3400  ;; subclass thereof) becomes the shared document controller.  So it
3401  ;; may look like we're dropping this instance on the floor, but
3402  ;; we're really not.
3403  (make-instance 'hemlock-document-controller)
3404  ;(#/sharedPanel lisp-preferences-panel)
3405  (make-editor-style-map))
3406 
3407
3408;;; This needs to run on the main thread.  Sets the cocoa selection from the
3409;;; hemlock selection.
3410(defmethod update-hemlock-selection ((self hemlock-text-storage))
3411  (assume-cocoa-thread)
3412  (let* ((buffer (hemlock-buffer self)))
3413    (for-each-textview-using-storage
3414     self
3415     (lambda (tv)
3416       (with-view-selection-info (tv buffer)
3417         (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
3418           #+debug
3419           (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
3420                    :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
3421           (#/updateSelection:length:affinity: tv
3422                                               start
3423                                               (- end start)
3424                                               (if (eql start 0)
3425                                                 #$NSSelectionAffinityUpstream
3426                                                 #$NSSelectionAffinityDownstream))))))))
3427
3428;; This should be invoked by any command that modifies the buffer, so it can show the
3429;; user what happened...  This ensures the Cocoa selection is made visible, so it
3430;; assumes the Cocoa selection has already been synchronized with the hemlock one.
3431(defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view))
3432  (let ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
3433    (#/scrollRangeToVisible: tv (#/selectedRange tv))))
3434
3435(defloadvar *general-pasteboard* nil)
3436
3437(defun general-pasteboard ()
3438  (or *general-pasteboard*
3439      (setq *general-pasteboard*
3440            (#/retain (#/generalPasteboard ns:ns-pasteboard)))))
3441
3442(defloadvar *string-pasteboard-types* ())
3443
3444(defun string-pasteboard-types ()
3445  (or *string-pasteboard-types*
3446      (setq *string-pasteboard-types*
3447            (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType)))))
3448
3449
3450(objc:defmethod (#/stringToPasteBoard:  :void)
3451    ((self lisp-application) string)
3452  (let* ((pb (general-pasteboard)))
3453    (#/declareTypes:owner: pb (string-pasteboard-types) nil)
3454    (#/setString:forType: pb string #&NSStringPboardType)))
3455   
3456(defun hemlock-ext:string-to-clipboard (string)
3457  (when (> (length string) 0)
3458    (#/performSelectorOnMainThread:withObject:waitUntilDone:
3459     *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t)))
3460
3461#+cocotron
3462;;; Work around a byte-order bug that affects #/paste.
3463(defun maybe-byte-reverse-string (nsstring)
3464  (let* ((len (#/length nsstring))
3465         (maybe-reversed-count  0))
3466    (dotimes (i len)
3467      (when (not (logtest #xff (#/characterAtIndex: nsstring i)))
3468        (incf maybe-reversed-count)))
3469    (if (> maybe-reversed-count (ash len -1))
3470      (%stack-block ((chars (* 2 len)))
3471        (ns:with-ns-range (r 0 len)
3472          (#/getCharacters:range: nsstring chars r)
3473          (dotimes (i len)
3474            (declare (fixnum i))
3475            (let* ((j (+ i i)))
3476              (declare (fixnum j))
3477              (let* ((w (%get-unsigned-word chars j)))
3478                (setf (%get-unsigned-word chars j)
3479                      (dpb (ldb (byte 8 0) w)
3480                           (byte 8 8)
3481                           (ldb (byte 8 8) w))))))
3482
3483           
3484          (#/autorelease
3485           (make-instance ns:ns-string
3486                          :with-characters chars
3487                          :length len))))
3488      nsstring)))
3489                       
3490                   
3491                                                           
3492;;; The default #/paste method seems to want to set the font to
3493;;; something ... inappropriate.  If we can figure out why it
3494;;; does that and persuade it not to, we wouldn't have to do
3495;;; this here.
3496;;; (It's likely to also be the case that Carbon applications
3497;;; terminate lines with #\Return when writing to the clipboard;
3498;;; we may need to continue to override this method in order to
3499;;; fix that.)
3500(objc:defmethod (#/paste: :void) ((self hemlock-textstorage-text-view) sender)
3501  (declare (ignorable sender))
3502  #+debug (#_NSLog #@"Paste: sender = %@" :id sender)
3503  (let* ((pb (general-pasteboard))
3504         (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType))))
3505    #+debug (log-debug "   string = ~s" string)
3506    (unless (%null-ptr-p string)
3507      #+cocotron (setq string (maybe-byte-reverse-string string))
3508      (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*)))
3509        (setq string (make-instance 'ns:ns-mutable-string :with-string string))
3510        (#/replaceOccurrencesOfString:withString:options:range:
3511                string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))
3512      (let* ((textstorage (#/textStorage self)))
3513        (unless (#/shouldChangeTextInRange:replacementString: self (#/selectedRange self) string)
3514          (#/setSelectedRange: self (ns:make-ns-range (#/length textstorage) 0)))
3515        (let* ((selectedrange (#/selectedRange self)))
3516          ;; We really should bracket the call to
3517          ;; #/repaceCharactersInRange:withString: here with calls
3518          ;; to #/beginEditing and #/endEditing, but our implementation
3519          ;; of #/replaceCharactersInRange:withString: calls code that
3520          ;; asserts that editing isn't in progress.  Once that's
3521          ;; fixed, this should be fixed as well.
3522          (#/beginEditing textstorage)
3523          (#/replaceCharactersInRange:withString: textstorage selectedrange string)
3524          (#/endEditing textstorage)
3525          (update-hemlock-selection textstorage) )))))
3526
3527
3528(objc:defmethod (#/hyperSpecLookUp: :void)
3529    ((self hemlock-text-view) sender)
3530  (declare (ignore sender))
3531  (let* ((range (#/selectedRange self)))
3532    (unless (eql 0 (ns:ns-range-length range))
3533      (let* ((string (nstring-upcase (lisp-string-from-nsstring (#/substringWithRange: (#/string (#/textStorage self)) range)))))
3534        (multiple-value-bind (symbol win) (find-symbol string "CL")
3535          (when win
3536            (lookup-hyperspec-symbol symbol self)))))))
3537
3538
3539;; This is called by stuff that makes a window programmatically, e.g. m-. or grep.
3540;; But the Open and New menus invoke the cocoa fns below directly. So just changing
3541;; things here will not change how the menus create views.  Instead,f make changes to
3542;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers.
3543(defun find-or-make-hemlock-view (&optional pathname)
3544  (assume-cocoa-thread)
3545  (rlet ((perror :id +null-ptr+))
3546    (let* ((doc (if pathname
3547                  (#/openDocumentWithContentsOfURL:display:error:
3548                   (#/sharedDocumentController ns:ns-document-controller)
3549                   (pathname-to-url pathname)
3550                   #$YES
3551                   perror)
3552                  (let ((*last-document-created* nil))
3553                    (#/newDocument: 
3554                     (#/sharedDocumentController hemlock-document-controller)
3555                     +null-ptr+)
3556                    *last-document-created*))))
3557      #+debug (log-debug "created ~s" doc)
3558      (when (%null-ptr-p doc)
3559        (error "Couldn't open ~s: ~a" pathname
3560               (let ((error (pref perror :id)))
3561                 (if (%null-ptr-p error)
3562                   "unknown error encountered"
3563                   (lisp-string-from-nsstring (#/localizedDescription error))))))
3564      (front-view-for-buffer (hemlock-buffer doc)))))
3565
3566(defun hemlock-ext:execute-in-file-view (pathname thunk)
3567  (execute-in-gui #'(lambda ()
3568                      (assume-cocoa-thread)
3569                      (handler-case
3570                          (let ((view (find-or-make-hemlock-view pathname)))
3571                            (hi::handle-hemlock-event view thunk))
3572                        (error (c)
3573                          (alert-window :title "Error in Hemlock command processing"
3574                                        :message (or (ignore-errors (princ-to-string c))
3575                                                     "#<error printing error message>")
3576                                        :default-button "Ok"))))))
3577
3578(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
3579  (make-instance 'sequence-window-controller
3580    :title title
3581    :sequence sequence
3582    :result-callback action
3583    :display printer))
3584
3585(objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
3586                                                    type)
3587  (if (#/isEqualToString: type #@"html")
3588      display-document
3589      (call-next-method type)))
3590     
3591
3592(objc:defmethod #/newDisplayDocumentWithTitle:content:
3593                ((self hemlock-document-controller)
3594                 title
3595                 string)
3596  (assume-cocoa-thread)
3597  (let* ((doc #+cocotron (#/makeUntitledDocumentOfType: self #@"html")
3598              #-cocotron (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+)))
3599    (unless (%null-ptr-p doc)
3600      (#/addDocument: self doc)
3601      (#/makeWindowControllers doc)
3602      (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0))))
3603        (#/setTitle: window title)
3604        (let* ((tv (slot-value doc 'text-view))
3605               (lm (#/layoutManager tv))
3606               (ts (#/textStorage lm)))
3607          (#/beginEditing ts)
3608          (#/replaceCharactersInRange:withAttributedString:
3609           ts
3610           (ns:make-ns-range 0 (#/length ts))
3611           string)
3612          (#/endEditing ts))
3613        (#/makeKeyAndOrderFront: window self)))
3614    doc))
3615
3616(defun hemlock-ext:revert-hemlock-buffer (buffer)
3617  (let* ((doc (hi::buffer-document buffer)))
3618    (when doc
3619      (#/performSelectorOnMainThread:withObject:waitUntilDone:
3620       doc
3621       (@selector #/revertDocumentToSaved:)
3622       +null-ptr+
3623       t))))
3624
3625(defun hemlock-ext:raise-buffer-view (buffer &optional action)
3626  "Bring a window containing buffer to front and then execute action in
3627   the window.  Returns before operation completes."
3628  ;; Queue for after this event, so don't screw up current context.
3629  (queue-for-gui #'(lambda ()
3630                     (let ((doc (hi::buffer-document buffer)))
3631                       (unless (and doc (not (%null-ptr-p doc)))
3632                         (hi:editor-error "Deleted buffer: ~s" buffer))
3633                       (#/showWindows doc)
3634                       (when action
3635                         (hi::handle-hemlock-event (front-view-for-buffer buffer) action))))))
3636
3637;;; Enable CL:ED
3638(defun cocoa-edit (&optional arg)
3639  (cond ((or (null arg)
3640             (typep arg 'string)
3641             (typep arg 'pathname))
3642         (when arg
3643           (unless (probe-file arg)
3644             (let ((lpath (merge-pathnames arg *.lisp-pathname*)))
3645               (when (probe-file lpath) (setq arg lpath)))))
3646         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
3647        ((ccl::valid-function-name-p arg)
3648         (hemlock::edit-definition arg)
3649         nil)
3650        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
3651
3652(setq ccl::*resident-editor-hook* 'cocoa-edit)
3653
3654#-cocotron
3655(defclass url-handler-command (ns:ns-script-command)
3656  ()
3657  (:documentation
3658   "Handles AppleEvents that send us URLs to open. Both logical pathnames
3659    ('ccl:lib;foo.lisp') and symbols (ccl::*current-process*) can be parsed as a URL
3660    with a scheme of 'ccl'. So, we accept those as URLs, and handle them appropriately.")
3661  (:metaclass ns:+ns-script-command))
3662
3663#-cocotron
3664(objc:defmethod #/performDefaultImplementation ((self url-handler-command))
3665  (let* ((string (ccl::lisp-string-from-nsstring (#/directParameter self)))
3666         (symbol (let ((*read-eval* nil))
3667                   (handler-case (read-from-string string)
3668                     (error () nil)))))
3669    (if symbol
3670      (hemlock::edit-definition symbol)
3671      (execute-in-gui #'(lambda ()
3672                          (find-or-make-hemlock-view
3673                           (if (probe-file string)
3674                             string
3675                             (let ((lpath (merge-pathnames string *.lisp-pathname*)))
3676                               (when (probe-file lpath)
3677                                 lpath))))))))
3678  +null-ptr+)
Note: See TracBrowser for help on using the repository browser.