source: trunk/ccl/examples/cocoa-editor.lisp @ 869

Last change on this file since 869 was 869, checked in by gb, 17 years ago

Lots of changes, mostly:

  • try to speed up callbacks that fetch characters from the virtual nsstring
  • kill echo-area buffers when closing windows
  • windows should be released when closed; documents should close when the last window closes.
  • try not to invalidate the buffer cache on insertions
  • disable background layout before closing the window (in case that's still going on ...)
  • clear the buffer's modified state when buffer is saved (not sure if the modeline indicator's updated correctly)
  • DISABLE-BLINK tells the layout manager to force redisplay of the (now non-blinking) character.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 84.4 KB
Line 
1;;;-*- Mode: LISP; Package: CCL -*-
2
3
4(in-package "CCL")
5
6(eval-when (:compile-toplevel :load-toplevel :execute)
7  (require "COCOA-WINDOW")
8  (require "HEMLOCK"))
9
10(eval-when (:compile-toplevel :execute)
11  (pushnew :all-in-cocoa-thread *features*)
12  (use-interface-dir :cocoa))
13
14(def-cocoa-default *editor-rows* :int 24 "Initial height of editor windows, in characters")
15(def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters")
16
17;;; Background color components: red, blue, green, alpha.
18;;; All should be single-floats between 0.0f0 and 1.0f0, inclusive.
19(def-cocoa-default *editor-background-red-component* :float 1.0f0 "Red component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
20(def-cocoa-default *editor-background-green-component* :float 1.0f0 "Green component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
21(def-cocoa-default *editor-background-blue-component* :float 1.0f0 "Blue component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
22(def-cocoa-default *editor-background-alpha-component* :float 1.0f0 "Alpha component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
23
24;;; At runtime, this'll be a vector of character attribute dictionaries.
25(defloadvar *styles* ())
26
27(defun make-editor-style-map ()
28  (let* ((font-name *default-font-name*)
29         (font-size *default-font-size*)
30         (font (default-font :name font-name :size font-size))
31         (color-class (find-class 'ns:ns-color))
32         (colors (vector (send color-class 'black-color)
33                         (send color-class 'white-color)
34                         (send color-class 'dark-gray-color)
35                         (send color-class 'light-gray-color)
36                         (send color-class 'red-color)
37                         (send color-class 'blue-color)
38                         (send color-class 'green-color)
39                         (send color-class 'yellow-color)))
40         (styles (make-array (the fixnum (* 4 (length colors)))))
41         (bold-stroke-width font-size)
42         (s 0))
43    (declare (dynamic-extent fonts colors))
44    (dotimes (c (length colors))
45      (dotimes (i 4)
46        (setf (svref styles s) (create-text-attributes :font font
47                                                       :color (svref colors c)
48                                                       :obliqueness
49                                                       (if (logbitp 1 i)
50                                                         0.15f0)
51                                                       :stroke-width
52                                                       (if (logbitp 0 i)
53                                                         bold-stroke-width)))
54        (incf s)))
55    (setq *styles* styles)))
56
57(defun make-hemlock-buffer (&rest args)
58  (let* ((buf (apply #'hi::make-buffer args)))
59    (if buf
60      (progn
61        (setf (hi::buffer-gap-context buf) (hi::make-buffer-gap-context))
62        buf)
63      (progn
64        (format t "~& couldn't make hemlock buffer with args ~s" args)
65        (dbg)
66        nil))))
67         
68;;; Define some key event modifiers.
69
70;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
71;;; it to map NSEvent modifier keys to key-event modifiers.
72
73(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
74(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
75(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
76(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
77
78
79;;; We want to display a Hemlock buffer in a "pane" (an on-screen
80;;; view) which in turn is presented in a "frame" (a Cocoa window).  A
81;;; 1:1 mapping between frames and panes seems to fit best into
82;;; Cocoa's document architecture, but we should try to keep the
83;;; concepts separate (in case we come up with better UI paradigms.)
84;;; Each pane has a modeline (which describes attributes of the
85;;; underlying document); each frame has an echo area (which serves
86;;; to display some commands' output and to provide multi-character
87;;; input.)
88
89
90;;; I'd pretty much concluded that it wouldn't be possible to get the
91;;; Cocoa text system (whose storage model is based on NSString
92;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with
93;;; Hemlock, and (since the whole point of using Hemlock was to be
94;;; able to treat an editor buffer as a rich lisp data structure) it
95;;; seemed like it'd be necessary to toss the higher-level Cocoa text
96;;; system and implement our own scrolling, redisplay, selection
97;;; ... code.
98;;;
99;;; Mikel Evins pointed out that NSString and friends were
100;;; abstract classes and that there was therefore no reason (in
101;;; theory) not to implement a thin wrapper around a Hemlock buffer
102;;; that made it act like an NSString.  As long as the text system can
103;;; ask a few questions about the NSString (its length and the
104;;; character and attributes at a given location), it's willing to
105;;; display the string in a scrolling, mouse-selectable NSTextView;
106;;; as long as Hemlock tells the text system when and how the contents
107;;; of the abstract string changes, Cocoa will handle the redisplay
108;;; details.
109;;;
110
111
112;;; Hemlock-buffer-string objects:
113
114(defclass hemlock-buffer-string (ns:ns-string)
115    ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache))
116  (:metaclass ns:+ns-object))
117
118;;; Cocoa wants to treat the buffer as a linear array of characters;
119;;; Hemlock wants to treat it as a doubly-linked list of lines, so
120;;; we often have to map between an absolute position in the buffer
121;;; and a relative position on a line.  We can certainly do that
122;;; by counting the characters in preceding lines every time that we're
123;;; asked, but we're often asked to map a sequence of nearby positions
124;;; and wind up repeating a lot of work.  Caching the results of that
125;;; work seems to speed things up a bit in many cases; this data structure
126;;; is used in that process.  (It's also the only way to get to the
127;;; actual underlying Lisp buffer from inside the network of text-system
128;;; objects.)
129
130(defstruct buffer-cache 
131  buffer                                ; the hemlock buffer
132  buflen                                ; length of buffer, if known
133  workline                              ; cache for character-at-index
134  workline-offset                       ; cached offset of workline
135  workline-length                       ; length of cached workline
136  workline-start-font-index             ; current font index at start of worklin
137  )
138
139;;; Initialize (or reinitialize) a buffer cache, so that it points
140;;; to the buffer's first line (which is the only line whose
141;;; absolute position will never change).  Code which modifies the
142;;; buffer generally has to call this, since any cached information
143;;; might be invalidated by the modification.
144
145(defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d)
146                                                buffer-p))
147  (when buffer-p (setf (buffer-cache-buffer d) buffer))
148  (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
149         (workline (hi::mark-line
150                    (hi::buffer-start-mark buffer))))
151    (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer)
152          (buffer-cache-workline-offset d) 0
153          (buffer-cache-workline d) workline
154          (buffer-cache-workline-length d) (hi::line-length workline)
155          (buffer-cache-workline-start-font-index d) 0)
156    d))
157
158
159(defun adjust-buffer-cache-for-insertion (display pos n)
160  (if (buffer-cache-workline display)
161    (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context (buffer-cache-buffer display))))
162      (if (> (buffer-cache-workline-offset display) pos)
163        (incf (buffer-cache-workline-offset display) n)
164        (when (>= (+ (buffer-cache-workline-offset display)
165                    (buffer-cache-workline-length display))
166                 pos)
167          (setf (buffer-cache-workline-length display)
168                (hi::line-length (buffer-cache-workline display)))))
169      (incf (buffer-cache-buflen display) n))
170    (reset-buffer-cache display)))
171
172         
173           
174
175;;; Update the cache so that it's describing the current absolute
176;;; position.
177
178(defun update-line-cache-for-index (cache index)
179  (let* ((buffer (buffer-cache-buffer cache))
180         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
181         (line (or
182                (buffer-cache-workline cache)
183                (progn
184                  (reset-buffer-cache cache)
185                  (buffer-cache-workline cache))))
186         (pos (buffer-cache-workline-offset cache))
187         (len (buffer-cache-workline-length cache))
188         (moved nil))
189    (loop
190      (when (and (>= index pos)
191                   (< index (1+ (+ pos len))))
192          (let* ((idx (- index pos)))
193            (when moved
194              (setf (buffer-cache-workline cache) line
195                    (buffer-cache-workline-offset cache) pos
196                    (buffer-cache-workline-length cache) len))
197            (return (values line idx))))
198      (setq moved t)
199      (if (< index pos)
200        (setq line (hi::line-previous line)
201              len (hi::line-length line)
202              pos (1- (- pos len)))
203        (setq line (hi::line-next line)
204              pos (1+ (+ pos len))
205              len (hi::line-length line))))))
206
207;;; Ask Hemlock to count the characters in the buffer.
208(defun hemlock-buffer-length (buffer)
209  (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
210    (hemlock::count-characters (hemlock::buffer-region buffer))))
211
212;;; Find the line containing (or immediately preceding) index, which is
213;;; assumed to be less than the buffer's length.  Return the character
214;;; in that line or the trailing #\newline, as appropriate.
215(defun hemlock-char-at-index (cache index)
216  (let* ((hi::*buffer-gap-context*
217          (hi::buffer-gap-context (buffer-cache-buffer cache))))
218    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
219      (let* ((len (hemlock::line-length line)))
220        (if (< idx len)
221          (hemlock::line-character line idx)
222          #\newline)))))
223
224;;; Given an absolute position, move the specified mark to the appropriate
225;;; offset on the appropriate line.
226(defun move-hemlock-mark-to-absolute-position (mark cache abspos)
227  (let* ((hi::*buffer-gap-context*
228          (hi::buffer-gap-context (buffer-cache-buffer cache))))
229    (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos)
230      #+debug
231      (#_NSLog #@"Moving point from current pos %d to absolute position %d"
232               :int (mark-absolute-position mark)
233               :int abspos)
234      (hemlock::move-to-position mark idx line)
235      #+debug
236      (#_NSLog #@"Moved mark to %d" :int (mark-absolute-position mark)))))
237
238;;; Return the absolute position of the mark in the containing buffer.
239;;; This doesn't use the caching mechanism, so it's always linear in the
240;;; number of preceding lines.
241(defun mark-absolute-position (mark)
242  (let* ((pos (hi::mark-charpos mark))
243         (hi::*buffer-gap-context* (hi::buffer-gap-context (hi::line-%buffer
244                                                            (hi::mark-line mark)))))
245    (do* ((line (hi::line-previous (hi::mark-line mark))
246                (hi::line-previous line)))
247         ((null line) pos)
248      (incf pos (1+ (hi::line-length line))))))
249
250;;; Return the length of the abstract string, i.e., the number of
251;;; characters in the buffer (including implicit newlines.)
252(define-objc-method ((:unsigned length)
253                     hemlock-buffer-string)
254  (let* ((cache (hemlock-buffer-string-cache self)))
255    (or (buffer-cache-buflen cache)
256        (setf (buffer-cache-buflen cache)
257              (let* ((buffer (buffer-cache-buffer cache)))
258                (hemlock-buffer-length buffer))))))
259
260
261
262;;; Return the character at the specified index (as a :unichar.)
263
264(define-objc-method ((:unichar :character-at-index (unsigned index))
265                     hemlock-buffer-string)
266  #+debug
267  (#_NSLog #@"Character at index: %d" :unsigned index)
268  (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index)))
269
270
271(define-objc-method ((:void :get-characters (:address buffer) :range (:<NSR>ange r))
272                     hemlock-buffer-string)
273  (let* ((cache (hemlock-buffer-string-cache self))
274         (index (pref r :<NSR>ange.location))
275         (length (pref r :<NSR>ange.length))
276         (hi::*buffer-gap-context*
277          (hi::buffer-gap-context (buffer-cache-buffer cache))))
278    #+debug
279    (#_NSLog #@"get characters: %d/%d"
280             :unsigned index
281             :unsigned length)
282    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
283      (let* ((len (hemlock::line-length line)))
284        (do* ((i 0 (1+ i))
285              (p 0 (+ p 2)))
286             ((= i length))
287          (cond ((< idx len)
288                 (setf (%get-unsigned-word buffer p)
289                       (char-code (hemlock::line-character line idx)))
290                 (incf idx))
291                (t
292                 (setf (%get-unsigned-word buffer p)
293                       (char-code #\Newline)
294                       line (hi::line-next line)
295                       len (hi::line-length line)
296                  idx 0))))))))
297
298(define-objc-method ((:void :get-line-start ((:* :unsigned) startptr)
299                            :end ((:* :unsigned) endptr)
300                            :contents-end ((:* :unsigned) contents-endptr)
301                            :for-range (:<NSR>ange r))
302                     hemlock-buffer-string)
303  (let* ((cache (hemlock-buffer-string-cache self))
304         (index (pref r :<NSR>ange.location))
305         (length (pref r :<NSR>ange.length))
306         (hi::*buffer-gap-context*
307          (hi::buffer-gap-context (buffer-cache-buffer cache))))
308    #+debug 0
309    (#_NSLog #@"get line start: %d/%d"
310             :unsigned index
311             :unsigned length)
312    (update-line-cache-for-index cache index)
313    (unless (%null-ptr-p startptr)
314      ;; Index of the first character in the line which contains
315      ;; the start of the range.
316      (setf (pref startptr :unsigned)
317            (buffer-cache-workline-offset cache)))
318    (unless (%null-ptr-p endptr)
319      ;; Index of the newline which terminates the line which
320      ;; contains the start of the range.
321      (setf (pref endptr :unsigned)
322            (+ (buffer-cache-workline-offset cache)
323               (buffer-cache-workline-length cache))))
324    (unless (%null-ptr-p contents-endptr)
325      ;; Index of the newline which terminates the line which
326      ;; contains the start of the range.
327      (unless (zerop length)
328        (update-line-cache-for-index cache (+ index length)))
329      (setf (pref contents-endptr :unsigned)
330            (1+ (+ (buffer-cache-workline-offset cache)
331                   (buffer-cache-workline-length cache)))))))
332
333                     
334;;; Return an NSData object representing the bytes in the string.  If
335;;; the underlying buffer uses #\linefeed as a line terminator, we can
336;;; let the superclass method do the work; otherwise, we have to
337;;; ensure that each line is terminated according to the buffer's
338;;; conventions.
339(define-objc-method ((:id :data-using-encoding (:<NSS>tring<E>ncoding encoding)
340                          :allow-lossy-conversion (:<BOOL> flag))
341                     hemlock-buffer-string)
342  (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache self)))
343         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
344         (external-format (if buffer (hi::buffer-external-format buffer )))
345         (raw-length (if buffer (hemlock-buffer-length buffer) 0)))
346    (hi::%set-buffer-modified buffer nil)
347    (if (eql 0 raw-length)
348      (make-objc-instance 'ns:ns-mutable-data :with-length 0)
349      (case external-format
350        ((:unix nil)
351         (send-super :data-using-encoding encoding :allow-lossy-conversion flag))
352        ((:macos :cp/m)
353         (let* ((cp/m-p (eq external-format :cp/m)))
354           (when cp/m-p
355             ;; This may seem like lot of fuss about an ancient OS and its
356             ;; odd line-termination conventions.  Of course, I'm actually
357             ;; referring to CP/M-86.
358             (do* ((line (hi::mark-line (hi::buffer-start-mark buffer))
359                         next)
360                   (next (hi::line-next line) (hi::line-next line)))
361                  ((null line))
362               (when next (incf raw-length))))
363           (let* ((pos 0)
364                  (data (make-objc-instance 'ns:ns-mutable-data
365                                            :with-length raw-length))
366                  (bytes (send data 'mutable-bytes)))
367             (do* ((line (hi::mark-line (hi::buffer-start-mark buffer))
368                         next)
369                   (next (hi::line-next line) (hi::line-next line)))
370                  ((null line) data)
371               (let* ((chars (hi::line-chars line))
372                      (len (length chars)))
373                 (unless (zerop len)
374                   (%copy-ivector-to-ptr chars 0 bytes pos len)
375                   (incf pos len))
376                 (when next
377                   (setf (%get-byte bytes pos) (char-code #\return))
378                   (when cp/m-p
379                     (incf pos)
380                   (setf (%get-byte bytes pos) (char-code #\linefeed)) 
381                   (incf pos))))))))))))
382
383
384;;; For debugging, mostly: make the printed representation of the string
385;;; referenence the named Hemlock buffer.
386(define-objc-method ((:id description)
387                     hemlock-buffer-string)
388  (let* ((cache (hemlock-buffer-string-cache self))
389         (b (buffer-cache-buffer cache)))
390    (with-cstrs ((s (format nil "~a" b)))
391      (send (@class ns-string) :string-with-format #@"<%s for %s>"
392        (:address (#_object_getClassName self) :address s)))))
393
394
395
396;;; hemlock-text-storage objects
397(defclass hemlock-text-storage (ns:ns-text-storage)
398    ((string :foreign-type :id)
399     (edit-count :foreign-type :int))
400  (:metaclass ns:+ns-object))
401
402(define-objc-method ((:unsigned :line-break-before-index (:unsigned index)
403                                :within-range (:<NSR>ange r))
404                     hemlock-text-storage)
405  (#_NSLog #@"Line break before index: %d within range: %@"
406           :unsigned index
407           :id (#_NSStringFromRange r))
408  (send-super :line-break-before-index index :within-range r))
409
410
411
412;;; Return true iff we're inside a "beginEditing/endEditing" pair
413(define-objc-method ((:<BOOL> editing-in-progress) hemlock-text-storage)
414  (not (eql (slot-value self 'edit-count) 0)))
415
416(defun textstorage-note-insertion-at-position (self pos n)
417  (send self
418        :edited #$NSTextStorageEditedAttributes
419        :range (ns-make-range pos 0)
420        :change-in-length n)
421  (send self
422        :edited #$NSTextStorageEditedCharacters
423        :range (ns-make-range pos n)
424        :change-in-length 0))
425
426(define-objc-method ((:void :note-insertion params) hemlock-text-storage)
427  (let* ((pos (send (send params :object-at-index 0) 'int-value))
428         (n (send (send params :object-at-index 1) 'int-value)))
429    (textstorage-note-insertion-at-position self pos n)))
430
431(define-objc-method ((:void :note-deletion params) hemlock-text-storage)
432  (let* ((pos (send (send params :object-at-index 0) 'int-value))
433         (n (send (send params :object-at-index 1) 'int-value)))
434    (send self
435          :edited #$NSTextStorageEditedCharacters
436          :range (ns-make-range pos n)
437          :change-in-length (- n))
438    (let* ((display (hemlock-buffer-string-cache (send self 'string))))
439      (reset-buffer-cache display) 
440      (update-line-cache-for-index display pos))))
441
442(define-objc-method ((:void :note-modification params) hemlock-text-storage)
443  (let* ((pos (send (send params :object-at-index 0) 'int-value))
444         (n (send (send params :object-at-index 1) 'int-value)))
445    #+debug
446    (#_NSLog #@"Note modification: pos = %d, n = %d" :int pos :int n)
447    (send self
448          :edited (logior #$NSTextStorageEditedCharacters
449                          #$NSTextStorageEditedAttributes)
450          :range (ns-make-range pos n)
451          :change-in-length 0)))
452
453(define-objc-method ((:void :note-attr-change params) hemlock-text-storage)
454  (let* ((pos (send (send params :object-at-index 0) 'int-value))
455         (n (send (send params :object-at-index 1) 'int-value)))
456    #+debug (#_NSLog #@"attribute-change at %d/%d" :int pos :int n)
457    (send self
458          :edited #$NSTextStorageEditedAttributes
459          :range (ns-make-range pos n)
460          :change-in-length 0)))
461
462(define-objc-method ((:void begin-editing) hemlock-text-storage)
463  #+debug
464  (#_NSLog #@"begin-editing")
465  (incf (slot-value self 'edit-count))
466  (send-super 'begin-editing))
467
468(define-objc-method ((:void end-editing) hemlock-text-storage)
469  #+debug
470  (#_NSLog #@"end-editing")
471  (send-super 'end-editing)
472  (decf (slot-value self 'edit-count)))
473
474;;; Return true iff we're inside a "beginEditing/endEditing" pair
475(define-objc-method ((:<BOOL> editing-in-progress) hemlock-text-storage)
476  (not (eql (slot-value self 'edit-count) 0)))
477
478 
479
480;;; Access the string.  It'd be nice if this was a generic function;
481;;; we could have just made a reader method in the class definition.
482(define-objc-method ((:id string) hemlock-text-storage)
483  (slot-value self 'string))
484
485(define-objc-method ((:id :init-with-string s) hemlock-text-storage)
486  (let* ((newself (send-super 'init)))
487    (setf (slot-value newself 'string) s)
488    newself))
489
490;;; This is the only thing that's actually called to create a
491;;; hemlock-text-storage object.  (It also creates the underlying
492;;; hemlock-buffer-string.)
493(defun make-textstorage-for-hemlock-buffer (buffer)
494  (make-objc-instance 'hemlock-text-storage
495                      :with-string
496                      (make-instance
497                       'hemlock-buffer-string
498                       :cache
499                       (reset-buffer-cache
500                        (make-buffer-cache)
501                        buffer))))
502
503(define-objc-method ((:id :attributes-at-index (:unsigned index)
504                          :effective-range ((* :<NSR>ange) rangeptr))
505                     hemlock-text-storage)
506  #+debug
507  (#_NSLog #@"Attributes at index: %d" :unsigned index)
508  (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string)))
509         (buffer (buffer-cache-buffer buffer-cache))
510         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
511    (update-line-cache-for-index buffer-cache index)
512    (multiple-value-bind (start len style)
513        (ccl::do-dll-nodes (node
514                            (hi::buffer-font-regions buffer)
515                            (values 0 (buffer-cache-buflen buffer-cache) 0))
516          (let* ((region (hi::font-region-node-region node))
517                 (start (hi::region-start region))
518                 (end (hi::region-end region))
519                 (startpos (mark-absolute-position start))
520                 (endpos (mark-absolute-position end)))
521            (when (and (>= index startpos)
522                       (< index endpos))
523              (return (values startpos
524                              (- endpos startpos)
525                              (hi::font-mark-font start))))))
526      #+debug
527      (#_NSLog #@"Start = %d, len = %d, style = %d"
528               :int start :int len :int style)
529      (unless (%null-ptr-p rangeptr)
530        (setf (pref rangeptr :<NSR>ange.location) start
531              (pref rangeptr :<NSR>ange.length) len))
532      (svref *styles* style))))
533
534(define-objc-method ((:void :replace-characters-in-range (:<NSR>ange r)
535                            :with-string string)
536                     hemlock-text-storage)
537    (let* ((cache (hemlock-buffer-string-cache (send self 'string)))
538           (buffer (if cache (buffer-cache-buffer cache)))
539           (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
540           (location (pref r :<NSR>ange.location))
541           (length (pref r :<NSR>ange.length))
542           (mark (hi::buffer-%mark buffer))
543           (point (hi::buffer-point buffer)))
544      (cond ((> length 0)
545             (move-hemlock-mark-to-absolute-position mark cache location)
546             (move-hemlock-mark-to-absolute-position point cache (+ location length))
547             (hemlock::%buffer-activate-region buffer))
548            (t
549             (move-hemlock-mark-to-absolute-position point cache location)))
550      (hi::insert-string point (lisp-string-from-nsstring string))))
551
552
553;;; I'm not sure if we want the text system to be able to change
554;;; attributes in the buffer.
555(define-objc-method ((:void :set-attributes attributes
556                            :range (:<NSR>ange r))
557                     hemlock-text-storage)
558  (declare (ignorable attributes r))
559  #+debug
560  (#_NSLog #@"set-attributes %@ range (%d %d)"
561           :id attributes
562           :unsigned (pref r :<NSR>ange.location)
563           :unsigned (pref r :<NSR>ange.length)))
564
565(defun for-each-textview-using-storage (textstorage f)
566  (let* ((layouts (send textstorage 'layout-managers)))
567    (unless (%null-ptr-p layouts)
568      (dotimes (i (send (the ns:ns-array layouts) 'count))
569        (let* ((layout (send layouts :object-at-index i))
570               (containers (send layout 'text-containers)))
571          (unless (%null-ptr-p containers)
572            (dotimes (j (send (the ns:ns-array containers) 'count))
573              (let* ((container (send containers :object-at-index j))
574                     (tv (send container 'text-view)))
575                (funcall f tv)))))))))
576
577;;; Again, it's helpful to see the buffer name when debugging.
578(define-objc-method ((:id description)
579                     hemlock-text-storage)
580  (send (@class ns-string) :string-with-format #@"%s : string %@"
581        (:address (#_object_getClassName self) :id (slot-value self 'string))))
582
583;;; This needs to happen on the main thread.
584(define-objc-method ((:void ensure-selection-visible)
585                     hemlock-text-storage)
586  (for-each-textview-using-storage
587   self
588   #'(lambda (tv)
589       (send tv :scroll-range-to-visible (send tv 'selected-range)))))
590
591
592(defun close-hemlock-textstorage (ts)
593  (let* ((string (slot-value ts 'string)))
594    (setf (slot-value ts 'string) (%null-ptr))
595    (unless (%null-ptr-p string)
596      (let* ((cache (hemlock-buffer-string-cache string))
597             (buffer (if cache (buffer-cache-buffer cache))))
598        (when buffer
599          (setf (buffer-cache-buffer cache) nil
600                (slot-value string 'cache) nil
601                (hi::buffer-document buffer) nil)
602          (let* ((p (hi::buffer-process buffer)))
603            (when p
604              (setf (hi::buffer-process buffer) nil)
605              (process-kill p)))
606          (when (eq buffer hi::*current-buffer*)
607            (setf (hi::current-buffer)
608                  (car (last hi::*buffer-list*))))
609          (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer)
610          (hi::invoke-hook hemlock::delete-buffer-hook buffer)
611          (setq hi::*buffer-list* (delq buffer hi::*buffer-list*))
612          (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*))))))
613
614     
615
616
617;;; An abstract superclass of the main and echo-area text views.
618(defclass hemlock-textstorage-text-view (ns::ns-text-view)
619    ((blink-location :foreign-type :unsigned :accessor text-view-blink-location)
620     (blink-color-attribute :foreign-type :id :accessor text-view-blink-color)
621     (blink-enabled :foreign-type :<BOOL> :accessor text-view-blink-enabled) )
622  (:metaclass ns:+ns-object))
623
624
625(def-cocoa-default *layout-text-in-background* :int 1 "When non-zero, do text layout when idle.")
626
627(define-objc-method ((:void :layout-manager layout
628                            :did-complete-layout-for-text-container cont
629                            :at-end (:<BOOL> flag))
630                     hemlock-textstorage-text-view)
631  (declare (ignore cont))
632  (when (zerop *layout-text-in-background*)
633    (send layout :set-delegate (%null-ptr))
634    (send layout :set-background-layout-enabled nil)))
635   
636;;; Note changes to the textview's background color; record them
637;;; as the value of the "temporary" foreground color (for blinking).
638(define-objc-method ((:void :set-background-color color)
639                     hemlock-textstorage-text-view)
640  (setf (text-view-blink-color self) color)
641  (send-super :set-background-color color))
642
643;;; Maybe cause 1 character in the textview to blink (by drawing an empty
644;;; character rectangle) in synch with the insertion point.
645
646(define-objc-method ((:void :draw-insertion-point-in-rect (:<NSR>ect r)
647                            :color color
648                            :turned-on (:<BOOL> flag))
649                     hemlock-textstorage-text-view)
650  (unless (send (send self 'text-storage) 'editing-in-progress)
651    (unless (eql #$NO (text-view-blink-enabled self))
652      (let* ((layout (send self 'layout-manager))
653             (container (send self 'text-container))
654             (blink-color (text-view-blink-color self)))
655        ;; We toggle the blinked character "off" by setting its
656        ;; foreground color to the textview's background color.
657        ;; The blinked character should be "on" whenever the insertion
658        ;; point is drawn as "off"
659        (slet ((glyph-range
660                (send layout
661                      :glyph-range-for-character-range
662                      (ns-make-range (text-view-blink-location self) 1)
663                      :actual-character-range (%null-ptr))))
664          #+debug (#_NSLog #@"Flag = %d, location = %d" :<BOOL> (if flag #$YES #$NO) :int (text-view-blink-location self))
665          (slet ((rect (send layout
666                             :bounding-rect-for-glyph-range glyph-range
667                             :in-text-container container)))
668            (send (the ns:ns-color blink-color) 'set)
669            (#_NSRectFill rect))
670          (if flag
671            (send layout
672                  :draw-glyphs-for-glyph-range glyph-range
673                  :at-point  (send self 'text-container-origin)))
674          )))
675    (send-super :draw-insertion-point-in-rect r
676                :color color
677                :turned-on flag)))
678               
679(defmethod disable-blink ((self hemlock-textstorage-text-view))
680  (when (eql (text-view-blink-enabled self) #$YES)
681    (setf (text-view-blink-enabled self) #$NO)
682    ;; Force the blinked character to be redrawn.  Let the text
683    ;; system do the drawing.
684    (let* ((layout (send self 'layout-manager)))
685      (send layout :invalidate-display-for-character-range
686            (ns-make-range (text-view-blink-location self) 1)))))
687
688(defmethod update-blink ((self hemlock-textstorage-text-view))
689  (disable-blink self)
690  (let* ((d (hemlock-buffer-string-cache (send self 'string)))
691         (buffer (buffer-cache-buffer d)))
692    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
693      (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
694             (point (hi::buffer-point buffer)))
695        #+debug (#_NSLog #@"Syntax check for blinking")
696        (cond ((eql (hi::next-character point) #\()
697               (hemlock::pre-command-parse-check point)
698               (when (hemlock::valid-spot point nil)
699                 (hi::with-mark ((temp point))
700                   (when (hemlock::list-offset temp 1)
701                     #+debug (#_NSLog #@"enable blink, forward")
702                     (setf (text-view-blink-location self)
703                           (1- (mark-absolute-position temp))
704                           (text-view-blink-enabled self) #$YES)))))
705              ((eql (hi::previous-character point) #\))
706               (hemlock::pre-command-parse-check point)
707               (when (hemlock::valid-spot point nil)
708                 (hi::with-mark ((temp point))
709                   (when (hemlock::list-offset temp -1)
710                     #+debug (#_NSLog #@"enable blink, backward")
711                     (setf (text-view-blink-location self)
712                           (mark-absolute-position temp)
713                           (text-view-blink-enabled self) #$YES))))))))))
714
715;;; Set and display the selection at pos, whose length is len and whose
716;;; affinity is affinity.  This should never be called from any Cocoa
717;;; event handler; it should not call anything that'll try to set the
718;;; underlying buffer's point and/or mark.
719(define-objc-method ((:void :update-selection (:int pos)
720                            :length (:int len)
721                            :affinity (:<NSS>election<A>ffinity affinity))
722                     hemlock-textstorage-text-view)
723  (when (eql len 0)
724    (update-blink self))
725  (slet ((range (ns-make-range pos len)))
726    (send-super :set-selected-range range
727                :affinity affinity
728                :still-selecting nil)
729    (send self :scroll-range-to-visible range)))
730 
731;;; A specialized NSTextView. The NSTextView is part of the "pane"
732;;; object that displays buffers.
733(defclass hemlock-text-view (hemlock-textstorage-text-view)
734    ((pane :foreign-type :id :accessor text-view-pane))
735  (:metaclass ns:+ns-object))
736
737;;; Access the underlying buffer in one swell foop.
738(defmethod text-view-buffer ((self hemlock-text-view))
739  (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string))))
740
741(define-objc-method (((:struct :<NSR>ange r)
742                      :selection-range-for-proposed-range (:<NSR>ange proposed)
743                      :granularity (:<NSS>election<G>ranularity g))
744                     hemlock-textstorage-text-view)
745  #+debug
746  (#_NSLog #@"Granularity = %d" :int g)
747  (block HANDLED
748    (let* ((index (pref proposed :<NSR>ange.location))
749           (length (pref proposed :<NSR>ange.length)))
750      (when (and (eql 0 length)              ; not extending existing selection
751                 (not (eql g #$NSSelectByCharacter)))
752        (let* ((textstorage (send self 'text-storage))
753               (cache (hemlock-buffer-string-cache (send textstorage 'string)))
754               (buffer (if cache (buffer-cache-buffer cache))))
755          (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
756            (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
757              (hi::with-mark ((m1 (hi::buffer-point buffer)))
758                (move-hemlock-mark-to-absolute-position m1 cache index)
759                (hemlock::pre-command-parse-check m1)
760                (when (hemlock::valid-spot m1 nil)
761                  (cond ((eql (hi::next-character m1) #\()
762                         (hi::with-mark ((m2 m1))
763                           (when (hemlock::list-offset m2 1)
764                             (setf (pref r :<NSR>ange.location) index
765                                   (pref r :<NSR>ange.length)
766                                   (- (mark-absolute-position m2) index))
767                             (return-from HANDLED nil))))
768                        ((eql (hi::previous-character m1) #\))
769                         (hi::with-mark ((m2 m1))
770                           (when (hemlock::list-offset m2 -1)
771                             (setf (pref r :<NSR>ange.location)
772                                   (mark-absolute-position m2)
773                                   (pref r :<NSR>ange.length)
774                                   (- index (mark-absolute-position m2)))
775                             (return-from HANDLED nil))))))))))))
776    (objc-message-send-super-stret r (super) "selectionRangeForProposedRange:granularity:"
777                                   :<NSR>ange proposed
778                                   :<NSS>election<G>ranularity g)
779    #+debug
780    (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
781             :address (#_NSStringFromRange r)
782             :address (#_NSStringFromRange proposed)
783             :<NSS>election<G>ranularity g)))
784
785;;; Translate a keyDown NSEvent to a Hemlock key-event.
786(defun nsevent-to-key-event (nsevent)
787  (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers))
788         (n (if (%null-ptr-p unmodchars)
789              0
790              (send (the ns:ns-string unmodchars) 'length)))
791         (c (if (eql n 1)
792              (send unmodchars :character-at-index 0))))
793    (when c
794      (let* ((bits 0)
795             (modifiers (send nsevent 'modifier-flags))
796             (useful-modifiers (logandc2 modifiers
797                                         (logior #$NSShiftKeyMask
798                                                 #$NSAlphaShiftKeyMask))))
799        (dolist (map hemlock-ext::*modifier-translations*)
800          (when (logtest useful-modifiers (car map))
801            (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
802                                     (cdr map))))))
803        (hemlock-ext::make-key-event c bits)))))
804
805(defun pass-key-down-event-to-hemlock (self event)
806  #+debug
807  (#_NSLog #@"Key down event = %@" :address event)
808  (let* ((buffer (text-view-buffer self)))
809    (when buffer
810      (let* ((q (hemlock-frame-event-queue (send self 'window))))
811        (hi::enqueue-key-event q (nsevent-to-key-event event))))))
812
813(defun enqueue-buffer-operation (buffer thunk)
814  (dolist (w (hi::buffer-windows buffer))
815    (let* ((q (hemlock-frame-event-queue (send w 'window)))
816           (op (hi::make-buffer-operation :thunk thunk)))
817      (hi::event-queue-insert q op))))
818
819 
820;;; Process a key-down NSEvent in a Hemlock text view by translating it
821;;; into a Hemlock key event and passing it into the Hemlock command
822;;; interpreter.
823
824(define-objc-method ((:void :key-down event)
825                     hemlock-text-view)
826  (pass-key-down-event-to-hemlock self event))
827
828;;; Update the underlying buffer's point (and "active region", if appropriate.
829;;; This is called in response to a mouse click or other event; it shouldn't
830;;; be called from the Hemlock side of things.
831(define-objc-method ((:void :set-selected-range (:<NSR>ange r)
832                            :affinity (:<NSS>election<A>ffinity affinity)
833                            :still-selecting (:<BOOL> still-selecting))
834                     hemlock-text-view)
835    #+debug
836  (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d"
837           :int (pref r :<NSR>ange.location)
838           :int (pref r :<NSR>ange.length)
839           :<NSS>election<A>ffinity affinity
840           :<BOOL> (if still-selecting #$YES #$NO))
841  (unless (send (send self 'text-storage) 'editing-in-progress)
842    (let* ((d (hemlock-buffer-string-cache (send self 'string)))
843           (buffer (buffer-cache-buffer d))
844           (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
845           (point (hi::buffer-point buffer))
846           (location (pref r :<NSR>ange.location))
847           (len (pref r :<NSR>ange.length)))
848      (cond ((eql len 0)
849             #+debug
850             (#_NSLog #@"Moving point to absolute position %d" :int location)
851             (setf (hi::buffer-region-active buffer) nil)
852             (move-hemlock-mark-to-absolute-position point d location)
853             (update-blink self))
854            (t
855             ;; We don't get much information about which end of the
856             ;; selection the mark's at and which end point is at, so
857             ;; we have to sort of guess.  In every case I've ever seen,
858             ;; selection via the mouse generates a sequence of calls to
859             ;; this method whose parameters look like:
860             ;; a: range: {n0,0} still-selecting: false  [ rarely repeats ]
861             ;; b: range: {n0,0) still-selecting: true   [ rarely repeats ]
862             ;; c: range: {n1,m} still-selecting: true   [ often repeats ]
863             ;; d: range: {n1,m} still-selecting: false  [ rarely repeats ]
864             ;;
865             ;; (Sadly, "affinity" doesn't tell us anything interesting.
866             ;; We've handled a and b in the clause above; after handling
867             ;; b, point references buffer position n0 and the
868             ;; region is inactive.
869             ;; Let's ignore c, and wait until the selection's stabilized.
870             ;; Make a new mark, a copy of point (position n0).
871             ;; At step d (here), we should have either
872             ;; d1) n1=n0.  Mark stays at n0, point moves to n0+m.
873             ;; d2) n1+m=n0.  Mark stays at n0, point moves to n0-m.
874             ;; If neither d1 nor d2 apply, arbitrarily assume forward
875             ;; selection: mark at n1, point at n1+m.
876             ;; In all cases, activate Hemlock selection.
877             (unless still-selecting
878                (let* ((pointpos (mark-absolute-position point))
879                       (selection-end (+ location len))
880                       (mark (hi::copy-mark point :right-inserting)))
881                   (cond ((eql pointpos location)
882                          (move-hemlock-mark-to-absolute-position point
883                                                                  d
884                                                                  selection-end))
885                         ((eql pointpos selection-end)
886                          (move-hemlock-mark-to-absolute-position point
887                                                                  d
888                                                                  location))
889                         (t
890                          (move-hemlock-mark-to-absolute-position mark
891                                                                  d
892                                                                  location)
893                          (move-hemlock-mark-to-absolute-position point
894                                                                  d
895                                                                  selection-end)))
896                   (hemlock::%buffer-push-buffer-mark buffer mark t)))))))
897  (send-super :set-selected-range r
898              :affinity affinity
899              :still-selecting still-selecting))
900
901
902
903;;; Modeline-view
904
905;;; The modeline view is embedded in the horizontal scroll bar of the
906;;; scrollview which surrounds the textview in a pane.  (A view embedded
907;;; in a scrollbar like this is sometimes called a "placard").  Whenever
908;;; the view's invalidated, its drawRect: method draws a string containing
909;;; the current values of the buffer's modeline fields.
910
911(defclass modeline-view (ns:ns-view)
912    ((pane :foreign-type :id :accessor modeline-view-pane))
913  (:metaclass ns:+ns-object))
914
915
916;;; Attributes to use when drawing the modeline fields.  There's no
917;;; simple way to make the "placard" taller, so using fonts larger than
918;;; about 12pt probably wouldn't look too good.  10pt Courier's a little
919;;; small, but allows us to see more of the modeline fields (like the
920;;; full pathname) in more cases.
921
922(defloadvar *modeline-text-attributes* nil)
923
924(def-cocoa-default *modeline-font-name* :string "Courier New Bold Italic"
925                   "Name of font to use in modelines")
926(def-cocoa-default  *modeline-font-size* :float 10.0 "Size of font to use in modelines" (single-float 4.0 14.0))
927
928
929;;; Find the underlying buffer.
930(defun buffer-for-modeline-view (mv)
931  (let* ((pane (modeline-view-pane mv)))
932    (unless (%null-ptr-p pane)
933      (let* ((tv (text-pane-text-view pane)))
934        (unless (%null-ptr-p tv)
935          (text-view-buffer tv))))))
936
937;;; Draw a string in the modeline view.  The font and other attributes
938;;; are initialized lazily; apparently, calling the Font Manager too
939;;; early in the loading sequence confuses some Carbon libraries that're
940;;; used in the event dispatch mechanism,
941(defun draw-modeline-string (modeline-view)
942  (let* ((pane (modeline-view-pane modeline-view))
943         (buffer (buffer-for-modeline-view modeline-view)))
944    (when buffer
945      ;; You don't want to know why this is done this way.
946      (unless *modeline-text-attributes*
947        (setq *modeline-text-attributes*
948              (create-text-attributes :color (send (@class "NSColor") 'black-color)
949                                      :font (default-font
950                                              :name *modeline-font-name*
951                                              :size *modeline-font-size*))))
952     
953      (let* ((string
954              (apply #'concatenate 'string
955                     (mapcar
956                      #'(lambda (field)
957                          (funcall (hi::modeline-field-function field)
958                                   buffer pane))
959                      (hi::buffer-modeline-fields buffer)))))
960        (send (%make-nsstring string)
961              :draw-at-point (ns-make-point 0.0f0 0.0f0)
962              :with-attributes *modeline-text-attributes*)))))
963
964;;; Draw the underlying buffer's modeline string on a white background
965;;; with a bezeled border around it.
966(define-objc-method ((:void :draw-rect (:<NSR>ect rect)) 
967                     modeline-view)
968  (declare (ignore rect))
969  (slet ((frame (send self 'bounds)))
970     (#_NSDrawWhiteBezel frame frame)
971     (draw-modeline-string self)))
972
973;;; Hook things up so that the modeline is updated whenever certain buffer
974;;; attributes change.
975(hi::%init-mode-redisplay)
976
977
978;;; Modeline-scroll-view
979
980;;; This is just an NSScrollView that draws a "placard" view (the modeline)
981;;; in the horizontal scrollbar.  The modeline's arbitrarily given the
982;;; leftmost 75% of the available real estate.
983(defclass modeline-scroll-view (ns:ns-scroll-view)
984    ((modeline :foreign-type :id :accessor scroll-view-modeline)
985     (pane :foreign-type :id :accessor scroll-view-pane))
986  (:metaclass ns:+ns-object))
987
988;;; Making an instance of a modeline scroll view instantiates the
989;;; modeline view, as well.
990
991(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
992                     modeline-scroll-view)
993    (let* ((v (send-super :init-with-frame frame)))
994      (when v
995        (let* ((modeline (make-objc-instance 'modeline-view)))
996          (send v :add-subview modeline)
997          (setf (scroll-view-modeline v) modeline)))
998      v))
999
1000;;; Scroll views use the "tile" method to lay out their subviews.
1001;;; After the next-method has done so, steal some room in the horizontal
1002;;; scroll bar and place the modeline view there.
1003
1004(define-objc-method ((:void tile) modeline-scroll-view)
1005  (send-super 'tile)
1006  (let* ((modeline (scroll-view-modeline self)))
1007    (when (and (send self 'has-horizontal-scroller)
1008               (not (%null-ptr-p modeline)))
1009      (let* ((hscroll (send self 'horizontal-scroller)))
1010        (slet ((scrollbar-frame (send hscroll 'frame))
1011               (modeline-frame (send hscroll 'frame))) ; sic
1012           (let* ((modeline-width (* (pref modeline-frame
1013                                           :<NSR>ect.size.width)
1014                                     0.75e0)))
1015             (declare (single-float modeline-width))
1016             (setf (pref modeline-frame :<NSR>ect.size.width)
1017                   modeline-width
1018                   (the single-float
1019                     (pref scrollbar-frame :<NSR>ect.size.width))
1020                   (- (the single-float
1021                        (pref scrollbar-frame :<NSR>ect.size.width))
1022                      modeline-width)
1023                   (the single-float
1024                     (pref scrollbar-frame :<NSR>ect.origin.x))
1025                   (+ (the single-float
1026                        (pref scrollbar-frame :<NSR>ect.origin.x))
1027                      modeline-width))
1028             (send hscroll :set-frame scrollbar-frame)
1029             (send modeline :set-frame modeline-frame)))))))
1030
1031;;; We want to constrain the scrolling that happens under program control,
1032;;; so that the clipview is always scrolled in character-sized increments.
1033#+doesnt-work-yet
1034(define-objc-method ((:void :scroll-clip-view clip-view :to-point (:<NSP>oint p))
1035                     modeline-scroll-view)
1036  #+debug
1037  (#_NSLog #@"Scrolling to point %@" :id (#_NSStringFromPoint p))
1038 
1039  (let* ((char-height (send self 'vertical-line-scroll)))
1040    (slet ((proposed (ns-make-point (pref p :<NSP>oint.x)
1041                                         (* char-height
1042                                            (round (pref p :<NSP>oint.y)
1043                                                    char-height)))))
1044    #+debug
1045    (#_NSLog #@" Proposed point = %@" :id
1046             (#_NSStringFromPoint proposed)))
1047    (send-super :scroll-clip-view clip-view
1048                :to-point p #+nil (ns-make-point (pref p :<NSP>oint.x)
1049                                         (* char-height
1050                                            (ffloor (pref p :<NSP>oint.y)
1051                                                    char-height))))))
1052
1053
1054
1055;;; Text-pane
1056
1057;;; The text pane is just an NSBox that (a) provides a draggable border
1058;;; around (b) encapsulates the text view and the mode line.
1059
1060(defclass text-pane (ns:ns-box)
1061    ((text-view :foreign-type :id :accessor text-pane-text-view)
1062     (mode-line :foreign-type :id :accessor text-pane-mode-line)
1063     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
1064  (:metaclass ns:+ns-object))
1065
1066;;; Mark the pane's modeline as needing display.  This is called whenever
1067;;; "interesting" attributes of a buffer are changed.
1068
1069(defun hi::invalidate-modeline (pane)
1070  (send (text-pane-mode-line pane) :set-needs-display t))
1071
1072(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
1073(def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane")
1074
1075
1076(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
1077                     text-pane)
1078    (let* ((pane (send-super :init-with-frame frame)))
1079      (unless (%null-ptr-p pane)
1080        (send pane :set-autoresizing-mask (logior
1081                                           #$NSViewWidthSizable
1082                                           #$NSViewHeightSizable))
1083        (send pane :set-box-type #$NSBoxPrimary)
1084        (send pane :set-border-type #$NSNoBorder)
1085        (send pane :set-content-view-margins (ns-make-size *text-pane-margin-width* *text-pane-margin-height*))
1086        (send pane :set-title-position #$NSNoTitle))
1087      pane))
1088
1089
1090(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color)
1091  (slet ((contentrect (ns-make-rect x y width height)))
1092    (let* ((scrollview (send (make-objc-instance
1093                              'modeline-scroll-view
1094                              :with-frame contentrect) 'autorelease)))
1095      (send scrollview :set-border-type #$NSBezelBorder)
1096      (send scrollview :set-has-vertical-scroller t)
1097      (send scrollview :set-has-horizontal-scroller t)
1098      (send scrollview :set-rulers-visible nil)
1099      (send scrollview :set-autoresizing-mask (logior
1100                                               #$NSViewWidthSizable
1101                                               #$NSViewHeightSizable))
1102      (send (send scrollview 'content-view) :set-autoresizes-subviews t)
1103      (let* ((layout (make-objc-instance 'ns-layout-manager)))
1104        (send textstorage :add-layout-manager layout)
1105        (send layout 'release)
1106        (slet* ((contentsize (send scrollview 'content-size))
1107                (containersize (ns-make-size
1108                                1.0f7
1109                                1.0f7))
1110                (tv-frame (ns-make-rect
1111                           0.0f0
1112                           0.0f0
1113                           (pref contentsize :<NSS>ize.width)
1114                           (pref contentsize :<NSS>ize.height))))
1115          (let* ((container (send (make-objc-instance
1116                                   'ns-text-container
1117                                   :with-container-size containersize)
1118                                  'autorelease)))
1119            (send layout :add-text-container container)
1120            (let* ((tv (send (make-objc-instance 'hemlock-text-view
1121                                                 :with-frame tv-frame
1122                                                 :text-container container)
1123                             'autorelease)))
1124              (send layout :set-delegate tv)
1125              (send tv :set-min-size (ns-make-size
1126                                      0.0f0
1127                                      (pref contentsize :<NSS>ize.height)))
1128              (send tv :set-max-size (ns-make-size 1.0f7 1.0f7))
1129              (send tv :set-rich-text nil)
1130              (send tv :set-horizontally-resizable t)
1131              (send tv :set-vertically-resizable t) 
1132              (send tv :set-autoresizing-mask #$NSViewWidthSizable)
1133              (send tv :set-background-color color)
1134              (send container :set-width-tracks-text-view tracks-width)
1135              (send container :set-height-tracks-text-view nil)
1136              (send scrollview :set-document-view tv)         
1137              (values tv scrollview))))))))
1138
1139(defun make-scrolling-textview-for-pane (pane textstorage track-width color)
1140  (slet ((contentrect (send (send pane 'content-view) 'frame)))
1141    (multiple-value-bind (tv scrollview)
1142        (make-scrolling-text-view-for-textstorage
1143         textstorage
1144         (pref contentrect :<NSR>ect.origin.x)
1145         (pref contentrect :<NSR>ect.origin.y)
1146         (pref contentrect :<NSR>ect.size.width)
1147         (pref contentrect :<NSR>ect.size.height)
1148         track-width
1149         color)
1150      (send pane :set-content-view scrollview)
1151      (setf (slot-value pane 'scroll-view) scrollview
1152            (slot-value pane 'text-view) tv
1153            (slot-value tv 'pane) pane
1154            (slot-value scrollview 'pane) pane)
1155      (let* ((modeline  (scroll-view-modeline scrollview)))
1156        (setf (slot-value pane 'mode-line) modeline
1157              (slot-value modeline 'pane) pane))
1158      tv)))
1159
1160
1161(defmethod hi::activate-hemlock-view ((view text-pane))
1162  (let* ((hemlock-frame (send view 'window))
1163         (text-view (text-pane-text-view view)))
1164    (send hemlock-frame :make-first-responder text-view)))
1165
1166
1167(defclass echo-area-view (hemlock-textstorage-text-view)
1168    ()
1169  (:metaclass ns:+ns-object))
1170
1171(defmethod hi::activate-hemlock-view ((view echo-area-view))
1172  (let* ((hemlock-frame (send view 'window)))
1173    #+debug
1174    (#_NSLog #@"Activating echo area")
1175    (send hemlock-frame :make-first-responder view)))
1176
1177(defmethod text-view-buffer ((self echo-area-view))
1178  (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string))))
1179
1180;;; The "document" for an echo-area isn't a real NSDocument.
1181(defclass echo-area-document (ns:ns-object)
1182    ((textstorage :foreign-type :id))
1183  (:metaclass ns:+ns-object))
1184
1185(define-objc-method ((:void close) echo-area-document)
1186  (let* ((ts (slot-value self 'textstorage)))
1187    (unless (%null-ptr-p ts)
1188      (setf (slot-value self 'textstorage) (%null-ptr))
1189      (close-hemlock-textstorage ts))))
1190
1191(define-objc-method ((:void :update-change-count (:<NSD>ocument<C>hange<T>ype change)) echo-area-document)
1192  (declare (ignore change)))
1193
1194(define-objc-method ((:void :key-down event)
1195                     echo-area-view)
1196  (pass-key-down-event-to-hemlock self event))
1197
1198
1199(defloadvar *hemlock-frame-count* 0)
1200
1201(defun make-echo-area (hemlock-frame x y width height gap-context color)
1202  (slet ((frame (ns-make-rect x y width height)))
1203    (let* ((box (make-objc-instance "NSView"
1204                                    :with-frame frame)))
1205      (send box :set-autoresizing-mask #$NSViewWidthSizable)
1206      (slet* ((box-frame (send box 'bounds))
1207              (containersize (ns-make-size 1.0f7 (pref box-frame :<NSR>ect.size.height))))
1208        (let* ((clipview (make-objc-instance "NSClipView"
1209                                             :with-frame box-frame)))
1210          (send clipview :set-autoresizing-mask (logior #$NSViewWidthSizable
1211                                                        #$NSViewHeightSizable))
1212          (send clipview :set-background-color color)
1213          (send box :add-subview clipview)
1214          (send box :set-autoresizes-subviews t)
1215          (send clipview 'release)
1216          (let* ((buffer (hi:make-buffer (format nil "Echo Area ~d"
1217                                                 (prog1
1218                                                     *hemlock-frame-count*
1219                                                   (incf *hemlock-frame-count*)))
1220                                         :modes '("Echo Area")))
1221                 (textstorage
1222                  (progn
1223                    (setf (hi::buffer-gap-context buffer) gap-context)
1224                    (make-textstorage-for-hemlock-buffer buffer)))
1225                 (doc (make-objc-instance 'echo-area-document))
1226                 (layout (make-objc-instance 'ns-layout-manager))
1227                 (container (send (make-objc-instance 'ns-text-container
1228                                                      :with-container-size
1229                                                      containersize)
1230                                  'autorelease)))
1231            (send textstorage :add-layout-manager layout)
1232            (send layout :add-text-container container)
1233            (send layout 'release)
1234            (let* ((echo (make-objc-instance 'echo-area-view
1235                                             :with-frame box-frame
1236                                             :text-container container)))
1237              (send echo :set-min-size (pref box-frame :<NSR>ect.size))
1238              (send echo :set-max-size (ns-make-size 1.0f7 (pref box-frame :<NSR>ect.size)))
1239              (send echo :set-rich-text nil)
1240              (send echo :set-horizontally-resizable t)
1241              (send echo :set-vertically-resizable nil)
1242              (send echo :set-autoresizing-mask #$NSViewNotSizable)
1243              (send echo :set-background-color color)
1244              (send container :set-width-tracks-text-view nil)
1245              (send container :set-height-tracks-text-view nil)
1246              (setf (hemlock-frame-echo-area-buffer hemlock-frame) buffer
1247                    (slot-value doc 'textstorage) textstorage
1248                    (hi::buffer-document buffer) doc)
1249              (send clipview :set-document-view echo)
1250              (send clipview :set-autoresizes-subviews nil)
1251              (send echo 'size-to-fit)
1252              (values echo box))))))))
1253                   
1254(defun make-echo-area-for-window (w gap-context-for-echo-area-buffer color)
1255  (let* ((content-view (send w 'content-view)))
1256    (slet ((bounds (send content-view 'bounds)))
1257      (multiple-value-bind (echo-area box)
1258          (make-echo-area w
1259                          0.0f0
1260                          0.0f0
1261                          (- (pref bounds :<NSR>ect.size.width) 24.0f0)
1262                          20.0f0
1263                          gap-context-for-echo-area-buffer
1264                          color)
1265        (send content-view :add-subview box)
1266        echo-area))))
1267               
1268(defclass hemlock-frame (ns:ns-window)
1269    ((echo-area-view :foreign-type :id)
1270     (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue))
1271                  :reader hemlock-frame-event-queue)
1272     (command-thread :initform nil)
1273     (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
1274     (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream))
1275  (:metaclass ns:+ns-object))
1276
1277
1278(defun double-%-in (string)
1279  ;; Replace any % characters in string with %%, to keep them from
1280  ;; being treated as printf directives.
1281  (let* ((%pos (position #\% string)))
1282    (if %pos
1283      (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos))))
1284      string)))
1285
1286(defun nsstring-for-lisp-condition (cond)
1287  (%make-nsstring (double-%-in (princ-to-string cond))))
1288
1289(define-objc-method ((:void :run-error-sheet info) hemlock-frame)
1290  (let* ((message (send info :object-at-index 0))
1291         (signal (send info :object-at-index 1)))
1292    (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
1293                         (if (logbitp 0 (random 2))
1294                           #@"Not OK, but what can you do?"
1295                           #@"The sky is falling. FRED never did this!")
1296                         (%null-ptr)
1297                         (%null-ptr)
1298                         self
1299                         self
1300                         (@selector "sheetDidEnd:returnCode:contextInfo:")
1301                         (@selector "sheetDidDismiss:returnCode:contextInfo:")
1302                         signal
1303                         message)))
1304
1305(define-objc-method ((:void :sheet-did-end sheet
1306                            :return-code code
1307                            :context-info info)
1308                     hemlock-frame)
1309 (declare (ignore sheet code info)))
1310
1311(define-objc-method ((:void :sheet-did-dismiss sheet
1312                            :return-code code
1313                            :context-info info)
1314                     hemlock-frame)
1315  (declare (ignore sheet code))
1316  (ccl::%signal-semaphore-ptr (%int-to-ptr (send info 'unsigned-int-value))))
1317 
1318(defun report-condition-in-hemlock-frame (condition frame)
1319  (let* ((semaphore (make-semaphore))
1320         (message (nsstring-for-lisp-condition condition))
1321         (sem-value (make-objc-instance 'ns:ns-number
1322                                        :with-unsigned-int (%ptr-to-int (semaphore.value semaphore)))))
1323    (%stack-block ((paramptrs (ash 2 target::word-shift)))
1324      (setf (%get-ptr paramptrs 0) message
1325            (%get-ptr paramptrs (ash 1 target::word-shift)) sem-value)
1326      (let* ((params (make-objc-instance 'ns:ns-array
1327                                         :with-objects paramptrs
1328                                         :count 2)))
1329        (send frame
1330              :perform-selector-on-main-thread
1331              (@selector "runErrorSheet:")
1332              :with-object params
1333              :wait-until-done t)
1334        (wait-on-semaphore semaphore)))))
1335
1336(defun hi::report-hemlock-error (condition)
1337  (report-condition-in-hemlock-frame condition (send (hi::current-window) 'window)))
1338                       
1339                       
1340(defun hemlock-thread-function (q buffer pane echo-buffer echo-window)
1341  (let* ((hi::*real-editor-input* q)
1342         (hi::*editor-input* q)
1343         (hi::*current-buffer* hi::*current-buffer*)
1344         (hi::*current-window* pane)
1345         (hi::*echo-area-window* echo-window)
1346         (hi::*echo-area-buffer* echo-buffer)
1347         (region (hi::buffer-region echo-buffer))
1348         (hi::*echo-area-region* region)
1349         (hi::*echo-area-stream* (hi::make-hemlock-output-stream
1350                              (hi::region-end region) :full))
1351         (hi::*parse-starting-mark*
1352          (hi::copy-mark (hi::buffer-point hi::*echo-area-buffer*)
1353                         :right-inserting))
1354         (hi::*parse-input-region*
1355          (hi::region hi::*parse-starting-mark*
1356                      (hi::region-end region)))
1357         (hi::*cache-modification-tick* -1)
1358         (hi::now-tick 0)
1359         (hi::*disembodied-buffer-counter* 0)
1360         (hi::*in-a-recursive-edit* nil)
1361         (hi::*last-key-event-typed* nil)
1362         (hi::*input-transcript* nil)
1363         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
1364         (hemlock::*target-column* 0)
1365         (hemlock::*last-comment-start* 0)
1366         (hemlock::*last-search-string* ())
1367         (hemlock::*last-search-pattern*
1368            (hemlock::new-search-pattern :string-insensitive :forward "Foo"))
1369         )
1370   
1371    (setf (hi::current-buffer) buffer)
1372    (unwind-protect
1373         (loop
1374           (catch 'hi::editor-top-level-catcher
1375             (handler-bind ((error #'(lambda (condition)
1376                                       (hi::lisp-error-error-handler condition
1377                                                                     :internal))))
1378               (hi::invoke-hook hemlock::abort-hook)
1379               (hi::%command-loop))))
1380      (hi::invoke-hook hemlock::exit-hook))))
1381
1382
1383(define-objc-method ((:void close) hemlock-frame)
1384  (let* ((content-view (send self 'content-view))
1385         (subviews (send content-view 'subviews)))
1386    (do* ((i (1- (send subviews 'count)) (1- i)))
1387         ((< i 0))
1388      (send (send subviews :object-at-index i)
1389            'remove-from-superview-without-needing-display)))
1390  (let* ((proc (slot-value self 'command-thread)))
1391    (when proc
1392      (setf (slot-value self 'command-thread) nil)
1393      (process-kill proc)))
1394  (let* ((buf (hemlock-frame-echo-area-buffer self))
1395         (echo-doc (if buf (hi::buffer-document buf))))
1396    (when echo-doc
1397      (setf (hemlock-frame-echo-area-buffer self) nil)
1398      (send echo-doc 'close)))
1399  (release-canonical-nsobject self)
1400  (send-super 'close))
1401 
1402(defun new-hemlock-document-window ()
1403  (let* ((w (new-cocoa-window :class (find-class 'hemlock-frame)
1404                              :activate nil)))
1405      (values w (add-pane-to-window w :reserve-below 20.0))))
1406
1407
1408
1409(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
1410  (let* ((window-content-view (send w 'content-view)))
1411    (slet ((window-frame (send window-content-view 'frame)))
1412      (slet ((pane-rect (ns-make-rect 0.0f0
1413                                      reserve-below
1414                                      (pref window-frame :<NSR>ect.size.width)
1415                                      (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below)))))
1416        (let* ((pane (make-objc-instance 'text-pane :with-frame pane-rect)))
1417          (send window-content-view :add-subview pane)
1418          pane)))))
1419
1420                                       
1421                                     
1422(defun textpane-for-textstorage (ts ncols nrows container-tracks-text-view-width color)
1423  (let* ((pane (nth-value
1424                1
1425                (new-hemlock-document-window))))
1426    (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color)
1427    (multiple-value-bind (height width)
1428        (size-of-char-in-font (default-font))
1429      (size-text-pane pane height width nrows ncols))
1430    pane))
1431
1432
1433
1434
1435(defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
1436  (let* ((buffer (make-hemlock-buffer name :modes modes)))
1437    (nsstring-to-buffer nsstring buffer)))
1438
1439(defun %nsstring-to-mark (nsstring mark)
1440  "returns external-format of string"
1441  (let* ((string-len (send (the ns:ns-string nsstring) 'length))
1442         (line-start 0)
1443         (first-line-terminator ())
1444         (first-line (hi::mark-line mark))
1445         (previous first-line)
1446         (buffer (hi::line-%buffer first-line))
1447         (hi::*buffer-gap-context*
1448          (or 
1449           (hi::buffer-gap-context buffer)
1450           (setf (hi::buffer-gap-context buffer)
1451                 (hi::make-buffer-gap-context)))))
1452    (slet ((remaining-range (ns-make-range 0 1)))
1453          (rlet ((line-end-index :unsigned)
1454                 (contents-end-index :unsigned))
1455            (do* ((number (+ (hi::line-number first-line) hi::line-increment)
1456                          (+ number hi::line-increment)))
1457                 ((= line-start string-len)
1458                  (let* ((line (hi::mark-line mark)))
1459                    (hi::insert-string mark (make-string 0))
1460                    (setf (hi::line-next previous) line
1461                          (hi::line-previous line) previous))
1462                  nil)
1463              (setf (pref remaining-range :<NSR>ange.location) line-start)
1464              (send nsstring
1465                    :get-line-start (%null-ptr)
1466                    :end line-end-index
1467                    :contents-end contents-end-index
1468                    :for-range remaining-range)
1469              (let* ((contents-end (pref contents-end-index :unsigned))
1470                     (line-end (pref line-end-index :unsigned))
1471                     (chars (make-string (- contents-end line-start))))
1472                (do* ((i line-start (1+ i))
1473                      (j 0 (1+ j)))
1474                     ((= i contents-end))
1475                  (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
1476                (unless first-line-terminator
1477                  (let* ((terminator (code-char
1478                                      (send nsstring :character-at-index
1479                                            contents-end))))
1480                    (setq first-line-terminator
1481                          (case terminator
1482                            (#\return (if (= line-end (+ contents-end 2))
1483                                        :cp/m
1484                                        :macos))
1485                            (t :unix)))))
1486                (if (eq previous first-line)
1487                  (progn
1488                    (hi::insert-string mark chars)
1489                    (hi::insert-character mark #\newline)
1490                    (setq first-line nil))
1491                  (if (eq string-len contents-end)
1492                    (hi::insert-string mark chars)
1493                    (let* ((line (hi::make-line
1494                                  :previous previous
1495                                  :%buffer buffer
1496                                  :chars chars
1497                                  :number number)))
1498                      (setf (hi::line-next previous) line)
1499                      (setq previous line))))
1500                (setq line-start line-end)))))
1501    first-line-terminator))
1502 
1503(defun nsstring-to-buffer (nsstring buffer)
1504  (let* ((document (hi::buffer-document buffer))
1505         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
1506    (setf (hi::buffer-document buffer) nil)
1507    (unwind-protect
1508         (progn
1509           (hi::delete-region (hi::buffer-region buffer))
1510           (hi::modifying-buffer buffer)
1511           (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
1512             (setf (hi::buffer-external-format buffer)
1513                   (%nsstring-to-mark nsstring mark)))
1514)
1515           (setf (hi::buffer-modified buffer) nil)
1516           (hi::buffer-start (hi::buffer-point buffer))
1517           buffer)
1518      (setf (hi::buffer-document buffer) document)))
1519
1520;;; This assumes that the buffer has no document and no textstorage (yet).
1521(defun hi::cocoa-read-file (lisp-pathname mark buffer)
1522  (let* ((lisp-namestring (native-translated-namestring lisp-pathname))
1523         (cocoa-pathname (%make-nsstring lisp-namestring))
1524         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
1525         (data (make-objc-instance 'ns:ns-data
1526                                   :with-contents-of-file cocoa-pathname))
1527         (string (make-objc-instance 'ns:ns-string
1528                                     :with-data data
1529                                     :encoding #$NSASCIIStringEncoding))
1530         (external-format (%nsstring-to-mark string mark)))
1531    (unless (hi::buffer-external-format buffer)
1532      (setf (hi::buffer-external-format buffer) external-format))
1533    buffer))
1534   
1535         
1536(setq hi::*beep-function* #'(lambda (stream)
1537                              (declare (ignore stream))
1538                              (#_NSBeep)))
1539
1540
1541;;; This function must run in the main event thread.
1542(defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color)
1543  (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width color))
1544         (frame (send pane 'window))
1545         (buffer (text-view-buffer (text-pane-text-view pane))))
1546    (setf (slot-value frame 'echo-area-view)
1547          (make-echo-area-for-window frame (hi::buffer-gap-context buffer) color))
1548    (setf (slot-value frame 'command-thread)
1549          (process-run-function (format nil "Hemlock window thread")
1550                                #'(lambda ()
1551                                    (hemlock-thread-function
1552                                     (hemlock-frame-event-queue frame)
1553                                     buffer
1554                                     pane
1555                                     (hemlock-frame-echo-area-buffer frame)
1556                                     (slot-value frame 'echo-area-view)))))
1557    frame))
1558         
1559   
1560
1561
1562(defun hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color)
1563  (process-interrupt *cocoa-event-process*
1564                     #'%hemlock-frame-for-textstorage
1565                     ts  ncols nrows container-tracks-text-view-width color))
1566
1567
1568
1569(defun hi::lock-buffer (b)
1570  (grab-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b))))
1571
1572(defun hi::unlock-buffer (b)
1573  (release-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b)))) 
1574 
1575(defun hi::document-begin-editing (document)
1576  #-all-in-cocoa-thread
1577  (send (slot-value document 'textstorage) 'begin-editing)
1578  #+all-in-cocoa-thread
1579  (send (slot-value document 'textstorage)
1580        :perform-selector-on-main-thread
1581        (@selector "beginEditing")
1582        :with-object (%null-ptr)
1583        :wait-until-done t))
1584
1585
1586
1587(defun hi::document-end-editing (document)
1588  #-all-in-cocoa-thread
1589  (send (slot-value document 'textstorage) 'end-editing)
1590  #+all-in-cocoa-thread
1591  (send (slot-value document 'textstorage)
1592        :perform-selector-on-main-thread
1593        (@selector "endEditing")
1594        :with-object (%null-ptr)
1595        :wait-until-done t))
1596
1597(defun hi::document-set-point-position (document)
1598  (declare (ignorable document))
1599  #+debug
1600  (#_NSLog #@"Document set point position called")
1601  (let* ((textstorage (slot-value document 'textstorage)))
1602    (send textstorage
1603          :perform-selector-on-main-thread
1604          (@selector "updateHemlockSelection")
1605          :with-object (%null-ptr)
1606          :wait-until-done t)))
1607
1608
1609
1610(defun perform-edit-change-notification (textstorage selector pos n)
1611  (let* ((number-for-pos
1612          (send (send (@class "NSNumber") 'alloc)
1613                :init-with-int pos))
1614         (number-for-n 
1615          (send (send (@class "NSNumber") 'alloc)
1616                :init-with-int n)))
1617    (%stack-block ((paramptrs (ash 2 target::word-shift)))
1618      (setf (%get-ptr paramptrs 0) number-for-pos
1619            (%get-ptr paramptrs (ash 1 target::word-shift))
1620            number-for-n)
1621      (let* ((params
1622              (send (send (@class "NSArray") 'alloc)
1623                    :init-with-objects paramptrs
1624                    :count 2)))
1625        (send textstorage
1626                    :perform-selector-on-main-thread
1627                    selector
1628                    :with-object params
1629                    :wait-until-done t)
1630              (send params 'release)
1631              (send number-for-pos 'release)
1632              (send number-for-n 'release)))))
1633
1634(defun textstorage-note-insertion-at-position (textstorage pos n)
1635  #+debug
1636  (#_NSLog #@"insertion at position %d, len %d" :int pos :int n)
1637  (send textstorage
1638        :edited #$NSTextStorageEditedAttributes
1639        :range (ns-make-range pos 0)
1640        :change-in-length n)
1641  (send textstorage
1642        :edited #$NSTextStorageEditedCharacters
1643        :range (ns-make-range pos n)
1644        :change-in-length 0))
1645
1646
1647
1648
1649(defun hi::buffer-note-font-change (buffer region)
1650  (when (hi::bufferp buffer)
1651    (let* ((document (hi::buffer-document buffer))
1652           (textstorage (if document (slot-value document 'textstorage)))
1653           (pos (mark-absolute-position (hi::region-start region)))
1654           (n (- (mark-absolute-position (hi::region-end region)) pos)))
1655      (perform-edit-change-notification textstorage
1656                                        (@selector "noteAttrChange:")
1657                                        pos
1658                                        n))))
1659
1660(defun hi::buffer-note-insertion (buffer mark n)
1661  (when (hi::bufferp buffer)
1662    (let* ((document (hi::buffer-document buffer))
1663           (textstorage (if document (slot-value document 'textstorage))))
1664      (when textstorage
1665        (let* ((pos (mark-absolute-position mark)))
1666          (unless (eq (hi::mark-%kind mark) :right-inserting)
1667            (decf pos n))
1668          #+debug
1669          (format t "~&insert: pos = ~d, n = ~d" pos n)
1670          (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
1671            ;(reset-buffer-cache display)
1672            (adjust-buffer-cache-for-insertion display pos n)
1673            (update-line-cache-for-index display pos))
1674          #-all-in-cocoa-thread
1675          (textstorage-note-insertion-at-position textstorage pos n)
1676          #+all-in-cocoa-thread
1677          (perform-edit-change-notification textstorage
1678                                            (@selector "noteInsertion:")
1679                                            pos
1680                                            n))))))
1681
1682(defun hi::buffer-note-modification (buffer mark n)
1683  (when (hi::bufferp buffer)
1684    (let* ((document (hi::buffer-document buffer))
1685           (textstorage (if document (slot-value document 'textstorage))))
1686      (when textstorage
1687        #+debug
1688        (#_NSLog #@"enqueue modify: pos = %d, n = %d"
1689                 :int (mark-absolute-position mark)
1690                 :int n)
1691        #-all-in-cocoa-thread
1692        (send textstorage
1693          :edited (logior #$NSTextStorageEditedCharacters
1694                          #$NSTextStorageEditedAttributes)
1695          :range (ns-make-range (mark-absolute-position mark) n)
1696          :change-in-length 0)
1697        #+all-in-cocoa-thread
1698        (perform-edit-change-notification textstorage
1699                                          (@selector "noteModification:")
1700                                          (mark-absolute-position mark)
1701                                          n)))))
1702 
1703
1704(defun hi::buffer-note-deletion (buffer mark n)
1705  (when (hi::bufferp buffer)
1706    (let* ((document (hi::buffer-document buffer))
1707           (textstorage (if document (slot-value document 'textstorage))))
1708      (when textstorage
1709        #-all-in-cocoa-thread
1710        (let* ((pos (mark-absolute-position mark)))
1711          (send textstorage
1712          :edited #$NSTextStorageEditedCharacters
1713          :range (ns-make-range pos n)
1714          :change-in-length (- n))
1715          (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
1716            (reset-buffer-cache display) 
1717            (update-line-cache-for-index display pos)))
1718        #+all-in-cocoa-thread
1719        (perform-edit-change-notification textstorage
1720                                          (@selector "noteDeletion:")
1721                                          (mark-absolute-position mark)
1722                                          (abs n))))))
1723
1724(defun hi::set-document-modified (document flag)
1725  (send document
1726        :update-change-count (if flag #$NSChangeDone #$NSChangeCleared)))
1727
1728
1729(defmethod hi::document-panes ((document t))
1730  )
1731
1732
1733
1734   
1735
1736(defun size-of-char-in-font (f)
1737  (let* ((sf (send f 'screen-font)))
1738    (if (%null-ptr-p sf) (setq sf f))
1739    (values (send sf 'default-line-height-for-font)
1740            (send sf :width-of-string #@" "))))
1741         
1742
1743
1744(defun size-text-pane (pane char-height char-width nrows ncols)
1745  (let* ((tv (text-pane-text-view pane))
1746         (height (fceiling (* nrows char-height)))
1747         (width (fceiling (* ncols char-width)))
1748         (scrollview (text-pane-scroll-view pane))
1749         (window (send scrollview 'window)))
1750    (rlet ((tv-size :<NSS>ize :height height
1751                    :width (+ width (* 2 (send (send tv 'text-container)
1752                                               'line-fragment-padding)))))
1753      (when (send scrollview 'has-vertical-scroller)
1754        (send scrollview :set-vertical-line-scroll char-height)
1755        (send scrollview :set-vertical-page-scroll 0.0f0 #|char-height|#))
1756      (when (send scrollview 'has-horizontal-scroller)
1757        (send scrollview :set-horizontal-line-scroll char-width)
1758        (send scrollview :set-horizontal-page-scroll 0.0f0 #|char-width|#))
1759      (slet ((sv-size
1760              (send (@class ns-scroll-view)
1761                    :frame-size-for-content-size tv-size
1762                    :has-horizontal-scroller
1763                    (send scrollview 'has-horizontal-scroller)
1764                    :has-vertical-scroller
1765                    (send scrollview 'has-vertical-scroller)
1766                    :border-type (send scrollview 'border-type))))
1767        (slet ((pane-frame (send pane 'frame))
1768               (margins (send pane 'content-view-margins)))
1769          (incf (pref sv-size :<NSS>ize.height)
1770                (+ (pref pane-frame :<NSR>ect.origin.y)
1771                   (* 2 (pref margins :<NSS>ize.height))))
1772          (incf (pref sv-size :<NSS>ize.width)
1773                (pref margins :<NSS>ize.width))
1774          (send window :set-content-size sv-size)
1775          (send window :set-resize-increments
1776                (ns-make-size char-width char-height)))))))
1777                                   
1778 
1779(defclass hemlock-editor-window-controller (ns:ns-window-controller)
1780    ()
1781  (:metaclass ns:+ns-object))
1782
1783
1784
1785(define-objc-method ((:void :_window-will-close notification)
1786                     hemlock-editor-window-controller)
1787  #+debug
1788  (let* ((w (send notification 'object)))
1789    (#_NSLog #@"Window controller: window will close: %@" :id w))
1790  (send-super :_window-will-close notification))
1791
1792;;; The HemlockEditorDocument class.
1793
1794
1795(defclass hemlock-editor-document (ns:ns-document)
1796    ((textstorage :foreign-type :id))
1797  (:metaclass ns:+ns-object))
1798
1799(defmethod textview-background-color ((doc hemlock-editor-document))
1800  (send (find-class 'ns:ns-color)
1801        :color-with-calibrated-red *editor-background-red-component*
1802        :green *editor-background-green-component*
1803        :blue *editor-background-blue-component*
1804        :alpha *editor-background-alpha-component*))
1805
1806
1807(define-objc-method ((:id :set-text-storage ts)
1808                     hemlock-editor-document)
1809  (let* ((doc (%inc-ptr self 0))
1810         (string (send ts 'string))
1811         (cache (hemlock-buffer-string-cache string))
1812         (buffer (buffer-cache-buffer cache)))
1813    (unless (%null-ptr-p doc)
1814      (setf (slot-value doc 'textstorage) ts
1815            (hi::buffer-document buffer) doc))
1816    doc))
1817         
1818     
1819   
1820           
1821 
1822(define-objc-method ((:id init) hemlock-editor-document)
1823  (let* ((doc (send-super 'init)))
1824    (unless  (%null-ptr-p doc)
1825      (send doc
1826        :set-text-storage (make-textstorage-for-hemlock-buffer
1827                           (make-hemlock-buffer
1828                            (lisp-string-from-nsstring
1829                             (send doc 'display-name))
1830                            :modes '("Lisp" "Editor")))))
1831    doc))
1832                     
1833
1834(define-objc-method ((:id :read-from-file filename
1835                          :of-type type)
1836                     hemlock-editor-document)
1837  (declare (ignorable type))
1838  (let* ((pathname (lisp-string-from-nsstring filename))
1839         (buffer-name (hi::pathname-to-buffer-name pathname))
1840         (buffer (or
1841                  (hemlock-document-buffer self)
1842                  (let* ((b (make-hemlock-buffer buffer-name)))
1843                    (setf (hi::buffer-pathname b) pathname)
1844                    (setf (slot-value self 'textstorage)
1845                          (make-textstorage-for-hemlock-buffer b))
1846                    b)))
1847         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
1848         (data (make-objc-instance 'ns:ns-data
1849                                   :with-contents-of-file filename))
1850         (string (make-objc-instance 'ns:ns-string
1851                                     :with-data data
1852                                     :encoding #$NSASCIIStringEncoding)))
1853    (hi::document-begin-editing self)
1854    (nsstring-to-buffer string buffer)
1855    (let* ((textstorage (slot-value self 'textstorage))
1856           (display (hemlock-buffer-string-cache (send textstorage 'string))))
1857      (reset-buffer-cache display) 
1858      (update-line-cache-for-index display 0)
1859      (textstorage-note-insertion-at-position
1860       textstorage
1861       0
1862       (hemlock-buffer-length buffer)))
1863    (hi::document-end-editing self)
1864    (setf (hi::buffer-modified buffer) nil)
1865    (hi::process-file-options buffer pathname)
1866    self))
1867   
1868 
1869(defmethod hemlock-document-buffer (document)
1870  (let* ((string (send (slot-value document 'textstorage) 'string)))
1871    (unless (%null-ptr-p string)
1872      (let* ((cache (hemlock-buffer-string-cache string)))
1873        (when cache (buffer-cache-buffer cache))))))
1874
1875(defmethod hi::document-panes ((document hemlock-editor-document))
1876  (let* ((ts (slot-value document 'textstorage))
1877         (panes ()))
1878    (for-each-textview-using-storage
1879     ts
1880     #'(lambda (tv)
1881         (let* ((pane (text-view-pane tv)))
1882           (unless (%null-ptr-p pane)
1883             (push pane panes)))))
1884    panes))
1885
1886(define-objc-method ((:id :data-representation-of-type type)
1887                      hemlock-editor-document)
1888  (declare (ignorable type))
1889  (let* ((buffer (hemlock-document-buffer self)))
1890    (when buffer
1891      (setf (hi::buffer-modified buffer) nil)))
1892  (send (send (slot-value self 'textstorage) 'string)
1893        :data-using-encoding #$NSASCIIStringEncoding
1894        :allow-lossy-conversion t))
1895
1896
1897;;; Shadow the setFileName: method, so that we can keep the buffer
1898;;; name and pathname in synch with the document.
1899(define-objc-method ((:void :set-file-name full-path)
1900                     hemlock-editor-document)
1901  (send-super :set-file-name full-path)
1902  (let* ((buffer (hemlock-document-buffer self)))
1903    (when buffer
1904      (let* ((new-pathname (lisp-string-from-nsstring full-path)))
1905        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
1906        (setf (hi::buffer-pathname buffer) new-pathname)))))
1907
1908
1909(def-cocoa-default *initial-editor-x-pos* :float 200.0f0 "X position of upper-left corner of initial editor")
1910
1911(def-cocoa-default *initial-editor-y-pos* :float 400.0f0 "Y position of upper-left corner of initial editor")
1912
1913(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized
1914(defloadvar *next-editor-y-pos* nil)
1915
1916(define-objc-method ((:void make-window-controllers) hemlock-editor-document)
1917  #+debug
1918  (#_NSLog #@"Make window controllers")
1919  (let* ((window (%hemlock-frame-for-textstorage 
1920                                    (slot-value self 'textstorage)
1921                                    *editor-columns*
1922                                    *editor-rows*
1923                                    nil
1924                                    (textview-background-color self)))
1925         (controller (make-objc-instance
1926                      'hemlock-editor-window-controller
1927                      :with-window window)))
1928    (send self :add-window-controller controller)
1929    (send controller 'release)
1930    (slet ((current-point (ns-make-point (or *next-editor-x-pos*
1931                                             *initial-editor-x-pos*)
1932                                         (or *next-editor-y-pos*
1933                                             *initial-editor-y-pos*))))
1934      (slet ((new-point (send window
1935                              :cascade-top-left-from-point current-point)))
1936            (setf *next-editor-x-pos* (pref new-point :<NSP>oint.x)
1937                  *next-editor-y-pos* (pref new-point :<NSP>oint.y))))))
1938
1939
1940(define-objc-method ((:void close) hemlock-editor-document)
1941  #+debug
1942  (#_NSLog #@"Document close: %@" :id self)
1943  (let* ((textstorage (slot-value self 'textstorage)))
1944    (unless (%null-ptr-p textstorage)
1945      (setf (slot-value self 'textstorage) (%null-ptr))
1946      (for-each-textview-using-storage
1947       textstorage
1948       #'(lambda (tv)
1949           (let* ((layout (send tv 'layout-manager)))
1950             (send layout :set-background-layout-enabled nil))))
1951      (close-hemlock-textstorage textstorage)))
1952  (send-super 'close))
1953
1954
1955(defun initialize-user-interface ()
1956  (send (find-class 'preferences-panel) 'shared-panel)
1957  (update-cocoa-defaults)
1958  (make-editor-style-map))
1959
1960(defun hi::scroll-window (textpane n)
1961  (let* ((textview (text-pane-text-view textpane)))
1962    (unless (%null-ptr-p textview)
1963      (let* ((selector (if (>= n 0 )
1964                         (@selector "pageDown:")
1965                         (@selector "pageUp:"))))
1966        (send textview
1967              :perform-selector-on-main-thread selector
1968              :with-object (%null-ptr)
1969              :wait-until-done t)))))
1970
1971(defmethod hemlock::center-text-pane ((pane text-pane))
1972  (send (text-pane-text-view pane)
1973        :center-selection-in-visible-area (%null-ptr)))
1974
1975
1976(defun hi::open-document ()
1977  (send (send (find-class 'ns:ns-document-controller)
1978              'shared-document-controller)
1979        :perform-selector-on-main-thread (@selector "openDocument:")
1980        :with-object (%null-ptr)
1981        :wait-until-done t))
1982 
1983(defmethod hi::save-hemlock-document ((self hemlock-editor-document))
1984  (send self
1985        :perform-selector-on-main-thread (@selector "saveDocument:")
1986        :with-object (%null-ptr)
1987        :wait-until-done t))
1988
1989
1990(defmethod hi::save-hemlock-document-as ((self hemlock-editor-document))
1991  (send self
1992        :perform-selector-on-main-thread (@selector "saveDocumentAs:")
1993        :with-object (%null-ptr)
1994        :wait-until-done t))
1995
1996;;; This needs to run on the main thread.
1997(define-objc-method ((void update-hemlock-selection)
1998                     hemlock-text-storage)
1999  (let* ((string (send self 'string))
2000         (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))
2001         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
2002         (point (hi::buffer-point buffer))
2003         (pointpos (mark-absolute-position point))
2004         (location pointpos)
2005         (len 0))
2006    (when (hemlock::%buffer-region-active-p buffer)
2007      (let* ((mark (hi::buffer-%mark buffer)))
2008        (when mark
2009          (let* ((markpos (mark-absolute-position mark)))
2010            (if (< markpos pointpos)
2011              (setq location markpos len (- pointpos markpos))
2012              (if (< pointpos markpos)
2013                (setq location pointpos len (- markpos pointpos))))))))
2014    #+debug
2015    (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
2016             :int (hi::mark-charpos point) :int pos)
2017    (for-each-textview-using-storage
2018     self
2019     #'(lambda (tv)
2020         (send tv
2021               :update-selection location
2022               :length len
2023               :affinity (if (eql location 0)
2024                           #$NSSelectionAffinityUpstream
2025                           #$NSSelectionAffinityDownstream))))))
2026
2027
2028(defun hi::allocate-temporary-object-pool ()
2029  (create-autorelease-pool))
2030
2031(defun hi::free-temporary-objects (pool)
2032  (release-autorelease-pool pool))
2033
2034(provide "COCOA-EDITOR")
Note: See TracBrowser for help on using the repository browser.