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

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them
succeeds:

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

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