Context Navigation

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

Visit:

Last change on this file since 12168 was 12168, checked in by rme, 12 years ago
Remove modeline-scroll-view class. Add #/evalAll: method on hemlock-text-view. Set "Execute All" menu item action to #/evalAll:. Add code to hemlock-text-view's #/validateMenuItem: method to try to enable/disable the "Execute All" menu item approrpriately (we don't want "Execute All" to work on listener windows).
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 132.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: