Context Navigation

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

Visit:

Last change on this file since 7116 was 7116, checked in by gz, 13 years ago
umm, load cocoa-grep where it will work...
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 113.7 KB

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

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

Download in other formats: