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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

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