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

Last change on this file since 7476 was 7476, checked in by gb, 13 years ago

make modeline font pref work

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