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

Last change on this file since 7698 was 7698, checked in by gz, 14 years ago

A new package and a reorg:

I put all the cocoa-ide files (except for a greatly stripped-down
cocoa.lisp and cocoa-application.lisp) in a new package named "GUI".

The package is defined in defsystem.lisp, which also defines a
function to load all the files explicitly, putting the fasls in
cocoa-ide;fasls; I stripped out all pretense that the files can or
should be loaded individually. Also, it is no longer necessary or
appropriate to compile hemlock separately, as it now compiles as
needed as part of the normal loading sequence. (Over time I am hoping
to get hemlock more and more integrated into the IDE, and having to
maintain it as if it still were a separate package is an unnecessary
burden).

Updated the README file appropriately.

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