source: trunk/ccl/cocoa-ide/cocoa-editor.lisp @ 7684

Last change on this file since 7684 was 7684, checked in by rme, 14 years ago

Add preference option so that bitmap screen font substitution can be
disabled.

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