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

Last change on this file since 14492 was 14492, checked in by gb, 9 years ago

Suppress some cocotron-specific warnings.
Paren highlighting seems to work on Cocotron.

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