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

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

Hide mouse cursor when typing. (ticket:203)

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