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

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

export hemlock-ext::invoke-allowing-buffer-display

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 140.2 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
[617]2146
[744]2147(defun hi::lock-buffer (b)
[7595]2148  (grab-lock (hi::buffer-lock b)))
[592]2149
[744]2150(defun hi::unlock-buffer (b)
[7595]2151  (release-lock (hi::buffer-lock b))) 
[7363]2152
[8428]2153(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk)
2154  (assume-cocoa-thread)
2155  (when buffer ;; nil means just get rid of any prior buffer
2156    (setq buffer (require-type buffer 'hi::buffer)))
2157  (let ((old *buffer-being-edited*))
2158    (if (eq buffer old)
2159      (funcall thunk)
2160      (unwind-protect
2161          (progn
2162            (buffer-document-end-editing old)
2163            (buffer-document-begin-editing buffer)
2164            (funcall thunk))
2165        (buffer-document-end-editing buffer)
2166        (buffer-document-begin-editing old)))))
[592]2167
[12229]2168
[8428]2169(defun buffer-document-end-editing (buffer)
2170  (when buffer
2171    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
2172      (when document
2173        (setq *buffer-being-edited* nil)
2174        (let ((ts (slot-value document 'textstorage)))
2175          (#/endEditing ts)
2176          (update-hemlock-selection ts))))))
2177
2178(defun buffer-document-begin-editing (buffer)
2179  (when buffer
2180    (let* ((document (hi::buffer-document buffer)))
2181      (when document
2182        (setq *buffer-being-edited* buffer)
2183        (#/beginEditing (slot-value document 'textstorage))))))
2184
[2133]2185(defun document-edit-level (document)
[7363]2186  (assume-cocoa-thread) ;; see comment in #/editingInProgress
[2133]2187  (slot-value (slot-value document 'textstorage) 'edit-count))
[707]2188
[12229]2189(defun hi::buffer-edit-level (buffer)
2190  (if buffer
2191    (let* ((document (hi::buffer-document buffer)))
2192      (if document
2193        (document-edit-level document)
2194        0))
2195    0))
2196
[12856]2197(defun hemlock-ext:invoke-allowing-buffer-display (buffer thunk)
[12229]2198  ;; Call THUNK with the buffer's edit-level at 0, then restore the buffer's edit level.
2199  (let* ((level (hi::buffer-edit-level buffer)))
2200    (dotimes (i level) (buffer-document-end-editing buffer))
2201    (unwind-protect
2202        (funcall thunk)
2203      (dotimes (i level) (buffer-document-begin-editing buffer)))))
2204
2205
[12319]2206(defun hi::buffer-document-modified (buffer)
2207  (let* ((doc (hi::buffer-document buffer)))
2208    (if doc
2209      (#/isDocumentEdited doc))))
[12229]2210
[7142]2211(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
2212  (with-lock-grabbed (*buffer-change-invocation-lock*)
2213    (let* ((invocation *buffer-change-invocation*))
2214      (rlet ((ppos :<NSI>nteger pos)
2215             (pn :<NSI>nteger n)
2216             (pextra :<NSI>nteger extra))
2217        (#/setTarget: invocation textstorage)
2218        (#/setSelector: invocation selector)
2219        (#/setArgument:atIndex: invocation ppos 2)
2220        (#/setArgument:atIndex: invocation pn 3)
2221        (#/setArgument:atIndex: invocation pextra 4))
2222      (#/performSelectorOnMainThread:withObject:waitUntilDone:
2223       invocation
2224       (@selector #/invoke)
2225       +null-ptr+
2226       t))))
[717]2227
[592]2228
[716]2229
[11037]2230
[6614]2231(defun hi::buffer-note-font-change (buffer region font)
[793]2232  (when (hi::bufferp buffer)
2233    (let* ((document (hi::buffer-document buffer))
2234           (textstorage (if document (slot-value document 'textstorage)))
[8428]2235           (pos (hi:mark-absolute-position (hi::region-start region)))
2236           (n (- (hi:mark-absolute-position (hi::region-end region)) pos)))
[793]2237      (perform-edit-change-notification textstorage
[7142]2238                                        (@selector #/noteHemlockAttrChangeAtPosition:length:)
[793]2239                                        pos
[7142]2240                                        n
2241                                        font))))
[793]2242
[8428]2243(defun buffer-active-font-attributes (buffer)
[6622]2244  (let* ((style 0)
[6724]2245         (region (hi::buffer-active-font-region buffer))
2246         (textstorage (slot-value (hi::buffer-document buffer) 'textstorage))
2247         (styles (#/styles textstorage)))
[6622]2248    (when region
2249      (let* ((start (hi::region-end region)))
2250        (setq style (hi::font-mark-font start))))
[6724]2251    (#/objectAtIndex: styles style)))
[6622]2252     
[7595]2253;; Note that inserted a string of length n at mark.  Assumes this is called after
2254;; buffer marks were updated.
[592]2255(defun hi::buffer-note-insertion (buffer mark n)
2256  (when (hi::bufferp buffer)
2257    (let* ((document (hi::buffer-document buffer))
2258           (textstorage (if document (slot-value document 'textstorage))))
2259      (when textstorage
[8428]2260        (let* ((pos (hi:mark-absolute-position mark)))
[7595]2261          (when (eq (hi::mark-%kind mark) :left-inserting)
2262            ;; Make up for the fact that the mark moved forward with the insertion.
2263            ;; For :right-inserting and :temporary marks, they should be left back.
[592]2264            (decf pos n))
[717]2265          (perform-edit-change-notification textstorage
[7142]2266                                            (@selector #/noteHemlockInsertionAtPosition:length:)
[717]2267                                            pos
2268                                            n))))))
[592]2269
[717]2270(defun hi::buffer-note-modification (buffer mark n)
2271  (when (hi::bufferp buffer)
2272    (let* ((document (hi::buffer-document buffer))
2273           (textstorage (if document (slot-value document 'textstorage))))
2274      (when textstorage
[6614]2275            (perform-edit-change-notification textstorage
[7142]2276                                              (@selector #/noteHemlockModificationAtPosition:length:)
[8428]2277                                              (hi:mark-absolute-position mark)
[7142]2278                                              n)))))
[592]2279 
2280
2281(defun hi::buffer-note-deletion (buffer mark n)
2282  (when (hi::bufferp buffer)
2283    (let* ((document (hi::buffer-document buffer))
2284           (textstorage (if document (slot-value document 'textstorage))))
2285      (when textstorage
[8428]2286        (let* ((pos (hi:mark-absolute-position mark)))
[6614]2287          (perform-edit-change-notification textstorage
[7142]2288                                            (@selector #/noteHemlockDeletionAtPosition:length:)
[6614]2289                                            pos
2290                                            (abs n)))))))
[869]2291
[7142]2292
2293
[8428]2294(defun hemlock-ext:note-buffer-saved (buffer)
2295  (assume-cocoa-thread)
2296  (let* ((document (hi::buffer-document buffer)))
2297    (when document
2298      ;; Hmm... I guess this is always done by the act of saving.
2299      nil)))
[592]2300
[8428]2301(defun hemlock-ext:note-buffer-unsaved (buffer)
2302  (assume-cocoa-thread)
2303  (let* ((document (hi::buffer-document buffer)))
2304    (when document
2305      (#/updateChangeCount: document #$NSChangeCleared))))
[592]2306
2307
[6]2308(defun size-of-char-in-font (f)
[6234]2309  (let* ((sf (#/screenFont f))
[7804]2310         (screen-p *use-screen-fonts*))
[6234]2311    (if (%null-ptr-p sf) (setq sf f screen-p nil))
2312    (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager)))))
2313      (#/setUsesScreenFonts: layout screen-p)
2314      (values (fround (#/defaultLineHeightForFont: layout sf))
[12493]2315              (fround (ns:ns-size-width (#/advancementForGlyph: sf (char-code #\space))))))))
[6]2316         
2317
2318
[8428]2319(defun size-text-pane (pane line-height char-width nrows ncols)
[790]2320  (let* ((tv (text-pane-text-view pane))
[8428]2321         (height (fceiling (* nrows line-height)))
[6]2322         (width (fceiling (* ncols char-width)))
[790]2323         (scrollview (text-pane-scroll-view pane))
[6234]2324         (window (#/window scrollview))
2325         (has-horizontal-scroller (#/hasHorizontalScroller scrollview))
2326         (has-vertical-scroller (#/hasVerticalScroller scrollview)))
2327    (ns:with-ns-size (tv-size
2328                      (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv))))
2329                      height)
[5885]2330      (when has-vertical-scroller 
[8428]2331        (#/setVerticalLineScroll: scrollview line-height)
2332        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#))
[5885]2333      (when has-horizontal-scroller
[6234]2334        (#/setHorizontalLineScroll: scrollview char-width)
[7804]2335        (#/setHorizontalPageScroll: scrollview (cgfloat 0.0) #|char-width|#))
[6234]2336      (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview)))
2337             (pane-frame (#/frame pane))
2338             (margins (#/contentViewMargins pane)))
2339        (incf (ns:ns-size-height sv-size)
2340              (+ (ns:ns-rect-y pane-frame)
2341                 (* 2 (ns:ns-size-height  margins))))
2342        (incf (ns:ns-size-width sv-size)
2343              (ns:ns-size-width margins))
2344        (#/setContentSize: window sv-size)
[6687]2345        (setf (slot-value tv 'char-width) char-width
[8428]2346              (slot-value tv 'line-height) line-height)
[6234]2347        (#/setResizeIncrements: window
[8428]2348                                (ns:make-ns-size char-width line-height))))))
[6]2349                                   
2350 
[707]2351(defclass hemlock-editor-window-controller (ns:ns-window-controller)
[12009]2352  ()
[430]2353  (:metaclass ns:+ns-object))
[6]2354
[12009]2355;;; This is borrowed from emacs.  The first click on the zoom button will
2356;;; zoom vertically.  The second will zoom completely.  The third will
2357;;; return to the original size.
2358(objc:defmethod (#/windowWillUseStandardFrame:defaultFrame: #>NSRect)
2359                ((wc hemlock-editor-window-controller) sender (default-frame #>NSRect))
2360  (let* ((r (#/frame sender)))
2361    (if (= (ns:ns-rect-height r) (ns:ns-rect-height default-frame))
2362      (setf r default-frame)
2363      (setf (ns:ns-rect-height r) (ns:ns-rect-height default-frame)
2364            (ns:ns-rect-y r) (ns:ns-rect-y default-frame)))
2365    r))
2366
[12786]2367(objc:defmethod (#/windowWillClose: :void) ((wc hemlock-editor-window-controller)
2368                                            notification)
2369  (declare (ignore notification))
2370  ;; The echo area "document" should probably be a slot in the document
2371  ;; object, and released when the document object is.
2372  (let* ((w (#/window wc))
2373         (buf (hemlock-frame-echo-area-buffer w))
2374         (echo-doc (if buf (hi::buffer-document buf))))
2375    (when echo-doc
2376      (setf (hemlock-frame-echo-area-buffer w) nil)
2377      (#/close echo-doc))
2378    (#/setFrameAutosaveName: w #@"")
2379    (#/autorelease w)))
2380
[8428]2381(defmethod hemlock-view ((self hemlock-editor-window-controller))
2382  (let ((frame (#/window self)))
2383    (unless (%null-ptr-p frame)
2384      (hemlock-view frame))))
[6]2385
[6687]2386;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
2387(defun get-default-encoding ()
[12493]2388  #-cocotron                            ;need IANA conversion stuff
[12125]2389  (let* ((file-encoding *default-file-character-encoding*))
2390    (when (and (typep file-encoding 'keyword)
2391               (lookup-character-encoding file-encoding))
2392      (let* ((string (string file-encoding))
2393             (len (length string)))
2394        (with-cstrs ((cstr string))
2395          (with-nsstr (nsstr cstr len)
2396            (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr)))
2397              (if (= cf #$kCFStringEncodingInvalidId)
2398                (setq cf (#_CFStringGetSystemEncoding)))
2399              (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf)))
2400                (if (= ns #$kCFStringEncodingInvalidId)
2401                  (#/defaultCStringEncoding ns:ns-string)
2402                  ns)))))))))
[6]2403
[7804]2404(defclass hemlock-document-controller (ns:ns-document-controller)
2405    ((last-encoding :foreign-type :<NSS>tring<E>ncoding))
2406  (:metaclass ns:+ns-object))
2407(declaim (special hemlock-document-controller))
2408
2409(objc:defmethod #/init ((self hemlock-document-controller))
2410  (prog1
2411      (call-next-method)
2412    (setf (slot-value self 'last-encoding) 0)))
2413
2414
[707]2415;;; The HemlockEditorDocument class.
[6]2416
2417
[707]2418(defclass hemlock-editor-document (ns:ns-document)
[6589]2419    ((textstorage :foreign-type :id)
[12125]2420     (encoding :foreign-type :<NSS>tring<E>ncoding))
[430]2421  (:metaclass ns:+ns-object))
[6]2422
[8428]2423(defmethod hemlock-buffer ((self hemlock-editor-document))
2424  (let ((ts (slot-value self 'textstorage)))
2425    (unless (%null-ptr-p ts)
2426      (hemlock-buffer ts))))
[7142]2427
[7363]2428(defmethod assume-not-editing ((doc hemlock-editor-document))
2429  (assume-not-editing (slot-value doc 'textstorage)))
[7142]2430
[8428]2431(defmethod document-invalidate-modeline ((self hemlock-editor-document))
2432  (for-each-textview-using-storage
2433   (slot-value self 'textstorage)
2434   #'(lambda (tv)
2435       (let* ((pane (text-view-pane tv)))
2436         (unless (%null-ptr-p pane)
2437           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
2438
[6785]2439(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
[12125]2440  (let* ((name (or (hemlock::package-at-mark (hi::buffer-point buffer))
2441                   (hi::variable-value 'hemlock::default-package :buffer buffer))))
[6785]2442    (when name
2443      (let* ((pkg (find-package name)))
2444        (if pkg
2445          (setq name (shortest-package-name pkg))))
2446      (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer)))
2447        (if (or (null curname)
2448                (not (string= curname name)))
2449          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
[6687]2450
[8428]2451(defun hemlock-ext:note-selection-set-by-search (buffer)
2452  (let* ((doc (hi::buffer-document buffer)))
2453    (when doc
2454      (with-slots (textstorage) doc
2455        (when textstorage
2456          (with-slots (selection-set-by-search) textstorage
2457            (setq selection-set-by-search #$YES)))))))
[7058]2458
[6709]2459(objc:defmethod (#/validateMenuItem: :<BOOL>)
[6718]2460    ((self hemlock-text-view) item)
[6709]2461  (let* ((action (#/action item)))
[6718]2462    #+debug (#_NSLog #@"action = %s" :address action)
[6887]2463    (cond ((eql action (@selector #/hyperSpecLookUp:))
2464           ;; For now, demand a selection.
[7563]2465           (and *hyperspec-lookup-enabled*
2466                (hyperspec-root-url)
[6887]2467                (not (eql 0 (ns:ns-range-length (#/selectedRange self))))))
2468          ((eql action (@selector #/cut:))
2469           (let* ((selection (#/selectedRange self)))
2470             (and (> (ns:ns-range-length selection))
2471                  (#/shouldChangeTextInRange:replacementString: self selection #@""))))
[7493]2472          ((eql action (@selector #/evalSelection:))
[7531]2473           (not (eql 0 (ns:ns-range-length (#/selectedRange self)))))
[12168]2474          ((eql action (@selector #/evalAll:))
2475           (let* ((doc (#/document (#/windowController (#/window self)))))
2476             (and (not (%null-ptr-p doc))
2477                  (eq (type-of doc) 'hemlock-editor-document))))
[7531]2478          ;; if this hemlock-text-view is in an editor windowm and its buffer has
2479          ;; an associated pathname, then activate the Load Buffer item
[7532]2480          ((or (eql action (@selector #/loadBuffer:))
2481               (eql action (@selector #/compileBuffer:))
2482               (eql action (@selector #/compileAndLoadBuffer:))) 
[8428]2483           (let* ((buffer (hemlock-buffer self))
[7531]2484                  (pathname (hi::buffer-pathname buffer)))
2485             (not (null pathname))))
[7493]2486          (t (call-next-method item)))))
[6709]2487
[6687]2488(defmethod user-input-style ((doc hemlock-editor-document))
2489  0)
2490
2491(defvar *encoding-name-hash* (make-hash-table))
2492
[8428]2493(defmethod document-encoding-name ((doc hemlock-editor-document))
[6687]2494  (with-slots (encoding) doc
2495    (if (eql encoding 0)
2496      "Automatic"
2497      (or (gethash encoding *encoding-name-hash*)
2498          (setf (gethash encoding *encoding-name-hash*)
2499                (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
2500
[8428]2501(defun hi::buffer-encoding-name (buffer)
2502  (let ((doc (hi::buffer-document buffer)))
2503    (and doc (document-encoding-name doc))))
[6687]2504
[8428]2505;; TODO: make each buffer have a slot, and this is just the default value.
[744]2506(defmethod textview-background-color ((doc hemlock-editor-document))
[6724]2507  *editor-background-color*)
[744]2508
2509
[6234]2510(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts)
2511  (let* ((doc (%inc-ptr self 0))        ; workaround for stack-consed self
[6687]2512         (string (#/hemlockString ts))
[12543]2513         (buffer (hemlock-buffer string)))
[793]2514    (unless (%null-ptr-p doc)
2515      (setf (slot-value doc 'textstorage) ts
[1179]2516            (hi::buffer-document buffer) doc))))
[2133]2517
[5693]2518;; This runs on the main thread.
[6234]2519(objc:defmethod (#/revertToSavedFromFile:ofType: :<BOOL>)
2520    ((self hemlock-editor-document) filename filetype)
[2133]2521  (declare (ignore filetype))
[7363]2522  (assume-cocoa-thread)
[2133]2523  #+debug
2524  (#_NSLog #@"revert to saved from file %@ of type %@"
2525           :id filename :id filetype)
[6614]2526  (let* ((encoding (slot-value self 'encoding))
[6234]2527         (nsstring (make-instance ns:ns-string
[6614]2528                                  :with-contents-of-file filename
2529                                  :encoding encoding
2530                                  :error +null-ptr+))
[8428]2531         (buffer (hemlock-buffer self))
[2133]2532         (old-length (hemlock-buffer-length buffer))
[7595]2533         (hi::*current-buffer* buffer)
[2133]2534         (textstorage (slot-value self 'textstorage))
2535         (point (hi::buffer-point buffer))
[8428]2536         (pointpos (hi:mark-absolute-position point)))
2537    (hemlock-ext:invoke-modifying-buffer-storage
2538     buffer
2539     #'(lambda ()
2540         (#/edited:range:changeInLength:
2541          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
2542         (nsstring-to-buffer nsstring buffer)
2543         (let* ((newlen (hemlock-buffer-length buffer)))
2544           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
2545           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
2546           (let* ((ts-string (#/hemlockString textstorage))
2547                  (display (hemlock-buffer-string-cache ts-string)))
2548             (reset-buffer-cache display) 
2549             (update-line-cache-for-index display 0)
2550             (move-hemlock-mark-to-absolute-position point
2551                                                     display
2552                                                     (min newlen pointpos))))
2553         (#/updateMirror textstorage)
2554         (setf (hi::buffer-modified buffer) nil)
2555         (hi::note-modeline-change buffer)))
[2133]2556    t))
[8428]2557
2558
2559(defvar *last-document-created* nil)
2560
[6234]2561(objc:defmethod #/init ((self hemlock-editor-document))
2562  (let* ((doc (call-next-method)))
[855]2563    (unless  (%null-ptr-p doc)
[6234]2564      (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer
2565                              (make-hemlock-buffer
2566                               (lisp-string-from-nsstring
2567                                (#/displayName doc))
[12570]2568                               :modes '("Lisp" "Editor"))))
[12571]2569      ;; Cocotron's NSUndoManager implementation causes CPU usage to peg at 90+%
2570      ;; Remove this when Cocotron issue #273 is fixed
2571      ;;  (http://code.google.com/p/cocotron/issues/detail?id=273)
[12570]2572      #+cocotron (#/setHasUndoManager: doc nil))
[12125]2573    (with-slots (encoding) doc
2574      (setq encoding (or (get-default-encoding) #$NSISOLatin1StringEncoding)))
[8428]2575    (setq *last-document-created* doc)
[568]2576    doc))
[6589]2577
2578 
[8428]2579(defun make-buffer-for-document (ns-document pathname)
2580  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
2581         (buffer (make-hemlock-buffer buffer-name)))
2582    (setf (slot-value ns-document 'textstorage)
2583          (make-textstorage-for-hemlock-buffer buffer))
2584    (setf (hi::buffer-pathname buffer) pathname)
2585    buffer))
2586
[6589]2587(objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
2588    ((self hemlock-editor-document) url type (perror (:* :id)))
[569]2589  (declare (ignorable type))
[8428]2590  (with-callback-context "readFromURL"
2591    (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
2592      (let* ((pathname
2593              (lisp-string-from-nsstring
2594               (if (#/isFileURL url)
2595                 (#/path url)
2596                 (#/absoluteString url))))
2597             (buffer (or (hemlock-buffer self)
2598                         (make-buffer-for-document self pathname)))
2599             (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
2600             (string
2601              (if (zerop selected-encoding)
2602                (#/stringWithContentsOfURL:usedEncoding:error:
2603                 ns:ns-string
2604                 url
2605                 pused-encoding
2606                 perror)
2607                +null-ptr+)))
2608       
2609        (if (%null-ptr-p string)
2610          (progn
[6589]2611            (if (zerop selected-encoding)
[12125]2612              (setq selected-encoding (or (get-default-encoding) #$NSISOLatin1StringEncoding)))
[8428]2613            (setq string (#/stringWithContentsOfURL:encoding:error:
2614                          ns:ns-string
2615                          url
2616                          selected-encoding
2617                          perror)))
2618          (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
2619        (unless (%null-ptr-p string)
2620          (with-slots (encoding) self (setq encoding selected-encoding))
[7595]2621
[8428]2622          ;; ** TODO: Argh.  How about we just let hemlock insert it.
2623          (let* ((textstorage (slot-value self 'textstorage))
2624                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
2625                 (hi::*current-buffer* buffer))
2626            (hemlock-ext:invoke-modifying-buffer-storage
2627             buffer
2628             #'(lambda ()
2629                 (nsstring-to-buffer string buffer)
2630                 (reset-buffer-cache display) 
2631                 (#/updateMirror textstorage)
2632                 (update-line-cache-for-index display 0)
2633                 (textstorage-note-insertion-at-position
2634                  textstorage
2635                  0
2636                  (hemlock-buffer-length buffer))
2637                 (hi::note-modeline-change buffer)
2638                 (setf (hi::buffer-modified buffer) nil))))
2639          t)))))
[7595]2640
2641
2642
2643
[6785]2644(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files")
2645
[6234]2646(objc:defmethod (#/keepBackupFile :<BOOL>) ((self hemlock-editor-document))
[7142]2647  ;;; Don't use the NSDocument backup file scheme.
2648  nil)
[1378]2649
[7142]2650(objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :<BOOL>)
2651    ((self hemlock-editor-document)
2652     absolute-url
2653     type
2654     (save-operation :<NSS>ave<O>peration<T>ype)
2655     (error (:* :id)))
2656  (when (and *editor-keep-backup-files*
2657             (eql save-operation #$NSSaveOperation))
2658    (write-hemlock-backup-file (#/fileURL self)))
2659  (call-next-method absolute-url type save-operation error))
[1378]2660
[7142]2661(defun write-hemlock-backup-file (url)
2662  (unless (%null-ptr-p url)
2663    (when (#/isFileURL url)
2664      (let* ((path (#/path url)))
2665        (unless (%null-ptr-p path)
2666          (let* ((newpath (#/stringByAppendingString: path #@"~"))
2667                 (fm (#/defaultManager ns:ns-file-manager)))
2668            ;; There are all kinds of ways for this to lose.
2669            ;; In order for the copy to succeed, the destination can't exist.
2670            ;; (It might exist, but be a directory, or there could be
2671            ;; permission problems ...)
2672            (#/removeFileAtPath:handler: fm newpath +null-ptr+)
2673            (#/copyPath:toPath:handler: fm path newpath +null-ptr+)))))))
2674
2675             
2676
[6]2677
[11037]2678
[8428]2679(defun hemlock-ext:all-hemlock-views ()
2680  "List of all hemlock views, in z-order, frontmost first"
2681  (loop for win in (windows)
2682    as buf = (and (typep win 'hemlock-frame) (hemlock-view win))
2683    when buf collect buf))
[7528]2684
[707]2685(defmethod hi::document-panes ((document hemlock-editor-document))
[666]2686  (let* ((ts (slot-value document 'textstorage))
2687         (panes ()))
2688    (for-each-textview-using-storage
2689     ts
2690     #'(lambda (tv)
2691         (let* ((pane (text-view-pane tv)))
2692           (unless (%null-ptr-p pane)
2693             (push pane panes)))))
2694    panes))
2695
[6687]2696(objc:defmethod (#/noteEncodingChange: :void) ((self hemlock-editor-document)
2697                                               popup)
2698  (with-slots (encoding) self
[6812]2699    (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
[8428]2700    (hi::note-modeline-change (hemlock-buffer self))))
[6]2701
[12695]2702#-cocotron
[6614]2703(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
2704                                               panel)
2705  (with-slots (encoding) self
[7563]2706    (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller) encoding)))
[6687]2707      (#/setAction: popup (@selector #/noteEncodingChange:))
2708      (#/setTarget: popup self)
[6614]2709      (#/setAccessoryView: panel popup)))
2710  (#/setExtensionHidden: panel nil)
2711  (#/setCanSelectHiddenExtension: panel nil)
[7503]2712  (#/setAllowedFileTypes: panel +null-ptr+)
[6614]2713  (call-next-method panel))
2714
2715
2716(defloadvar *ns-cr-string* (%make-nsstring (string #\return)))
2717(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed)))
[6798]2718(defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*))))
[6614]2719
2720(objc:defmethod (#/writeToURL:ofType:error: :<BOOL>)
2721    ((self hemlock-editor-document) url type (error (:* :id)))
2722  (declare (ignore type))
2723  (with-slots (encoding textstorage) self
2724    (let* ((string (#/string textstorage))
[8428]2725           (buffer (hemlock-buffer self)))
[6687]2726      (case (when buffer (hi::buffer-line-termination buffer))
[8428]2727        (:crlf (unless (typep string 'ns:ns-mutable-string)
2728                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
2729                 (#/replaceOccurrencesOfString:withString:options:range:
2730                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
2731        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
2732                            string
2733                            (make-instance 'ns:ns-mutable-string :with string string)))
2734             (#/replaceOccurrencesOfString:withString:options:range:
2735              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
[6614]2736      (when (#/writeToURL:atomically:encoding:error:
2737             string url t encoding error)
2738        (when buffer
2739          (setf (hi::buffer-modified buffer) nil))
2740        t))))
2741
[12697]2742;;; Cocotron's NSDocument uses the deprecated as of 10.4 methods to implement the NSSavePanel
2743#+cocotron
2744(objc:defmethod (#/writeToFile:ofType: :<BOOL>)
2745    ((self hemlock-editor-document) path type)
2746  (rlet ((perror :id +null-ptr+))
[12698]2747    (#/writeToURL:ofType:error: self (#/fileURLWithPath: ns:ns-url path) type perror)))
[6614]2748
2749
[7142]2750;;; Shadow the setFileURL: method, so that we can keep the buffer
[592]2751;;; name and pathname in synch with the document.
[6614]2752(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document)
2753                                        url)
2754  (call-next-method url)
[12070]2755  (let* ((path nil)
2756         (controllers (#/windowControllers self)))
2757    (dotimes (i (#/count controllers))
2758      (let* ((controller (#/objectAtIndex: controllers i))
2759             (window (#/window controller)))
2760        (#/setFrameAutosaveName: window (or path (setq path (#/path url)))))))
[8428]2761  (let* ((buffer (hemlock-buffer self)))
[592]2762    (when buffer
[6614]2763      (let* ((new-pathname (lisp-string-from-nsstring (#/path url))))
[592]2764        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
2765        (setf (hi::buffer-pathname buffer) new-pathname)))))
[793]2766
2767
[6687]2768(def-cocoa-default *initial-editor-x-pos* :float 20.0f0 "X position of upper-left corner of initial editor")
[793]2769
[12017]2770(def-cocoa-default *initial-editor-y-pos* :float 10.0f0 "Y position of upper-left corner of initial editor")
[793]2771
[12017]2772(defloadvar *editor-cascade-point* nil)
2773
[793]2774(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized
2775(defloadvar *next-editor-y-pos* nil)
2776
[6687]2777(defun x-pos-for-window (window x)
2778  (let* ((frame (#/frame window))
2779         (screen (#/screen window)))
2780    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
2781    (let* ((screen-rect (#/visibleFrame screen)))
2782      (if (>= x 0)
2783        (+ x (ns:ns-rect-x screen-rect))
2784        (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame))))))
2785
2786(defun y-pos-for-window (window y)
2787  (let* ((frame (#/frame window))
2788         (screen (#/screen window)))
2789    (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen)))
2790    (let* ((screen-rect (#/visibleFrame screen)))
2791      (if (>= y 0)
2792        (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame))
2793        (+ (ns:ns-rect-height screen-rect) y)))))
2794
[6234]2795(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document))
[721]2796  #+debug
2797  (#_NSLog #@"Make window controllers")
[8428]2798    (let* ((textstorage  (slot-value self 'textstorage))
2799           (window (%hemlock-frame-for-textstorage
2800                    hemlock-frame
2801                    textstorage
2802                    *editor-columns*
2803                    *editor-rows*
2804                    nil
2805                    (textview-background-color self)
2806                    (user-input-style self)))