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

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

#/replaceCharactersAtPosition:length:withString: UNWIND-PROTECT
around #/beginEditing / #/endEditing.

Try to support :NATIVE quote-next-char behavior. Doesn't work yet.

If our clip-view (the contentview of a scroll view) gets asked to
#/scrollToPoint: while live resize is active, don't do it. (This
seems to prevent the unwanted scrolling that occurs during resize,
which seems to have to do with NSTextView wanting to center the
selection.)

When a Hemlock Frame (window) closes, set its autosave name to #@"".
(This allows previously used names - including listener document
names - to be reused.)

In GET-DEFAULT-ENCODING, only bother if CCL:*DEFAULT-CHARACTER-ENCODING*
is a keyword for which CCL::LOOKUP-CHARACTER-ENCODING returns non-nil.
(This increases the chance that GET-DEFAULT-ENCODING may return NIL.)

Don't expect an :INITFORM to take effect for a foreign slot in
the DEFCLASS for HEMLOCK-EDITOR-DOCUMENT; set the slot in the #/init
method instead.

In UPDATE-BUFFER-PACKAGE, fall back to the (new) default package if
there's no IN-PACKAGE form before point.

For now, the encodings popup menu in Open and Save dialogs only lists
the ~2 dozen encodings that CCL actually supports.

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