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

Last change on this file since 7113 was 7113, checked in by gz, 13 years ago

load cocoa-grep

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