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

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

Try to keep track of the state of the insertion point in the blink-phase
slot of a text-view.

Implement a "before" method on #/drawRect: for hemlock-textstorage-textview;
in it, do way to much parsing to support primitive syntax highlighting via
temporary attributes.

Handle drawing/erasing the matching paren by invalidating its glyph
rectangle; decide whether to erase it in the drawRect: method (and
use a temporary attribute when erasing it.) Disable blinking when
the view's deactivated. (This seems to remove the delay before the
matching paren starts blinking; I think that I've seen a delay when
reactivating the window when blinking should take place. Sometimes.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 128.1 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package "GUI")
6
7;;; In the double-float case, this is probably way too small.
8;;; Traditionally, it's (approximately) the point at which
9;;; a single-float stops being able to accurately represent
10;;; integral values.
11(eval-when (:compile-toplevel :load-toplevel :execute)
12  (defconstant large-number-for-text (cgfloat 1.0f7)))
13
14(def-cocoa-default *editor-font* :font #'(lambda ()
15                                           (#/fontWithName:size:
16                                            ns:ns-font
17                                            #@"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    ((blink-location :foreign-type :unsigned :accessor text-view-blink-location)
853     (blink-color-attribute :foreign-type :id :accessor text-view-blink-color)
854     (blink-enabled :foreign-type :<BOOL> :accessor text-view-blink-enabled)
855     (blink-phase :foreign-type :<BOOL> :accessor text-view-blink-phase)
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  (setf (text-view-blink-phase self) #$NO)
879  (disable-blink self)
880  (#/setSelectable: self nil))
881
882(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view))
883  ;; Return true if cmd-. is in the queue.  Not sure what to do about c-g:
884  ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe
885  ;; c-g will need to be synchronous meaning just end current command,
886  ;; while cmd-. is the real abort.
887  #|
888   (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0)))
889    (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue:
890                         target (logior #$whatever) now #&NSDefaultRunLoopMode t)))
891            (when (%null-ptr-p event) (return)))))
892  "target" can either be an NSWindow or the global shared application object;
893  |#
894  nil)
895
896(defvar *buffer-being-edited* nil)
897
898(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event)
899  #+debug (#_NSLog #@"Key down event = %@" :address event)
900  (let* ((view (hemlock-view self))
901         ;; quote-p means handle characters natively
902         (quote-p (and view (hi::hemlock-view-quote-next-p view))))
903    #+debug (log-debug "~&quote-p ~s event ~s" quote-p event)
904    (if (or (null view)
905            (#/hasMarkedText self)
906            (and quote-p (zerop (#/length (#/characters event))))) ;; dead key, e.g. option-E
907      (call-next-method event)
908      (unless (eventqueue-abort-pending-p self)
909        (let ((hemlock-key (nsevent-to-key-event event quote-p)))
910          (when hemlock-key
911            (hi::handle-hemlock-event view hemlock-key)))))))
912
913(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
914  (declare (ignore event))
915  (with-autorelease-pool
916   (call-next-method)))
917
918(defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift"))
919
920;;; Translate a keyDown NSEvent to a Hemlock key-event.
921(defun nsevent-to-key-event (event quote-p)
922  (let* ((modifiers (#/modifierFlags event)))
923    (unless (logtest #$NSCommandKeyMask modifiers)
924      (let* ((chars (if quote-p
925                      (#/characters event)
926                      (#/charactersIgnoringModifiers event)))
927             (n (if (%null-ptr-p chars)
928                  0
929                  (#/length chars)))
930             (c (and (eql n 1)
931                     (#/characterAtIndex: chars 0))))
932        (when c
933          (let* ((bits 0)
934                 (useful-modifiers (logandc2 modifiers
935                                             (logior
936                                              ;#$NSShiftKeyMask
937                                              #$NSAlphaShiftKeyMask))))
938            (unless quote-p
939              (dolist (map hi:*modifier-translations*)
940                (when (logtest useful-modifiers (car map))
941                  (setq bits (logior bits
942                                     (hi:key-event-modifier-mask (cdr map)))))))
943            (let* ((char (code-char c)))
944              (when (and char (standard-char-p char))
945                (setq bits (logandc2 bits +shift-event-mask+))))
946            (hi:make-key-event c bits)))))))
947
948;; For now, this is only used to abort i-search.  All actual mouse handling is done
949;; by Cocoa.   In the future might want to allow users to extend via hemlock, e.g.
950;; to implement mouse-copy.
951;; Also -- shouldn't this happen on mouse up?
952(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
953  ;; If no modifier keys are pressed, send hemlock a no-op.
954  ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect)
955  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
956    (let* ((view (hemlock-view self)))
957      (when view
958        (unless (eventqueue-abort-pending-p self)
959          (hi::handle-hemlock-event view #k"leftdown")))))
960  (call-next-method event))
961
962#+GZ
963(objc:defmethod  (#/mouseUp: :void) ((self hemlock-textstorage-text-view) event)
964  (log-debug "~&MOUSE UP!!")
965  (call-next-method event))
966
967(defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
968  (assume-not-editing (#/textStorage tv)))
969
970(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view)
971                                        sender)
972  (declare (ignorable sender))
973  #+debug (#_NSLog #@"Change color to = %@" :id (#/color sender)))
974
975(def-cocoa-default *layout-text-in-background* :bool t "When true, do text layout when idle.")
976
977(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void)
978    ((self hemlock-textstorage-text-view) layout cont (flag :<BOOL>))
979  (declare (ignorable cont flag))
980  #+debug (#_NSLog #@"layout complete: container = %@, atend = %d" :id cont :int (if flag 1 0))
981  (unless *layout-text-in-background*
982    (#/setDelegate: layout +null-ptr+)
983    (#/setBackgroundLayoutEnabled: layout nil)))
984   
985;;; Note changes to the textview's background color; record them
986;;; as the value of the "temporary" foreground color (for blinking).
987(objc:defmethod (#/setBackgroundColor: :void)
988    ((self hemlock-textstorage-text-view) color)
989  #+debug (#_NSLog #@"Set background color: %@" :id color)
990  (let* ((old (text-view-blink-color self)))
991    (unless (%null-ptr-p old)
992      (#/release old)))
993  (setf (text-view-blink-color self) (#/retain color))
994  (call-next-method color))
995
996;;; Maybe cause 1 character in the textview to blink (by drawing an empty
997;;; character rectangle) in synch with the insertion point.
998
999(objc:defmethod (#/drawInsertionPointInRect:color:turnedOn: :void)
1000    ((self hemlock-textstorage-text-view)
1001     (r :<NSR>ect)
1002     color
1003     (flag :<BOOL>))
1004  (unless (or (not (eq ccl::*current-process* ccl::*initial-process*))
1005              (#/editingInProgress (#/textStorage self)))
1006    (unless (eql #$NO (text-view-blink-enabled self))
1007      #+debug (#_NSLog #@"Flag = %@" :id (if flag #@"T" #@"NIL"))
1008      (setf (text-view-blink-phase self) (if flag 1 0))
1009      (let* ((layout (#/layoutManager self))
1010             (container (#/textContainer self)))
1011        ;; We toggle the blinked character "off" by setting its
1012        ;; foreground color to the textview's background color.
1013        ;; The blinked character should be "off" whenever the insertion
1014        ;; point is drawn as "on".  (This means that when this method
1015        ;; is invoked to tunr off the insertion point - as when a
1016        ;; view loses keyboard focus - the matching paren character
1017        ;; is drawn.
1018        (ns:with-ns-range  (char-range (text-view-blink-location self) 1)
1019          (let* ((glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
1020                               layout
1021                               char-range
1022                               +null-ptr+)))
1023            #+debug (#_NSLog #@"Flag = %d, location = %d" :<BOOL> (if flag #$YES #$NO) :int (text-view-blink-location self))
1024            (let* ((rect (#/boundingRectForGlyphRange:inTextContainer:
1025                          layout
1026                          glyph-range
1027                          container)))
1028              (#/setNeedsDisplayInRect: self rect)))))))
1029  (call-next-method r color flag))
1030
1031
1032(defmethod disable-blink ((self hemlock-textstorage-text-view))
1033  (when (eql (text-view-blink-enabled self) #$YES)
1034    (setf (text-view-blink-enabled self) #$NO)
1035    (ns:with-ns-range  (char-range (text-view-blink-location self) 1)
1036      (let* ((layout (#/layoutManager self))
1037             (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
1038                               layout
1039                               char-range
1040                               +null-ptr+)))
1041        (#/lockFocus self)
1042        (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self))
1043        (#/unlockFocus self)))))
1044
1045
1046(defmethod update-blink ((self hemlock-textstorage-text-view))
1047  (disable-blink self)
1048  (let* ((buffer (hemlock-buffer self)))
1049    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
1050      (let* ((hi::*current-buffer* buffer)
1051             (point (hi::buffer-point buffer)))
1052        #+debug (#_NSLog #@"Syntax check for blinking")
1053        (update-buffer-package (hi::buffer-document buffer) buffer)
1054        (cond ((eql (hi::next-character point) #\()
1055               (hemlock::pre-command-parse-check point)
1056               (when (hemlock::valid-spot point t)
1057                 (hi::with-mark ((temp point))
1058                   (when (hemlock::list-offset temp 1)
1059                     #+debug (#_NSLog #@"enable blink, forward")
1060                     (setf (text-view-blink-location self)
1061                           (1- (hi:mark-absolute-position temp))
1062                           (text-view-blink-enabled self) #$YES)))))
1063              ((eql (hi::previous-character point) #\))
1064               (hemlock::pre-command-parse-check point)
1065               (when (hemlock::valid-spot point nil)
1066                 (hi::with-mark ((temp point))
1067                   (when (hemlock::list-offset temp -1)
1068                     #+debug (#_NSLog #@"enable blink, backward")
1069                     (setf (text-view-blink-location self)
1070                           (hi:mark-absolute-position temp)
1071                           (text-view-blink-enabled self) #$YES))))))
1072        (when (eql (text-view-blink-enabled self) #$YES)
1073          (ns:with-ns-range (char-range (text-view-blink-location self) 1)
1074            (let* ((layout (#/layoutManager self))
1075                   (container (#/textContainer self))
1076                   (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
1077                                 layout
1078                                 char-range
1079                                 +null-ptr+))
1080                   (rect (#/boundingRectForGlyphRange:inTextContainer:
1081                          layout
1082                          glyph-range
1083                          container)))
1084              (setf (text-view-blink-phase self) #$YES)
1085              (#/setNeedsDisplayInRect: self rect))))))))
1086
1087(objc:defmethod (#/updateInsertionPointStateAndRestartTimer: :void)
1088    ((self hemlock-textstorage-text-view)
1089     (restart #>BOOL))
1090  (setf (text-view-blink-phase self) #$YES)
1091  (call-next-method restart))
1092
1093;;; Set and display the selection at pos, whose length is len and whose
1094;;; affinity is affinity.  This should never be called from any Cocoa
1095;;; event handler; it should not call anything that'll try to set the
1096;;; underlying buffer's point and/or mark
1097
1098(objc:defmethod (#/updateSelection:length:affinity: :void)
1099    ((self hemlock-textstorage-text-view)
1100     (pos :int)
1101     (length :int)
1102     (affinity :<NSS>election<A>ffinity))
1103  (assume-cocoa-thread)
1104  (when (eql length 0)
1105    (update-blink self))
1106  (rlet ((range :ns-range :location pos :length length))
1107    (ccl::%call-next-objc-method self
1108                                 hemlock-textstorage-text-view
1109                                 (@selector #/setSelectedRange:affinity:stillSelecting:)
1110                                 '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
1111                                 range
1112                                 affinity
1113                                 nil)
1114    (assume-not-editing self)
1115    (when (> length 0)
1116      (let* ((ts (#/textStorage self)))
1117        (with-slots (selection-set-by-search) ts
1118          (when (prog1 (eql #$YES selection-set-by-search)
1119                  (setq selection-set-by-search #$NO))
1120            (highlight-search-selection self pos length)))))
1121    ))
1122
1123(defloadvar *can-use-show-find-indicator-for-range*
1124    (#/instancesRespondToSelector: ns:ns-text-view (@selector "showFindIndicatorForRange:")))
1125
1126;;; Add transient highlighting to a selection established via a search
1127;;; primitive, if the OS supports it.
1128(defun highlight-search-selection (tv pos length)
1129  (when *can-use-show-find-indicator-for-range*
1130    (ns:with-ns-range (r pos length)
1131      (objc-message-send tv "showFindIndicatorForRange:" :<NSR>ange r :void))))
1132 
1133;;; A specialized NSTextView. The NSTextView is part of the "pane"
1134;;; object that displays buffers.
1135(defclass hemlock-text-view (hemlock-textstorage-text-view)
1136    ((pane :foreign-type :id :accessor text-view-pane)
1137     (char-width :foreign-type :<CGF>loat :accessor text-view-char-width)
1138     (line-height :foreign-type :<CGF>loat :accessor text-view-line-height))
1139  (:metaclass ns:+ns-object))
1140(declaim (special hemlock-text-view))
1141
1142
1143
1144;;; LAYOUT is an NSLayoutManager in which we'll set temporary character
1145;;; attrubutes before redisplay.
1146;;; POS is the absolute character position of the start of START-LINE.
1147;;; END-LINE is either EQ to START-LNE (in the degenerate case) or
1148;;; follows it in the buffer; it may be NIL and is the exclusive
1149;;; end of a range of lines
1150;;; HI::*CURRENT-BUFFER* is bound to the buffer containing START-LINE
1151;;; and END-LINE
1152(defun set-temporary-character-attributes (layout pos start-line end-line blink-location  blink-color)
1153  (ns:with-ns-range (range)
1154    (let* ((color-attribute #&NSForegroundColorAttributeName)
1155           (string-color  (#/blueColor ns:ns-color) )
1156           (comment-color (#/grayColor ns:ns-color)))
1157      (hi::with-mark ((m (hi::buffer-start-mark hi::*current-buffer*)))
1158        (hi::line-start m start-line)
1159        (hi::pre-command-parse-check m t))
1160      (do ((p pos (+ p (1+ (hi::line-length line))))
1161           (line start-line (hi::line-next line)))
1162          ((eq line end-line))
1163        (let* ((parse-info (getf (hi::line-plist line) 'hemlock::lisp-info)))
1164          (when parse-info
1165            (dolist (r (hemlock::lisp-info-ranges-to-ignore parse-info))
1166              (destructuring-bind (istart . iend) r
1167                (let* ((is-string (if (= istart 0)
1168                                    (hemlock::lisp-info-begins-quoted parse-info)
1169                                    (eql (hi::line-character line (1- istart))
1170                                         #\")))
1171                       (color (if is-string
1172                                string-color
1173                                comment-color)))
1174                  (if (and is-string (not (= istart 0)))
1175                    (decf istart))
1176                  (setf (ns:ns-range-location range) (+ p istart)
1177                        (ns:ns-range-length range) (1+ (- iend istart)))
1178                  (#/addTemporaryAttribute:value:forCharacterRange:
1179                   layout color-attribute color range)))))))
1180      (when blink-location
1181        (#/addTemporaryAttribute:value:forCharacterRange:
1182             layout color-attribute blink-color (ns:make-ns-range blink-location 1))))))
1183
1184(objc:defmethod (#/drawRect: :void) ((self hemlock-text-view) (rect :<NSR>ect))
1185  (let* ((container (#/textContainer self))
1186         (layout (#/layoutManager container))
1187         (glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
1188                       layout rect container))
1189         (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
1190                      layout glyph-range +null-ptr+))
1191         (start (ns:ns-range-location char-range))
1192         (length (ns:ns-range-length char-range)))
1193    (when (> length 0)
1194      ;; Remove all temporary attributes from the character range
1195      (#/removeTemporaryAttribute:forCharacterRange:
1196       layout #&NSForegroundColorAttributeName char-range)
1197      (let* ((ts (#/textStorage self))
1198             (cache (hemlock-buffer-string-cache (slot-value ts 'hemlock-string)))
1199             (hi::*current-buffer* (buffer-cache-buffer cache)))
1200        #+debug (#_NSLog #@"blink-phase = %d" :int (text-view-blink-phase self))
1201        (multiple-value-bind (start-line start-offset)
1202            (update-line-cache-for-index cache start)
1203          (let* ((end-line (update-line-cache-for-index cache (+ start length))))
1204            (set-temporary-character-attributes
1205             layout
1206             (- start start-offset)
1207             start-line
1208             (hi::line-next end-line)
1209             (and (eql #$YES (text-view-blink-enabled self))
1210                  (eql #$YES (text-view-blink-phase self))
1211                  (#/shouldDrawInsertionPoint self)
1212                  (text-view-blink-location self))
1213             (text-view-blink-color self))))))
1214    ;; Um, don't forget to actually draw the view..
1215    (call-next-method  rect)))
1216
1217
1218(defmethod hemlock-view ((self hemlock-text-view))
1219  (let ((pane (text-view-pane self)))
1220    (when pane (hemlock-view pane))))
1221
1222(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender)
1223  (declare (ignore sender))
1224  (let* ((buffer (hemlock-buffer self))
1225         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
1226         (pathname (hi::buffer-pathname buffer))
1227         (ranges (#/selectedRanges self))
1228         (text (#/string self)))
1229    (dotimes (i (#/count ranges))
1230      (let* ((r (#/rangeValue (#/objectAtIndex: ranges i)))
1231             (s (#/substringWithRange: text r)))
1232        (setq s (lisp-string-from-nsstring s))
1233        (ui-object-eval-selection *NSApp* (list package-name pathname s))))))
1234
1235(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender)
1236  (declare (ignore sender))
1237  (let* ((buffer (hemlock-buffer self))
1238         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
1239         (pathname (hi::buffer-pathname buffer)))
1240    (ui-object-load-buffer *NSApp* (list package-name pathname))))
1241
1242(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender)
1243  (declare (ignore sender))
1244  (let* ((buffer (hemlock-buffer self))
1245         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
1246         (pathname (hi::buffer-pathname buffer)))
1247    (ui-object-compile-buffer *NSApp* (list package-name pathname))))
1248
1249(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender)
1250  (declare (ignore sender))
1251  (let* ((buffer (hemlock-buffer self))
1252         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
1253         (pathname (hi::buffer-pathname buffer)))
1254    (ui-object-compile-and-load-buffer *NSApp* (list package-name pathname))))
1255
1256(defloadvar *text-view-context-menu* ())
1257
1258(defun text-view-context-menu ()
1259  (or *text-view-context-menu*
1260      (setq *text-view-context-menu*
1261            (#/retain
1262             (let* ((menu (make-instance 'ns:ns-menu :with-title #@"Menu")))
1263               (#/addItemWithTitle:action:keyEquivalent:
1264                menu #@"Cut" (@selector #/cut:) #@"")
1265               (#/addItemWithTitle:action:keyEquivalent:
1266                menu #@"Copy" (@selector #/copy:) #@"")
1267               (#/addItemWithTitle:action:keyEquivalent:
1268                menu #@"Paste" (@selector #/paste:) #@"")
1269               ;; Separator
1270               (#/addItem: menu (#/separatorItem ns:ns-menu-item))
1271               (#/addItemWithTitle:action:keyEquivalent:
1272                menu #@"Background Color ..." (@selector #/changeBackgroundColor:) #@"")
1273               (#/addItemWithTitle:action:keyEquivalent:
1274                menu #@"Text Color ..." (@selector #/changeTextColor:) #@"")
1275
1276               menu)))))
1277
1278
1279
1280
1281
1282(objc:defmethod (#/changeBackgroundColor: :void)
1283    ((self hemlock-text-view) sender)
1284  (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel))
1285         (color (#/backgroundColor self)))
1286    (#/close colorpanel)
1287    (#/setAction: colorpanel (@selector #/updateBackgroundColor:))
1288    (#/setColor: colorpanel color)
1289    (#/setTarget: colorpanel self)
1290    (#/setContinuous: colorpanel nil)
1291    (#/orderFrontColorPanel: *NSApp* sender)))
1292
1293
1294
1295(objc:defmethod (#/updateBackgroundColor: :void)
1296    ((self hemlock-text-view) sender)
1297  (when (#/isVisible sender)
1298    (let* ((color (#/color sender)))
1299      (unless (typep self 'echo-area-view)
1300        (let* ((window (#/window self))
1301               (echo-view (unless (%null-ptr-p window)
1302                            (slot-value window 'echo-area-view))))
1303          (when echo-view (#/setBackgroundColor: echo-view color))))
1304      #+debug (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender)
1305      (#/setBackgroundColor: self color))))
1306
1307(objc:defmethod (#/changeTextColor: :void)
1308    ((self hemlock-text-view) sender)
1309  (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel))
1310         (textstorage (#/textStorage self))
1311         (color (#/objectForKey:
1312                 (#/objectAtIndex: (slot-value textstorage 'styles) 0)
1313                 #&NSForegroundColorAttributeName)))
1314    (#/close colorpanel)
1315    (#/setAction: colorpanel (@selector #/updateTextColor:))
1316    (#/setColor: colorpanel color)
1317    (#/setTarget: colorpanel self)
1318    (#/setContinuous: colorpanel nil)
1319    (#/orderFrontColorPanel: *NSApp* sender)))
1320
1321
1322
1323
1324
1325
1326   
1327(objc:defmethod (#/updateTextColor: :void)
1328    ((self hemlock-textstorage-text-view) sender)
1329  (unwind-protect
1330      (progn
1331        (#/setUsesFontPanel: self t)
1332        (ccl::%call-next-objc-method
1333         self
1334         hemlock-textstorage-text-view
1335         (@selector #/changeColor:)
1336         '(:void :id)
1337         sender))
1338    (#/setUsesFontPanel: self nil))
1339  (#/setNeedsDisplay: self t))
1340   
1341(objc:defmethod (#/updateTextColor: :void)
1342    ((self hemlock-text-view) sender)
1343  (let* ((textstorage (#/textStorage self))
1344         (styles (slot-value textstorage 'styles))
1345         (newcolor (#/color sender)))
1346    (dotimes (i 4)
1347      (let* ((dict (#/objectAtIndex: styles i)))
1348        (#/setValue:forKey: dict newcolor #&NSForegroundColorAttributeName)))
1349    (call-next-method sender)))
1350
1351
1352
1353(defmethod text-view-string-cache ((self hemlock-textstorage-text-view))
1354  (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
1355
1356(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range)
1357    ((self hemlock-textstorage-text-view)
1358     (proposed :ns-range)
1359     (g :<NSS>election<G>ranularity))
1360  #+debug
1361  (#_NSLog #@"Granularity = %d" :int g)
1362  (objc:returning-foreign-struct (r)
1363     (block HANDLED
1364       (let* ((index (ns:ns-range-location proposed))             
1365              (length (ns:ns-range-length proposed)))
1366         (when (and (eql 0 length)      ; not extending existing selection
1367                    (not (eql g #$NSSelectByCharacter)))
1368           (let* ((textstorage (#/textStorage self))
1369                  (cache (hemlock-buffer-string-cache (#/hemlockString textstorage)))
1370                  (buffer (if cache (buffer-cache-buffer cache))))
1371             (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
1372               (let* ((hi::*current-buffer* buffer))
1373                 (hi::with-mark ((m1 (hi::buffer-point buffer)))
1374                   (move-hemlock-mark-to-absolute-position m1 cache index)
1375                   (hemlock::pre-command-parse-check m1)
1376                   (when (hemlock::valid-spot m1 nil)
1377                     (cond ((eql (hi::next-character m1) #\()
1378                            (hi::with-mark ((m2 m1))
1379                              (when (hemlock::list-offset m2 1)
1380                                (ns:init-ns-range r index (- (hi:mark-absolute-position m2) index))
1381                                (return-from HANDLED r))))
1382                           ((eql (hi::previous-character m1) #\))
1383                            (hi::with-mark ((m2 m1))
1384                              (when (hemlock::list-offset m2 -1)
1385                                (ns:init-ns-range r (hi:mark-absolute-position m2) (- index (hi:mark-absolute-position m2)))
1386                                (return-from HANDLED r))))))))))))
1387       (call-next-method proposed g)
1388       #+debug
1389       (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
1390                :address (#_NSStringFromRange r)
1391                :address (#_NSStringFromRange proposed)
1392                :<NSS>election<G>ranularity g))))
1393
1394
1395
1396(defun append-output (view string)
1397  (assume-cocoa-thread)
1398  ;; Arrange to do the append in command context
1399  (when view
1400    (hi::handle-hemlock-event view #'(lambda ()
1401                                       (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string)))))
1402
1403
1404;;; Update the underlying buffer's point (and "active region", if appropriate.
1405;;; This is called in response to a mouse click or other event; it shouldn't
1406;;; be called from the Hemlock side of things.
1407
1408(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void)
1409    ((self hemlock-text-view)
1410     (r :<NSR>ange)
1411     (affinity :<NSS>election<A>ffinity)
1412     (still-selecting :<BOOL>))
1413  #+debug 
1414  (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d"
1415           :int (pref r :<NSR>ange.location)
1416           :int (pref r :<NSR>ange.length)
1417           :<NSS>election<A>ffinity affinity
1418           :<BOOL> (if still-selecting #$YES #$NO))
1419  #+debug
1420  (#_NSLog #@"text view string = %@, textstorage string = %@"
1421           :id (#/string self)
1422           :id (#/string (#/textStorage self)))
1423  (unless (#/editingInProgress (#/textStorage self))
1424    (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
1425           (buffer (buffer-cache-buffer d))
1426           (hi::*current-buffer* buffer)
1427           (point (hi::buffer-point buffer))
1428           (location (pref r :<NSR>ange.location))
1429           (len (pref r :<NSR>ange.length)))
1430      (cond ((eql len 0)
1431             #+debug
1432             (#_NSLog #@"Moving point to absolute position %d" :int location)
1433             (setf (hi::buffer-region-active buffer) nil)
1434             (move-hemlock-mark-to-absolute-position point d location)
1435             (update-blink self))
1436            (t
1437             ;; We don't get much information about which end of the
1438             ;; selection the mark's at and which end point is at, so
1439             ;; we have to sort of guess.  In every case I've ever seen,
1440             ;; selection via the mouse generates a sequence of calls to
1441             ;; this method whose parameters look like:
1442             ;; a: range: {n0,0} still-selecting: false  [ rarely repeats ]
1443             ;; b: range: {n0,0) still-selecting: true   [ rarely repeats ]
1444             ;; c: range: {n1,m} still-selecting: true   [ often repeats ]
1445             ;; d: range: {n1,m} still-selecting: false  [ rarely repeats ]
1446             ;;
1447             ;; (Sadly, "affinity" doesn't tell us anything interesting.)
1448             ;; We've handled a and b in the clause above; after handling
1449             ;; b, point references buffer position n0 and the
1450             ;; region is inactive.
1451             ;; Let's ignore c, and wait until the selection's stabilized.
1452             ;; Make a new mark, a copy of point (position n0).
1453             ;; At step d (here), we should have either
1454             ;; d1) n1=n0.  Mark stays at n0, point moves to n0+m.
1455             ;; d2) n1+m=n0.  Mark stays at n0, point moves to n0-m.
1456             ;; If neither d1 nor d2 apply, arbitrarily assume forward
1457             ;; selection: mark at n1, point at n1+m.
1458             ;; In all cases, activate Hemlock selection.
1459             (unless still-selecting
1460                (let* ((pointpos (hi:mark-absolute-position point))
1461                       (selection-end (+ location len))
1462                       (mark (hi::copy-mark point :right-inserting)))
1463                   (cond ((eql pointpos location)
1464                          (move-hemlock-mark-to-absolute-position point
1465                                                                  d
1466                                                                  selection-end))
1467                         ((eql pointpos selection-end)
1468                          (move-hemlock-mark-to-absolute-position point
1469                                                                  d
1470                                                                  location))
1471                         (t
1472                          (move-hemlock-mark-to-absolute-position mark
1473                                                                  d
1474                                                                  location)
1475                          (move-hemlock-mark-to-absolute-position point
1476                                                                  d
1477                                                                  selection-end)))
1478                   (hemlock::%buffer-push-buffer-mark buffer mark t)))))))
1479  (call-next-method r affinity still-selecting))
1480
1481
1482
1483;;; Modeline-view
1484
1485;;; The modeline view is embedded in the horizontal scroll bar of the
1486;;; scrollview which surrounds the textview in a pane.  (A view embedded
1487;;; in a scrollbar like this is sometimes called a "placard").  Whenever
1488;;; the view's invalidated, its drawRect: method draws a string containing
1489;;; the current values of the buffer's modeline fields.
1490
1491(defparameter *modeline-grays* #(255 255 253 247 242 236 231
1492                                 224 229 234 239 245 252 255))
1493
1494(defparameter *modeline-height* 14)
1495(defloadvar *modeline-pattern-image* nil)
1496
1497(defun create-modeline-pattern-image ()
1498  (let* ((n (length *modeline-grays*)))
1499    (multiple-value-bind (samples-array samples-macptr)
1500        (make-heap-ivector n '(unsigned-byte 8))
1501      (dotimes (i n)
1502        (setf (aref samples-array i) (aref *modeline-grays* i)))
1503      (rlet ((p :address samples-macptr))
1504        (let* ((rep (make-instance 'ns:ns-bitmap-image-rep
1505                                   :with-bitmap-data-planes p
1506                                   :pixels-wide 1
1507                                   :pixels-high n
1508                                   :bits-per-sample 8
1509                                   :samples-per-pixel 1
1510                                   :has-alpha #$NO
1511                                   :is-planar #$NO
1512                                   :color-space-name #&NSDeviceWhiteColorSpace
1513                                   :bytes-per-row 1
1514                                   :bits-per-pixel 8))
1515               (image (make-instance 'ns:ns-image
1516                                     :with-size (ns:make-ns-size 1 n))))
1517          (#/addRepresentation: image rep)
1518          (#/release rep)
1519          (setf *modeline-pattern-image* image))))))
1520
1521(defclass modeline-view (ns:ns-view)
1522    ((pane :foreign-type :id :accessor modeline-view-pane)
1523     (text-attributes :foreign-type :id :accessor modeline-text-attributes))
1524  (:metaclass ns:+ns-object))
1525
1526(objc:defmethod #/initWithFrame: ((self modeline-view) (frame :<NSR>ect))
1527  (call-next-method frame)
1528  (unless *modeline-pattern-image*
1529    (create-modeline-pattern-image))
1530  (let* ((size (#/smallSystemFontSize ns:ns-font))
1531         (font (#/systemFontOfSize: ns:ns-font size))
1532         (dict (#/dictionaryWithObject:forKey: ns:ns-dictionary font #&NSFontAttributeName)))
1533    (setf (modeline-text-attributes self) (#/retain dict)))
1534  self)
1535
1536;;; Find the underlying buffer.
1537(defun buffer-for-modeline-view (mv)
1538  (let* ((pane (modeline-view-pane mv)))
1539    (unless (%null-ptr-p pane)
1540      (let* ((tv (text-pane-text-view pane)))
1541        (unless (%null-ptr-p tv)
1542          (hemlock-buffer tv))))))
1543
1544;;; Draw a string in the modeline view.  The font and other attributes
1545;;; are initialized lazily; apparently, calling the Font Manager too
1546;;; early in the loading sequence confuses some Carbon libraries that're
1547;;; used in the event dispatch mechanism,
1548(defun draw-modeline-string (the-modeline-view)
1549  (with-slots (text-attributes) the-modeline-view
1550    (let* ((buffer (buffer-for-modeline-view the-modeline-view)))
1551      (when buffer
1552        (let* ((string
1553                (apply #'concatenate 'string
1554                       (mapcar
1555                        #'(lambda (field)
1556                            (funcall (hi::modeline-field-function field) buffer))
1557                        (hi::buffer-modeline-fields buffer)))))
1558          (#/drawAtPoint:withAttributes: (%make-nsstring string)
1559                                         (ns:make-ns-point 5 1)
1560                                         text-attributes))))))
1561
1562;;; Draw the underlying buffer's modeline string on a white background
1563;;; with a bezeled border around it.
1564(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :<NSR>ect))
1565  (declare (ignorable rect))
1566  (let* ((bounds (#/bounds self))
1567         (context (#/currentContext ns:ns-graphics-context)))
1568    (#/saveGraphicsState context)
1569    (ns:with-ns-point (p0 0 (ns:ns-rect-height bounds))
1570      (let ((p1 (#/convertPoint:toView: self p0 +null-ptr+)))
1571        (#/setPatternPhase: context p1)))
1572    (#/set (#/colorWithPatternImage: ns:ns-color *modeline-pattern-image*))
1573    (#_NSRectFill bounds)
1574    (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.3333 1.0))
1575    (ns:with-ns-rect (r 0 0.5 (ns:ns-rect-width bounds) 0.5)
1576      (#_NSRectFill r))
1577    (ns:with-ns-rect (r 0 (- (ns:ns-rect-height bounds) 0.5)
1578                        (ns:ns-rect-width bounds) (- (ns:ns-rect-height bounds) 0.5))
1579      (#_NSRectFill r))
1580    (#/set (#/blackColor ns:ns-color))
1581    (draw-modeline-string self)
1582    (#/restoreGraphicsState context)))
1583
1584;;; Hook things up so that the modeline is updated whenever certain buffer
1585;;; attributes change.
1586(hi::%init-mode-redisplay)
1587
1588
1589;;; Modeline-scroll-view
1590
1591;;; This is just an NSScrollView that draws a "placard" view (the modeline)
1592;;; in the horizontal scrollbar.  The modeline's arbitrarily given the
1593;;; leftmost 75% of the available real estate.
1594(defclass modeline-scroll-view (ns:ns-scroll-view)
1595    ((modeline :foreign-type :id :accessor scroll-view-modeline)
1596     (pane :foreign-type :id :accessor scroll-view-pane))
1597  (:metaclass ns:+ns-object))
1598
1599;;; Making an instance of a modeline scroll view instantiates the
1600;;; modeline view, as well.
1601
1602(objc:defmethod #/initWithFrame: ((self modeline-scroll-view) (frame :<NSR>ect))
1603    (let* ((v (call-next-method frame)))
1604      (when v
1605        (let* ((modeline (make-instance 'modeline-view)))
1606          (#/addSubview: v modeline)
1607          (setf (scroll-view-modeline v) modeline)))
1608      v))
1609
1610;;; Scroll views use the "tile" method to lay out their subviews.
1611;;; After the next-method has done so, steal some room in the horizontal
1612;;; scroll bar and place the modeline view there.
1613
1614(objc:defmethod (#/tile :void) ((self modeline-scroll-view))
1615  (call-next-method)
1616  (let* ((modeline (scroll-view-modeline self)))
1617    (when (and (#/hasHorizontalScroller self)
1618               (not (%null-ptr-p modeline)))
1619      (let* ((hscroll (#/horizontalScroller self))
1620             (scrollbar-frame (#/frame hscroll))
1621             (modeline-frame (#/frame hscroll)) ; sic
1622             (modeline-width (* (pref modeline-frame
1623                                      :<NSR>ect.size.width)
1624                                0.75f0)))
1625        (declare (type cgfloat modeline-width))
1626        (setf (pref modeline-frame :<NSR>ect.size.width)
1627              modeline-width
1628              (the cgfloat
1629                (pref scrollbar-frame :<NSR>ect.size.width))
1630              (- (the cgfloat
1631                   (pref scrollbar-frame :<NSR>ect.size.width))
1632                 modeline-width)
1633              (the cg-float
1634                (pref scrollbar-frame :<NSR>ect.origin.x))
1635              (+ (the cgfloat
1636                   (pref scrollbar-frame :<NSR>ect.origin.x))
1637                 modeline-width))
1638        (#/setFrame: hscroll scrollbar-frame)
1639        (#/setFrame: modeline modeline-frame)))))
1640
1641
1642
1643
1644
1645;;; Text-pane
1646
1647;;; The text pane is just an NSBox that (a) provides a draggable border
1648;;; around (b) encapsulates the text view and the mode line.
1649
1650(defclass text-pane (ns:ns-box)
1651    ((hemlock-view :initform nil :reader text-pane-hemlock-view)
1652     (text-view :foreign-type :id :accessor text-pane-text-view)
1653     (mode-line :foreign-type :id :accessor text-pane-mode-line)
1654     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
1655  (:metaclass ns:+ns-object))
1656
1657(defmethod hemlock-view ((self text-pane))
1658  (text-pane-hemlock-view self))
1659
1660;;; Mark the buffer's modeline as needing display.  This is called whenever
1661;;; "interesting" attributes of a buffer are changed.
1662(defun hemlock-ext:invalidate-modeline (buffer)
1663  (let* ((doc (hi::buffer-document buffer)))
1664    (when doc
1665      (document-invalidate-modeline doc))))
1666
1667(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
1668(def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane")
1669
1670
1671(objc:defmethod #/initWithFrame: ((self text-pane) (frame :<NSR>ect))
1672  (let* ((pane (call-next-method frame)))
1673    (unless (%null-ptr-p pane)
1674      (#/setAutoresizingMask: pane (logior
1675                                    #$NSViewWidthSizable
1676                                    #$NSViewHeightSizable))
1677      (#/setBoxType: pane #$NSBoxPrimary)
1678      (#/setBorderType: pane #$NSNoBorder)
1679      (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width*  *text-pane-margin-height*))
1680      (#/setTitlePosition: pane #$NSNoTitle))
1681    pane))
1682
1683(objc:defmethod #/defaultMenu ((class +hemlock-text-view))
1684  (text-view-context-menu))
1685
1686;;; If we don't override this, NSTextView will start adding Google/
1687;;; Spotlight search options and dictionary lookup when a selection
1688;;; is active.
1689(objc:defmethod #/menuForEvent: ((self hemlock-text-view) event)
1690  (declare (ignore event))
1691  (#/menu self))
1692
1693(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color style)
1694  (let* ((scrollview (#/autorelease
1695                      (make-instance
1696                       'modeline-scroll-view
1697                       :with-frame (ns:make-ns-rect x y width height)))))
1698    (#/setBorderType: scrollview #$NSNoBorder)
1699    (#/setHasVerticalScroller: scrollview t)
1700    (#/setHasHorizontalScroller: scrollview t)
1701    (#/setRulersVisible: scrollview nil)
1702    (#/setAutoresizingMask: scrollview (logior
1703                                        #$NSViewWidthSizable
1704                                        #$NSViewHeightSizable))
1705    (#/setAutoresizesSubviews: (#/contentView scrollview) t)
1706    (let* ((layout (make-instance 'ns:ns-layout-manager)))
1707      #+suffer
1708      (#/setTypesetter: layout (make-instance 'hemlock-ats-typesetter))
1709      (#/addLayoutManager: textstorage layout)
1710      (#/setUsesScreenFonts: layout *use-screen-fonts*)
1711      (#/release layout)
1712      (let* ((contentsize (#/contentSize scrollview)))
1713        (ns:with-ns-size (containersize large-number-for-text large-number-for-text)
1714          (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
1715            (ns:init-ns-size containersize large-number-for-text large-number-for-text)
1716            (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
1717            (let* ((container (#/autorelease (make-instance
1718                                              'ns:ns-text-container
1719                                              :with-container-size containersize))))
1720              (#/addTextContainer: layout  container)
1721              (let* ((tv (#/autorelease (make-instance 'hemlock-text-view
1722                                                       :with-frame tv-frame
1723                                                       :text-container container))))
1724                (#/setDelegate: layout tv)
1725                (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize)))
1726                (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text))
1727                (#/setRichText: tv nil)
1728                (#/setAutoresizingMask: tv #$NSViewWidthSizable)
1729                (#/setBackgroundColor: tv color)
1730                (#/setTypingAttributes: tv (#/objectAtIndex: (#/styles textstorage) style))
1731                (#/setSmartInsertDeleteEnabled: tv nil)
1732                (#/setAllowsUndo: tv nil) ; don't want NSTextView undo
1733                (#/setUsesFindPanel: tv t)
1734                (#/setUsesFontPanel: tv nil)
1735                (#/setMenu: tv (text-view-context-menu))
1736
1737                ;;  The container tracking and the text view sizability along a
1738                ;;  particular axis must always be different, or else things can
1739                ;;  get really confused (possibly causing an infinite loop).
1740
1741                (if (or tracks-width *wrap-lines-to-window*)
1742                  (progn
1743                    (#/setWidthTracksTextView: container t)
1744                    (#/setHeightTracksTextView: container nil)
1745                    (#/setHorizontallyResizable: tv nil)
1746                    (#/setVerticallyResizable: tv t))
1747                  (progn
1748                    (#/setWidthTracksTextView: container nil)
1749                    (#/setHeightTracksTextView: container nil)
1750                    (#/setHorizontallyResizable: tv t)
1751                    (#/setVerticallyResizable: tv t)))
1752
1753                (#/setDocumentView: scrollview tv)           
1754                (values tv scrollview)))))))))
1755
1756(defun make-scrolling-textview-for-pane (pane textstorage track-width color style)
1757  (let* ((contentrect (#/frame (#/contentView pane))))
1758    (multiple-value-bind (tv scrollview)
1759        (make-scrolling-text-view-for-textstorage
1760         textstorage
1761         (ns:ns-rect-x contentrect)
1762         (ns:ns-rect-y contentrect)
1763         (ns:ns-rect-width contentrect)
1764         (ns:ns-rect-height contentrect)
1765         track-width
1766         color
1767         style)
1768      (#/setContentView: pane scrollview)
1769      (setf (slot-value pane 'scroll-view) scrollview
1770            (slot-value pane 'text-view) tv
1771            (slot-value tv 'pane) pane
1772            (slot-value scrollview 'pane) pane)
1773      (let* ((modeline  (scroll-view-modeline scrollview)))
1774        (setf (slot-value pane 'mode-line) modeline
1775              (slot-value modeline 'pane) pane))
1776      tv)))
1777
1778(defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane)
1779  #+debug (log-debug "change active pane to ~s" new-pane)
1780  (let* ((pane (hi::hemlock-view-pane view))
1781         (text-view (text-pane-text-view pane))
1782         (tv (ecase new-pane
1783               (:echo (slot-value text-view 'peer))
1784               (:text text-view))))
1785    (activate-hemlock-view tv)))
1786
1787(defclass echo-area-view (hemlock-textstorage-text-view)
1788    ()
1789  (:metaclass ns:+ns-object))
1790(declaim (special echo-area-view))
1791
1792(defmethod hemlock-view ((self echo-area-view))
1793  (let ((text-view (slot-value self 'peer)))
1794    (when text-view
1795      (hemlock-view text-view))))
1796
1797;;; The "document" for an echo-area isn't a real NSDocument.
1798(defclass echo-area-document (ns:ns-object)
1799    ((textstorage :foreign-type :id))
1800  (:metaclass ns:+ns-object))
1801
1802(defmethod hemlock-buffer ((self echo-area-document))
1803  (let ((ts (slot-value self 'textstorage)))
1804    (unless (%null-ptr-p ts)
1805      (hemlock-buffer ts))))
1806
1807(objc:defmethod #/undoManager ((self echo-area-document))
1808  +null-ptr+) ;For now, undo is not supported for echo-areas
1809
1810(defmethod update-buffer-package ((doc echo-area-document) buffer)
1811  (declare (ignore buffer)))
1812
1813(defmethod document-invalidate-modeline ((self echo-area-document))
1814  nil)
1815
1816(objc:defmethod (#/close :void) ((self echo-area-document))
1817  (let* ((ts (slot-value self 'textstorage)))
1818    (unless (%null-ptr-p ts)
1819      (setf (slot-value self 'textstorage) (%null-ptr))
1820      (close-hemlock-textstorage ts))))
1821
1822(objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :<NSD>ocument<C>hange<T>ype))
1823  (declare (ignore change)))
1824
1825(defun make-echo-area (the-hemlock-frame x y width height main-buffer color)
1826  (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height))))
1827    (#/setAutoresizingMask: box #$NSViewWidthSizable)
1828    (let* ((box-frame (#/bounds box))
1829           (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame)))
1830           (clipview (make-instance 'ns:ns-clip-view
1831                                    :with-frame box-frame)))
1832      (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable
1833                                               #$NSViewHeightSizable))
1834      (#/setBackgroundColor: clipview color)
1835      (#/addSubview: box clipview)
1836      (#/setAutoresizesSubviews: box t)
1837      (#/release clipview)
1838      (let* ((buffer (hi::make-echo-buffer))
1839             (textstorage
1840              (progn
1841                ;; What's the reason for sharing this?  Is it just the lock?
1842                (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer))
1843                (make-textstorage-for-hemlock-buffer buffer)))
1844             (doc (make-instance 'echo-area-document))
1845             (layout (make-instance 'ns:ns-layout-manager))
1846             (container (#/autorelease
1847                         (make-instance 'ns:ns-text-container
1848                                        :with-container-size
1849                                        containersize))))
1850        (#/addLayoutManager: textstorage layout)
1851        (#/setUsesScreenFonts: layout *use-screen-fonts*)
1852        (#/addTextContainer: layout container)
1853        (#/release layout)
1854        (let* ((echo (make-instance 'echo-area-view
1855                                    :with-frame box-frame
1856                                    :text-container container)))
1857          (#/setMinSize: echo (pref box-frame :<NSR>ect.size))
1858          (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text))
1859          (#/setRichText: echo nil)
1860          (#/setUsesFontPanel: echo nil)
1861          (#/setHorizontallyResizable: echo t)
1862          (#/setVerticallyResizable: echo nil)
1863          (#/setAutoresizingMask: echo #$NSViewNotSizable)
1864          (#/setBackgroundColor: echo color)
1865          (#/setWidthTracksTextView: container nil)
1866          (#/setHeightTracksTextView: container nil)
1867          (#/setMenu: echo +null-ptr+)
1868          (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer
1869                (slot-value doc 'textstorage) textstorage
1870                (hi::buffer-document buffer) doc)
1871          (#/setDocumentView: clipview echo)
1872          (#/setAutoresizesSubviews: clipview nil)
1873          (#/sizeToFit echo)
1874          (values echo box))))))
1875                   
1876(defun make-echo-area-for-window (w main-buffer color)
1877  (let* ((content-view (#/contentView w))
1878         (bounds (#/bounds content-view)))
1879    (multiple-value-bind (echo-area box)
1880                         (make-echo-area w
1881                                         0.0f0
1882                                         0.0f0
1883                                         (- (ns:ns-rect-width bounds) 16.0f0)
1884                                         20.0f0
1885                                         main-buffer
1886                                         color)
1887      (#/addSubview: content-view box)
1888      echo-area)))
1889               
1890(defclass hemlock-frame (ns:ns-window)
1891    ((echo-area-view :foreign-type :id)
1892     (pane :foreign-type :id)
1893     (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
1894     (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream))
1895  (:metaclass ns:+ns-object))
1896(declaim (special hemlock-frame))
1897
1898
1899(defmethod hemlock-view ((frame hemlock-frame))
1900  (let ((pane (slot-value frame 'pane)))
1901    (when (and pane (not (%null-ptr-p pane)))
1902      (hemlock-view pane))))
1903
1904(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message)
1905  #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
1906  (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
1907                       (if (logbitp 0 (random 2))
1908                         #@"Not OK, but what can you do?"
1909                         #@"The sky is falling. FRED never did this!")
1910                       +null-ptr+
1911                       +null-ptr+
1912                       self
1913                       self
1914                       +null-ptr+
1915                       +null-ptr+
1916                       +null-ptr+
1917                       message))
1918
1919(defun report-condition-in-hemlock-frame (condition frame)
1920  (assume-cocoa-thread)
1921  (let ((message (nsstring-for-lisp-condition condition)))
1922    (#/performSelectorOnMainThread:withObject:waitUntilDone:
1923     frame
1924     (@selector #/runErrorSheet:)
1925     message
1926     t)))
1927
1928(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition debug-p)
1929  (when debug-p (maybe-log-callback-error condition))
1930  (let ((pane (hi::hemlock-view-pane view)))
1931    (when (and pane (not (%null-ptr-p pane)))
1932      (report-condition-in-hemlock-frame condition (#/window pane)))))
1933                       
1934(objc:defmethod (#/close :void) ((self hemlock-frame))
1935  (let* ((content-view (#/contentView self))
1936         (subviews (#/subviews content-view)))
1937    (do* ((i (1- (#/count subviews)) (1- i)))
1938         ((< i 0))
1939      (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i))))
1940  (let* ((buf (hemlock-frame-echo-area-buffer self))
1941         (echo-doc (if buf (hi::buffer-document buf))))
1942    (when echo-doc
1943      (setf (hemlock-frame-echo-area-buffer self) nil)
1944      (#/close echo-doc)))
1945  (release-canonical-nsobject self)
1946  (call-next-method))
1947 
1948(defun new-hemlock-document-window (class)
1949  (let* ((w (new-cocoa-window :class class
1950                              :activate nil)))
1951      (values w (add-pane-to-window w :reserve-below 20.0))))
1952
1953
1954
1955(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
1956  (let* ((window-content-view (#/contentView w))
1957         (window-frame (#/frame window-content-view)))
1958    (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)))
1959       (let* ((pane (make-instance 'text-pane :with-frame pane-rect)))
1960         (#/addSubview: window-content-view pane)
1961         pane))))
1962
1963(defun textpane-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
1964  (let* ((pane (nth-value
1965                1
1966                (new-hemlock-document-window class))))
1967    (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color style)
1968    (multiple-value-bind (height width)
1969        (size-of-char-in-font (default-font))
1970      (size-text-pane pane height width nrows ncols))
1971    pane))
1972
1973
1974
1975
1976(defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
1977  (let* ((buffer (make-hemlock-buffer name :modes modes)))
1978    (nsstring-to-buffer nsstring buffer)))
1979
1980(defun %nsstring-to-hemlock-string (nsstring)
1981  "returns line-termination of string"
1982  (let* ((string (lisp-string-from-nsstring nsstring))
1983         (lfpos (position #\linefeed string))
1984         (crpos (position #\return string))
1985         (line-termination (if crpos
1986                             (if (eql lfpos (1+ crpos))
1987                               :crlf
1988                               :cr)
1989                             :lf))
1990         (hemlock-string (case line-termination
1991                           (:crlf (remove #\return string))
1992                           (:cr (nsubstitute #\linefeed #\return string))
1993                           (t string))))
1994    (values hemlock-string line-termination)))
1995
1996;: TODO: I think this is jumping through hoops because it want to be invokable outside the main
1997;; cocoa thread.
1998(defun nsstring-to-buffer (nsstring buffer)
1999  (let* ((document (hi::buffer-document buffer))
2000         (hi::*current-buffer* buffer)
2001         (region (hi::buffer-region buffer)))
2002    (multiple-value-bind (hemlock-string line-termination)
2003                         (%nsstring-to-hemlock-string nsstring)
2004      (setf (hi::buffer-line-termination buffer) line-termination)
2005
2006      (setf (hi::buffer-document buffer) nil) ;; What's this about??
2007      (unwind-protect
2008          (let ((point (hi::buffer-point buffer)))
2009            (hi::delete-region region)
2010            (hi::insert-string point hemlock-string)
2011            (setf (hi::buffer-modified buffer) nil)
2012            (hi::buffer-start point)
2013            ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping.
2014            (hi::renumber-region region)
2015            buffer)
2016        (setf (hi::buffer-document buffer) document)))))
2017
2018
2019(setq hi::*beep-function* #'(lambda (stream)
2020                              (declare (ignore stream))
2021                              (#_NSBeep)))
2022
2023
2024;;; This function must run in the main event thread.
2025(defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
2026  (assume-cocoa-thread)
2027  (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style))
2028         (buffer (hemlock-buffer ts))
2029         (frame (#/window pane))
2030         (echo-area (make-echo-area-for-window frame buffer color))
2031         (echo-buffer (hemlock-buffer (#/textStorage echo-area)))
2032         (tv (text-pane-text-view pane)))
2033    #+GZ (assert echo-buffer)
2034    (with-slots (peer) tv
2035      (setq peer echo-area))
2036    (with-slots (peer) echo-area
2037      (setq peer tv))
2038    (setf (slot-value frame 'echo-area-view) echo-area
2039          (slot-value frame 'pane) pane)
2040    (setf (slot-value pane 'hemlock-view)
2041          (make-instance 'hi:hemlock-view
2042            :buffer buffer
2043            :pane pane
2044            :echo-area-buffer echo-buffer))
2045    (activate-hemlock-view tv)
2046   frame))
2047
2048
2049(defun hi::lock-buffer (b)
2050  (grab-lock (hi::buffer-lock b)))
2051
2052(defun hi::unlock-buffer (b)
2053  (release-lock (hi::buffer-lock b))) 
2054
2055(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk)
2056  (assume-cocoa-thread)
2057  (when buffer ;; nil means just get rid of any prior buffer
2058    (setq buffer (require-type buffer 'hi::buffer)))
2059  (let ((old *buffer-being-edited*))
2060    (if (eq buffer old)
2061      (funcall thunk)
2062      (unwind-protect
2063          (progn
2064            (buffer-document-end-editing old)
2065            (buffer-document-begin-editing buffer)
2066            (funcall thunk))
2067        (buffer-document-end-editing buffer)
2068        (buffer-document-begin-editing old)))))
2069
2070(defun buffer-document-end-editing (buffer)
2071  (when buffer
2072    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
2073      (when document
2074        (setq *buffer-being-edited* nil)
2075        (let ((ts (slot-value document 'textstorage)))
2076          (#/endEditing ts)
2077          (update-hemlock-selection ts))))))
2078
2079(defun buffer-document-begin-editing (buffer)
2080  (when buffer
2081    (let* ((document (hi::buffer-document buffer)))
2082      (when document
2083        (setq *buffer-being-edited* buffer)
2084        (#/beginEditing (slot-value document 'textstorage))))))
2085
2086(defun document-edit-level (document)
2087  (assume-cocoa-thread) ;; see comment in #/editingInProgress
2088  (slot-value (slot-value document 'textstorage) 'edit-count))
2089
2090(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
2091  (with-lock-grabbed (*buffer-change-invocation-lock*)
2092    (let* ((invocation *buffer-change-invocation*))
2093      (rlet ((ppos :<NSI>nteger pos)
2094             (pn :<NSI>nteger n)
2095             (pextra :<NSI>nteger extra))
2096        (#/setTarget: invocation textstorage)
2097        (#/setSelector: invocation selector)
2098        (#/setArgument:atIndex: invocation ppos 2)
2099        (#/setArgument:atIndex: invocation pn 3)
2100        (#/setArgument:atIndex: invocation pextra 4))
2101      (#/performSelectorOnMainThread:withObject:waitUntilDone:
2102       invocation
2103       (@selector #/invoke)
2104       +null-ptr+
2105       t))))
2106
2107
2108
2109
2110(defun hi::buffer-note-font-change (buffer region font)
2111  (when (hi::bufferp buffer)
2112    (let* ((document (hi::buffer-document buffer))
2113           (textstorage (if document (slot-value document 'textstorage)))
2114           (pos (hi:mark-absolute-position (hi::region-start region)))
2115           (n (- (hi:mark-absolute-position (hi::region-end region)) pos)))
2116      (perform-edit-change-notification textstorage
2117                                        (@selector #/noteHemlockAttrChangeAtPosition:length:)
2118                                        pos
2119                                        n
2120                                        font))))
2121
2122(defun buffer-active-font-attributes (buffer)
2123  (let* ((style 0)
2124         (region (hi::buffer-active-font-region buffer))
2125         (textstorage (slot-value (hi::buffer-document buffer) 'textstorage))
2126         (styles (#/styles textstorage)))
2127    (when region
2128      (let* ((start (hi::region-end region)))
2129        (setq style (hi::font-mark-font start))))
2130    (#/objectAtIndex: styles style)))
2131     
2132;; Note that inserted a string of length n at mark.  Assumes this is called after
2133;; buffer marks were updated.
2134(defun hi::buffer-note-insertion (buffer mark n)
2135  (when (hi::bufferp buffer)
2136    (let* ((document (hi::buffer-document buffer))
2137           (textstorage (if document (slot-value document 'textstorage))))
2138      (when textstorage
2139        (let* ((pos (hi:mark-absolute-position mark)))
2140          (when (eq (hi::mark-%kind mark) :left-inserting)
2141            ;; Make up for the fact that the mark moved forward with the insertion.
2142            ;; For :right-inserting and :temporary marks, they should be left back.
2143            (decf pos n))
2144          (perform-edit-change-notification textstorage
2145                                            (@selector #/noteHemlockInsertionAtPosition:length:)
2146                                            pos
2147                                            n))))))
2148
2149(defun hi::buffer-note-modification (buffer mark n)
2150  (when (hi::bufferp buffer)
2151    (let* ((document (hi::buffer-document buffer))
2152           (textstorage (if document (slot-value document 'textstorage))))
2153      (when textstorage
2154            (perform-edit-change-notification textstorage
2155                                              (@selector #/noteHemlockModificationAtPosition:length:)
2156                                              (hi:mark-absolute-position mark)
2157                                              n)))))
2158 
2159
2160(defun hi::buffer-note-deletion (buffer mark n)
2161  (when (hi::bufferp buffer)
2162    (let* ((document (hi::buffer-document buffer))
2163           (textstorage (if document (slot-value document 'textstorage))))
2164      (when textstorage
2165        (let* ((pos (hi:mark-absolute-position mark)))
2166          (perform-edit-change-notification textstorage
2167                                            (@selector #/noteHemlockDeletionAtPosition:length:)
2168                                            pos
2169                                            (abs n)))))))
2170
2171
2172
2173(defun hemlock-ext:note-buffer-saved (buffer)
2174  (assume-cocoa-thread)
2175  (let* ((document (hi::buffer-document buffer)))
2176    (when document
2177      ;; Hmm... I guess this is always done by the act of saving.
2178      nil)))
2179
2180(defun hemlock-ext:note-buffer-unsaved (buffer)
2181  (assume-cocoa-thread)
2182  (let* ((document (hi::buffer-document buffer)))
2183    (when document
2184      (#/updateChangeCount: document #$NSChangeCleared))))
2185
2186
2187(defun size-of-char-in-font (f)
2188  (let* ((sf (#/screenFont f))
2189         (screen-p *use-screen-fonts*))
2190    (if (%null-ptr-p sf) (setq sf f screen-p nil))
2191    (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager)))))
2192      (#/setUsesScreenFonts: layout screen-p)
2193      (values (fround (#/defaultLineHeightForFont: layout sf))
2194              (fround (ns:ns-size-width (#/advancementForGlyph: sf (#/glyphWithName: sf #@" "))))))))
2195         
2196
2197
2198(defun size-text-pane (pane line-height char-width nrows ncols)
2199  (let* ((tv (text-pane-text-view pane))
2200         (height (fceiling (* nrows line-height)))
2201         (width (fceiling (* ncols char-width)))
2202         (scrollview (text-pane-scroll-view pane))
2203         (window (#/window scrollview))
2204         (has-horizontal-scroller (#/hasHorizontalScroller scrollview))
2205         (has-vertical-scroller (#/hasVerticalScroller scrollview)))
2206    (ns:with-ns-size (tv-size
2207                      (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv))))
2208                      height)
2209      (when has-vertical-scroller 
2210        (#/setVerticalLineScroll: scrollview line-height)
2211        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#))
2212      (when has-horizontal-scroller
2213        (#/setHorizontalLineScroll: scrollview char-width)
2214        (#/setHorizontalPageScroll: scrollview (cgfloat 0.0) #|char-width|#))
2215      (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview)))
2216             (pane-frame (#/frame pane))
2217             (margins (#/contentViewMargins pane)))
2218        (incf (ns:ns-size-height sv-size)
2219              (+ (ns:ns-rect-y pane-frame)
2220                 (* 2 (ns:ns-size-height  margins))))
2221        (incf (ns:ns-size-width sv-size)
2222              (ns:ns-size-width margins))
2223        (#/setContentSize: window sv-size)
2224        (setf (slot-value tv 'char-width) char-width
2225              (slot-value tv 'line-height) line-height)
2226        (#/setResizeIncrements: window
2227                                (ns:make-ns-size char-width line-height))))))
2228                                   
2229 
2230(defclass hemlock-editor-window-controller (ns:ns-window-controller)
2231    ()
2232  (:metaclass ns:+ns-object))
2233
2234(defmethod hemlock-view ((self hemlock-editor-window-controller))
2235  (let ((frame (#/window self)))
2236    (unless (%null-ptr-p frame)
2237      (hemlock-view frame))))
2238
2239;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
2240(defun get-default-encoding ()
2241  (let* ((string (string (or *default-file-character-encoding*
2242                                 "ISO-8859-1")))
2243         (len (length string)))
2244    (with-cstrs ((cstr string))
2245      (with-nsstr (nsstr cstr len)
2246        (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr)))
2247          (if (= cf #$kCFStringEncodingInvalidId)
2248            (setq cf (#_CFStringGetSystemEncoding)))
2249          (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf)))
2250            (if (= ns #$kCFStringEncodingInvalidId)
2251              (#/defaultCStringEncoding ns:ns-string)
2252              ns)))))))
2253
2254(defclass hemlock-document-controller (ns:ns-document-controller)
2255    ((last-encoding :foreign-type :<NSS>tring<E>ncoding))
2256  (:metaclass ns:+ns-object))
2257(declaim (special hemlock-document-controller))
2258
2259(objc:defmethod #/init ((self hemlock-document-controller))
2260  (prog1
2261      (call-next-method)
2262    (setf (slot-value self 'last-encoding) 0)))
2263
2264
2265;;; The HemlockEditorDocument class.
2266
2267
2268(defclass hemlock-editor-document (ns:ns-document)
2269    ((textstorage :foreign-type :id)
2270     (encoding :foreign-type :<NSS>tring<E>ncoding :initform (get-default-encoding)))
2271  (:metaclass ns:+ns-object))
2272
2273(defmethod hemlock-buffer ((self hemlock-editor-document))
2274  (let ((ts (slot-value self 'textstorage)))
2275    (unless (%null-ptr-p ts)
2276      (hemlock-buffer ts))))
2277
2278(defmethod assume-not-editing ((doc hemlock-editor-document))
2279  (assume-not-editing (slot-value doc 'textstorage)))
2280
2281(defmethod document-invalidate-modeline ((self hemlock-editor-document))
2282  (for-each-textview-using-storage
2283   (slot-value self 'textstorage)
2284   #'(lambda (tv)
2285       (let* ((pane (text-view-pane tv)))
2286         (unless (%null-ptr-p pane)
2287           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
2288
2289(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
2290  (let* ((name (hemlock::package-at-mark (hi::buffer-point buffer))))
2291    (when name
2292      (let* ((pkg (find-package name)))
2293        (if pkg
2294          (setq name (shortest-package-name pkg))))
2295      (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer)))
2296        (if (or (null curname)
2297                (not (string= curname name)))
2298          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
2299
2300(defun hemlock-ext:note-selection-set-by-search (buffer)
2301  (let* ((doc (hi::buffer-document buffer)))
2302    (when doc
2303      (with-slots (textstorage) doc
2304        (when textstorage
2305          (with-slots (selection-set-by-search) textstorage
2306            (setq selection-set-by-search #$YES)))))))
2307
2308(objc:defmethod (#/validateMenuItem: :<BOOL>)
2309    ((self hemlock-text-view) item)
2310  (let* ((action (#/action item)))
2311    #+debug (#_NSLog #@"action = %s" :address action)
2312    (cond ((eql action (@selector #/hyperSpecLookUp:))
2313           ;; For now, demand a selection.
2314           (and *hyperspec-lookup-enabled*
2315                (hyperspec-root-url)
2316                (not (eql 0 (ns:ns-range-length (#/selectedRange self))))))
2317          ((eql action (@selector #/cut:))
2318           (let* ((selection (#/selectedRange self)))
2319             (and (> (ns:ns-range-length selection))
2320                  (#/shouldChangeTextInRange:replacementString: self selection #@""))))
2321          ((eql action (@selector #/evalSelection:))
2322           (not (eql 0 (ns:ns-range-length (#/selectedRange self)))))
2323          ;; if this hemlock-text-view is in an editor windowm and its buffer has
2324          ;; an associated pathname, then activate the Load Buffer item
2325          ((or (eql action (@selector #/loadBuffer:))
2326               (eql action (@selector #/compileBuffer:))
2327               (eql action (@selector #/compileAndLoadBuffer:))) 
2328           (let* ((buffer (hemlock-buffer self))
2329                  (pathname (hi::buffer-pathname buffer)))
2330             (not (null pathname))))
2331          (t (call-next-method item)))))
2332
2333(defmethod user-input-style ((doc hemlock-editor-document))
2334  0)
2335
2336(defvar *encoding-name-hash* (make-hash-table))
2337
2338(defmethod document-encoding-name ((doc hemlock-editor-document))
2339  (with-slots (encoding) doc
2340    (if (eql encoding 0)
2341      "Automatic"
2342      (or (gethash encoding *encoding-name-hash*)
2343          (setf (gethash encoding *encoding-name-hash*)
2344                (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
2345
2346(defun hi::buffer-encoding-name (buffer)
2347  (let ((doc (hi::buffer-document buffer)))
2348    (and doc (document-encoding-name doc))))
2349
2350;; TODO: make each buffer have a slot, and this is just the default value.
2351(defmethod textview-background-color ((doc hemlock-editor-document))
2352  *editor-background-color*)
2353
2354
2355(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts)
2356  (let* ((doc (%inc-ptr self 0))        ; workaround for stack-consed self
2357         (string (#/hemlockString ts))
2358         (cache (hemlock-buffer-string-cache string))
2359         (buffer (buffer-cache-buffer cache)))
2360    (unless (%null-ptr-p doc)
2361      (setf (slot-value doc 'textstorage) ts
2362            (hi::buffer-document buffer) doc))))
2363
2364;; This runs on the main thread.
2365(objc:defmethod (#/revertToSavedFromFile:ofType: :<BOOL>)
2366    ((self hemlock-editor-document) filename filetype)
2367  (declare (ignore filetype))
2368  (assume-cocoa-thread)
2369  #+debug
2370  (#_NSLog #@"revert to saved from file %@ of type %@"
2371           :id filename :id filetype)
2372  (let* ((encoding (slot-value self 'encoding))
2373         (nsstring (make-instance ns:ns-string
2374                                  :with-contents-of-file filename
2375                                  :encoding encoding
2376                                  :error +null-ptr+))
2377         (buffer (hemlock-buffer self))
2378         (old-length (hemlock-buffer-length buffer))
2379         (hi::*current-buffer* buffer)
2380         (textstorage (slot-value self 'textstorage))
2381         (point (hi::buffer-point buffer))
2382         (pointpos (hi:mark-absolute-position point)))
2383    (hemlock-ext:invoke-modifying-buffer-storage
2384     buffer
2385     #'(lambda ()
2386         (#/edited:range:changeInLength:
2387          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
2388         (nsstring-to-buffer nsstring buffer)
2389         (let* ((newlen (hemlock-buffer-length buffer)))
2390           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
2391           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
2392           (let* ((ts-string (#/hemlockString textstorage))
2393                  (display (hemlock-buffer-string-cache ts-string)))
2394             (reset-buffer-cache display) 
2395             (update-line-cache-for-index display 0)
2396             (move-hemlock-mark-to-absolute-position point
2397                                                     display
2398                                                     (min newlen pointpos))))
2399         (#/updateMirror textstorage)
2400         (setf (hi::buffer-modified buffer) nil)
2401         (hi::note-modeline-change buffer)))
2402    t))
2403
2404
2405(defvar *last-document-created* nil)
2406
2407(objc:defmethod #/init ((self hemlock-editor-document))
2408  (let* ((doc (call-next-method)))
2409    (unless  (%null-ptr-p doc)
2410      (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer
2411                              (make-hemlock-buffer
2412                               (lisp-string-from-nsstring
2413                                (#/displayName doc))
2414                               :modes '("Lisp" "Editor")))))
2415    (setq *last-document-created* doc)
2416    doc))
2417
2418 
2419(defun make-buffer-for-document (ns-document pathname)
2420  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
2421         (buffer (make-hemlock-buffer buffer-name)))
2422    (setf (slot-value ns-document 'textstorage)
2423          (make-textstorage-for-hemlock-buffer buffer))
2424    (setf (hi::buffer-pathname buffer) pathname)
2425    buffer))
2426
2427(objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
2428    ((self hemlock-editor-document) url type (perror (:* :id)))
2429  (declare (ignorable type))
2430  (with-callback-context "readFromURL"
2431    (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
2432      (let* ((pathname
2433              (lisp-string-from-nsstring
2434               (if (#/isFileURL url)
2435                 (#/path url)
2436                 (#/absoluteString url))))
2437             (buffer (or (hemlock-buffer self)
2438                         (make-buffer-for-document self pathname)))
2439             (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
2440             (string
2441              (if (zerop selected-encoding)
2442                (#/stringWithContentsOfURL:usedEncoding:error:
2443                 ns:ns-string
2444                 url
2445                 pused-encoding
2446                 perror)
2447                +null-ptr+)))
2448       
2449        (if (%null-ptr-p string)
2450          (progn
2451            (if (zerop selected-encoding)
2452              (setq selected-encoding (get-default-encoding)))
2453            (setq string (#/stringWithContentsOfURL:encoding:error:
2454                          ns:ns-string
2455                          url
2456                          selected-encoding
2457                          perror)))
2458          (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
2459        (unless (%null-ptr-p string)
2460          (with-slots (encoding) self (setq encoding selected-encoding))
2461
2462          ;; ** TODO: Argh.  How about we just let hemlock insert it.
2463          (let* ((textstorage (slot-value self 'textstorage))
2464                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
2465                 (hi::*current-buffer* buffer))
2466            (hemlock-ext:invoke-modifying-buffer-storage
2467             buffer
2468             #'(lambda ()
2469                 (nsstring-to-buffer string buffer)
2470                 (reset-buffer-cache display) 
2471                 (#/updateMirror textstorage)
2472                 (update-line-cache-for-index display 0)
2473                 (textstorage-note-insertion-at-position
2474                  textstorage
2475                  0
2476                  (hemlock-buffer-length buffer))
2477                 (hi::note-modeline-change buffer)
2478                 (setf (hi::buffer-modified buffer) nil))))
2479          t)))))
2480
2481
2482
2483
2484(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files")
2485
2486(objc:defmethod (#/keepBackupFile :<BOOL>) ((self hemlock-editor-document))
2487  ;;; Don't use the NSDocument backup file scheme.
2488  nil)
2489
2490(objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :<BOOL>)
2491    ((self hemlock-editor-document)
2492     absolute-url
2493     type
2494     (save-operation :<NSS>ave<O>peration<T>ype)
2495     (error (:* :id)))
2496  (when (and *editor-keep-backup-files*
2497             (eql save-operation #$NSSaveOperation))
2498    (write-hemlock-backup-file (#/fileURL self)))
2499  (call-next-method absolute-url type save-operation error))
2500
2501(defun write-hemlock-backup-file (url)
2502  (unless (%null-ptr-p url)
2503    (when (#/isFileURL url)
2504      (let* ((path (#/path url)))
2505        (unless (%null-ptr-p path)
2506          (let* ((newpath (#/stringByAppendingString: path #@"~"))
2507                 (fm (#/defaultManager ns:ns-file-manager)))
2508            ;; There are all kinds of ways for this to lose.
2509            ;; In order for the copy to succeed, the destination can't exist.
2510            ;; (It might exist, but be a directory, or there could be
2511            ;; permission problems ...)
2512            (#/removeFileAtPath:handler: fm newpath +null-ptr+)
2513            (#/copyPath:toPath:handler: fm path newpath +null-ptr+)))))))
2514
2515             
2516
2517
2518
2519(defun hemlock-ext:all-hemlock-views ()
2520  "List of all hemlock views, in z-order, frontmost first"
2521  (loop for win in (windows)
2522    as buf = (and (typep win 'hemlock-frame) (hemlock-view win))
2523    when buf collect buf))
2524
2525(defmethod hi::document-panes ((document hemlock-editor-document))
2526  (let* ((ts (slot-value document 'textstorage))
2527         (panes ()))
2528    (for-each-textview-using-storage
2529     ts
2530     #'(lambda (tv)
2531         (let* ((pane (text-view-pane tv)))
2532           (unless (%null-ptr-p pane)
2533             (push pane panes)))))
2534    panes))
2535
2536(objc:defmethod (#/noteEncodingChange: :void) ((self hemlock-editor-document)
2537                                               popup)
2538  (with-slots (encoding) self
2539    (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
2540    (hi::note-modeline-change (hemlock-buffer self))))
2541
2542(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
2543                                               panel)
2544  (with-slots (encoding) self
2545    (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller) encoding)))
2546      (#/setAction: popup (@selector #/noteEncodingChange:))
2547      (#/setTarget: popup self)
2548      (#/setAccessoryView: panel popup)))
2549  (#/setExtensionHidden: panel nil)
2550  (#/setCanSelectHiddenExtension: panel nil)
2551  (#/setAllowedFileTypes: panel +null-ptr+)
2552  (call-next-method panel))
2553
2554
2555(defloadvar *ns-cr-string* (%make-nsstring (string #\return)))
2556(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed)))
2557(defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*))))
2558
2559(objc:defmethod (#/writeToURL:ofType:error: :<BOOL>)
2560    ((self hemlock-editor-document) url type (error (:* :id)))
2561  (declare (ignore type))
2562  (with-slots (encoding textstorage) self
2563    (let* ((string (#/string textstorage))
2564           (buffer (hemlock-buffer self)))
2565      (case (when buffer (hi::buffer-line-termination buffer))
2566        (:crlf (unless (typep string 'ns:ns-mutable-string)
2567                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
2568                 (#/replaceOccurrencesOfString:withString:options:range:
2569                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
2570        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
2571                            string
2572                            (make-instance 'ns:ns-mutable-string :with string string)))
2573             (#/replaceOccurrencesOfString:withString:options:range:
2574              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
2575      (when (#/writeToURL:atomically:encoding:error:
2576             string url t encoding error)
2577        (when buffer
2578          (setf (hi::buffer-modified buffer) nil))
2579        t))))
2580
2581
2582
2583
2584;;; Shadow the setFileURL: method, so that we can keep the buffer
2585;;; name and pathname in synch with the document.
2586(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document)
2587                                        url)
2588  (call-next-method url)
2589  (let* ((buffer (hemlock-buffer self)))
2590    (when buffer
2591      (let* ((new-pathname (lisp-string-from-nsstring (#/path url))))
2592        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
2593        (setf (hi::buffer-pathname buffer) new-pathname)))))
2594
2595
2596(def-cocoa-default *initial-editor-x-pos* :float 20.0f0 "X position of upper-left corner of initial editor")
2597
2598(def-cocoa-default *initial-editor-y-pos* :float -20.0f0 "Y position of upper-left corner of initial editor")
2599
2600(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized
2601(defloadvar *next-editor-y-pos* nil)
2602
2603(defun x-pos-for-window (window x)
2604  (let* ((frame (#/frame window))
2605         (screen (#/screen window)))
2606    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
2607    (let* ((screen-rect (#/visibleFrame screen)))
2608      (if (>= x 0)
2609        (+ x (ns:ns-rect-x screen-rect))
2610        (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame))))))
2611
2612(defun y-pos-for-window (window y)
2613  (let* ((frame (#/frame window))
2614         (screen (#/screen window)))
2615    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
2616    (let* ((screen-rect (#/visibleFrame screen)))
2617      (if (>= y 0)
2618        (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame))
2619        (+ (ns:ns-rect-height screen-rect) y)))))
2620
2621(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document))
2622  #+debug
2623  (#_NSLog #@"Make window controllers")
2624  (with-callback-context "makeWindowControllers"
2625    (let* ((textstorage  (slot-value self 'textstorage))
2626           (window (%hemlock-frame-for-textstorage
2627                    hemlock-frame
2628                    textstorage
2629                    *editor-columns*
2630                    *editor-rows*
2631                    nil
2632                    (textview-background-color self)
2633                    (user-input-style self)))
2634           (controller (make-instance
2635                           'hemlock-editor-window-controller
2636                         :with-window window)))
2637      (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
2638      (#/addWindowController: self controller)
2639      (#/release controller)
2640      (ns:with-ns-point  (current-point
2641                          (or *next-editor-x-pos*
2642                              (x-pos-for-window window *initial-editor-x-pos*))
2643                          (or *next-editor-y-pos*
2644                              (y-pos-for-window window *initial-editor-y-pos*)))
2645        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
2646          (setq *next-editor-x-pos* (ns:ns-point-x new-point)
2647                *next-editor-y-pos* (ns:ns-point-y new-point))))
2648      (let ((view (hemlock-view window)))
2649        (hi::handle-hemlock-event view #'(lambda ()
2650                                           (hi::process-file-options)))))))
2651
2652
2653(objc:defmethod (#/close :void) ((self hemlock-editor-document))
2654  #+debug
2655  (#_NSLog #@"Document close: %@" :id self)
2656  (let* ((textstorage (slot-value self 'textstorage)))
2657    (unless (%null-ptr-p textstorage)
2658      (setf (slot-value self 'textstorage) (%null-ptr))
2659      (for-each-textview-using-storage
2660       textstorage
2661       #'(lambda (tv)
2662           (let* ((layout (#/layoutManager tv)))
2663             (#/setBackgroundLayoutEnabled: layout nil))))
2664      (close-hemlock-textstorage textstorage)))
2665  (call-next-method))
2666
2667(defmethod view-screen-lines ((view hi:hemlock-view))
2668    (let* ((pane (hi::hemlock-view-pane view)))
2669      (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane)))
2670             (text-view-line-height (text-pane-text-view pane)))))
2671
2672;; Beware this doesn't seem to take horizontal scrolling into account.
2673(defun visible-charpos-range (tv)
2674  (let* ((rect (#/visibleRect tv))
2675         (container-origin (#/textContainerOrigin tv))
2676         (layout (#/layoutManager tv)))
2677    ;; Convert from view coordinates to container coordinates
2678    (decf (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
2679    (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y))
2680    (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
2681                         layout rect (#/textContainer tv)))
2682           (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
2683                        layout glyph-range +null-ptr+)))
2684      (values (pref char-range :<NSR>ange.location)
2685              (pref char-range :<NSR>ange.length)))))
2686
2687(defun charpos-xy (tv charpos)
2688  (let* ((layout (#/layoutManager tv))
2689         (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
2690                       layout
2691                       (ns:make-ns-range charpos 0)
2692                       +null-ptr+))
2693         (rect (#/boundingRectForGlyphRange:inTextContainer:
2694                layout
2695                glyph-range
2696                (#/textContainer tv)))
2697         (container-origin (#/textContainerOrigin tv)))
2698    (values (+ (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
2699            (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y)))))
2700
2701;;(nth-value 1 (charpos-xy tv (visible-charpos-range tv))) - this is smaller as it
2702;; only includes lines fully scrolled off...
2703(defun text-view-vscroll (tv)
2704  ;; Return the number of pixels scrolled off the top of the view.
2705  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
2706         (clip-view (#/contentView scroll-view))
2707         (bounds (#/bounds clip-view)))
2708    (ns:ns-rect-y bounds)))
2709
2710(defun set-text-view-vscroll (tv vscroll)
2711  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
2712         (clip-view (#/contentView scroll-view))
2713         (bounds (#/bounds clip-view)))
2714    (decf vscroll (mod vscroll (text-view-line-height tv))) ;; show whole line
2715    (ns:with-ns-point (new-origin (ns:ns-rect-x bounds) vscroll)
2716      (#/scrollToPoint: clip-view (#/constrainScrollPoint: clip-view new-origin))
2717      (#/reflectScrolledClipView: scroll-view clip-view))))
2718
2719(defun scroll-by-lines (tv nlines)
2720  "Change the vertical origin of the containing scrollview's clipview"
2721  (set-text-view-vscroll tv (+ (text-view-vscroll tv)
2722                               (* nlines (text-view-line-height tv)))))
2723
2724;; TODO: should be a hemlock variable..
2725(defvar *next-screen-context-lines* 2)
2726
2727(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where)
2728  (assume-cocoa-thread)
2729  (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
2730    (when (eq how :line)
2731      (setq where (require-type where '(integer 0)))
2732      (let* ((line-y (nth-value 1 (charpos-xy tv where)))
2733             (top-y (text-view-vscroll tv))
2734             (nlines (floor (- line-y top-y) (text-view-line-height tv))))
2735        (setq how :lines-down where nlines)))
2736    (ecase how
2737      (:center-selection
2738       (#/centerSelectionInVisibleArea: tv +null-ptr+))
2739      (:page-up
2740       (require-type where 'null)
2741       ;; TODO: next-screen-context-lines
2742       (scroll-by-lines tv (- *next-screen-context-lines* (view-screen-lines view))))
2743      (:page-down
2744       (require-type where 'null)
2745       (scroll-by-lines tv (- (view-screen-lines view) *next-screen-context-lines*)))
2746      (:lines-up
2747       (scroll-by-lines tv (- (require-type where 'integer))))
2748      (:lines-down
2749       (scroll-by-lines tv (require-type where 'integer))))
2750    ;; If point is not on screen, move it.
2751    (let* ((point (hi::current-point))
2752           (point-pos (hi::mark-absolute-position point)))
2753      (multiple-value-bind (win-pos win-len) (visible-charpos-range tv)
2754        (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
2755          (let* ((point (hi::current-point-collapsing-selection))
2756                 (cache (hemlock-buffer-string-cache (#/hemlockString (#/textStorage tv)))))
2757            (move-hemlock-mark-to-absolute-position point cache win-pos)
2758            (update-hemlock-selection (#/textStorage tv))))))))
2759
2760(defun iana-charset-name-of-nsstringencoding (ns)
2761  (#_CFStringConvertEncodingToIANACharSetName
2762   (#_CFStringConvertNSStringEncodingToEncoding ns)))
2763   
2764
2765(defun nsstring-for-nsstring-encoding (ns)
2766  (let* ((iana (iana-charset-name-of-nsstringencoding ns)))
2767    (if (%null-ptr-p iana)
2768      (#/stringWithFormat: ns:ns-string #@"{%@}"
2769                           (#/localizedNameOfStringEncoding: ns:ns-string ns))
2770      iana)))
2771     
2772;;; Return a list of :<NSS>tring<E>ncodings, sorted by the
2773;;; (localized) name of each encoding.
2774(defun supported-nsstring-encodings ()
2775  (ccl::collect ((ids))
2776    (let* ((ns-ids (#/availableStringEncodings ns:ns-string)))
2777      (unless (%null-ptr-p ns-ids)
2778        (do* ((i 0 (1+ i)))
2779             ()
2780          (let* ((id (paref ns-ids (:* :<NSS>tring<E>ncoding) i)))
2781            (if (zerop id)
2782              (return (sort (ids)
2783                            #'(lambda (x y)
2784                                (= #$NSOrderedAscending
2785                                   (#/localizedCompare:
2786                                    (nsstring-for-nsstring-encoding x)
2787                                    (nsstring-for-nsstring-encoding y))))))
2788              (ids id))))))))
2789
2790
2791
2792
2793
2794;;; TexEdit.app has support for allowing the encoding list in this
2795;;; popup to be customized (e.g., to suppress encodings that the
2796;;; user isn't interested in.)
2797(defmethod build-encodings-popup ((self hemlock-document-controller)
2798                                  &optional (preferred-encoding (get-default-encoding)))
2799  (let* ((id-list (supported-nsstring-encodings))
2800         (popup (make-instance 'ns:ns-pop-up-button)))
2801    ;;; Add a fake "Automatic" item with tag 0.
2802    (#/addItemWithTitle: popup #@"Automatic")
2803    (#/setTag: (#/itemAtIndex: popup 0) 0)
2804    (dolist (id id-list)
2805      (#/addItemWithTitle: popup (nsstring-for-nsstring-encoding id))
2806      (#/setTag: (#/lastItem popup) (nsstring-encoding-to-nsinteger id)))
2807    (when preferred-encoding
2808      (#/selectItemWithTag: popup (nsstring-encoding-to-nsinteger preferred-encoding)))
2809    (#/sizeToFit popup)
2810    popup))
2811
2812
2813(objc:defmethod (#/runModalOpenPanel:forTypes: :<NSI>nteger)
2814    ((self hemlock-document-controller) panel types)
2815  (let* ((popup (build-encodings-popup self #|preferred|#)))
2816    (#/setAccessoryView: panel popup)
2817    (let* ((result (call-next-method panel types)))
2818      (when (= result #$NSOKButton)
2819        (with-slots (last-encoding) self
2820          (setq last-encoding (nsinteger-to-nsstring-encoding (#/tag (#/selectedItem popup))))))
2821      result)))
2822 
2823(defun hi::open-document ()
2824  (#/performSelectorOnMainThread:withObject:waitUntilDone:
2825   (#/sharedDocumentController hemlock-document-controller)
2826   (@selector #/openDocument:) +null-ptr+ t))
2827 
2828(defmethod hi::save-hemlock-document ((self hemlock-editor-document))
2829  (#/performSelectorOnMainThread:withObject:waitUntilDone:
2830   self (@selector #/saveDocument:) +null-ptr+ t))
2831
2832
2833(defmethod hi::save-hemlock-document-as ((self hemlock-editor-document))
2834  (#/performSelectorOnMainThread:withObject:waitUntilDone:
2835   self (@selector #/saveDocumentAs:) +null-ptr+ t))
2836
2837(defmethod hi::save-hemlock-document-to ((self hemlock-editor-document))
2838  (#/performSelectorOnMainThread:withObject:waitUntilDone:
2839   self (@selector #/saveDocumentTo:) +null-ptr+ t))
2840
2841(defun initialize-user-interface ()
2842  ;; The first created instance of an NSDocumentController (or
2843  ;; subclass thereof) becomes the shared document controller.  So it
2844  ;; may look like we're dropping this instance on the floor, but
2845  ;; we're really not.
2846  (make-instance 'hemlock-document-controller)
2847  ;(#/sharedPanel lisp-preferences-panel)
2848  (make-editor-style-map))
2849
2850;;; This needs to run on the main thread.  Sets the cocoa selection from the
2851;;; hemlock selection.
2852(defmethod update-hemlock-selection ((self hemlock-text-storage))
2853  (assume-cocoa-thread)
2854  (let ((buffer (hemlock-buffer self)))
2855    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
2856      #+debug
2857      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
2858               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
2859      (for-each-textview-using-storage
2860       self
2861       #'(lambda (tv)
2862           (#/updateSelection:length:affinity: tv
2863                                               start
2864                                               (- end start)
2865                                               (if (eql start 0)
2866                                                 #$NSSelectionAffinityUpstream
2867                                                 #$NSSelectionAffinityDownstream)))))))
2868
2869;; This should be invoked by any command that modifies the buffer, so it can show the
2870;; user what happened...  This ensures the Cocoa selection is made visible, so it
2871;; assumes the Cocoa selection has already been synchronized with the hemlock one.
2872(defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view))
2873  (let ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
2874    (#/scrollRangeToVisible: tv (#/selectedRange tv))))
2875
2876(defloadvar *general-pasteboard* nil)
2877
2878(defun general-pasteboard ()
2879  (or *general-pasteboard*
2880      (setq *general-pasteboard*
2881            (#/retain (#/generalPasteboard ns:ns-pasteboard)))))
2882
2883(defloadvar *string-pasteboard-types* ())
2884
2885(defun string-pasteboard-types ()
2886  (or *string-pasteboard-types*
2887      (setq *string-pasteboard-types*
2888            (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType)))))
2889
2890
2891(objc:defmethod (#/stringToPasteBoard:  :void)
2892    ((self lisp-application) string)
2893  (let* ((pb (general-pasteboard)))
2894    (#/declareTypes:owner: pb (string-pasteboard-types) nil)
2895    (#/setString:forType: pb string #&NSStringPboardType)))
2896   
2897(defun hi::string-to-clipboard (string)
2898  (when (> (length string) 0)
2899    (#/performSelectorOnMainThread:withObject:waitUntilDone:
2900     *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t)))
2901
2902;;; The default #/paste method seems to want to set the font to
2903;;; something ... inappropriate.  If we can figure out why it
2904;;; does that and persuade it not to, we wouldn't have to do
2905;;; this here.
2906;;; (It's likely to also be the case that Carbon applications
2907;;; terminate lines with #\Return when writing to the clipboard;
2908;;; we may need to continue to override this method in order to
2909;;; fix that.)
2910(objc:defmethod (#/paste: :void) ((self hemlock-text-view) sender)
2911  (declare (ignorable sender))
2912  #+debug (#_NSLog #@"Paste: sender = %@" :id sender)
2913  (let* ((pb (general-pasteboard))
2914         (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType))))
2915    #+debug (log-debug "   string = ~s" string)
2916    (unless (%null-ptr-p string)
2917      (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*)))
2918        (setq string (make-instance 'ns:ns-mutable-string :with-string string))
2919        (#/replaceOccurrencesOfString:withString:options:range:
2920                string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))
2921      (let* ((textstorage (#/textStorage self)))
2922        (unless (#/shouldChangeTextInRange:replacementString: self (#/selectedRange self) string)
2923          (#/setSelectedRange: self (ns:make-ns-range (#/length textstorage) 0)))
2924        (let* ((selectedrange (#/selectedRange self)))
2925          (#/replaceCharactersInRange:withString: textstorage selectedrange string))))))
2926
2927
2928(objc:defmethod (#/hyperSpecLookUp: :void)
2929    ((self hemlock-text-view) sender)
2930  (declare (ignore sender))
2931  (let* ((range (#/selectedRange self)))
2932    (unless (eql 0 (ns:ns-range-length range))
2933      (let* ((string (nstring-upcase (lisp-string-from-nsstring (#/substringWithRange: (#/string (#/textStorage self)) range)))))
2934        (multiple-value-bind (symbol win) (find-symbol string "CL")
2935          (when win
2936            (lookup-hyperspec-symbol symbol self)))))))
2937
2938
2939;; This is called by stuff that makes a window programmatically, e.g. m-. or grep.
2940;; But the Open and New menus invoke the cocoa fns below directly. So just changing
2941;; things here will not change how the menus create views.  Instead,f make changes to
2942;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers.
2943(defun find-or-make-hemlock-view (&optional pathname)
2944  (assume-cocoa-thread)
2945  (rlet ((perror :id +null-ptr+))
2946    (let* ((doc (if pathname
2947                  (#/openDocumentWithContentsOfURL:display:error:
2948                   (#/sharedDocumentController ns:ns-document-controller)
2949                   (pathname-to-url pathname)
2950                   #$YES
2951                   perror)
2952                  (let ((*last-document-created* nil))
2953                    (#/newDocument: 
2954                     (#/sharedDocumentController hemlock-document-controller)
2955                     +null-ptr+)
2956                    *last-document-created*))))
2957      #+debug (log-debug "created ~s" doc)
2958      (when (%null-ptr-p doc)
2959        (error "Couldn't open ~s: ~a" pathname
2960               (let ((error (pref perror :id)))
2961                 (if (%null-ptr-p error)
2962                   "unknown error encountered"
2963                   (lisp-string-from-nsstring (#/localizedDescription error))))))
2964      (front-view-for-buffer (hemlock-buffer doc)))))
2965
2966(defun cocoa-edit-single-definition (name info)
2967  (assume-cocoa-thread)
2968  (destructuring-bind (indicator . pathname) info
2969    (let ((view (find-or-make-hemlock-view pathname)))
2970      (hi::handle-hemlock-event view
2971                                #'(lambda ()
2972                                    (hemlock::find-definition-in-buffer name indicator))))))
2973
2974(defun hemlock-ext:edit-single-definition (name info)
2975  (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info))))
2976
2977(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
2978  (make-instance 'sequence-window-controller
2979    :title title
2980    :sequence sequence
2981    :result-callback action
2982    :display printer))
2983
2984(objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
2985                                                    type)
2986  (if (#/isEqualToString: type #@"html")
2987      display-document
2988      (call-next-method type)))
2989     
2990
2991(objc:defmethod #/newDisplayDocumentWithTitle:content:
2992                ((self hemlock-document-controller)
2993                 title
2994                 string)
2995  (assume-cocoa-thread)
2996  (let* ((doc (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+)))
2997    (unless (%null-ptr-p doc)
2998      (#/addDocument: self doc)
2999      (#/makeWindowControllers doc)
3000      (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0))))
3001        (#/setTitle: window title)
3002        (let* ((tv (slot-value doc 'text-view))
3003               (lm (#/layoutManager tv))
3004               (ts (#/textStorage lm)))
3005          (#/beginEditing ts)
3006          (#/replaceCharactersInRange:withAttributedString:
3007           ts
3008           (ns:make-ns-range 0 (#/length ts))
3009           string)
3010          (#/endEditing ts))
3011        (#/makeKeyAndOrderFront: window self)))
3012    doc))
3013
3014(defun hi::revert-document (doc)
3015  (#/performSelectorOnMainThread:withObject:waitUntilDone:
3016   doc
3017   (@selector #/revertDocumentToSaved:)
3018   +null-ptr+
3019   t))
3020
3021(defun hemlock-ext:raise-buffer-view (buffer &optional action)
3022  "Bring a window containing buffer to front and then execute action in
3023   the window.  Returns before operation completes."
3024  ;; Queue for after this event, so don't screw up current context.
3025  (queue-for-gui #'(lambda ()
3026                     (let ((doc (hi::buffer-document buffer)))
3027                       (unless (and doc (not (%null-ptr-p doc)))
3028                         (hi:editor-error "Deleted buffer: ~s" buffer))
3029                       (#/showWindows doc)
3030                       (when action
3031                         (hi::handle-hemlock-event (front-view-for-buffer buffer) action))))))
3032
3033;;; Enable CL:ED
3034(defun cocoa-edit (&optional arg)
3035  (cond ((or (null arg)
3036             (typep arg 'string)
3037             (typep arg 'pathname))
3038         (when arg
3039           (unless (probe-file arg)
3040             (let ((lpath (merge-pathnames arg *.lisp-pathname*)))
3041               (when (probe-file lpath) (setq arg lpath)))))
3042         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
3043        ((ccl::valid-function-name-p arg)
3044         (hemlock::edit-definition arg)
3045         nil)
3046        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
3047
3048(setq ccl::*resident-editor-hook* 'cocoa-edit)
3049
Note: See TracBrowser for help on using the repository browser.