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

Last change on this file since 12009 was 12009, checked in by rme, 11 years ago

Custom zoom behavior for editor windows (zoom vertical, then full, then
back to normal). Use the hemlock-editor-window-controller as the window's
delegate (instead of the document object).

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