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

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

Try to work around the confusion in #/replaceCharactersInRange:withString:
by adding more confusion. This method -should- assume that the caller
has done #/beginEditing on the textstorage and will do #/endEditing
at some point in the future, but it calls Hemlock code that asserts
that editing is not in progress. (Some of our own methods may call
this method without a preceding #/beginEditing.) So, to kludge around
this, note the edit count on the texstorage before modifying the buffer
and call #/endEditing until the edit count is 0, do the Hemlock-level
modification, then restore the edit count (by calling #/beginEditing
to raise the edit count back to the level it had on entry.)

This is a total hack (and may break something somewhere), but it keeps
this code from generating a spurious assertion failure and allows foreign
code to modify the buffer; for a good time, try "ctrl-q option-e e" on
a US keyboard. (This exposes other problems with non-ASCII characters
in lisp buffers; it's not clear that their syntax attributes are reasonable.)

In #/paste, assume that #/replaceCharactersInRange:withString: isn't broken,
and bracket the call to that method with #/beginEditing / #/endEditing
calls.

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