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

Last change on this file since 597 was 597, checked in by gb, 16 years ago

More changes. Every day, more changes. (Listeners kind of work now.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 42.8 KB
Line 
1;;;-*- Mode: LISP; Package: CCL -*-
2
3
4(in-package "CCL")
5
6(eval-when (:compile-toplevel :load-toplevel :execute)
7  (require "COCOA-WINDOW")
8  (require "HEMLOCK"))
9
10(eval-when (:compile-toplevel :execute)
11  (use-interface-dir :cocoa))
12
13(defun make-hemlock-buffer (&rest args)
14  (let* ((buf (apply #'hi::make-buffer args)))
15    (or buf
16        (progn
17          (format t "~& couldn't make hemlock buffer with args ~s" args)
18          (dbg)
19          nil))))
20         
21;;; Define some key event modifiers.
22
23;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
24;;; it to map NSEvent modifier keys to key-event modifiers.
25
26(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
27(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
28(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
29(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
30
31
32;;; We want to display a Hemlock buffer in a "pane" (an on-screen
33;;; view) which in turn is presented in a "frame" (a Cocoa window).  A
34;;; 1:1 mapping between frames and panes seems to fit best into
35;;; Cocoa's document architecture, but we should try to keep the
36;;; concepts separate (in case we come up with better UI paradigms.)
37;;; Each pane has a modeline (which describes attributes of the
38;;; underlying document); each frame has an echo area (which serves
39;;; to display some commands' output and to provide multi-character
40;;; input.)
41
42
43;;; I'd pretty much concluded that it wouldn't be possible to get the
44;;; Cocoa text system (whose storage model is based on NSString
45;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with
46;;; Hemlock, and (since the whole point of using Hemlock was to be
47;;; able to treat an editor buffer as a rich lisp data structure) it
48;;; seemed like it'd be necessary to toss the higher-level Cocoa text
49;;; system and implement our own scrolling, redisplay, selection
50;;; ... code.
51;;;
52;;; Mikel Evins pointed out that NSString and friends were
53;;; abstract classes and that there was therefore no reason (in
54;;; theory) not to implement a thin wrapper around a Hemlock buffer
55;;; that made it act like an NSString.  As long as the text system can
56;;; ask a few questions about the NSString (its length and the
57;;; character and attributes at a given location), it's willing to
58;;; display the string in a scrolling, mouse-selectable NSTextView;
59;;; as long as Hemlock tells the text system when and how the contents
60;;; of the abstract string changes, Cocoa will handle the redisplay
61;;; details.
62;;;
63
64
65;;; Hemlock-buffer-string objects:
66
67(defclass hemlock-buffer-string (ns:ns-string)
68    ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache))
69  (:metaclass ns:+ns-object))
70
71;;; Cocoa wants to treat the buffer as a linear array of characters;
72;;; Hemlock wants to treat it as a doubly-linked list of lines, so
73;;; we often have to map between an absolute position in the buffer
74;;; and a relative position on a line.  We can certainly do that
75;;; by counting the characters in preceding lines every time that we're
76;;; asked, but we're often asked to map a sequence of nearby positions
77;;; and wind up repeating a lot of work.  Caching the results of that
78;;; work seems to speed things up a bit in many cases; this data structure
79;;; is used in that process.  (It's also the only way to get to the
80;;; actual underlying Lisp buffer from inside the network of text-system
81;;; objects.)
82
83(defstruct buffer-cache 
84  buffer                                ; the hemlock buffer
85  buflen                                ; length of buffer, if known
86  workline                              ; cache for character-at-index
87  workline-offset                       ; cached offset of workline
88  workline-length                       ; length of cached workline
89  )
90
91;;; Initialize (or reinitialize) a buffer cache, so that it points
92;;; to the buffer's first line (which is the only line whose
93;;; absolute position will never change).  Code which modifies the
94;;; buffer generally has to call this, since any cached information
95;;; might be invalidated by the modification.
96(defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d)
97                                                buffer-p))
98  (when buffer-p (setf (buffer-cache-buffer d) buffer))
99  (let* ((workline (hemlock::mark-line
100                    (hemlock::buffer-start-mark buffer))))
101    (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer)
102          (buffer-cache-workline-offset d) 0
103          (buffer-cache-workline d) workline
104          (buffer-cache-workline-length d) (hemlock::line-length workline))
105    d))
106
107
108;;; Update the cache so that it's describing the current absolute
109;;; position.
110(defun update-line-cache-for-index (cache index)
111  (let* ((line (or
112                (buffer-cache-workline cache)
113                (progn
114                  (reset-buffer-cache cache)
115                  (buffer-cache-workline cache))))
116         (pos (buffer-cache-workline-offset cache))
117         (len (buffer-cache-workline-length cache))
118         (moved nil))
119    (loop
120      (when (and (>= index pos)
121                   (< index (1+ (+ pos len))))
122          (let* ((idx (- index pos)))
123            (when moved
124              (setf (buffer-cache-workline cache) line
125                    (buffer-cache-workline-offset cache) pos
126                    (buffer-cache-workline-length cache) len))
127            (return (values line idx))))
128        (setq moved t)
129      (if (< index pos)
130        (setq line (hemlock::line-previous line)
131              len (hemlock::line-length line)
132              pos (1- (- pos len)))
133        (setq line (hemlock::line-next line)
134              pos (1+ (+ pos len))
135              len (hemlock::line-length line))))))
136
137;;; Ask Hemlock to count the characters in the buffer.
138(defun hemlock-buffer-length (buffer)
139  (hemlock::count-characters (hemlock::buffer-region buffer)))
140
141;;; Find the line containing (or immediately preceding) index, which is
142;;; assumed to be less than the buffer's length.  Return the character
143;;; in that line or the trailing #\newline, as appropriate.
144(defun hemlock-char-at-index (cache index)
145  (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
146    (let* ((len (hemlock::line-length line)))
147      (if (< idx len)
148        (hemlock::line-character line idx)
149        #\newline))))
150
151;;; Given an absolute position, move the specified mark to the appropriate
152;;; offset on the appropriate line.
153(defun move-hemlock-mark-to-absolute-position (mark cache abspos)
154  (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos)
155    (hemlock::move-to-position mark idx line)))
156
157;;; Return the absolute position of the mark in the containing buffer.
158;;; This doesn't use the caching mechanism, so it's always linear in the
159;;; number of preceding lines.
160(defun mark-absolute-position (mark)
161  (let* ((pos (hemlock::mark-charpos mark)))
162    (do* ((line (hemlock::line-previous (hemlock::mark-line mark))
163                (hemlock::line-previous line)))
164         ((null line) pos)
165      (incf pos (1+ (hemlock::line-length line))))))
166
167;;; Return the length of the abstract string, i.e., the number of
168;;; characters in the buffer (including implicit newlines.)
169(define-objc-method ((:unsigned length)
170                     hemlock-buffer-string)
171  (let* ((cache (hemlock-buffer-string-cache self)))
172    (force-output)
173    (or (buffer-cache-buflen cache)
174        (setf (buffer-cache-buflen cache)
175              (hemlock-buffer-length (buffer-cache-buffer cache))))))
176
177
178;;; Return the character at the specified index (as a :unichar.)
179(define-objc-method ((:unichar :character-at-index (unsigned index))
180                     hemlock-buffer-string)
181  (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index)))
182
183
184;;; Return an NSData object representing the bytes in the string.  If
185;;; the underlying buffer uses #\linefeed as a line terminator, we can
186;;; let the superclass method do the work; otherwise, we have to
187;;; ensure that each line is terminated according to the buffer's
188;;; conventions.
189(define-objc-method ((:id :data-using-encoding (:<NSS>tring<E>ncoding encoding)
190                          :allow-lossy-conversion (:<BOOL> flag))
191                     hemlock-buffer-string)
192  (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache self)))
193         (external-format (if buffer (hi::buffer-external-format buffer )))
194         (raw-length (if buffer (hemlock-buffer-length buffer) 0)))
195    (if (eql 0 raw-length)
196      (make-objc-instance 'ns:ns-mutable-data :with-length 0)
197      (case external-format
198        ((:unix nil)
199         (send-super :data-using-encoding encoding :allow-lossy-conversion flag))
200        ((:macos :cp/m)
201         (let* ((cp/m-p (eq external-format :cp/m)))
202           (when cp/m-p
203         ;; This may seem like lot of fuss about an ancient OS and its
204         ;; odd line-termination conventions.  Of course, I'm actually
205         ;; referring to CP/M-86.
206             (do* ((line (hi::mark-line (hi::buffer-start-mark buffer))
207                         next)
208                   (next (hi::line-next line) (hi::line-next line)))
209                  ((null line))
210               (when next (incf raw-length))))
211           (let* ((pos 0)
212                  (data (make-objc-instance 'ns:ns-mutable-data
213                                            :with-length raw-length))
214                  (bytes (send data 'mutable-bytes)))
215             (do* ((line (hi::mark-line (hi::buffer-start-mark buffer))
216                         next)
217                   (next (hi::line-next line) (hi::line-next line)))
218                  ((null line) data)
219               (let* ((chars (hi::line-chars line))
220                      (len (length chars)))
221                 (unless (zerop len)
222                   (%copy-ivector-to-ptr chars 0 bytes pos len)
223                   (incf pos len))
224                 (when next
225                   (setf (%get-byte bytes pos) (char-code #\return))
226                   (when cp/m-p
227                     (incf pos)
228                   (setf (%get-byte bytes pos) (char-code #\linefeed)) 
229                   (incf pos))))))))))))
230
231
232;;; For debugging, mostly: make the printed representation of the string
233;;; referenence the named Hemlock buffer.
234(define-objc-method ((:id description)
235                     hemlock-buffer-string)
236  (let* ((cache (hemlock-buffer-string-cache self))
237         (b (buffer-cache-buffer cache)))
238    (with-cstrs ((s (format nil "~a" b)))
239      (send (@class ns-string) :string-with-format #@"<%s for %s>"
240        (:address (#_object_getClassName self) :address s)))))
241
242
243
244;;; Lisp-text-storage objects
245(defclass lisp-text-storage (ns:ns-text-storage)
246    ((string :foreign-type :id)
247     (defaultattrs :foreign-type :id))
248  (:metaclass ns:+ns-object))
249
250;;; Access the string.  It'd be nice if this was a generic function;
251;;; we could have just made a reader method in the class definition.
252(define-objc-method ((:id string) lisp-text-storage)
253  (slot-value self 'string))
254
255(define-objc-method ((:id :init-with-string s) lisp-text-storage)
256  (let* ((newself (send-super 'init)))
257    (setf (slot-value newself 'string) s
258          (slot-value newself 'defaultattrs) (create-text-attributes))
259    newself))
260
261;;; This is the only thing that's actually called to create a
262;;; lisp-text-storage object.  (It also creates the underlying
263;;; hemlock-buffer-string.)
264(defun make-textstorage-for-hemlock-buffer (buffer)
265  (make-objc-instance 'lisp-text-storage
266                      :with-string
267                      (make-instance
268                       'hemlock-buffer-string
269                       :cache
270                       (reset-buffer-cache
271                        (make-buffer-cache)
272                        buffer))))
273
274;;; So far, we're ignoring Hemlock's font-marks, so all characters in
275;;; the buffer are presumed to have default attributes.
276(define-objc-method ((:id :attributes-at-index (:unsigned index)
277                          :effective-range ((* :<NSR>ange) rangeptr))
278                     lisp-text-storage)
279  (declare (ignorable index))
280  (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string)))
281         (len (buffer-cache-buflen buffer-cache)))
282    (unless (%null-ptr-p rangeptr)
283      (setf (pref rangeptr :<NSR>ange.location) 0
284            (pref rangeptr :<NSR>ange.length) len))
285    (slot-value self 'defaultattrs)))
286
287;;; The range's origin should probably be the buffer's point; if
288;;; the range has non-zero length, we probably need to think about
289;;; things harder.
290(define-objc-method ((:void :replace-characters-in-range (:<NSR>ange r)
291                            :with-string string)
292                     lisp-text-storage)
293  (#_NSLog #@"replace-characters-in-range (%d %d) with-string %@"
294           :unsigned (pref r :<NSR>ange.location)
295           :unsigned (pref r :<NSR>ange.length)
296           :id string))
297
298;;; I'm not sure if we want the text system to be able to change
299;;; attributes in the buffer.
300(define-objc-method ((:void :set-attributes attributes
301                            :range (:<NSR>ange r))
302                     lisp-text-storage)
303  (#_NSLog #@"set-attributes %@ range (%d %d)"
304           :id attributes
305           :unsigned (pref r :<NSR>ange.location)
306           :unsigned (pref r :<NSR>ange.length)))
307
308
309;;; Again, it's helpful to see the buffer name when debugging.
310(define-objc-method ((:id description)
311                     lisp-text-storage)
312  (send (@class ns-string) :string-with-format #@"%s : string %@"
313        (:address (#_object_getClassName self) :id (slot-value self 'string))))
314
315(defun close-hemlock-textstorage (ts)
316  (let* ((string (slot-value ts 'string)))
317    (setf (slot-value ts 'string) (%null-ptr))
318    (unless (%null-ptr-p string)
319      (let* ((cache (hemlock-buffer-string-cache string))
320             (buffer (if cache (buffer-cache-buffer cache))))
321        (when buffer
322          (setf (buffer-cache-buffer cache) nil
323                (slot-value string 'cache) nil
324                (hi::buffer-document buffer) nil)
325          (let* ((p (hi::buffer-process buffer)))
326            (when p
327              (setf (hi::buffer-process buffer) nil)
328              (process-kill p)))
329          (when (eq buffer hi::*current-buffer*)
330            (setf (hi::current-buffer)
331                  (car (last hi::*buffer-list*))))
332          (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer)
333          (hi::invoke-hook hemlock::delete-buffer-hook buffer)
334          (setq hi::*buffer-list* (delq buffer hi::*buffer-list*))
335          (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*))))))
336
337     
338
339
340
341;;; A specialized NSTextView.  Some of the instance variables are intended
342;;; to support paren highlighting by blinking, but that doesn't work yet.
343;;; The NSTextView is part of the "pane" object that displays buffers.
344(defclass hemlock-text-view (ns:ns-text-view)
345    ((timer :foreign-type :id :accessor blink-timer)
346     (blink-pos :foreign-type :int :accessor blink-pos)
347     (blink-phase :foreign-type :<BOOL> :accessor blink-phase)
348     (blink-char :foreign-type :int :accessor blink-char)
349     (pane :foreign-type :id :accessor text-view-pane))
350  (:metaclass ns:+ns-object))
351
352;;; Access the underlying buffer in one swell foop.
353(defmethod text-view-buffer ((self hemlock-text-view))
354  (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string))))
355
356;;; Translate a keyDown NSEvent to a Hemlock key-event.
357(defun nsevent-to-key-event (nsevent)
358  (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers))
359         (n (if (%null-ptr-p unmodchars)
360              0
361              (send unmodchars 'length)))
362         (c (if (eql n 1)
363              (send unmodchars :character-at-index 0))))
364    (when c
365      (let* ((bits 0)
366             (modifiers (send nsevent 'modifier-flags))
367             (useful-modifiers (logandc2 modifiers
368                                         (logior #$NSShiftKeyMask
369                                                 #$NSAlphaShiftKeyMask))))
370        (dolist (map hemlock-ext::*modifier-translations*)
371          (when (logtest useful-modifiers (car map))
372            (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
373                                     (cdr map))))))
374        (hemlock-ext::make-key-event c bits)))))
375
376;;; Process a key-down NSEvent in a lisp text view by translating it
377;;; into a Hemlock key event and passing it into the Hemlock command
378;;; interpreter.  The underlying buffer becomes Hemlock's current buffer
379;;; and the containing pane becomes Hemlock's current window when the
380;;; command is processed.  Use the frame's command state object.
381
382(define-objc-method ((:void :key-down event)
383                     hemlock-text-view)
384  #+debug
385  (#_NSLog #@"Key down event = %@" :address event)
386  (let* ((buffer (text-view-buffer self)))
387    (when buffer
388      (let* ((info (hemlock-frame-command-info (send self 'window))))
389        (when info
390          (let* ((key-event (nsevent-to-key-event event)))
391            (when event
392              (unless (eq buffer hi::*current-buffer*)
393                (setf (hi::current-buffer) buffer))
394              (let* ((pane (text-view-pane self)))
395                (unless (eql pane (hi::current-window))
396                  (setf (hi::current-window) pane)))
397              #+debug 
398              (format t "~& key-event = ~s" key-event)
399              (hi::interpret-key-event key-event info))))))))
400
401;;; Update the underlying buffer's point.  Should really set the
402;;; active region (in Hemlock terms) as well.
403(define-objc-method ((:void :set-selected-range (:<NSR>ange r)
404                            :affinity (:<NSS>election<A>ffinity affinity)
405                            :still-selecting (:<BOOL> still-selecting))
406                     hemlock-text-view)
407  (let* ((d (hemlock-buffer-string-cache (send self 'string)))
408         (point (hemlock::buffer-point (buffer-cache-buffer d)))
409         (location (pref r :<NSR>ange.location))
410         (len (pref r :<NSR>ange.length)))
411    (when (eql len 0)
412      (move-hemlock-mark-to-absolute-position point d location))
413    (send-super :set-selected-range r
414                :affinity affinity
415                :still-selecting still-selecting)))
416
417
418
419;;; Modeline-view
420
421;;; The modeline view is embedded in the horizontal scroll bar of the
422;;; scrollview which surrounds the textview in a pane.  (A view embedded
423;;; in a scrollbar like this is sometimes called a "placard").  Whenever
424;;; the view's invalidated, its drawRect: method draws a string containing
425;;; the current values of the buffer's modeline fields.
426
427(defclass modeline-view (ns:ns-view)
428    ((pane :foreign-type :id :accessor modeline-view-pane))
429  (:metaclass ns:+ns-object))
430
431
432;;; Attributes to use when drawing the modeline fields.  There's no
433;;; simple way to make the "placard" taller, so using fonts larger than
434;;; about 12pt probably wouldn't look too good.  10pt Courier's a little
435;;; small, but allows us to see more of the modeline fields (like the
436;;; full pathname) in more cases.
437(defloadvar *modeline-text-attributes* nil)
438(defparameter *modeline-font-name* "Courier New Bold Italic")
439(defparameter *modeline-font-size* 10.0)
440
441
442;;; Find the underlying buffer.
443(defun buffer-for-modeline-view (mv)
444  (let* ((pane (modeline-view-pane mv)))
445    (unless (%null-ptr-p pane)
446      (let* ((tv (text-pane-text-view pane)))
447        (unless (%null-ptr-p tv)
448          (text-view-buffer tv))))))
449
450;;; Draw a string in the modeline view.  The font and other attributes
451;;; are initialized lazily; apparently, calling the Font Manager too
452;;; early in the loading sequence confuses some Carbon libraries that're
453;;; used in the event dispatch mechanism,
454(defun draw-modeline-string (modeline-view)
455  (let* ((pane (modeline-view-pane modeline-view))
456         (buffer (buffer-for-modeline-view modeline-view)))
457    (when buffer
458      ;; You don't want to know why this is done this way.
459      (unless *modeline-text-attributes*
460        (setq *modeline-text-attributes*
461              (create-text-attributes :color (send (@class "NSColor") 'black-color)
462                                      :font (default-font
463                                              :name *modeline-font-name*
464                                              :size *modeline-font-size*))))
465     
466      (let* ((string
467              (apply #'concatenate 'string
468                     (mapcar
469                      #'(lambda (field)
470                          (funcall (hi::modeline-field-function field)
471                                   buffer pane))
472                      (hi::buffer-modeline-fields buffer)))))
473        (send (%make-nsstring string)
474              :draw-at-point (ns-make-point 0.0f0 0.0f0)
475              :with-attributes *modeline-text-attributes*)))))
476
477;;; Draw the underlying buffer's modeline string on a white background
478;;; with a bezeled border around it.
479(define-objc-method ((:void :draw-rect (:<NSR>ect rect)) 
480                     modeline-view)
481  (declare (ignore rect))
482  (slet ((frame (send self 'bounds)))
483     (#_NSDrawWhiteBezel frame frame)
484     (draw-modeline-string self)))
485
486;;; Hook things up so that the modeline is updated whenever certain buffer
487;;; attributes change.
488(hi::%init-mode-redisplay)
489
490
491;;; Modeline-scroll-view
492
493;;; This is just an NSScrollView that draws a "placard" view (the modeline)
494;;; in the horizontal scrollbar.  The modeline's arbitrarily given the
495;;; leftmost 75% of the available real estate.
496(defclass modeline-scroll-view (ns:ns-scroll-view)
497    ((modeline :foreign-type :id :accessor scroll-view-modeline)
498     (pane :foreign-type :id :accessor scroll-view-pane))
499  (:metaclass ns:+ns-object))
500
501;;; Making an instance of a modeline scroll view instantiates the
502;;; modeline view, as well.
503
504(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
505                     modeline-scroll-view)
506    (let* ((v (send-super :init-with-frame frame)))
507      (when v
508        (let* ((modeline (make-objc-instance 'modeline-view)))
509          (send v :add-subview modeline)
510          (setf (scroll-view-modeline v) modeline)))
511      v))
512
513;;; Scroll views use the "tile" method to lay out their subviews.
514;;; After the next-method has done so, steal some room in the horizontal
515;;; scroll bar and place the modeline view there.
516
517(define-objc-method ((:void tile) modeline-scroll-view)
518  (send-super 'tile)
519  (let* ((modeline (scroll-view-modeline self)))
520    (when (and (send self 'has-horizontal-scroller)
521               (not (%null-ptr-p modeline)))
522      (let* ((hscroll (send self 'horizontal-scroller)))
523        (slet ((scrollbar-frame (send hscroll 'frame))
524               (modeline-frame (send hscroll 'frame))) ; sic
525           (let* ((modeline-width (* (pref modeline-frame
526                                           :<NSR>ect.size.width)
527                                     0.75e0)))
528             (declare (single-float modeline-width))
529             (setf (pref modeline-frame :<NSR>ect.size.width)
530                   modeline-width
531                   (the single-float
532                     (pref scrollbar-frame :<NSR>ect.size.width))
533                   (- (the single-float
534                        (pref scrollbar-frame :<NSR>ect.size.width))
535                      modeline-width)
536                   (the single-float
537                     (pref scrollbar-frame :<NSR>ect.origin.x))
538                   (+ (the single-float
539                        (pref scrollbar-frame :<NSR>ect.origin.x))
540                      modeline-width))
541             (send hscroll :set-frame scrollbar-frame)
542             (send modeline :set-frame modeline-frame)))))))
543
544
545;;; Text-pane
546
547;;; The text pane is just an NSBox that (a) provides a draggable border
548;;; around (b) encapsulates the text view and the mode line.
549
550(defclass text-pane (ns:ns-box)
551    ((text-view :foreign-type :id :accessor text-pane-text-view)
552     (mode-line :foreign-type :id :accessor text-pane-mode-line)
553     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
554  (:metaclass ns:+ns-object))
555
556;;; Mark the pane's modeline as needing display.  This is called whenever
557;;; "interesting" attributes of a buffer are changed.
558
559(defun hi::invalidate-modeline (pane)
560  (send (text-pane-mode-line pane) :set-needs-display t))
561
562(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
563                     text-pane)
564    (let* ((pane (send-super :init-with-frame frame)))
565      (unless (%null-ptr-p pane)
566        (send pane :set-autoresizing-mask (logior
567                                           #$NSViewWidthSizable
568                                           #$NSViewHeightSizable))
569        (send pane :set-box-type #$NSBoxPrimary)
570        (send pane :set-border-type #$NSLineBorder)
571        (send pane :set-title-position #$NSNoTitle))
572      pane))
573
574
575(defun make-scrolling-text-view-for-textstorage (textstorage x y width height)
576  (slet ((contentrect (ns-make-rect x y width height)))
577    (let* ((scrollview (send (make-objc-instance
578                              'modeline-scroll-view
579                              :with-frame contentrect) 'autorelease)))
580      (send scrollview :set-border-type #$NSBezelBorder)
581      (send scrollview :set-has-vertical-scroller t)
582      (send scrollview :set-has-horizontal-scroller t)
583      (send scrollview :set-rulers-visible nil)
584      (send scrollview :set-autoresizing-mask (logior
585                                               #$NSViewWidthSizable
586                                               #$NSViewHeightSizable))
587      (send (send scrollview 'content-view) :set-autoresizes-subviews t)
588      (let* ((layout (make-objc-instance 'ns-layout-manager)))
589        (send textstorage :add-layout-manager layout)
590        (send layout 'release)
591        (slet* ((contentsize (send scrollview 'content-size))
592                (containersize (ns-make-size
593                                1.0f7
594                                1.0f7))
595                (tv-frame (ns-make-rect
596                           0.0f0
597                           0.0f0
598                           (pref contentsize :<NSS>ize.width)
599                           (pref contentsize :<NSS>ize.height))))
600          (let* ((container (send (make-objc-instance
601                                   'ns-text-container
602                                   :with-container-size containersize)
603                                  'autorelease)))
604            (send layout :add-text-container container)
605            (let* ((tv (send (make-objc-instance 'hemlock-text-view
606                                                 :with-frame tv-frame
607                                                 :text-container container)
608                             'autorelease)))
609              (send tv :set-min-size (ns-make-size
610                                      0.0f0
611                                      (pref contentsize :<NSS>ize.height)))
612              (send tv :set-max-size (ns-make-size 1.0f7 1.0f7))
613              (send tv :set-rich-text nil)
614              (send tv :set-horizontally-resizable t)
615              (send tv :set-vertically-resizable t) 
616              (send tv :set-autoresizing-mask #$NSViewWidthSizable)
617              (send container :set-width-tracks-text-view nil)
618              (send container :set-height-tracks-text-view nil)
619              (send scrollview :set-document-view tv)         
620              (values tv scrollview))))))))
621
622(defun make-scrolling-textview-for-pane (pane textstorage)
623  (slet ((contentrect (send (send pane 'content-view) 'frame)))
624    (multiple-value-bind (tv scrollview)
625        (make-scrolling-text-view-for-textstorage
626         textstorage
627         (pref contentrect :<NSR>ect.origin.x)
628         (pref contentrect :<NSR>ect.origin.y)
629         (pref contentrect :<NSR>ect.size.width)
630         (pref contentrect :<NSR>ect.size.height))
631      (send pane :set-content-view scrollview)
632      (setf (slot-value pane 'scroll-view) scrollview
633            (slot-value pane 'text-view) tv
634            (slot-value tv 'pane) pane
635            (slot-value scrollview 'pane) pane)
636      (let* ((modeline  (scroll-view-modeline scrollview)))
637        (setf (slot-value pane 'mode-line) modeline
638              (slot-value modeline 'pane) pane))
639      tv)))
640
641
642(defmethod hemlock-frame-command-info ((w ns:ns-window))
643  nil)
644
645
646(defclass hemlock-frame (ns:ns-window)
647    ((command-info :initform (hi::make-command-interpreter-info)
648                   :accessor hemlock-frame-command-info))
649  (:metaclass ns:+ns-object))
650
651
652(defmethod shared-initialize :after ((w hemlock-frame)
653                                     slot-names
654                                     &key &allow-other-keys)
655  (declare (ignore slot-names))
656  (let ((info (hemlock-frame-command-info w)))
657    (when info
658      (setf (hi::command-interpreter-info-frame info) w))))
659
660
661(defun get-cocoa-window-flag (w flagname)
662  (case flagname
663    (:accepts-mouse-moved-events
664     (send w 'accepts-mouse-moved-events))
665    (:cursor-rects-enabled
666     (send w 'are-cursor-rects-enabled))
667    (:auto-display
668     (send w 'is-autodisplay))))
669
670
671
672(defun (setf get-cocoa-window-flag) (value w flagname)
673  (case flagname
674    (:accepts-mouse-moved-events
675     (send w :set-accepts-mouse-moved-events value))
676    (:auto-display
677     (send w :set-autodisplay value))))
678
679
680
681(defun activate-window (w)
682  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
683  (send w :make-key-and-order-front nil))
684
685(defun new-hemlock-document-window (&key
686                                    (x 200.0)
687                                    (y 200.0)
688                                    (height 200.0)
689                                    (width 500.0)
690                                    (closable t)
691                                    (iconifyable t)
692                                    (metal t)
693                                    (expandable t)
694                                    (backing :buffered)
695                                    (defer nil)
696                                    (accepts-mouse-moved-events nil)
697                                    (auto-display t)
698                                    (activate t))
699  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
700    (let* ((stylemask
701            (logior #$NSTitledWindowMask
702                    (if closable #$NSClosableWindowMask 0)
703                    (if iconifyable #$NSMiniaturizableWindowMask 0)
704                    (if expandable #$NSResizableWindowMask 0)
705                    (if metal #$NSTexturedBackgroundWindowMask 0)))
706           (backing-type
707            (ecase backing
708              ((t :retained) #$NSBackingStoreRetained)
709              ((nil :nonretained) #$NSBackingStoreNonretained)
710              (:buffered #$NSBackingStoreBuffered)))
711           (w (make-instance
712               'hemlock-frame
713               :with-content-rect frame
714               :style-mask stylemask
715               :backing backing-type
716               :defer defer)))
717      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
718            accepts-mouse-moved-events
719            (get-cocoa-window-flag w :auto-display)
720            auto-display)
721      (when activate (activate-window w))
722      (values w (add-pane-to-window w :reserve-below 20.0)))))
723
724
725
726(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
727  (let* ((window-content-view (send w 'content-view)))
728    (slet ((window-frame (send window-content-view 'frame)))
729      (slet ((pane-rect (ns-make-rect 0.0f0
730                                      reserve-below
731                                      (pref window-frame :<NSR>ect.size.width)
732                                      (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below)))))
733        (let* ((pane (make-objc-instance 'text-pane :with-frame pane-rect)))
734          (send window-content-view :add-subview pane)
735          pane)))))
736
737
738         
739                                       
740                                     
741(defun textpane-for-textstorage (ts)
742  (let* ((pane (nth-value
743                1
744                (new-hemlock-document-window :activate nil)))
745         (tv (make-scrolling-textview-for-pane pane ts)))
746    (multiple-value-bind (height width)
747        (size-of-char-in-font (default-font))
748      (size-textview-containers tv height width 24 80))
749    pane))
750
751
752(defun read-file-to-hemlock-buffer (path)
753  (hemlock::find-file-buffer path))
754
755(defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
756  (let* ((buffer (make-hemlock-buffer name :modes modes)))
757    (nsstring-to-buffer nsstring buffer)))
758
759(defun nsstring-to-buffer (nsstring buffer)
760  (let* ((document (hi::buffer-document buffer)))
761    (setf (hi::buffer-document buffer) nil)
762    (unwind-protect
763         (progn
764           (hi::delete-region (hi::buffer-region buffer))
765           (hi::modifying-buffer buffer)
766           (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
767             (let* ((string-len (send nsstring 'length))
768                    (line-start 0)
769                    (first-line-terminator ())
770                    (first-line (hi::mark-line mark))
771                    (previous first-line)
772                    (buffer (hi::line-%buffer first-line)))
773               (slet ((remaining-range (ns-make-range 0 1)))
774                 (rlet ((line-end-index :unsigned)
775                        (contents-end-index :unsigned))
776                   (do* ((number (+ (hi::line-number first-line) hi::line-increment)
777                                 (+ number hi::line-increment)))
778                        ((= line-start string-len)
779                         (let* ((line (hi::mark-line mark)))
780                           (hi::insert-string mark (make-string 0))
781                           (setf (hi::line-next previous) line
782                                 (hi::line-previous line) previous))
783                         nil)
784                     (setf (pref remaining-range :<NSR>ange.location) line-start)
785                     (send nsstring
786                           :get-line-start (%null-ptr)
787                           :end line-end-index
788                           :contents-end contents-end-index
789                           :for-range remaining-range)
790                     (let* ((contents-end (pref contents-end-index :unsigned))
791                            (line-end (pref line-end-index :unsigned))
792                            (chars (make-string (- contents-end line-start))))
793                       (do* ((i line-start (1+ i))
794                             (j 0 (1+ j)))
795                            ((= i contents-end))
796                         (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
797                       (unless first-line-terminator
798                         (let* ((terminator (code-char
799                                             (send nsstring :character-at-index
800                                                   contents-end))))
801                           (setq first-line-terminator
802                                 (case terminator
803                                   (#\return (if (= line-end (+ contents-end 2))
804                                               :cp/m
805                                               :macos))
806                                   (t :unix)))))
807                       (if (eq previous first-line)
808                         (progn
809                           (hi::insert-string mark chars)
810                           (hi::insert-character mark #\newline)
811                           (setq first-line nil))
812                         (if (eq string-len contents-end)
813                           (hi::insert-string mark chars)
814                           (let* ((line (hi::make-line
815                                         :previous previous
816                                         :%buffer buffer
817                                         :chars chars
818                                         :number number)))
819                             (setf (hi::line-next previous) line)
820                             (setq previous line))))
821                       (setq line-start line-end)))))
822               (when first-line-terminator
823                 (setf (hi::buffer-external-format buffer) first-line-terminator))))
824           (setf (hi::buffer-modified buffer) nil)
825           (hi::buffer-start (hi::buffer-point buffer))
826           buffer)
827      (setf (hi::buffer-document buffer) document))))
828
829(setq hi::*beep-function* #'(lambda (stream)
830                              (declare (ignore stream))
831                              (#_NSBeep)))
832
833
834;;; This function must run in the main event thread.
835(defun %hemlock-frame-for-textstorage (ts title activate)
836  (let* ((pane (textpane-for-textstorage ts))
837         (w (send pane 'window)))
838    (when title (send w :set-title (%make-nsstring title)))
839    (when activate (activate-window w))
840    w))
841
842(defun hemlock-frame-for-textstorage (ts title activate)
843  (process-interrupt *cocoa-event-process*
844                     #'%hemlock-frame-for-textstorage
845                     ts title activate))
846
847
848(defun for-each-textview-using-storage (textstorage f)
849  (let* ((layouts (send textstorage 'layout-managers)))
850    (unless (%null-ptr-p layouts)
851      (dotimes (i (send layouts 'count))
852        (let* ((layout (send layouts :object-at-index i))
853               (containers (send layout 'text-containers)))
854          (unless (%null-ptr-p containers)
855            (dotimes (j (send containers 'count))
856              (let* ((container (send containers :object-at-index j))
857                     (tv (send container 'text-view)))
858                (funcall f tv)))))))))
859
860
861 
862(defun hi::document-begin-editing (document)
863  (send (slot-value document 'textstorage) 'begin-editing))
864
865(defun hi::document-end-editing (document)
866  (let* ((textstorage (slot-value document 'textstorage)))
867    (send textstorage 'end-editing)
868    (for-each-textview-using-storage
869     textstorage
870     #'(lambda (tv)
871         (send tv :scroll-range-to-visible (send tv 'selected-range))))))
872
873(defun hi::document-set-point-position (document)
874  (let* ((textstorage (slot-value document 'textstorage))
875         (string (send textstorage 'string))
876         (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))
877         (point (hi::buffer-point buffer))
878         (pos (mark-absolute-position point)))
879    (for-each-textview-using-storage
880     textstorage
881     #'(lambda (tv)
882         (slet ((selection (ns-make-range pos 0)))
883          (send tv :set-selected-range selection))))))
884
885
886(defun textstorage-note-insertion-at-position (textstorage pos n)
887  (send textstorage
888        :edited #$NSTextStorageEditedAttributes
889        :range (ns-make-range pos 0)
890        :change-in-length n)
891  (send textstorage
892        :edited #$NSTextStorageEditedCharacters
893        :range (ns-make-range pos n)
894        :change-in-length 0))
895
896(defun hi::buffer-note-insertion (buffer mark n)
897  (when (hi::bufferp buffer)
898    (let* ((document (hi::buffer-document buffer))
899           (textstorage (if document (slot-value document 'textstorage))))
900      (when textstorage
901        (let* ((pos (mark-absolute-position mark)))
902          (unless (eq (hi::mark-%kind mark) :right-inserting)
903            (decf pos n))
904          #+debug
905          (format t "~&pos = ~d, n = ~d" pos n)
906          (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
907            (reset-buffer-cache display) 
908            (update-line-cache-for-index display pos))
909          (textstorage-note-insertion-at-position textstorage pos n))))))
910
911 
912
913(defun hi::buffer-note-deletion (buffer mark n)
914  (when (hi::bufferp buffer)
915    (let* ((document (hi::buffer-document buffer))
916           (textstorage (if document (slot-value document 'textstorage))))
917      (when textstorage
918        (let* ((pos (mark-absolute-position mark)))
919          (setq n (abs n))
920          #+debug
921          (format t "~& pos = ~d, n = ~d" pos n)
922          (force-output)
923          (send textstorage
924                :edited #$NSTextStorageEditedCharacters
925                :range (ns-make-range pos n)
926                :change-in-length (- n))
927          (let* ((cache (hemlock-buffer-string-cache (send textstorage 'string))))
928            (reset-buffer-cache cache) 
929            (update-line-cache-for-index cache pos)))))))
930
931(defun hi::set-document-modified (document flag)
932  (send document
933        :update-change-count (if flag #$NSChangeDone #$NSChangeCleared)))
934
935
936(defun hi::document-panes (document)
937  (let* ((ts (slot-value document 'textstorage))
938         (panes ()))
939    (for-each-textview-using-storage
940     ts
941     #'(lambda (tv)
942         (let* ((pane (text-view-pane tv)))
943           (unless (%null-ptr-p pane)
944             (push pane panes)))))
945    panes))
946
947   
948
949(defun size-of-char-in-font (f)
950  (let* ((sf (send f 'screen-font)))
951    (if (%null-ptr-p sf) (setq sf f))
952    (values (send sf 'default-line-height-for-font)
953            (send sf :width-of-string #@" "))))
954         
955   
956(defun get-size-for-textview (font nrows ncols)
957  (multiple-value-bind (h w) (size-of-char-in-font font)
958    (values (fceiling (* nrows h))
959            (fceiling (* ncols w)))))
960
961
962(defun size-textview-containers (tv char-height char-width nrows ncols)
963  (let* ((height (fceiling (* nrows char-height)))
964         (width (fceiling (* ncols char-width)))
965         (scrollview (send (send tv 'superview) 'superview))
966         (window (send scrollview 'window)))
967    (rlet ((tv-size :<NSS>ize :height height
968                    :width (+ width (* 2 (send (send tv 'text-container)
969                      'line-fragment-padding)))))
970      (when (send scrollview 'has-vertical-scroller)
971        (send scrollview :set-vertical-line-scroll char-height)
972        (send scrollview :set-vertical-page-scroll char-height))
973      (slet ((sv-size
974              (send (@class ns-scroll-view)
975                    :frame-size-for-content-size tv-size
976                    :has-horizontal-scroller
977                    (send scrollview 'has-horizontal-scroller)
978                    :has-vertical-scroller
979                    (send scrollview 'has-vertical-scroller)
980                    :border-type (send scrollview 'border-type))))
981        (slet ((sv-frame (send scrollview 'frame)))
982          (incf (pref sv-size :<NSS>ize.height)
983                (pref sv-frame :<NSR>ect.origin.y))
984          (send window :set-content-size sv-size)
985          (send window :set-resize-increments
986                (ns-make-size char-width char-height)))))))
987                                   
988 
989(defclass lisp-editor-window-controller (ns:ns-window-controller)
990    ()
991  (:metaclass ns:+ns-object))
992
993   
994;;; The LispEditorWindowController is the textview's "delegate": it
995;;; gets consulted before certain actions are performed, and can
996;;; perform actions on behalf of the textview.
997
998
999
1000;;; The LispEditorDocument class.
1001
1002
1003(defclass lisp-editor-document (ns:ns-document)
1004    ((textstorage :foreign-type :id))
1005  (:metaclass ns:+ns-object))
1006
1007(define-objc-method ((:id init) lisp-editor-document)
1008  (let* ((doc (send-super 'init)))
1009    (unless (%null-ptr-p doc)
1010      (let* ((buffer (make-hemlock-buffer
1011                      (lisp-string-from-nsstring (send doc 'display-name))
1012                      :modes '("Lisp"))))
1013        (setf (slot-value doc 'textstorage)
1014              (make-textstorage-for-hemlock-buffer buffer)
1015              (hi::buffer-document buffer) doc)))
1016    doc))
1017                     
1018
1019(define-objc-method ((:id :read-from-file filename
1020                          :of-type type)
1021                     lisp-editor-document)
1022  (declare (ignorable type))
1023  (let* ((pathname (lisp-string-from-nsstring filename))
1024         (buffer-name (hi::pathname-to-buffer-name pathname))
1025         (buffer (or
1026                  (hemlock-document-buffer self)
1027                  (let* ((b (make-hemlock-buffer buffer-name)))
1028                    (setf (hi::buffer-pathname b) pathname)
1029                    (setf (slot-value self 'textstorage)
1030                          (make-textstorage-for-hemlock-buffer b))
1031                    b)))
1032         (data (make-objc-instance 'ns:ns-data
1033                                   :with-contents-of-file filename))
1034         (string (make-objc-instance 'ns:ns-string
1035                                     :with-data data
1036                                     :encoding #$NSASCIIStringEncoding)))
1037    (hi::document-begin-editing self)
1038    (nsstring-to-buffer string buffer)
1039    (let* ((textstorage (slot-value self 'textstorage))
1040           (display (hemlock-buffer-string-cache (send textstorage 'string))))
1041      (reset-buffer-cache display) 
1042      (update-line-cache-for-index display 0)
1043      (textstorage-note-insertion-at-position
1044       textstorage
1045       0
1046       (hemlock-buffer-length buffer)))
1047    (hi::document-end-editing self)
1048    (setf (hi::buffer-modified buffer) nil)
1049    (hi::process-file-options buffer pathname)
1050    self))
1051   
1052 
1053(defmethod hemlock-document-buffer (document)
1054  (let* ((string (send (slot-value document 'textstorage) 'string)))
1055    (unless (%null-ptr-p string)
1056      (let* ((cache (hemlock-buffer-string-cache string)))
1057        (when cache (buffer-cache-buffer cache))))))
1058
1059(define-objc-method ((:id :data-representation-of-type type)
1060                      lisp-editor-document)
1061  (declare (ignorable type))
1062  (let* ((buffer (hemlock-document-buffer self)))
1063    (when buffer
1064      (setf (hi::buffer-modified buffer) nil)))
1065  (send (send (slot-value self 'textstorage) 'string)
1066        :data-using-encoding #$NSASCIIStringEncoding
1067        :allow-lossy-conversion t))
1068
1069
1070;;; Shadow the setFileName: method, so that we can keep the buffer
1071;;; name and pathname in synch with the document.
1072(define-objc-method ((:void :set-file-name full-path)
1073                     lisp-editor-document)
1074  (send-super :set-file-name full-path)
1075  (let* ((buffer (hemlock-document-buffer self)))
1076    (when buffer
1077      (let* ((new-pathname (lisp-string-from-nsstring full-path)))
1078        (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname))
1079        (setf (hi::buffer-pathname buffer) new-pathname)))))
1080 
1081(define-objc-method ((:void make-window-controllers) lisp-editor-document)
1082  (let* ((controller (make-objc-instance
1083                      'lisp-editor-window-controller
1084                      :with-window (%hemlock-frame-for-textstorage
1085                                    (slot-value self 'textstorage) nil nil))))
1086    (send self :add-window-controller controller)
1087    (send controller 'release)))         
1088
1089#|
1090(define-objc-method ((:void :window-controller-did-load-nib acontroller)
1091                     lisp-editor-document)
1092  (send-super :window-controller-did-load-nib  acontroller)
1093  ;; Apple/NeXT thinks that adding extra whitespace around cut & pasted
1094  ;; text is "smart".  Really, really smart insertion and deletion
1095  ;; would alphabetize the selection for you (byChars: or byWords:);
1096  ;; sadly, if you want that behavior you'll have to do it yourself.
1097  ;; Likewise with the extra spaces.
1098  (with-slots (text-view echoarea packagename filedata) self
1099    (send text-view :set-alignment  #$NSNaturalTextAlignment)
1100    (send text-view :set-smart-insert-delete-enabled nil)
1101    (send text-view :set-rich-text nil)
1102    (send text-view :set-uses-font-panel t)
1103    (send text-view :set-uses-ruler nil)
1104    (with-lock-grabbed (*open-editor-documents-lock*)
1105      (push (make-cocoa-editor-info
1106             :document (%setf-macptr (%null-ptr) self)
1107             :controller (%setf-macptr (%null-ptr) acontroller)
1108             :listener nil)
1109            *open-editor-documents*))
1110    (setf (slot-value acontroller 'textview) text-view
1111          (slot-value acontroller 'echoarea) echoarea
1112          (slot-value acontroller 'packagename) packagename)
1113    (send text-view :set-delegate acontroller)
1114    (let* ((font (default-font)))
1115      (multiple-value-bind (height width)
1116          (size-of-char-in-font font)
1117        (size-textview-containers text-view height width 24 80))
1118      (send text-view
1119            :set-typing-attributes
1120            (create-text-attributes
1121             :font font
1122             :color (send (@class ns-color) 'black-color)))
1123      (unless (%null-ptr-p filedata)
1124        (send text-view
1125              :replace-characters-in-range (ns-make-range 0 0)
1126              :with-string (make-objc-instance
1127                            'ns-string
1128                            :with-data filedata
1129                            :encoding #$NSASCIIStringEncoding))
1130))))
1131|#
1132
1133(define-objc-method ((:void close) lisp-editor-document)
1134  (send-super 'close)
1135  (let* ((textstorage (slot-value self 'textstorage)))
1136    (setf (slot-value self 'textstorage) (%null-ptr))
1137    (unless (%null-ptr-p textstorage)
1138      (close-hemlock-textstorage textstorage))))
1139
1140
1141(provide "COCOA-EDITOR")
Note: See TracBrowser for help on using the repository browser.