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

Last change on this file since 12695 was 12695, checked in by palter, 10 years ago

Don't try to do things on Cocotron that aren't implemented.
Allows the open panel (C-x C-f) to work. Save panel still has problems.

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