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

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

Fix (from Shannon Spires, over a year ago) to treat Caps Lock like
shift when mapping key events. (See ticket:219.)

Subclass NSClipView; use an instance of that clip view when embedding
a hemlock text view in a scroll view. Define a scrollToPoint: method
on that NSClipView subclass, so that we can tell when scrolling occurs
and update transient text attributes when it does. (May need to
handle cases when the view is enlarged vertically, as well.)

Try to finally fix ticket:150 (confused by double-click after close
paren at end of file.) There may have been similar problems having
to do with double-clicking before an open paren at the beginning
of the file; this would be caused by Hemlock's VALID-SPOT-P believing
that position 0 (at least) is in the attribute line. (Should probably
change the Hemlock code; files don't necessarily have attribute lines,
and there are probably better ways of telling whether or not we're
in te middle of one.) At EOF, Cocoa claims that a double-click is
trying to select a character (not a word or para); in order to
determine whether we got a single or multi-click, look at the current
event. On Leopard at least, the proposed range is correct in this
case (and it's the granularity that's confused us); should check
Tiger.

Try to clean up some cases where paren highlighting isn't cleared
when it should be. Wouldn't want to claim that no such cases remain,
but it's better.

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