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

Last change on this file since 11293 was 11293, checked in by gb, 12 years ago

Do matching-paren highlighting by setting the background color of
both matching parens. It's not clear that the recent changes to
try to make blinking work worked that much better or (since they
depended on undocumented behavior of the insertion-point blinking
code) if they'd continue to work on future OS releases.

The background color (which should ultimately be a preference)
is a sort of blue-green; if it was a little lighter than it is,
contrast with black text might be better. I'm not sure how
easy it'd be to draw the background rectangle inset by a pixel
or two; that might also look a little better. (I don't think that
the current scheme looks grossly bad, just thinking about what
might be easier on the eyes.)

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