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

Last change on this file since 12495 was 12495, checked in by gb, 11 years ago

Un-wedge MAKE-SCROLLING-TEXTVIEW-FOR-PANE (wrong frame origin, was
incidentally hiding welcome banner in listeners and likely the top
line or so in editor windows.)

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