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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

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